(define (copy/block parent environment block)
(let ((result (block/make parent (block/safe? block) '()))
- (old-bound (block/bound-variables-list block)))
+ (old-bound (block/bound-variables block)))
(let ((new-bound
(map (lambda (variable)
(let ((new
|#
;;;; SCode Optimizer: Environment Model
+;;; package: (scode-optimizer)
(declare (usual-integrations)
(integrate-external "object"))
(let ((block
(%block/make parent
safe?
- (let ((n-bound-variables (length bound-variables)))
- (if (fix:<= n-bound-variables block-hash-table-limit)
- (cons n-bound-variables bound-variables)
- (make-hash-table bound-variables))))))
+ bound-variables)))
(if parent
(set-block/children! parent (cons block (block/children parent))))
block))
(%variable/make&bind! block name)))
(define (%variable/make&bind! block name)
- (let ((variable (variable/make block name '()))
- (bound-variables (block/bound-variables block)))
- (cond ((hash-table? bound-variables)
- (hash-table-store! bound-variables variable))
- ((fix:= (car bound-variables) block-hash-table-limit)
- (set-block/bound-variables!
- block
- (make-hash-table (cons variable (cdr bound-variables)))))
- (else
- (set-car! bound-variables (fix:+ (car bound-variables) 1))
- (set-cdr! bound-variables (cons variable (cdr bound-variables)))))
+ (let ((variable (variable/make block name '())))
+ (set-block/bound-variables! block
+ (cons variable (block/bound-variables block)))
variable))
-(define-integrable block-hash-table-limit
- 20)
-
(define (block/lookup-name block name intern?)
(let search ((block block))
(or (%block/lookup-name block name)
(and intern? (%variable/make&bind! block name))))))
(define (%block/lookup-name block name)
- (let ((bound-variables (block/bound-variables block)))
- (if (hash-table? bound-variables)
- (hash-table-lookup bound-variables name)
- (let loop ((variables (cdr bound-variables)))
- (and (not (null? variables))
- (if (eq? name (variable/name (car variables)))
- (car variables)
- (loop (cdr variables))))))))
+ (find-matching-item (block/bound-variables block)
+ (lambda (variable)
+ (eq? (variable/name variable) name))))
(define (block/limited-lookup block name limit)
(let search ((block block))
(and (not (eq? block limit))
- (let ((bound-variables (block/bound-variables block)))
- (if (hash-table? bound-variables)
- (or (hash-table-lookup bound-variables name)
- (and (block/parent block)
- (search (block/parent block))))
- (let loop ((variables (cdr bound-variables)))
- (cond ((null? variables)
- (and (block/parent block)
- (search (block/parent block))))
- ((eq? name (variable/name (car variables)))
- (car variables))
- (else
- (loop (cdr variables))))))))))
-\f
-(define-structure (hash-table
- (type vector)
- (named (string->symbol "#[(scode-optimizer)hash-table]"))
- (constructor %make-hash-table))
- count
- buckets)
-
-(define (make-hash-table variables)
- (let ((count (length variables)))
- (let ((buckets (make-hash-table-buckets (fix:+ count 1))))
- (let ((table (%make-hash-table count buckets)))
- (for-each (lambda (variable)
- (%hash-table-store! buckets variable))
- variables)
- table))))
-
-(define (hash-table-store! table variable)
- (let ((count (fix:+ (hash-table-count table) 1)))
- (if (fix:= count (vector-length (hash-table-buckets table)))
- (let ((old-buckets (hash-table-buckets table)))
- (let ((new-buckets (make-hash-table-buckets (fix:+ count count))))
- (do ((h 0 (fix:+ h 1)))
- ((fix:= h count))
- (let ((variable (vector-ref old-buckets h)))
- (if variable
- (%hash-table-store! new-buckets variable))))
- (set-hash-table-buckets! table new-buckets))))
- (set-hash-table-count! table count))
- (%hash-table-store! (hash-table-buckets table) variable))
-
-(define (%hash-table-store! buckets variable)
- (let ((k (symbol-hash (variable/name variable)))
- (m (vector-length buckets)))
- (let ((h1 (modulo k m)))
- (if (not (vector-ref buckets h1))
- (vector-set! buckets h1 variable)
- (let ((h2 (fix:+ (modulo k (fix:- m 1)) 1)))
- (let loop ((h h1))
- (let ((h
- (let ((h (fix:+ h h2)))
- (if (fix:< h m)
- h
- (fix:- h m)))))
- (if (not (vector-ref buckets h))
- (vector-set! buckets h variable)
- (loop h)))))))))
-
-(define (make-hash-table-buckets n)
- (make-vector (let loop ((primes prime-numbers-stream))
- (if (<= n (car primes))
- (car primes)
- (loop (force (cdr primes)))))
- false))
-
-(define (hash-table-lookup table name)
- (let ((buckets (hash-table-buckets table)))
- (let ((k (symbol-hash name))
- (m (vector-length buckets)))
- (let ((h1 (modulo k m)))
- (let ((variable (vector-ref buckets h1)))
- (and variable
- (if (eq? name (variable/name variable))
- variable
- (let ((h2 (fix:+ (modulo k (fix:- m 1)) 1)))
- (let loop ((h h1))
- (let ((h
- (let ((h (fix:+ h h2)))
- (if (fix:< h m)
- h
- (fix:- h m)))))
- (let ((variable (vector-ref buckets h)))
- (and variable
- (if (eq? name (variable/name variable))
- variable
- (loop h))))))))))))))
+ (or (%block/lookup-name block name)
+ (and (block/parent block)
+ (search (block/parent block)))))))
\f
(define (block/lookup-names block names intern?)
(map (lambda (name)
names))
(define (block/for-each-bound-variable block procedure)
- (let ((bound-variables (block/bound-variables block)))
- (if (hash-table? bound-variables)
- (let ((buckets (hash-table-buckets bound-variables)))
- (let ((m (vector-length buckets)))
- (do ((h 0 (fix:+ h 1)))
- ((fix:= h m))
- (if (vector-ref buckets h)
- (procedure (vector-ref buckets h))))))
- (for-each procedure (cdr bound-variables)))))
-
-(define (block/bound-variables-list block)
- (let ((bound-variables (block/bound-variables block)))
- (if (hash-table? bound-variables)
- (let ((buckets (hash-table-buckets bound-variables)))
- (let ((m (vector-length buckets)))
- (let loop ((h 0) (result '()))
- (if (fix:= h m)
- result
- (loop (fix:+ h 1)
- (if (vector-ref buckets h)
- (cons (vector-ref buckets h) result)
- result))))))
- (cdr bound-variables))))
+ (for-each procedure (block/bound-variables block)))
(define (block/unsafe! block)
(if (block/safe? block)
|#
-;;;; SCode Optimizer: Free Variable Analysis
+;;;; SCode Optimizer: Free Variable Computation
+;;; package: (scode-optimizer free)
(declare (usual-integrations)
- (integrate-external "object" "lsets"))
+ (integrate-external "object"))
\f
-(declare (integrate-operator no-free-variables singleton-variable
- list->variable-set))
-
-(define (no-free-variables)
- (empty-set variable? eq?))
-
-(define (singleton-variable variable)
- (singleton-set variable? eq? variable))
-
-(define (list->variable-set variable-list)
- (list->set variable? eq? variable-list))
-
-(define (free/expressions expressions)
- (if (null? expressions)
- (no-free-variables)
- (set/union (free/expression (car expressions))
- (free/expressions (cdr expressions)))))
-
(declare (integrate-operator free/expression))
(define (free/expression expression)
((expression/method dispatch-vector expression) expression))
+(define (free/expressions expressions)
+ (fold-left (lambda (answer expression)
+ (set/union answer (free/expression expression)))
+ (no-free-variables)
+ expressions))
+
(define dispatch-vector
(expression/make-dispatch-vector))
(define-method/free 'CONDITIONAL
(lambda (expression)
- (set/union*
+ (set/union
(free/expression (conditional/predicate expression))
- (free/expression (conditional/consequent expression))
- (free/expression (conditional/alternative expression)))))
+ (set/union
+ (free/expression (conditional/consequent expression))
+ (free/expression (conditional/alternative expression))))))
(define-method/free 'CONSTANT
- (lambda (expression)
+ (lambda (expression)
expression
(no-free-variables)))
(set/union (free/expression (disjunction/predicate expression))
(free/expression (disjunction/alternative expression)))))
-(define-method/free 'PROCEDURE
+(define-method/free 'OPEN-BLOCK
(lambda (expression)
- (set/difference
- (free/expression (procedure/body expression))
- (list->variable-set
- (block/bound-variables-list (procedure/block expression))))))
+ (let ((omit (block/bound-variables (open-block/block expression))))
+ (fold-left (lambda (variables action)
+ (if (eq? action open-block/value-marker)
+ variables
+ (set/union variables (set/difference (free/expression action) omit))))
+ (set/difference (free/expressions (open-block/values expression)) omit)
+ (open-block/actions expression)))))
-(define-method/free 'OPEN-BLOCK
+(define-method/free 'PROCEDURE
(lambda (expression)
(set/difference
- (set/union (free/expressions (open-block/values expression))
- (let loop ((actions (open-block/actions expression)))
- (cond ((null? actions) (no-free-variables))
- ((eq? (car actions) open-block/value-marker)
- (loop (cdr actions)))
- (else
- (set/union (free/expression (car actions))
- (loop (cdr actions)))))))
- (list->variable-set
- (block/bound-variables-list (open-block/block expression))))))
+ (free/expression (procedure/body expression))
+ (block/bound-variables (procedure/block expression)))))
(define-method/free 'QUOTATION
- (lambda (expression)
+ (lambda (expression)
expression
(no-free-variables)))
(define-method/free 'REFERENCE
- (lambda (expression)
+ (lambda (expression)
(singleton-variable (reference/variable expression))))
(define-method/free 'SEQUENCE
(free/expressions (sequence/actions expression))))
(define-method/free 'THE-ENVIRONMENT
- (lambda (expression)
+ (lambda (expression)
expression
- (no-free-variables)))
\ No newline at end of file
+ (no-free-variables)))
+\f
+(define-integrable (no-free-variables)
+ '())
+
+(define-integrable (singleton-variable variable)
+ (list variable))
+
+(define (set/adjoin set element)
+ (if (memq element set)
+ set
+ (cons element set)))
+
+(define-integrable (set/union left right)
+ (fold-left set/adjoin left right))
+
+(define (set/difference original remove)
+ (fold-left (lambda (answer element)
+ (if (memq element remove)
+ answer
+ (set/adjoin answer element)))
+ '()
+ original))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-;;;; Unordered Set abstraction
-
-(declare (usual-integrations)
- (automagic-integrations)
- (open-block-optimizations))
-\f
-#|
-
-Each set has an ELEMENT-TYPE which is a predicate that all elements of
-the set must satisfy. Each set has a PREDICATE that is used to compare
-identity of the elements. An element appears in a set only once.
-
-This code is bummed up the wazoo for speed. It is derived from a SET
-abstraction based on streams written by JRM. I would not recommend trying
-to figure out what is going on in this code.
-
-;; User functions.
-
-(define empty-set)
-(define singleton-set)
-(define list->set)
-(define stream->set)
-(define set-element-type)
-
-(define set/member?)
-(define set/adjoin)
-(define set/adjoin*)
-(define set/remove)
-(define set->stream)
-(define set->list)
-(define set/for-each)
-(define set/map)
-(define set/empty?)
-(define set/union)
-(define set/union*)
-(define set/intersection)
-(define set/intersection*)
-
-(define any-type?)
-
-|#
-\f
-(define-integrable (check-type element-type element)
- element-type element ;ignore
- true)
-
-(define-integrable (member-procedure predicate)
- predicate ;ignore
- memq)
-
-(define-integrable (list-deletor predicate)
- (letrec ((list-deletor-loop
- (lambda (list)
- (if (pair? list)
- (if (predicate (car list))
- (list-deletor-loop (cdr list))
- (cons (car list) (list-deletor-loop (cdr list))))
- '()))))
- list-deletor-loop))
-
-(define-integrable (set? object)
- object ;ignore
- true)
-
-(define-integrable (%make-set element-type predicate elements)
- element-type predicate ;ignore
- elements)
-
-(define-integrable (%unsafe-set-element-type set)
- set ;ignore
- (lambda (object)
- (declare (integrate object))
- object ;ignore
- true))
-
-(define-integrable (%unsafe-set-predicate set)
- set ;ignore
- eq?)
-
-(define-integrable (%unsafe-set-elements set)
- set)
-
-(define-integrable (set-element-type set)
- (%unsafe-set-element-type set))
-
-(define-integrable (adjoin-lists-without-duplicates predicate l1 l2)
- predicate ;ignore
- (let loop ((new-list l1) (old-list l2))
- (cond ((null? old-list) new-list)
- ((memq (car old-list) new-list) (loop new-list (cdr old-list)))
- (else (loop (cons (car old-list) new-list) (cdr old-list))))))
-
-(define-integrable (invert-sense predicate)
- (lambda (object)
- (declare (integrate object))
- (not (predicate object))))
-\f
-(define-integrable (%subset predicate list)
- ((list-deletor (invert-sense predicate)) list))
-
-(define-integrable (remove-duplicates predicate list)
- (adjoin-lists-without-duplicates predicate '() list))
-
-(define (empty-set element-type predicate)
- (%make-set element-type predicate '()))
-
-(define (singleton-set element-type predicate element)
- (check-type element-type element)
- (%make-set element-type predicate (cons element '())))
-
-(define (list->set element-type predicate elements)
- (%make-set element-type predicate
- (let loop ((elements (apply list elements)))
- (cond ((null? elements) '())
- ((check-type element-type (car elements))
- (remove-duplicates predicate
- (cons (car elements)
- (loop (cdr elements)))))
- (else (error "Can't happen"))))))
-
-(define (stream->set element-type predicate stream)
- (%make-set element-type predicate
- (let loop ((stream stream))
- (cond ((empty-stream? stream) '())
- ((check-type element-type (head stream))
- (remove-duplicates predicate
- (cons (head stream)
- (loop (tail stream)))))
- (else (error "Can't happen"))))))
-
-;;; End of speed hack.
-
-(declare (integrate-operator spread-set))
-(define (spread-set set receiver)
- (declare (integrate receiver))
- (if (not (set? set))
- (error "Object not a set" set))
- (receiver (%unsafe-set-element-type set)
- (%unsafe-set-predicate set)
- (%unsafe-set-elements set)))
-
-#|
-(define (spread-2-sets set1 set2 receiver)
- (declare (integrate set1 set2 receiver))
- (spread-set set1
- (lambda (etype1 pred1 stream1)
- (spread-set set2
- (lambda (etype2 pred2 stream2)
- (declare (integrate etype2 pred2))
- (if (not (and (eq? etype1 etype2)
- (eq? pred1 pred2)))
- (error "Set mismatch")
- (receiver etype1 pred1 stream1 stream2)))))))
-|#
-(define-integrable (spread-2-sets set1 set2 receiver)
- (spread-set set1
- (lambda (etype1 pred1 stream1)
- (declare (integrate etype1 pred1))
- (spread-set set2
- (lambda (etype2 pred2 stream2)
- etype2 pred2 ; are ignored
- (receiver etype1 pred1 stream1 stream2))))))
-\f
-(define (set/member? set element)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate element-type predicate stream))
- (check-type element-type element)
- ((member-procedure predicate) element list))))
-
-(declare (integrate-operator adjoin-element))
-(define (adjoin-element predicate element list)
- (declare (integrate list))
- predicate ;ignore
- (if (memq element list)
- list
- (cons element list)))
-
-(define (set/adjoin set element)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate list))
- (check-type element-type element)
- (%make-set element-type predicate
- (adjoin-element predicate element list)))))
-
-(define (set/adjoin* set element-list)
- (if (null? element-list)
- set
- (set/adjoin (set/adjoin* set (cdr element-list)) (car element-list))))
-
-(define (set/remove set element)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate list))
- (check-type element-type element)
- (%make-set element-type predicate (delq element list)))))
-
-(define (set/subset set subset-predicate)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate element-type predicate list))
- (%make-set element-type predicate
- (%subset subset-predicate list)))))
-
-(define (set->stream set)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate list))
- element-type predicate ;ignore
- (list->stream list))))
-
-(define (list->stream list)
- (if (null? list)
- the-empty-stream
- (cons-stream (car list) (list->stream (cdr list)))))
-
-(define (set->list set)
- (spread-set set
- (lambda (element-type predicate l)
- (declare (integrate list))
- element-type predicate ;ignore
- (apply list l))))
-
-(define (set/for-each function set)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate list))
- element-type predicate ;ignore
- (for-each function list))))
-\f
-#|
-(define (set/map new-element-type new-predicate function set)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate list))
- element-type predicate ;ignore
- (%make-set new-element-type new-predicate
- (remove-duplicates
- new-predicate
- (map (lambda (element)
- (let ((new-element (function element)))
- (if (new-element-type new-element)
- new-element
- (error "Element of wrong type" new-element))))
- list))))))
-|#
-
-(define (set/map new-element-type new-predicate function set)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate list))
- element-type predicate ;ignore
- (%make-set new-element-type new-predicate
- (remove-duplicates eq? (map function list))))))
-
-(define (set/empty? set)
- (spread-set set
- (lambda (element-type predicate list)
- (declare (integrate list))
- element-type predicate ;ignore
- (null? list))))
-
-(define (interleave l1 l2)
- (if (null? l1)
- l2
- (cons (car l1) (interleave l2 (cdr l1)))))
-
-(define (set/union s1 s2)
- (spread-2-sets s1 s2
- (lambda (etype pred list1 list2)
- (declare (integrate etype list1 list2))
- (%make-set
- etype pred
- (adjoin-lists-without-duplicates pred list1 list2)))))
-
-(define (set/union* . sets)
- (cond ((null? sets) (error "Set/union* with no args"))
- ((null? (cdr sets)) (car sets))
- (else (set/union (car sets) (apply set/union* (cdr sets))))))
-
-(define (set/intersection s1 s2)
- (spread-2-sets s1 s2
- (lambda (etype pred l1 l2)
- (%make-set etype pred
- (let loop ((elements l1))
- (cond ((null? elements) '())
- (((member-procedure pred) (car elements) l2)
- (cons (car elements) (loop (cdr elements))))
- (else (loop (cdr elements)))))))))
-
-(define (set/intersection* . sets)
- (cond ((null? sets) (error "set/intersection* with no args"))
- ((null? (cdr sets)) (car sets))
- (else (set/intersection (car sets)
- (apply set/intersection* (cdr sets))))))
-
-(define (set/difference set1 set2)
- (spread-2-sets set1 set2
- (lambda (etype pred l1 l2)
- (declare (integrate etype l1 l2))
- (%make-set etype pred
- (%subset (lambda (l1-element)
- (not ((member-procedure pred) l1-element l2)))
- l1)))))
-
-(define (any-type? element)
- element ;ignore
- true)
\ No newline at end of file
(global-definitions "../runtime/runtime")
(define-package (scode-optimizer)
- (files "lsets"
- "table"
- "pthmap"
+ (files "pthmap"
"object"
"emodel"
"gconst"
THE-ENVIRONMENT?
VARIABLE?)))
(sf-conditionally "object")
- (sf-conditionally "lsets")
(sf-directory "."))
(load-option 'CREF)
;;; package: (scode-optimizer integrate)
(declare (usual-integrations)
- (integrate-external "object" "lsets"))
+ (integrate-external "object"))
\f
(define *top-level-block*)
(else
(let ((this-parameter (car parameters))
(this-operand (car operands)))
- (cond ((set/member? free-in-body this-parameter)
+ (cond ((memq this-parameter free-in-body)
(loop (cdr parameters)
(cdr operands)
(cons this-parameter required-parameters)
\f
(define *block-optimizing-switch #f)
-;; This is overly hairy, but if it works, no one need know.
-;; What we do is this:
-;; 1 Make a directed graph of the dependencies in an open
-;; block.
-;; 2 Identify the circular dependencies and place them in
-;; a open block.
-;; 3 Identify the bindings that can be made in parallel and
-;; make LET type statements.
-;; 4 This deletes unused bindings in an open block and
-;; compartmentalizes the environment.
-;; 5 Re-optimize the code in the body. This can help if the
-;; eta-substitution-switch is on.
-
(define (open-block/optimizing-make expression block vars values
actions operations environment)
- (if (and *block-optimizing-switch
- (block/safe? block))
- (let ((table:var->vals (associate-vars-and-vals vars values))
- (bound-variables (varlist->varset vars)))
- (let ((table:vals->free
- (get-free-vars-in-bindings bound-variables values))
- (body-free (get-body-free-vars bound-variables actions)))
- ;; (write-string "Free vars in body")
- ;; (display (map variable/name body-free))
- (let ((graph (build-graph vars
- table:var->vals
- table:vals->free
- body-free)))
- (collapse-circularities! graph)
- ;; (print-graph graph)
- (label-node-depth! graph)
- (let ((template (linearize graph)))
- ;; (print-template template)
- (integrate/expression
- operations environment
- (build-new-code expression
- template
- (block/parent block)
- table:var->vals actions))))))
- (open-block/make
- (and expression (object/scode expression))
- block vars values actions #t)))
-
-#|
-(define (print-template template)
- (if (null? template)
- '()
- (let ((this (car template)))
- (newline)
- (display (car this))
- (display (map variable/name (cdr this)))
- (print-template (cdr template)))))
-|#
-
-(define (associate-vars-and-vals vars vals)
- (let ((table (make-generic-eq?-table)))
- (define (fill-table vars vals)
- (cond ((null? vars) (if (null? vals) '() (error "Mismatch")))
- ((null? vals) (error "Mismatch"))
- (else (table-put! table (car vars) (car vals))
- (fill-table (cdr vars) (cdr vals)))))
- (fill-table vars vals)
- table))
-\f
-(declare (integrate varlist->varset nodelist->nodeset
- empty-nodeset singleton-nodeset
- empty-varset singleton-varset))
-
-(define (varlist->varset list)
- (declare (integrate list))
- (list->set variable? eq? list))
-
-(define (nodelist->nodeset list)
- (declare (integrate list))
- (list->set node? eq? list))
-
-(define (empty-nodeset)
- (empty-set node? eq?))
-
-(define (singleton-nodeset node)
- (declare (integrate node))
- (singleton-set node? eq? node))
-
-(define (empty-varset)
- (declare (integrate node))
- (empty-set variable? eq?))
-
-(define (singleton-varset variable)
- (declare (integrate variable))
- (singleton-set variable? eq? variable))
-
-(define (get-free-vars-in-bindings bound-variables vals)
- ;; find variables in bindings that are scoped to these
- ;; bound variables
- (let ((table (make-generic-eq?-table)))
- (define (kernel val)
- (let ((free-variables (free/expression val)))
- (table-put! table val
- (set/intersection bound-variables free-variables))))
- (for-each kernel vals)
- table))
-
-(define (get-body-free-vars bound-variables actions)
- (let ((body-forms (get-body actions)))
- (let loop ((body-forms body-forms)
- (free (empty-varset)))
- (if (null? body-forms)
- free
- (loop (cdr body-forms)
- (set/union free
- (set/intersection bound-variables
- (free/expression
- (car body-forms)))))))))
-
-(define (get-body actions)
- (cond ((null? actions) '())
- ((eq? (car actions) open-block/value-marker) (get-body (cdr actions)))
- (else (cons (car actions) (get-body (cdr actions))))))
-\f
-;;; Graph structure for figuring out dependencies in a LETREC
-
-(define-structure (node
- (constructor %make-node (type vars))
- (conc-name %node-))
- type
- (vars #f read-only #t)
- (needs (empty-nodeset))
- (needed-by (empty-nodeset))
- (depth #f))
-
-(define-integrable (make-base-node)
- (%make-node 'BASE (empty-varset)))
-
-(define-integrable (variable->node variable)
- (%make-node 'SETUP (singleton-varset variable)))
-
-(define-integrable (make-letrec-node variable-set)
- (%make-node 'LETREC variable-set))
-
-(define-integrable (add-node-need! needer what-i-need)
- (set-%node-needs! needer (set/adjoin (%node-needs needer) what-i-need)))
-
-(define-integrable (remove-node-need! needer what-i-no-longer-need)
- (set-%node-needs! needer
- (set/remove (%node-needs needer) what-i-no-longer-need)))
-
-(define-integrable (add-node-needed-by! needee what-needs-me)
- (set-%node-needed-by! needee
- (set/adjoin (%node-needed-by needee) what-needs-me)))
-
-(define-integrable (remove-node-needed-by! needee what-needs-me)
- (set-%node-needed-by! needee
- (set/remove (%node-needed-by needee) what-needs-me)))
-\f
-(define (build-graph vars table:var->vals table:vals->free body-free)
- (let ((table:variable->node (make-generic-eq?-table)))
-
- (define (kernel variable)
- (let ((node (variable->node variable)))
- (table-put! table:variable->node variable node)))
-
- (for-each kernel vars)
-
- (link-nodes! body-free table:var->vals table:vals->free vars
- table:variable->node)))
-
-(define-integrable (link-2-nodes! from-node to-node)
- (add-node-need! from-node to-node)
- (add-node-needed-by! to-node from-node))
-
-(define (unlink-node! node)
- (set/for-each (lambda (needer)
- (remove-node-needed-by! needer node))
- (%node-needs node))
- (set/for-each (lambda (needee)
- (remove-node-need! needee node))
- (%node-needed-by node))
- (set-%node-type! node 'UNLINKED))
-
-(define-integrable (unlink-nodes! nodelist)
- (for-each unlink-node! nodelist))
-
-(define (link-nodes! body-free
- table:var->vals table:vals->free variables table:var->node)
-
- (define (kernel variable)
- (table-get table:var->node variable
- (lambda (node)
- (table-get-chain variable
- (lambda (free-vars)
- (set/for-each
- (lambda (needed-var)
- (table-get table:var->node needed-var
- (lambda (needed-node)
- (link-2-nodes! node needed-node))
- (lambda ()
- (error "Broken analysis: can't get node"))))
- free-vars))
- (lambda () (error "Broken analysis: can't get free variable info"))
- table:var->vals table:vals->free))
- (lambda () (error "Broken analysis: no node for variable"))))
-
- (for-each kernel variables)
-
- (let ((base-node (make-base-node)))
- (set/for-each
- (lambda (needed-var)
- (table-get table:var->node needed-var
- (lambda (needed-node)
- (link-2-nodes! base-node needed-node))
- (lambda () (error "Broken analysis: free var"))))
- body-free)
- base-node))
-\f
-(define (collapse-circularities! graph)
- ;; Search for a circularity: if found, collapse it, and repeat
- ;; until none are found.
- (define (loop)
- (find-circularity graph
- (lambda (nodelist)
- (collapse-nodelist! nodelist)
- (loop))
- (lambda () graph)))
- (loop))
-
-(define (find-circularity graph if-found if-not)
- ;; Walk the tree keeping track of nodes visited
- ;; If a node is encountered more than once, there is
- ;; a circularitiy. NODES-VISITED is a list kept in
- ;; base node first order. If a node is found on the
- ;; list, the tail of the list is the nodes in the
- ;; circularity.
-
- (define (fc this-node nodes-visited if-found if-not)
- (if (null? this-node)
- (if-not)
- (let ((circularity (memq this-node nodes-visited)))
- (if circularity
- (if-found circularity)
- ;; Add this node to the visited list, and loop
- ;; over the needs of this node.
- (let ((new-visited (append nodes-visited (list this-node))))
- (let loop ((needs (set->list (%node-needs this-node))))
- (if (null? needs)
- (if-not)
- (fc (car needs) new-visited if-found
- (lambda () (loop (cdr needs)))))))))))
-
- (fc graph '() if-found if-not))
-
-(define (collapse-nodelist! nodelist)
- ;; Replace the nodes in the nodelist with a single node that
- ;; has all the variables in it. This node will become a LETREC
- ;; form.
-
- ;; Error check: make sure graph is consistant.
- (for-each (lambda (node) (if (eq? (%node-type node) 'UNLINKED)
- (error "node not linked")))
- nodelist)
-
- (let ((nodeset (nodelist->nodeset nodelist)))
- (let ((varset (apply set/union* (map %node-vars nodelist)))
- (needs-set (set/difference
- (apply set/union* (map %node-needs nodelist))
- nodeset))
- (needed-by (set/difference
- (apply set/union* (map %node-needed-by nodelist))
- nodeset)))
-
- (let ((letrec-node (make-letrec-node varset)))
- (set/for-each (lambda (need) (link-2-nodes! letrec-node need))
- needs-set)
- (set/for-each
- (lambda (needer) (link-2-nodes! needer letrec-node)) needed-by)
- ;; now delete nodes in nodelist
- (unlink-nodes! nodelist)))))
-\f
-(define (label-node-depth! graph)
- (define (label-nodes! nodeset depth)
- (if (set/empty? nodeset)
- '()
- (begin
- (set/for-each (lambda (node) (set-%node-depth! node depth)) nodeset)
- (label-nodes!
- (apply set/union* (map %node-needs (set->list nodeset)))
- (1+ depth)))))
- (label-nodes! (singleton-nodeset graph) 0))
-
-#|
-(define (print-graph node)
- (if (null? node)
- '()
- (begin
- (newline)
- (display (%node-depth node))
- (display (%node-type node))
- (set/for-each (lambda (variable)
- (display " ")
- (display (variable/name variable)))
- (%node-vars node))
- (set/for-each print-graph (%node-needs node)))))
-|#
-
-(define (collapse-parallel-nodelist depth nodeset)
- (if (set/empty? nodeset)
- '()
- (let loop ((nodestream (set->list nodeset))
- (let-children (empty-varset))
- (letrec-children (empty-varset))
- (children (empty-nodeset)))
- (if (null? nodestream)
- (let ((outer-contour
- (collapse-parallel-nodelist (1+ depth) children)))
- (append (if (set/empty? let-children)
- '()
- (list (cons 'LET (set->list let-children))))
- (if (set/empty? letrec-children)
- '()
- (list (cons 'LETREC (set->list letrec-children))))
- outer-contour))
- (let ((this-node (car nodestream)))
- (if (= (%node-depth this-node) (1+ depth))
- (if (eq? (%node-type this-node) 'LETREC)
- (loop (cdr nodestream)
- let-children
- (set/union (%node-vars this-node) letrec-children)
- (set/union (%node-needs this-node) children))
- (loop (cdr nodestream)
- (set/union (%node-vars this-node) let-children)
- letrec-children
- (set/union (%node-needs this-node) children)))
- ;; deeper nodes will be picked up later
- (loop (cdr nodestream)
- let-children
- letrec-children
- children)))))))
-\f
-(define (linearize graph)
- (collapse-parallel-nodelist 0 (%node-needs graph)))
-
-(define (build-new-code expression template parent vars->vals actions)
- (let ((body (sequence/optimizing-make expression (get-body actions))))
- (let loop ((template template)
- (block parent)
- (code body))
- (if (null? template)
- code
- (let ((this (car template)))
- (let ((this-type (car this))
- (this-vars (cdr this)))
- (let ((this-vals
- (map (lambda (var)
- (table-get vars->vals var
- (lambda (val) val)
- (lambda () (error "broken"))))
- this-vars)))
-
- (if (eq? this-type 'LET)
- (let ((block (block/make block #t this-vars)))
- (loop (cdr template)
- block
- (combination/optimizing-make
- expression
- block
- (procedure/make
- #f
- block
- lambda-tag:let
- this-vars
- '()
- #f
- code)
- this-vals)))
- (let ((block (block/make block #t this-vars)))
- (loop (cdr template)
- block
- (open-block/make
- (and expression (object/scode expression))
- block this-vars this-vals
- (append (make-list
- (length this-vals)
- open-block/value-marker)
- (list code))
- #t)))))))))))
\ No newline at end of file
+ (declare (ignore operations environment))
+ (open-block/make
+ (and expression (object/scode expression))
+ block vars values actions #t))
+++ /dev/null
-#| -*-Scheme-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-|#
-
-(declare (usual-integrations)
- (automagic-integrations)
- (open-block-optimizations)
- (eta-substitution))
-\f
-;;; simple table abstraction
-;;;
-;;; A table is a mutable mapping from key to value. There is a
-;;; comparison function to determine whether two keys are the same
-
-;;; A table is a 4 tuple consisting of a get-function, a put-function,
-;;; a remove-function, and a function to handle anything else.
-;;;
-
-;;; My big problem with this is that we have to go through the continuation
-;;; passing style get function whether we want to or not.
-
-(define-structure (table (conc-name %table-)
- (constructor %make-table))
- (get-function false read-only true)
- (put!-function false read-only true)
- (remove!-function false read-only true)
- (anything-else false read-only true))
-
-(define-integrable (table-get table key if-found if-not-found)
- ((%table-get-function table) key if-found if-not-found))
-
-(define-integrable (table-put! table key value)
- ((%table-put!-function table) key value))
-
-(define-integrable (table-remove! table key)
- ((%table-remove!-function table) key))
-
-(define-integrable (table-function table operation arglist)
- ((%table-anything-else table) operation arglist))
-
-(define (table-get-chain key1 if-found if-not-found . tables)
- (let loop ((table-list tables)
- (key key1))
- (if (null? table-list)
- (if-found key)
- (table-get (car table-list) key
- (lambda (value)
- (loop (cdr table-list) value))
- if-not-found))))
-
-(define (table-get-list table keylist)
- (map (lambda (key)
- (table-get table key
- identity-procedure
- (lambda () #f)))
- keylist))
-\f
-;;; Returns a table
-
-(define (make-generic-eq?-table)
- (let ((the-table '()))
-
- (declare (integrate make-entry
- entry-value
- set-entry-value!
- lookup
- extend-table!))
-
- (define make-entry cons)
- (define entry-value cdr)
- (define set-entry-value! set-cdr!)
-
- (define (lookup key)
- (declare (integrate key))
- (assq key the-table))
-
- (define (extend-table! entry)
- (declare (integrate entry))
- (set! the-table (cons entry the-table)))
-
- ;; User functions
-
- (define (get key if-found if-not-found)
- (let ((entry (lookup key)))
- (if (not entry)
- (if-not-found)
- (if-found (entry-value entry)))))
-
- (define (put! key value)
- (let ((entry (lookup key)))
- (if (not entry)
- (extend-table! (make-entry key value))
- (set-entry-value! entry value))))
-
- (define (remove! key)
- (set! the-table (del-assq key the-table)))
-
- (define (dispatch message args)
- args
- (case message
- ((predicate) eq?)
- (else (error "Don't understand that message"))))
-
- (%make-table get put! remove! dispatch)))
\ No newline at end of file
(let ((environment
(if top-level?
(environment/bind (environment/make)
- (block/bound-variables-list block))
+ (block/bound-variables block))
(environment/make))))
(if (scode-open-block? expression)
(begin
(lambda (required optional rest)
(let ((environment
(environment/bind environment
- (block/bound-variables-list block))))
+ (block/bound-variables block))))
(procedure/make
expression block name required optional rest
(transform/procedure-body block
projects / mit-scheme.git / commitdiff