--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.1 1987/12/04 20:00:46 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Environment model data structures
+
+(declare (usual-integrations))
+\f
+#|
+
+Interpreter compatible (hereafter, IC) blocks are vectors with an
+implementation dependent number of reserved slots at the beginning,
+followed by the variable bindings for that frame, in the usual order.
+The parent of such a frame is always an IC block or a global block,
+but extracting a pointer to that parent from the frame is again
+implementation dependent and possibly a complex operation. During the
+execution of an IC procedure, the block pointer is kept in the ENV
+register.
+
+Perfect closure blocks are vectors whose slots contain the values for
+the free variables in a closure procedure. The ordering of these
+slots is arbitrary.
+
+Imperfect closure blocks are similar, except that the first slot of
+the vector points to the parent, which is always an IC block.
+
+Stack blocks are contiguous regions of the stack. A stack block
+pointer is the address of that portion of the block which is nearest
+to the top of the stack (on the 68000, the most negative address in
+the block.)
+
+In closure and stack blocks, variables which the analyzer can
+guarantee will not be modified have their values stored directly in
+the block. For all other variables, the binding slot in the block
+contains a pointer to a cell which contains the value.
+
+Note that blocks of type CONTINUATION never have any children. This
+is because the body of a continuation is always generated separately
+from the continuation, and then "glued" into place afterwards.
+
+|#
+\f
+(define-rvalue block
+ type ;block type (see below)
+ parent ;lexically enclosing parent
+ children ;lexically enclosed children
+ disowned-children ;children whose `parent' used to be this block
+ frame-size ;for stack-allocated frames, size in words
+ procedure ;procedure for which this is invocation block, if any
+ bound-variables ;list of variables bound by this block
+ free-variables ;list of variables free in this block
+ declarations ;list of declarations
+ applications ;list of applications lexically within this block
+ interned-variables ;alist of interned SCode variable objects
+ closure-offsets ;for closure block, alist of bound variable offsets
+ frame ;debugging information (???)
+ stack-link ;for internal block, adjacent block on stack
+ )
+
+(define *blocks*)
+
+(define (make-block parent type)
+ (let ((block
+ (make-rvalue block-tag (enumeration/name->index block-types type)
+ parent '() '() false false '() '() '() '() '() '() false
+ false 'UNKNOWN)))
+ (if parent
+ (set-block-children! parent (cons block (block-children parent))))
+ (set! *blocks* (cons block *blocks*))
+ block))
+
+(define-vector-tag-unparser block-tag
+ (lambda (block)
+ (write-string "BLOCK")
+ (let ((procedure (block-procedure block)))
+ (if (and procedure (rvalue/procedure? procedure))
+ (begin (write-string " ")
+ (write (procedure-label procedure)))))))
+
+(define-integrable (rvalue/block? rvalue)
+ (eq? (tagged-vector/tag rvalue) block-tag))
+\f
+(define (add-block-application! block application)
+ (set-block-applications! block
+ (cons application (block-applications block))))
+
+(define (intern-scode-variable! block name)
+ (let ((entry (assq name (block-interned-variables block))))
+ (if entry
+ (cdr entry)
+ (let ((variable (scode/make-variable name)))
+ (set-block-interned-variables!
+ block
+ (cons (cons name variable) (block-interned-variables block)))
+ variable))))
+
+(define block-passed-out?
+ rvalue-%passed-out?)
+\f
+;;;; Block Type
+
+(define-enumeration block-type
+ (closure ;heap-allocated closing frame, compiler format
+ continuation ;continuation invocation frame
+ expression ;execution frame for expression (indeterminate type)
+ ic ;interpreter compatible heap-allocated frame
+ procedure ;invocation frame for procedure (indeterminate type)
+ stack ;invocation frame for procedure, stack-allocated
+ ))
+
+(define-integrable (ic-block? block)
+ (eq? (block-type block) block-type/ic))
+
+(define-integrable (closure-block? block)
+ (eq? (block-type block) block-type/closure))
+
+(define-integrable (stack-block? block)
+ (eq? (block-type block) block-type/stack))
+
+(define-integrable (continuation-block? block)
+ (eq? (block-type block) block-type/continuation))
+
+(define (block/external? block)
+ (and (stack-block? block)
+ (not (stack-parent? block))))
+
+(define (block/internal? block)
+ (and (stack-block? block)
+ (stack-parent? block)))
+
+(define (stack-parent? block)
+ (and (block-parent block)
+ (stack-block? (block-parent block))))
+
+(define-integrable (ic-block/use-lookup? block)
+ (or (rvalue/procedure? (block-procedure block))
+ (not compiler:cache-free-variables?)))
+\f
+;;;; Block Inheritance
+
+(define (block-ancestor-or-self? block block*)
+ (or (eq? block block*)
+ (block-ancestor? block block*)))
+
+(define (block-ancestor? block block*)
+ (define (loop block)
+ (and block
+ (or (eq? block block*)
+ (loop (block-parent block)))))
+ (loop (block-parent block)))
+
+(define-integrable (block-child? block block*)
+ (eq? block (block-parent block*)))
+
+(define-integrable (block-sibling? block block*)
+ ;; Assumes that at least one block has a parent.
+ (eq? (block-parent block) (block-parent block*)))
+
+(define (block-nearest-common-ancestor block block*)
+ (let loop
+ ((join false)
+ (ancestry (block-ancestry block '()))
+ (ancestry* (block-ancestry block* '())))
+ (if (and (not (null? ancestry))
+ (not (null? ancestry*))
+ (eq? (car ancestry) (car ancestry*)))
+ (loop (car ancestry) (cdr ancestry) (cdr ancestry*))
+ join)))
+
+(define (block-farthest-uncommon-ancestor block block*)
+ (let loop
+ ((ancestry (block-ancestry block '()))
+ (ancestry* (block-ancestry block* '())))
+ (and (not (null? ancestry))
+ (if (and (not (null? ancestry*))
+ (eq? (car ancestry) (car ancestry*)))
+ (loop (cdr ancestry) (cdr ancestry*))
+ (car ancestry)))))
+
+(define (block-ancestry block path)
+ (if (block-parent block)
+ (block-ancestry (block-parent block) (cons block path))
+ (cons block path)))
+\f
+(define (stack-block/external-ancestor block)
+ (let ((parent (block-parent block)))
+ (if (and parent (stack-block? parent))
+ (stack-block/external-ancestor parent)
+ block)))
+
+(define (block/external-ancestor block)
+ (if (stack-block? block)
+ (stack-block/external-ancestor block)
+ block))
+
+(define (stack-block/ancestor-distance block offset join)
+ (let loop ((block block) (n offset))
+ (if (eq? block join)
+ n
+ (loop (block-parent block)
+ (+ n (block-frame-size block))))))
+
+(define (for-each-block-descendent! block procedure)
+ (let loop ((block block))
+ (procedure block)
+ (for-each loop (block-children block))))
+
+(define-integrable (internal-block/parent-known? block)
+ (not (null? (block-stack-link block))))
+
+(define-integrable (stack-block/continuation-lvalue block)
+ (procedure-continuation-lvalue (block-procedure block)))
+
+(define (stack-block/static-link? block)
+ (and (not (null? (block-free-variables block)))
+ (or (not (stack-block? (block-parent block)))
+ (not (internal-block/parent-known? block)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.150 1987/08/07 17:02:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.1 1987/12/04 20:03:16 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
;;;; Node Datatypes
-(define cfg-node-tag (make-vector-tag false 'CFG-NODE))
-(define cfg-node? (tagged-vector-subclass-predicate cfg-node-tag))
+(define cfg-node-tag (make-vector-tag false 'CFG-NODE false))
+(define cfg-node? (tagged-vector/subclass-predicate cfg-node-tag))
(define-vector-slots node 1 generation previous-edges)
-(define-vector-method cfg-node-tag ':DESCRIBE
- (lambda (node)
- (descriptor-list node generation previous-edges)))
+(set-vector-tag-description!
+ cfg-node-tag
+ (lambda (node)
+ (descriptor-list node generation previous-edges)))
-(define snode-tag (make-vector-tag cfg-node-tag 'SNODE))
-(define snode? (tagged-vector-subclass-predicate snode-tag))
+(define snode-tag (make-vector-tag cfg-node-tag 'SNODE false))
+(define snode? (tagged-vector/subclass-predicate snode-tag))
(define-vector-slots snode 3 next-edge)
(define (make-snode tag . extra)
(list->vector (cons* tag false '() false extra)))
-(define-vector-method snode-tag ':DESCRIBE
- (lambda (snode)
- (append! ((vector-tag-parent-method snode-tag ':DESCRIBE) snode)
- (descriptor-list snode next-edge))))
+(set-vector-tag-description!
+ snode-tag
+ (lambda (snode)
+ (append! ((vector-tag-description (vector-tag-parent snode-tag)) snode)
+ (descriptor-list snode next-edge))))
-(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE))
-(define pnode? (tagged-vector-subclass-predicate pnode-tag))
+(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE false))
+(define pnode? (tagged-vector/subclass-predicate pnode-tag))
(define-vector-slots pnode 3 consequent-edge alternative-edge)
(define (make-pnode tag . extra)
(list->vector (cons* tag false '() false false extra)))
-(define-vector-method pnode-tag ':DESCRIBE
- (lambda (pnode)
- (append! ((vector-tag-parent-method pnode-tag ':DESCRIBE) pnode)
- (descriptor-list pnode consequent-edge alternative-edge))))
+(set-vector-tag-description!
+ pnode-tag
+ (lambda (pnode)
+ (append! ((vector-tag-description (vector-tag-parent pnode-tag)) pnode)
+ (descriptor-list pnode consequent-edge alternative-edge))))
+
+(define (add-node-previous-edge! node edge)
+ (set-node-previous-edges! node (cons edge (node-previous-edges node))))
+
+(define (delete-node-previous-edge! node edge)
+ (set-node-previous-edges! node (delq! edge (node-previous-edges node))))
(define (edge-next-node edge)
(and edge (edge-right-node edge)))
\f
;;;; Edge Datatype
-(define-vector-slots edge 0 left-node left-connect right-node)
-
-(define-integrable (make-edge left-node left-connect right-node)
- (vector left-node left-connect right-node))
+(define-structure (edge (type vector)) left-node left-connect right-node)
(define (create-edge! left-node left-connect right-node)
(let ((edge (make-edge left-node left-connect right-node)))
(if left-node
(left-connect left-node edge))
(if right-node
- (let ((previous (node-previous-edges right-node)))
- (if (not (memq right-node previous))
- (set-node-previous-edges! right-node (cons edge previous)))))))
+ (add-node-previous-edge! right-node edge))
+ edge))
(define (edge-connect-left! edge left-node left-connect)
- (set-edge-left-node! edge left-node)
- (set-edge-left-connect! edge left-connect)
+ (if (edge-left-node edge)
+ (error "Attempt to doubly connect left node of edge" edge))
(if left-node
- (left-connect left-node edge)))
+ (begin
+ (set-edge-left-node! edge left-node)
+ (set-edge-left-connect! edge left-connect)
+ (left-connect left-node edge))))
(define (edge-connect-right! edge right-node)
- (set-edge-right-node! edge right-node)
+ (if (edge-right-node edge)
+ (error "Attempt to doubly connect right node of edge" edge))
(if right-node
- (let ((previous (node-previous-edges right-node)))
- (if (not (memq right-node previous))
- (set-node-previous-edges! right-node (cons edge previous))))))
-
-(define (edges-connect-right! edges right-node)
- (for-each (lambda (edge)
- (edge-connect-right! edge right-node))
- edges))
+ (begin
+ (set-edge-right-node! edge right-node)
+ (add-node-previous-edge! right-node edge))))
(define (edge-disconnect-left! edge)
- (let ((left-node (set-edge-left-node! edge false))
- (left-connect (set-edge-left-connect! edge false)))
+ (let ((left-node (edge-left-node edge))
+ (left-connect (edge-left-connect edge)))
(if left-node
- (left-connect left-node false))))
+ (begin
+ (set-edge-left-node! edge false)
+ (set-edge-left-connect! edge false)
+ (left-connect left-node false)))))
(define (edge-disconnect-right! edge)
- (let ((right-node (set-edge-right-node! edge false)))
+ (let ((right-node (edge-right-node edge)))
(if right-node
- (set-node-previous-edges! right-node
- (delq! edge
- (node-previous-edges right-node))))))
+ (begin
+ (set-edge-right-node! edge false)
+ (delete-node-previous-edge! right-node edge)))))
+
+(define (edges-connect-right! edges right-node)
+ (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges))
(define (edge-disconnect! edge)
(edge-disconnect-left! edge)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 1.3 1987/08/31 21:17:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 4.1 1987/12/04 20:03:33 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(edges-connect-right! previous-edges snode)
(create-edge! snode set-snode-next-edge! node)))
-(define (node->edge node)
- (let ((edge (make-edge false false false)))
- (edge-connect-right! edge node)
- edge))
+(define-integrable (node->edge node)
+ (create-edge! false false node))
(define-integrable (cfg-entry-edge cfg)
(node->edge (cfg-entry-node cfg)))\f
value)))
(define noop-node-tag
- (make-vector-tag snode-tag 'NOOP))
+ (make-vector-tag snode-tag 'NOOP false))
(define-integrable (make-noop-node)
(let ((node (make-snode noop-node-tag)))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.1 1987/12/04 20:00:53 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Continuation datatype
+
+(declare (usual-integrations))
+\f
+;;; Continuations are a subtype of procedures, whose `type' is
+;;; something other than PROCEDURE.
+
+(define (make-continuation block continuation type)
+ (let ((block (make-block block 'CONTINUATION)))
+ (let ((required (list (make-value-variable block))))
+ (set-block-bound-variables! block required)
+ (make-procedure type block 'CONTINUATION required '() false '() '()
+ (make-fg-noop)))))
+
+(define-enumeration continuation-type
+ (effect
+ predicate
+ procedure
+ push
+ register
+ value))
+
+(define-integrable (procedure-continuation? procedure)
+ (not (eq? (procedure-type procedure) continuation-type/procedure)))
+
+(define (rvalue/continuation? rvalue)
+ (and (rvalue/procedure? rvalue)
+ (procedure-continuation? rvalue)))
+
+(define-integrable continuation/type procedure-type)
+(define-integrable set-continuation/type! set-procedure-type!)
+(define-integrable continuation/block procedure-block)
+(define-integrable continuation/closing-block procedure-closing-block)
+(define-integrable continuation/entry-node procedure-entry-node)
+(define-integrable set-continuation/entry-node! set-procedure-entry-node!)
+(define-integrable continuation/combinations procedure-original-rest)
+(define-integrable set-continuation/combinations! set-procedure-original-rest!)
+(define-integrable continuation/label procedure-label)
+(define-integrable continuation/returns procedure-applications)
+(define-integrable set-continuation/returns! set-procedure-applications!)
+(define-integrable continuation/always-known-operator?
+ procedure-always-known-operator?)
+(define-integrable continuation/dynamic-link? procedure-closing-limit)
+(define-integrable set-continuation/dynamic-link?!
+ set-procedure-closing-limit!)
+(define-integrable continuation/lvalues procedure-closure-block)
+(define-integrable set-continuation/lvalues! set-procedure-closure-block!)
+(define-integrable continuation/offset procedure-closure-offset)
+(define-integrable set-continuation/offset! set-procedure-closure-offset!)
+(define-integrable continuation/passed-out? procedure-passed-out?)
+(define-integrable set-continuation/passed-out?! set-procedure-passed-out?!)
+\f
+(define (continuation/register continuation)
+ (or (procedure-register continuation)
+ (let ((register (rtl:make-pseudo-register)))
+ (set-procedure-register! continuation register)
+ register)))
+
+(define-integrable (continuation/parameter continuation)
+ (car (procedure-original-required continuation)))
+
+(define-integrable return-operator/subproblem? rvalue/procedure?)
+(define-integrable return-operator/reduction? rvalue/reference?)
+
+(define-integrable reduction-continuation/block reference-block)
+(define-integrable reduction-continuation/lvalue reference-lvalue)
+
+(define-integrable (reduction-continuation/popping-limit continuation)
+ (variable-popping-limit (reference-lvalue continuation)))
+
+(define (return-operator/popping-limit operator)
+ (if (return-operator/reduction? operator)
+ (reduction-continuation/popping-limit operator)
+ (continuation/closing-block operator)))
+
+(define (continuation/frame-size continuation)
+ (cond ((continuation/always-known-operator? continuation) 0)
+ ((continuation/dynamic-link? continuation) 2)
+ (else 1)))
+
+(define (uni-continuation? rvalue)
+ (and (rvalue/procedure? rvalue)
+ (procedure-arity-correct? rvalue 1)))
+
+(define-integrable (uni-continuation/parameter continuation)
+ (car (procedure-original-required continuation)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.51 1987/08/07 17:03:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.1 1987/12/04 20:03:40 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define-snode assignment block lvalue rvalue)
+;;;; Application
+
+(define-snode application
+ type
+ block
+ operator
+ operands
+ (parallel-node owner)
+ (operators ;used in simulate-application
+ arguments) ;used in outer-analysis
+ operand-values ;set by outer-analysis, used by identify-closure-limits
+ )
+
+(define *applications*)
+
+(define (make-application type block operator operands)
+ (let ((application
+ (make-snode application-tag
+ type block operator operands false '() '())))
+ (set! *applications* (cons application *applications*))
+ (add-block-application! block application)
+ (if (rvalue/reference? operator)
+ (add-lvalue-application! (reference-lvalue operator) application))
+ (make-scfg application '())))
+
+(define-vector-tag-unparser application-tag
+ (lambda (application)
+ (let ((type (application-type application)))
+ (cond ((eq? type 'COMBINATION)
+ (write-string "COMBINATION"))
+ ((eq? type 'RETURN)
+ (write-string "RETURN ")
+ (write (return/operand application)))
+ (else
+ (write-string "APPLICATION ")
+ (write type))))))
+
+(define-snode parallel
+ application-node
+ subproblems)
+
+(define *parallels*)
+
+(define (make-parallel application subproblems)
+ (let ((parallel (make-snode parallel-tag false subproblems)))
+ (set-parallel-application-node! parallel application)
+ (set-application-parallel-node! application parallel)
+ (set! *parallels* (cons parallel *parallels*))
+ (snode->scfg parallel)))
+\f
+(define (make-combination block continuation operator operands)
+ (let ((application
+ (make-application 'COMBINATION
+ block
+ (subproblem-rvalue operator)
+ (cons continuation
+ (map subproblem-rvalue operands)))))
+ (scfg*scfg->scfg!
+ (make-parallel (cfg-entry-node application) (cons operator operands))
+ application)))
+
+(define-integrable (application/combination? application)
+ (eq? (application-type application) 'COMBINATION))
+
+(define-integrable combination/block application-block)
+(define-integrable combination/operator application-operator)
+(define-integrable combination/inliner application-arguments)
+(define-integrable set-combination/inliner! set-application-arguments!)
+(define-integrable combination/frame-size application-operand-values)
+(define-integrable set-combination/frame-size! set-application-operand-values!)
+(define-integrable combination/inline? combination/inliner)
+
+(define-integrable (combination/continuation combination)
+ (car (application-operands combination)))
+
+(define-integrable (combination/operands combination)
+ (cdr (application-operands combination)))
+
+(define-structure (inliner (type vector) (conc-name inliner/))
+ (handler false read-only true)
+ (generator false read-only true)
+ operands)
+\f
+;;; This method of handling constant combinations has the feature that
+;;; such combinations are handled exactly like RETURNs by the
+;;; procedure classification phase, which occurs after all constant
+;;; combinations have been identified.
+
+(define (combination/constant! combination rvalue)
+ (let ((continuation (combination/continuation combination)))
+ (set-application-type! combination 'RETURN)
+ (set-application-operator! combination continuation)
+ (set-application-operands! combination (list rvalue))))
+
+(define-integrable (make-return block continuation rvalue)
+ (make-application 'RETURN block continuation (list rvalue)))
+
+(define-integrable (application/return? application)
+ (eq? (application-type application) 'RETURN))
+
+(define-integrable return/block
+ application-block)
+
+(define-integrable return/operator
+ application-operator)
+
+(define-integrable (return/operand return)
+ (car (application-operands return)))
+\f
+;;;; Miscellaneous Node Types
+
+(define-snode assignment
+ block
+ lvalue
+ rvalue)
+
+(define *assignments*)
(define (make-assignment block lvalue rvalue)
- (vnode-connect! lvalue rvalue)
- (if (variable? lvalue)
- (variable-assigned! lvalue))
- (snode->scfg (make-snode assignment-tag block lvalue rvalue)))
+ (lvalue-connect! lvalue rvalue)
+ (let ((assignment (make-snode assignment-tag block lvalue rvalue)))
+ (set! *assignments* (cons assignment *assignments*))
+ (snode->scfg assignment)))
-(define-snode definition block lvalue rvalue)
+(define-snode definition
+ block
+ lvalue
+ rvalue)
(define (make-definition block lvalue rvalue)
- (vnode-connect! lvalue rvalue)
- (if (variable? lvalue)
- (variable-assigned! lvalue))
+ (lvalue-connect! lvalue rvalue)
(snode->scfg (make-snode definition-tag block lvalue rvalue)))
-(define-pnode true-test rvalue)
+(define-pnode true-test
+ rvalue)
-(define-integrable (make-true-test rvalue)
+(define (make-true-test rvalue)
(pnode->pcfg (make-pnode true-test-tag rvalue)))
-(define-pnode unassigned-test block variable)
+(define-snode fg-noop)
-(define-integrable (make-unassigned-test block variable)
- (pnode->pcfg (make-pnode unassigned-test-tag block variable)))
+(define (make-fg-noop)
+ (snode->scfg (make-snode fg-noop-tag)))
-(define-pnode unbound-test block variable)
+(define-snode virtual-return
+ operator
+ operand)
-(define-integrable (make-unbound-test block variable)
- (pnode->pcfg (make-pnode unbound-test-tag block variable)))
-\f
-(define-snode combination block compilation-type value operator operands
- procedures known-operator constant?)
-(define *combinations*)
-
-(define (make-combination block compilation-type value operator operands)
- (let ((combination
- (make-snode combination-tag block compilation-type value operator
- operands '() false false)))
- (define (add-vnode-combination! vnode)
- (set-vnode-combinations! vnode
- (cons combination (vnode-combinations vnode))))
- (set! *combinations* (cons combination *combinations*))
- (set-block-combinations! block
- (cons combination (block-combinations block)))
- (let ((rvalue (subproblem-value operator)))
- (cond ((vnode? rvalue)
- (add-vnode-combination! rvalue))
- ((reference? rvalue)
- (add-vnode-combination! (reference-variable rvalue)))))
- (snode->scfg combination)))
-
-(define-integrable (combination-compiled-for-predicate? combination)
- (eq? 'PREDICATE (combination-compilation-type combination)))
-
-(define-integrable (combination-compiled-for-effect? combination)
- (eq? 'EFFECT (combination-compilation-type combination)))
-
-(define-integrable (combination-compiled-for-value? combination)
- (eq? 'VALUE (combination-compilation-type combination)))
-\f
-(define continuation-tag
- (make-vector-tag false 'CONTINUATION))
+(define (make-virtual-return operator operand)
+ (snode->scfg (make-snode virtual-return-tag operator operand)))
-(define continuation?
- (tagged-vector-predicate continuation-tag))
+(define (make-push block rvalue)
+ (make-virtual-return (virtual-continuation/make block continuation-type/push)
+ rvalue))
-(define-vector-slots continuation 1
- rtl-edge
- label
- frame-pointer-offset
- block
- rgraph)
-
-(define *continuations*)
-
-(define (make-continuation block rgraph)
- (let ((continuation
- (vector continuation-tag
- false
- (generate-label 'CONTINUATION)
- false
- block
- rgraph)))
- (set! *continuations* (cons continuation *continuations*))
- (set-rgraph-continuations!
- rgraph
- (cons continuation (rgraph-continuations rgraph)))
- (symbol-hash-table/insert! *label->object*
- (continuation-label continuation)
- continuation)
- continuation))
-
-(define-unparser continuation-tag
- (lambda (continuation)
- (write (continuation-label continuation))))
-
-(define-integrable (label->continuation label)
- (symbol-hash-table/lookup *label->object* label))
\ No newline at end of file
+(define-snode pop
+ continuation)
+
+(define (make-pop continuation)
+ (snode->scfg (make-snode pop-tag continuation)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.1 1987/12/04 20:00:58 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler Debugging Support
+
+(declare (usual-integrations))
+\f
+(define (po object)
+ (let ((object (->tagged-vector object)))
+ (write-line object)
+ (for-each pp ((tagged-vector/description object) object))))
+
+(define (dump-rtl filename)
+ (write-instructions
+ (lambda ()
+ (with-output-to-file (pathname-new-type (->pathname filename) "rtl")
+ (lambda ()
+ (for-each show-rtl-instruction
+ ((access linearize-rtl rtl-generator-package)
+ *rtl-graphs*)))))))
+
+(define (show-rtl rtl)
+ (pp-instructions
+ (lambda ()
+ (for-each show-rtl-instruction rtl))))
+
+(define (show-bblock-rtl bblock)
+ (pp-instructions
+ (lambda ()
+ (bblock-walk-forward (->tagged-vector bblock)
+ (lambda (rinst)
+ (show-rtl-instruction (rinst-rtl rinst)))))))
+
+(define (write-instructions thunk)
+ (fluid-let ((*show-instruction* write-line)
+ (*unparser-radix* 16))
+ (thunk)))
+
+(define (pp-instructions thunk)
+ (fluid-let ((*show-instruction* pp)
+ ((access *pp-primitives-by-name* scheme-pretty-printer) false)
+ (*unparser-radix* 16))
+ (thunk)))
+
+(define *show-instruction*)
+
+(define (show-rtl-instruction rtl)
+ (if (memq (car rtl)
+ '(LABEL PROCEDURE-HEAP-CHECK CONTINUATION-HEAP-CHECK SETUP-LEXPR))
+ (newline))
+ (*show-instruction* rtl))
+\f
+(package (show-fg)
+
+(define *procedure-queue*)
+(define *procedures*)
+
+(define-export (show-fg)
+ (fluid-let ((*procedure-queue* (make-queue))
+ (*procedures* '()))
+ (write-string "\n---------- Expression ----------")
+ (fg/print-object *root-expression*)
+ (with-new-node-marks
+ (lambda ()
+ (fg/print-entry-node (expression-entry-node *root-expression*))
+ (queue-map! *procedure-queue*
+ (lambda (procedure)
+ (if (procedure-continuation? procedure)
+ (write-string "\n\n---------- Continuation ----------")
+ (write-string "\n\n---------- Procedure ----------"))
+ (fg/print-object procedure)
+ (fg/print-entry-node (procedure-entry-node procedure))))))
+ (write-string "\n\n---------- Blocks ----------")
+ (fg/print-blocks (expression-block *root-expression*))))
+
+(define (fg/print-entry-node node)
+ (if node
+ (fg/print-node node)))
+
+(define (fg/print-object object)
+ (newline)
+ (po object))
+
+(define (fg/print-blocks block)
+ (fg/print-object block)
+ (for-each fg/print-object (block-bound-variables block))
+ (if (not (block-parent block))
+ (for-each fg/print-object (block-free-variables block)))
+ (for-each fg/print-blocks (block-children block))
+ (for-each fg/print-blocks (block-disowned-children block)))
+\f
+(define (fg/print-node node)
+ (if (not (node-marked? node)) (begin
+ (node-mark! node)
+ (fg/print-object node)
+ (cfg-node-case (tagged-vector/tag node)
+ ((PARALLEL)
+ (for-each fg/print-subproblem (parallel-subproblems node))
+ (fg/print-node (snode-next node)))
+ ((APPLICATION)
+ (fg/print-rvalue (application-operator node))
+ (for-each fg/print-rvalue (application-operands node)))
+ ((VIRTUAL-RETURN)
+ (fg/print-rvalue (virtual-return-operand node))
+ (fg/print-node (snode-next node)))
+ ((POP)
+ (fg/print-rvalue (pop-continuation node))
+ (fg/print-node (snode-next node)))
+ ((ASSIGNMENT)
+ (fg/print-rvalue (assignment-rvalue node))
+ (fg/print-node (snode-next node)))
+ ((DEFINITION)
+ (fg/print-rvalue (definition-rvalue node))
+ (fg/print-node (snode-next node)))
+ ((TRUE-TEST)
+ (fg/print-rvalue (true-test-rvalue node))
+ (fg/print-node (pnode-consequent node))
+ (fg/print-node (pnode-alternative node)))))))
+
+(define (fg/print-rvalue rvalue)
+ (let ((rvalue (rvalue-known-value rvalue)))
+ (if (and rvalue
+ (rvalue/procedure? rvalue)
+ (not (memq rvalue *procedures*)))
+ (begin
+ (set! *procedures* (cons rvalue *procedures*))
+ (enqueue! *procedure-queue* rvalue)))))
+
+(define (fg/print-subproblem subproblem)
+ (fg/print-object subproblem)
+ (if (subproblem-canonical? subproblem)
+ (fg/print-rvalue (subproblem-continuation subproblem)))
+ (let ((prefix (subproblem-prefix subproblem)))
+ (if (not (cfg-null? prefix))
+ (fg/print-node (cfg-entry-node prefix)))))
+
+;;; end SHOW-FG
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/enumer.scm,v 4.1 1987/12/04 20:03:52 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Support for enumerations
+
+(declare (usual-integrations))
+\f
+;;;; Enumerations
+
+(define-structure (enumeration
+ (conc-name enumeration/)
+ (constructor %make-enumeration))
+ (enumerands false read-only true))
+
+(define-structure (enumerand
+ (conc-name enumerand/)
+ (print-procedure
+ (standard-unparser 'ENUMERAND
+ (lambda (enumerand)
+ (write (enumerand/name enumerand))))))
+ (enumeration false read-only true)
+ (name false read-only true)
+ (index false read-only true))
+
+(define (make-enumeration names)
+ (let ((enumerands (make-vector (length names))))
+ (let ((enumeration (%make-enumeration enumerands)))
+ (let loop ((names names) (index 0))
+ (if (not (null? names))
+ (begin
+ (vector-set! enumerands
+ index
+ (make-enumerand enumeration (car names) index))
+ (loop (cdr names) (1+ index)))))
+ enumeration)))
+
+(define-integrable (enumeration/cardinality enumeration)
+ (vector-length (enumeration/enumerands enumeration)))
+
+(define-integrable (enumeration/index->enumerand enumeration index)
+ (vector-ref (enumeration/enumerands enumeration) index))
+
+(define-integrable (enumeration/index->name enumeration index)
+ (enumerand/name (enumeration/index->enumerand enumeration index)))
+
+(define (enumeration/name->enumerand enumeration name)
+ (let ((end (enumeration/cardinality enumeration)))
+ (let loop ((index 0))
+ (if (< index end)
+ (let ((enumerand (enumeration/index->enumerand enumeration index)))
+ (if (eqv? (enumerand/name enumerand) name)
+ enumerand
+ (loop (1+ index))))
+ (error "Unknown enumeration name" name)))))
+
+(define-integrable (enumeration/name->index enumeration name)
+ (enumerand/index (enumeration/name->enumerand enumeration name)))
+\f
+;;;; Method Tables
+
+(define-structure (method-table (constructor %make-method-table))
+ (enumeration false read-only true)
+ (vector false read-only true))
+
+(define (make-method-table enumeration default-method . method-alist)
+ (let ((table
+ (%make-method-table enumeration
+ (make-vector (enumeration/cardinality enumeration)
+ default-method))))
+ (for-each (lambda (entry)
+ (define-method-table-entry table (car entry) (cdr entry)))
+ method-alist)
+ table))
+
+(define (define-method-table-entry name method-table method)
+ (vector-set! (method-table-vector method-table)
+ (enumeration/name->index (method-table-enumeration method-table)
+ name)
+ method)
+ name)
+
+(define (define-method-table-entries names method-table method)
+ (for-each (lambda (name)
+ (define-method-table-entry name method-table method))
+ names)
+ names)
+
+(define-integrable (method-table-lookup method-table index)
+ (vector-ref (method-table-vector method-table) index))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 1.2 1987/07/02 20:45:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.1 1987/12/04 20:03:56 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Compiler DFG Datatypes: Variable Nodes
+;;;; Left (Hand Side) Values
(declare (usual-integrations))
\f
-(define-vnode variable block name assigned? in-cell? normal-offset
- declarations)
+(define-root-type lvalue
+ forward-links ;lvalues that sink values from here
+ backward-links ;lvalues that source values to here
+ initial-values ;rvalues that are possible sources
+ values-cache ;(see `lvalue-values')
+ known-value ;either #F or the rvalue which is the unique value
+ applications ;applications whose operators are this lvalue
+ passed-in? ;true iff this lvalue gets an unknown value
+ passed-out? ;true iff this lvalue passes its value to unknown place
+ marks ;attribute marks list (see `lvalue-mark-set?')
+ )
+
+;;; Note that the rvalues stored in `initial-values', `values-cache',
+;;; and `known-value' are NEVER references.
+
+(define *lvalues*)
+
+(define (make-lvalue tag . extra)
+ (let ((lvalue
+ (list->vector
+ (cons* tag '() '() '() 'NOT-CACHED false '() false false '()
+ extra))))
+ (set! *lvalues* (cons lvalue *lvalues*))
+ lvalue))
+
+(define (add-lvalue-application! lvalue application)
+ (set-lvalue-applications! lvalue
+ (cons application
+ (lvalue-applications lvalue))))
+\f
+(define-lvalue variable
+ block ;block in which variable is defined
+ name ;name of variable [symbol]
+ assigned? ;true iff variable appears in an assignment
+ in-cell? ;true iff variable requires cell at runtime
+ (normal-offset ;offset of variable within `block'
+ popping-limit) ;popping-limit for continuation variables
+ declarations ;list of declarations for this variable
+ )
(define (make-variable block name)
- (make-vnode variable-tag block name false false false '()))
+ (make-lvalue variable-tag block name false false false '()))
(define variable-assoc
(association-procedure eq? variable-name))
(cdr (assq variable (block-closure-offsets block)))
(variable-normal-offset variable)))
-(define-unparser variable-tag
+(define-vector-tag-unparser variable-tag
(lambda (variable)
(write-string "VARIABLE ")
(write (variable-name variable))))
-(define-vnode access environment name)
-
-(define (make-access environment name)
- (make-vnode access-tag environment name))
-
-(define-vnode temporary type conflicts allocation)
-
-(define (make-temporary)
- (make-vnode temporary-tag false '() false))
-
-(define-vnode value-register)
-
-(define (make-value-register)
- (make-vnode value-register-tag))
-
-(define-vnode value-ignore)
-
-(define (make-value-ignore)
- (make-vnode value-ignore-tag))
\ No newline at end of file
+(define-integrable (lvalue/variable? lvalue)
+ (eq? (tagged-vector/tag lvalue) variable-tag))
+
+(let-syntax
+ ((define-named-variable
+ (macro (name)
+ (let ((symbol
+ (string->symbol
+ (string-append "#["
+ (string-downcase (symbol->string name))
+ "]"))))
+ `(BEGIN (DEFINE-INTEGRABLE
+ (,(symbol-append 'MAKE- name '-VARIABLE) BLOCK)
+ (MAKE-VARIABLE BLOCK ',symbol))
+ (DEFINE-INTEGRABLE
+ (,(symbol-append 'VARIABLE/ name '-VARIABLE?) LVALUE)
+ (EQ? (VARIABLE-NAME LVALUE) ',symbol))
+ (DEFINE (,(symbol-append name '-VARIABLE?) LVALUE)
+ (AND (VARIABLE? LVALUE)
+ (EQ? (VARIABLE-NAME LVALUE) ',symbol))))))))
+ (define-named-variable continuation)
+ (define-named-variable value))
+\f
+;;;; Linking
+
+;;; Eventually, links may be triples consisting of a source, a sink,
+;;; and a set of paths. Each path will be an ordered sequence of
+;;; actions. Actions will keep track of what paths they are part of,
+;;; and paths will keep track of what links they are part of. But for
+;;; now, this significantly cheaper representation will do.
+
+(define (lvalue-connect! lvalue rvalue)
+ (if (rvalue/reference? rvalue)
+ (lvalue-connect!:lvalue lvalue (reference-lvalue rvalue))
+ (lvalue-connect!:rvalue lvalue rvalue)))
+
+(define (lvalue-connect!:rvalue lvalue rvalue)
+ (if (not (memq rvalue (lvalue-initial-values lvalue)))
+ (set-lvalue-initial-values! lvalue
+ (cons rvalue
+ (lvalue-initial-values lvalue)))))
+
+(define (lvalue-connect!:lvalue to from)
+ (if (not (memq from (lvalue-backward-links to)))
+ (begin
+ (set-lvalue-backward-links! to (cons from (lvalue-backward-links to)))
+ (set-lvalue-forward-links! from (cons to (lvalue-forward-links from)))
+ (for-each (lambda (from)
+ (lvalue-connect!:lvalue to from))
+ (lvalue-backward-links from))
+ (for-each (lambda (to)
+ (lvalue-connect!:lvalue to from))
+ (lvalue-forward-links to)))))
+
+(define (lvalue-values lvalue)
+ ;; No recursion is needed here because the dataflow graph is
+ ;; transitively closed when this is run.
+ (if (eq? 'NOT-CACHED (lvalue-values-cache lvalue))
+ (let ((values
+ (eq-set-union* (lvalue-initial-values lvalue)
+ (map lvalue-initial-values
+ (lvalue-backward-links lvalue)))))
+ (set-lvalue-values-cache! lvalue values)
+ values)
+ (lvalue-values-cache lvalue)))
+
+(define (reset-lvalue-cache! lvalue)
+ (set-lvalue-values-cache! lvalue 'NOT-CACHED)
+ (for-each (lambda (lvalue)
+ (set-lvalue-values-cache! lvalue 'NOT-CACHED))
+ (lvalue-forward-links lvalue)))
+\f
+;;;; Attribute Marking
+
+(define (lvalue-mark-set! lvalue mark)
+ (if (not (memq mark (lvalue-marks lvalue)))
+ (set-lvalue-marks! lvalue (cons mark (lvalue-marks lvalue)))))
+
+(define (lvalue-mark-clear! lvalue mark)
+ (set-lvalue-marks! lvalue (delq! mark (lvalue-marks lvalue))))
+
+(define-integrable (lvalue-mark-set? lvalue mark)
+ (memq mark (lvalue-marks lvalue)))
+#|
+(define-integrable (variable-auxiliary! variable)
+ (set-variable-auxiliary?! variable true))
+
+(define (variable-assigned! variable)
+ (set-variable-assignments! variable (1+ (variable-assignments variable))))
+
+(define (variable-assigned? variable)
+ (> (variable-assignments variable)
+ (if (variable-auxiliary? variable) 1 0)))
+|#
+(define-integrable (variable-assigned! variable)
+ (set-variable-assigned?! variable true))
+
+(define (lvalue-integrated? lvalue)
+ (let ((value (lvalue-known-value lvalue)))
+ (and value
+ (or (rvalue/constant? value)
+ (and (rvalue/procedure? value)
+ (procedure/open? value))))))
+\f
+(define (lvalue=? lvalue lvalue*)
+ (or (eq? lvalue lvalue*)
+ (eq-set-same-set? (lvalue/source-set lvalue)
+ (lvalue/source-set lvalue*))))
+
+(define (lvalue/unique-source lvalue)
+ (let ((source-set (lvalue/source-set lvalue)))
+ (and (not (null? source-set))
+ (null? (cdr source-set))
+ (car source-set))))
+
+(define (lvalue/source-set lvalue)
+ (list-transform-positive
+ (eq-set-adjoin lvalue (lvalue-backward-links lvalue))
+ lvalue/source?))
+
+(define (lvalue/external-source-set lvalue)
+ (list-transform-positive
+ (eq-set-adjoin lvalue (lvalue-backward-links lvalue))
+ lvalue/external-source?))
+
+(define (lvalue/source? lvalue)
+ (or (lvalue/external-source? lvalue)
+ (lvalue/internal-source? lvalue)))
+
+(define-integrable (lvalue/external-source? lvalue)
+ (eq? 'SOURCE (lvalue-passed-in? lvalue)))
+
+(define-integrable (lvalue/internal-source? lvalue)
+ (not (null? (lvalue-initial-values lvalue))))
+
+(define (variable-in-known-location? block variable)
+ (let ((definition-block (variable-block variable)))
+ (or (not (ic-block? definition-block))
+ ;; If the block has no procedure, then we know nothing about
+ ;; the locations of its bindings.
+ (and (rvalue/procedure? (block-procedure block))
+ ;; If IC reference in same block as definition, then
+ ;; incremental definitions cannot screw us.
+ (eq? block definition-block)
+ ;; Make sure that IC variables are bound! A variable
+ ;; that is not bound by the code being compiled still has
+ ;; a "definition" block, which is the outermost IC block
+ ;; of the expression in which the variable is referenced.
+ (memq variable (block-bound-variables block))))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.61 1987/08/07 17:04:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.1 1987/12/04 20:04:06 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
'()))))
(cdr expression)))))
\f
-(define enable-integration-declarations
- true)
-
-(define enable-expansion-declarations
- true)
-
(let ()
(define (parse-define-syntax pattern body if-variable if-lambda)
((symbol? (car pattern))
(if-lambda pattern body))
(else
- (error "Illegal name" parse-define-syntax (car pattern))))))
+ (error "Illegal name" (car pattern))))))
((symbol? pattern)
(if-variable pattern body))
(else
- (error "Illegal name" parse-define-syntax pattern))))
+ (error "Illegal name" pattern))))
(define lambda-list->bound-names
- (let ((accumulate
- (lambda (lambda-list)
- (cons (let ((parameter (car lambda-list)))
- (if (pair? parameter) (car parameter) parameter))
- (lambda-list->bound-names (cdr lambda-list))))))
- (named-lambda (lambda-list->bound-names lambda-list)
- (cond ((symbol? lambda-list)
- lambda-list)
- ((null? lambda-list) '())
- ((not (pair? lambda-list))
- (error "Illegal rest variable" lambda-list))
- ((eq? (car lambda-list)
- (access lambda-optional-tag lambda-package))
- (if (pair? (cdr lambda-list))
- (accumulate (cdr lambda-list))
- (error "Missing optional variable" lambda-list)))
- (else
- (accumulate lambda-list))))))
+ (letrec ((lambda-list->bound-names
+ (lambda (lambda-list)
+ (cond ((null? lambda-list)
+ '())
+ ((pair? lambda-list)
+ (if (eq? (car lambda-list)
+ (access lambda-optional-tag lambda-package))
+ (if (pair? (cdr lambda-list))
+ (accumulate (cdr lambda-list))
+ (error "Missing optional variable" lambda-list))
+ (accumulate lambda-list)))
+ ((symbol? lambda-list)
+ (list lambda-list))
+ (else
+ (error "Illegal rest variable" lambda-list)))))
+ (accumulate
+ (lambda (lambda-list)
+ (cons (let ((parameter (car lambda-list)))
+ (if (pair? parameter) (car parameter) parameter))
+ (lambda-list->bound-names (cdr lambda-list))))))
+ lambda-list->bound-names))
\f
(syntax-table-define compiler-syntax-table 'DEFINE-EXPORT
(macro (pattern . body)
(syntax-table-define compiler-syntax-table 'DEFINE-INTEGRABLE
(macro (pattern . body)
- (if enable-integration-declarations
+ (if compiler:enable-integration-declarations?
(parse-define-syntax pattern body
(lambda (name body)
`(BEGIN (DECLARE (INTEGRATE ,pattern))
'*THE-NON-PRINTING-OBJECT*
`(BEGIN ,@(loop slots index)))))
+(syntax-table-define compiler-syntax-table 'DEFINE-ROOT-TYPE
+ (macro (type . slots)
+ (let ((tag-name (symbol-append type '-TAG)))
+ `(BEGIN (DEFINE ,tag-name
+ (MAKE-VECTOR-TAG FALSE ',type FALSE))
+ (DEFINE ,(symbol-append type '?)
+ (TAGGED-VECTOR/SUBCLASS-PREDICATE ,tag-name))
+ (DEFINE-VECTOR-SLOTS ,type 1 ,@slots)
+ (SET-VECTOR-TAG-DESCRIPTION!
+ ,tag-name
+ (LAMBDA (,type)
+ (DESCRIPTOR-LIST ,type ,@slots)))))))
+\f
(let-syntax
((define-type-definition
- (macro (name reserved)
+ (macro (name reserved enumeration)
(let ((parent (symbol-append name '-TAG)))
`(SYNTAX-TABLE-DEFINE COMPILER-SYNTAX-TABLE
',(symbol-append 'DEFINE- name)
(macro (type . slots)
(let ((tag-name (symbol-append type '-TAG)))
`(BEGIN (DEFINE ,tag-name
- (MAKE-VECTOR-TAG ,',parent ',type))
+ (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration))
(DEFINE ,(symbol-append type '?)
- (TAGGED-VECTOR-PREDICATE ,tag-name))
+ (TAGGED-VECTOR/PREDICATE ,tag-name))
(DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
- (DEFINE-VECTOR-METHOD ,tag-name ':DESCRIBE
- (LAMBDA (,type)
- (APPEND!
- ((VECTOR-TAG-METHOD ,',parent ':DESCRIBE) ,type)
- (DESCRIPTOR-LIST ,type ,@slots))))))))))))
- (define-type-definition snode 4)
- (define-type-definition pnode 5)
- (define-type-definition rvalue 1)
- (define-type-definition vnode 10))
+ (SET-VECTOR-TAG-DESCRIPTION!
+ ,tag-name
+ (LAMBDA (,type)
+ (APPEND!
+ ((VECTOR-TAG-DESCRIPTION ,',parent) ,type)
+ (DESCRIPTOR-LIST ,type ,@slots))))))))))))
+ (define-type-definition snode 4 false)
+ (define-type-definition pnode 5 false)
+ (define-type-definition rvalue 2 rvalue-types)
+ (define-type-definition lvalue 10 false))
(syntax-table-define compiler-syntax-table 'DESCRIPTOR-LIST
(macro (type . slots)
- `(LIST ,@(map (lambda (slot)
- (let ((ref-name (symbol-append type '- slot)))
- ``(,',ref-name ,(,ref-name ,type))))
- slots))))
+ (let ((ref-name (lambda (slot) (symbol-append type '- slot))))
+ `(LIST ,@(map (lambda (slot)
+ (if (pair? slot)
+ (let ((ref-names (map ref-name slot)))
+ ``(,',ref-names ,(,(car ref-names) ,type)))
+ (let ((ref-name (ref-name slot)))
+ ``(,',ref-name ,(,ref-name ,type)))))
+ slots)))))
\f
(let ((rtl-common
(lambda (type prefix components wrap-constructor)
(rtl-common type prefix components
(lambda (expression) `(PREDICATE->PRTL ,expression))))))
\f
-(syntax-table-define compiler-syntax-table 'DEFINE-REGISTER-REFERENCES
- (macro (slot)
- (let ((name (symbol-append 'REGISTER- slot)))
- (let ((vector `(,(symbol-append 'RGRAPH- name) *CURRENT-RGRAPH*)))
- `(BEGIN (DEFINE-INTEGRABLE (,name REGISTER)
- (VECTOR-REF ,vector REGISTER))
- (DEFINE-INTEGRABLE
- (,(symbol-append 'SET- name '!) REGISTER VALUE)
- (VECTOR-SET! ,vector REGISTER VALUE)))))))
-
(syntax-table-define compiler-syntax-table 'UCODE-TYPE
(macro (name)
(microcode-type name)))
(syntax-table-define compiler-syntax-table 'INST-EA
(macro (ea)
- (list 'QUASIQUOTE ea)))
\ No newline at end of file
+ (list 'QUASIQUOTE ea)))
+\f
+(syntax-table-define compiler-syntax-table 'DEFINE-ENUMERATION
+ (macro (name elements)
+ (let ((enumeration (symbol-append name 'S)))
+ `(BEGIN (DEFINE ,enumeration
+ (MAKE-ENUMERATION ',elements))
+ ,@(map (lambda (element)
+ `(DEFINE ,(symbol-append name '/ element)
+ (ENUMERATION/NAME->INDEX ,enumeration ',element)))
+ elements)))))
+
+(define (macros/case-macro expression clauses predicate default)
+ (let ((need-temp? (not (symbol? expression))))
+ (let ((expression*
+ (if need-temp?
+ (generate-uninterned-symbol)
+ expression)))
+ (let ((body
+ `(COND
+ ,@(let loop ((clauses clauses))
+ (cond ((null? clauses)
+ (default expression*))
+ ((eq? (caar clauses) 'ELSE)
+ (if (null? (cdr clauses))
+ clauses
+ (error "ELSE clause not last" clauses)))
+ (else
+ `(((OR ,@(map (lambda (element)
+ (predicate expression* element))
+ (caar clauses)))
+ ,@(cdar clauses))
+ ,@(loop (cdr clauses)))))))))
+ (if need-temp?
+ `(LET ((,expression* ,expression))
+ ,body)
+ body)))))
+
+(syntax-table-define compiler-syntax-table 'ENUMERATION-CASE
+ (macro (name expression . clauses)
+ (macros/case-macro expression
+ clauses
+ (lambda (expression element)
+ `(EQ? ,expression ,(symbol-append name '/ element)))
+ (lambda (expression)
+ '()))))
+
+(syntax-table-define compiler-syntax-table 'CFG-NODE-CASE
+ (macro (expression . clauses)
+ (macros/case-macro expression
+ clauses
+ (lambda (expression element)
+ `(EQ? ,expression ,(symbol-append element '-TAG)))
+ (lambda (expression)
+ `((ELSE (ERROR "Unknown node type" ,expression)))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 1.1 1987/03/19 00:44:29 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/object.scm,v 4.1 1987/12/04 20:04:24 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (make-vector-tag parent name)
- (let ((tag (cons '() (or parent vector-tag:object))))
- (vector-tag-put! tag ':TYPE-NAME name)
- ((access add-unparser-special-object! unparser-package)
- tag tagged-vector-unparser)
- tag))
-
-(define *tagged-vector-unparser-show-hash*
- true)
-
-(define (tagged-vector-unparser object)
- (unparse-with-brackets
- (lambda ()
- (write-string "LIAR ")
- (if *tagged-vector-unparser-show-hash*
- (begin (fluid-let ((*unparser-radix* 10))
- (write (hash object)))
- (write-string " ")))
- (fluid-let ((*unparser-radix* 16))
- ((vector-method object ':UNPARSE) object)))))
-
+(define-structure (vector-tag
+ (constructor %make-vector-tag (parent name index)))
+ (parent false read-only true)
+ (name false read-only true)
+ (index false read-only true)
+ (%unparser false)
+ (description false)
+ (method-alist '()))
+
+(define make-vector-tag
+ (let ((root-tag (%make-vector-tag false 'OBJECT false)))
+ (set-vector-tag-%unparser!
+ root-tag
+ (lambda (object)
+ (write (vector-tag-name (tagged-vector/tag object)))))
+ (named-lambda (make-vector-tag parent name enumeration)
+ (let ((tag
+ (%make-vector-tag (or parent root-tag)
+ name
+ (and enumeration
+ (enumeration/name->index enumeration
+ name)))))
+ ((access add-unparser-special-object! unparser-package)
+ tag
+ tagged-vector/unparse)
+ tag))))
+
+(define (define-vector-tag-unparser tag unparser)
+ (set-vector-tag-%unparser! tag unparser)
+ (vector-tag-name tag))
+
+(define (vector-tag-unparser tag)
+ (or (vector-tag-%unparser tag)
+ (let ((parent (vector-tag-parent tag)))
+ (if parent
+ (vector-tag-unparser parent)
+ (error "Missing unparser" tag)))))
+\f
(define (vector-tag-put! tag key value)
- (let ((entry (assq key (car tag))))
+ (let ((entry (assq key (vector-tag-method-alist tag))))
(if entry
(set-cdr! entry value)
- (set-car! tag (cons (cons key value) (car tag))))))
+ (set-vector-tag-method-alist! tag
+ (cons (cons key value)
+ (vector-tag-method-alist tag))))))
(define (vector-tag-get tag key)
- (define (loop tag)
- (and (pair? tag)
- (or (assq key (car tag))
- (loop (cdr tag)))))
(let ((value
- (or (assq key (car tag))
- (loop (cdr tag)))))
+ (or (assq key (vector-tag-method-alist tag))
+ (let loop ((tag (vector-tag-parent tag)))
+ (and tag
+ (or (assq key (vector-tag-method-alist tag))
+ (loop (vector-tag-parent tag))))))))
(and value (cdr value))))
-(define vector-tag:object
- (list '()))
-
-(vector-tag-put! vector-tag:object ':TYPE-NAME 'OBJECT)
-
-(define-integrable (vector-tag vector)
- (vector-ref vector 0))
-
-(define (define-vector-method tag name method)
+(define (define-vector-tag-method tag name method)
(vector-tag-put! tag name method)
name)
(define (vector-tag-method tag name)
(or (vector-tag-get tag name)
- (error "Unbound method" tag name)))
+ (error "Unbound method" name tag)))
\f
-(define-integrable (vector-tag-parent-method tag name)
- (vector-tag-method (cdr tag) name))
+(define-integrable make-tagged-vector
+ vector)
-(define-integrable (vector-method vector name)
- (vector-tag-method (vector-tag vector) name))
+(define-integrable (tagged-vector/tag vector)
+ (vector-ref vector 0))
-(define (define-unparser tag unparser)
- (define-vector-method tag ':UNPARSE unparser))
+(define-integrable (tagged-vector/index vector)
+ (vector-tag-index (tagged-vector/tag vector)))
-(define-integrable make-tagged-vector
- vector)
+(define-integrable (tagged-vector/unparser vector)
+ (vector-tag-unparser (tagged-vector/tag vector)))
-(define ((tagged-vector-predicate tag) object)
+(define (tagged-vector? object)
(and (vector? object)
(not (zero? (vector-length object)))
- (eq? tag (vector-tag object))))
+ (let ((tag (tagged-vector/tag object)))
+ (or (vector-tag? tag)
+ (type-object? tag)))))
+
+(define (->tagged-vector object)
+ (let ((object (if (integer? object) (unhash object) object))) (and (tagged-vector? object) object)))
-(define (tagged-vector-subclass-predicate tag)
- (define (loop tag*)
- (or (eq? tag tag*)
- (and (pair? tag*)
- (loop (cdr tag*)))))
+(define (tagged-vector/predicate tag)
(lambda (object)
(and (vector? object)
(not (zero? (vector-length object)))
- (loop (vector-tag object)))))
+ (eq? tag (tagged-vector/tag object)))))
-(define tagged-vector?
- (tagged-vector-subclass-predicate vector-tag:object))
-
-(define-unparser vector-tag:object
+(define (tagged-vector/subclass-predicate tag)
(lambda (object)
- (write (vector-method object ':TYPE-NAME))))
-
-(define (->tagged-vector object)
- (or (and (tagged-vector? object) object)
- (and (integer? object)
- (let ((object (unhash object)))
- (and (tagged-vector? object) object)))))
\ No newline at end of file
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (let loop ((tag* (tagged-vector/tag object)))
+ (or (eq? tag tag*)
+ (and (pair? tag*)
+ (loop (vector-tag-parent tag*))))))))
+
+(define (tagged-vector/description object)
+ (if (tagged-vector? object)
+ (let ((tag (tagged-vector/tag object)))
+ (cond ((vector-tag? tag) (vector-tag-description tag))
+ ((type-object? tag) (type-object-description tag))
+ (else (error "Unknown vector tag" tag))))
+ (error "Not a tagged vector" object)))
+
+(define (type-object-description type-object)
+ (2d-get type-object type-object-description))
+
+(define (set-type-object-description! type-object description)
+ (2d-put! type-object type-object-description description))
+\f
+(define (standard-unparser name unparser)
+ (lambda (object)
+ (unparse-with-brackets
+ (lambda ()
+ (standard-unparser/prefix object)
+ (write name)
+ (if unparser
+ (begin (write-string " ")
+ (unparser object)))))))
+
+(define (tagged-vector/unparse vector)
+ (unparse-with-brackets
+ (lambda ()
+ (standard-unparser/prefix vector)
+ (fluid-let ((*unparser-radix* 16))
+ ((tagged-vector/unparser vector) vector)))))
+
+(define (standard-unparser/prefix object)
+ (if *tagged-vector-unparse-prefix-string*
+ (begin (write-string *tagged-vector-unparse-prefix-string*)
+ (write-string " ")))
+ (if *tagged-vector-unparse-show-hash*
+ (begin (write-string (number->string (hash object) 10))
+ (write-string " "))))
+
+(define *tagged-vector-unparse-prefix-string* "LIAR")
+(define *tagged-vector-unparse-show-hash* true)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.1 1987/12/04 20:04:40 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Procedure datatype
+
+(declare (usual-integrations))
+\f
+(define-rvalue procedure
+ type ;either PROCEDURE or a continuation type
+ block ;model of invocation environment [block]
+ name ;name of procedure [symbol]
+ required ;list of required parameters [variables]
+ optional ;list of optional parameters [variables]
+ rest ;"rest" parameter, if any [variable or false]
+ names ;list of internal letrec names [variables]
+ values ;list of internal letrec values [rvalues]
+ entry-edge ;body of procedure [cfg edge]
+ original-required ;like `required' but never changed
+ original-optional ;like `optional' but never changed
+ original-rest ;like `rest' but never changed
+ label ;label to identify procedure entry point [symbol]
+ applications ;list of applications for which this is an operator
+ always-known-operator? ;true if always known operator of application
+ closing-limit ;closing limit (see code)
+ closure-block ;for closure, where procedure is closed [block]
+ closure-offset ;for closure, offset of procedure in stack frame
+ register ;for continuation, argument register
+ )
+
+(define *procedures*)
+
+(define (make-procedure type block name required optional rest names values
+ scfg)
+ (map lvalue-connect! names values)
+ (let ((procedure
+ (make-rvalue procedure-tag
+ type block name required optional rest names values
+ (node->edge (cfg-entry-node scfg))
+ (list-copy required) (list-copy optional) rest
+ (generate-label name) false false false false false
+ false)))
+ (set! *procedures* (cons procedure *procedures*))
+ (set-block-procedure! block procedure)
+ procedure))
+
+(define-vector-tag-unparser procedure-tag
+ (lambda (procedure)
+ (let ((type
+ (enumeration/index->name continuation-types
+ (procedure-type procedure))))
+ (if (eq? type 'PROCEDURE)
+ (begin
+ (write-string "PROCEDURE ")
+ (write (procedure-label procedure)))
+ (begin
+ (write-string "CONTINUATION ")
+ (write type))))))
+
+(define-integrable (rvalue/procedure? rvalue)
+ (eq? (tagged-vector/tag rvalue) procedure-tag))
+\f
+(define (procedure-arity-correct? procedure argument-count)
+ (let ((number-required (length (procedure-required procedure))))
+ (and (>= argument-count number-required)
+ (if (procedure-rest procedure)
+ true
+ (<= argument-count
+ (+ number-required
+ (length (procedure-optional procedure))))))))
+
+(define-integrable (procedure-closing-block procedure)
+ (block-parent (procedure-block procedure)))
+
+(define-integrable (procedure-continuation-lvalue procedure)
+ ;; Valid only if (not (procedure-continuation? procedure))
+ (car (procedure-required procedure)))
+
+(define-integrable (procedure-required-arguments procedure)
+ ;; Valid only if (not (procedure-continuation? procedure))
+ (cdr (procedure-required procedure)))
+
+(define-integrable (procedure-entry-node procedure)
+ (edge-next-node (procedure-entry-edge procedure)))
+
+(define (set-procedure-entry-node! procedure node)
+ (let ((edge (procedure-entry-edge procedure)))
+ (edge-disconnect-right! edge)
+ (edge-connect-right! edge node)))
+
+(define-integrable procedure-passed-out?
+ rvalue-%passed-out?)
+
+(define-integrable set-procedure-passed-out?!
+ set-rvalue-%passed-out?!)
+
+(define (close-procedure? procedure)
+ (not (eq? (procedure-closing-limit procedure)
+ (procedure-closing-block procedure))))
+\f
+(define-integrable (closure-procedure-needs-operator? procedure)
+ ;; **** When implemented, this must be true if the closure needs its
+ ;; parent frame since the parent frame is stored in the operator.
+ true)
+
+(define (procedure-interface-optimizible? procedure)
+ (and (stack-block? (procedure-block procedure))
+ (procedure-always-known-operator? procedure)))
+
+(define-integrable (procedure-application-unique? procedure)
+ (null? (cdr (procedure-applications procedure))))
+
+(define (procedure-inline-code? procedure)
+ (and (procedure-always-known-operator? procedure)
+ (procedure-application-unique? procedure)))
+
+(define (open-procedure-needs-static-link? procedure)
+ (let ((block (procedure-block procedure)))
+ (let ((parent (block-parent block)))
+ (and parent
+ (or (not (stack-block? parent))
+ (not (internal-block/parent-known? block)))))))
+\f
+;;;; Procedure Types
+
+;;; IC ("interpreter compatible") procedures are closed procedures
+;;; whose environment frames are compatible with those generated by
+;;; the interpreter. Both the procedure's frame and all of its
+;;; ancestors are interpreter compatible.
+
+;;; CLOSURE procedures are closed procedures whose frame is a stack
+;;; frame. The parent frame of such a procedure may be null, an IC
+;;; frame, or a CLOSURE frame (which is a compiler generated, heap
+;;; allocated frame).
+
+;;; OPEN-EXTERNAL procedures are open procedures whose frame is a
+;;; stack frame, and whose parent frame is either null, or an IC
+;;; frame. These are treated similarly to CLOSURE procedures except
+;;; that the stack frame is laid out differently.
+
+;;; OPEN-INTERNAL procedures are open procedures whose frame and
+;;; parent are both stack frames. The parent frame of such a
+;;; procedure is created by either a closure or open-external
+;;; procedure.
+
+(define (procedure/type procedure)
+ (let ((block (procedure-block procedure)))
+ (enumeration-case block-type (block-type block)
+ ((STACK)
+ (cond ((procedure-closure-block procedure) 'CLOSURE)
+ ((stack-parent? block) 'OPEN-INTERNAL)
+ (else 'OPEN-EXTERNAL)))
+ ((IC) 'IC)
+ ((CLOSURE) (error "Illegal occurrence of CLOSURE block" procedure))
+ (else (error "Unknown block type" block)))))
+\f
+(define-integrable (procedure/ic? procedure)
+ (ic-block? (procedure-block procedure)))
+
+(define-integrable (procedure/closure? procedure)
+ (procedure-closure-block procedure))
+
+(define (procedure/closed? procedure)
+ (or (procedure/ic? procedure)
+ (procedure/closure? procedure)))
+
+(define-integrable (procedure/open? procedure)
+ (not (procedure/closed? procedure)))
+
+(define-integrable (procedure/external? procedure)
+ (block/external? (procedure-block procedure)))
+
+(define-integrable (procedure/internal? procedure)
+ (block/internal? (procedure-block procedure)))
+
+(define (procedure/open-external? procedure)
+ (and (procedure/open? procedure)
+ (procedure/external? procedure)))
+
+(define (procedure/open-internal? procedure)
+ (and (procedure/open? procedure)
+ (procedure/internal? procedure)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 1.5 1987/08/07 17:03:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 4.1 1987/12/04 20:04:48 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Compiler DFG Datatypes: Right (Hand Side) Values
+;;;; Right (Hand Side) Values
(declare (usual-integrations))
\f
-(define-rvalue constant value)
+(define-root-type rvalue
+ %passed-out?)
+
+(define (make-rvalue tag . extra)
+ (list->vector (cons* tag false extra)))
+
+(define-enumeration rvalue-type
+ (block
+ constant
+ expression
+ procedure
+ reference
+ unassigned-test))
+
+(define (rvalue-values rvalue)
+ (if (rvalue/reference? rvalue)
+ (reference-values rvalue)
+ (list rvalue)))
+
+(define (rvalue-passed-in? rvalue)
+ (and (rvalue/reference? rvalue)
+ (reference-passed-in? rvalue)))
+
+(define (rvalue-passed-out? rvalue)
+ (if (rvalue/reference? rvalue)
+ (reference-passed-out? rvalue)
+ (rvalue-%passed-out? rvalue)))
+
+(define (rvalue-known-value rvalue)
+ (if (rvalue/reference? rvalue)
+ (reference-known-value rvalue)
+ rvalue))
+
+(define (rvalue-known-constant? rvalue)
+ (let ((value (rvalue-known-value rvalue)))
+ (and value
+ (rvalue/constant? value))))
+
+(define (rvalue-constant-value rvalue)
+ (constant-value (rvalue-known-value rvalue)))
+
+(define (rvalue=? rvalue rvalue*)
+ (if (rvalue/reference? rvalue)
+ (if (rvalue/reference? rvalue*)
+ (lvalue=? (reference-lvalue rvalue) (reference-lvalue rvalue*))
+ (eq? (lvalue-known-value (reference-lvalue rvalue)) rvalue*))
+ (if (rvalue/reference? rvalue*)
+ (eq? rvalue (lvalue-known-value (reference-lvalue rvalue*)))
+ (eq? rvalue rvalue*))))
+\f
+;;;; Constant
+
+(define-rvalue constant
+ value)
+
(define *constants*)
(define (make-constant value)
(set! *constants* (cons (cons value constant) *constants*))
constant))))
-(define-unparser constant-tag
+(define-vector-tag-unparser constant-tag
(lambda (constant)
(write-string "CONSTANT ")
(write (constant-value constant))))
-(define-rvalue block parent children bound-variables free-variables procedure
- declarations type closures combinations interned-variables closure-offsets frame)
-(define *blocks*)
+(define-integrable (rvalue/constant? rvalue)
+ (eq? (tagged-vector/tag rvalue) constant-tag))
+\f
+;;;; Reference
-(define (make-block parent)
- (let ((block
- (make-rvalue block-tag parent '() '() '() false
- '() 'STACK '() '() '() '() false)))
- (if parent
- (set-block-children! parent (cons block (block-children parent))))
- (set! *blocks* (cons block *blocks*))
- block))
+(define-rvalue reference
+ block
+ lvalue
+ safe?)
-(define-unparser block-tag
- (lambda (block)
- (write-string "BLOCK")
- (let ((procedure (block-procedure block)))
- (if procedure
- (begin (write-string " ")
- (write (procedure-label procedure)))))))
+(define (make-reference block lvalue safe?)
+ (make-rvalue reference-tag block lvalue safe?))
-(define-rvalue reference block variable safe?)
+(define-vector-tag-unparser reference-tag
+ (lambda (reference)
+ (write-string "REFERENCE ")
+ (write (variable-name (reference-lvalue reference)))))
-(define (make-reference block variable)
- (make-rvalue reference-tag block variable false))
+(define-integrable (rvalue/reference? rvalue)
+ (eq? (tagged-vector/tag rvalue) reference-tag))
-(define (make-safe-reference block variable)
- (make-rvalue reference-tag block variable true))
+(define-integrable (reference-values reference)
+ (lvalue-values (reference-lvalue reference)))
-(define-unparser reference-tag
- (lambda (reference)
- (write-string "REFERENCE ")
- (write (variable-name (reference-variable reference)))))
+(define-integrable (reference-passed-in? reference)
+ (lvalue-passed-in? (reference-lvalue reference)))
+
+(define-integrable (reference-passed-out? reference)
+ (lvalue-passed-out? (reference-lvalue reference)))
+
+(define-integrable (reference-known-value reference)
+ (lvalue-known-value (reference-lvalue reference)))
+
+(define (reference-to-known-location? reference)
+ (variable-in-known-location? (reference-block reference)
+ (reference-lvalue reference)))
\f
-(define-rvalue procedure block value fg-edge rgraph externally-visible?
- closure-block label external-label name required optional rest
- names values auxiliary original-parameters)
-(define *procedures*)
-
-(define (make-procedure block subproblem name required optional rest
- names values auxiliary)
- (let ((procedure
- (make-rvalue procedure-tag block (subproblem-value subproblem)
- (cfg-entry-edge (subproblem-cfg subproblem))
- (rgraph-allocate) false false
- (generate-label (variable-name name))
- (generate-label) name required optional rest
- names values auxiliary (vector required optional rest))))
- (set-block-procedure! block procedure)
- (vnode-connect! name procedure)
- (set! *procedures* (cons procedure *procedures*))
- (symbol-hash-table/insert! *label->object*
- (procedure-label procedure)
- procedure)
- procedure))
-
-(define-integrable (procedure-fg-entry procedure)
- (edge-right-node (procedure-fg-edge procedure)))
-
-(define-integrable (unset-procedure-fg-entry! procedure)
- (set-procedure-fg-edge! procedure false))
-
-(define-integrable (procedure-original-required procedure)
- (vector-ref (procedure-original-parameters procedure) 0))
-
-(define-integrable (procedure-original-optional procedure)
- (vector-ref (procedure-original-parameters procedure) 1))
-
-(define-integrable (procedure-original-rest procedure)
- (vector-ref (procedure-original-parameters procedure) 2))
-
-(define-unparser procedure-tag
- (lambda (procedure)
- (write-string "PROCEDURE ")
- (write (procedure-label procedure))))
-
-(define-integrable (label->procedure label)
- (symbol-hash-table/lookup *label->object* label))
+;;; This type is only important while we use the `unassigned?' special
+;;; form to perform optional argument defaulting. When we switch over
+;;; to the new optional argument proposal we can flush this since the
+;;; efficiency of this construct won't matter anymore.
+
+(define-rvalue unassigned-test
+ block
+ lvalue)
+
+(define (make-unassigned-test block lvalue)
+ (make-rvalue unassigned-test-tag block lvalue))
+
+(define-vector-tag-unparser unassigned-test-tag
+ (lambda (unassigned-test)
+ (write-string "UNASSIGNED-TEST ")
+ (write (unassigned-test-lvalue unassigned-test))))
+
+(define-integrable (rvalue/unassigned-test? rvalue)
+ (eq? (tagged-vector/tag rvalue) unassigned-test-tag))
\f
-(define-rvalue quotation block value fg-edge rgraph label)
-(define *quotations*)
-
-(define (make-quotation block subproblem)
- (let ((quotation
- (make-rvalue quotation-tag block (subproblem-value subproblem)
- (cfg-entry-edge (subproblem-cfg subproblem))
- (rgraph-allocate)
- (generate-label 'QUOTATION))))
- (set! *quotations* (cons quotation *quotations*))
- quotation))
-
-(define-integrable (quotation-fg-entry quotation)
- (edge-right-node (quotation-fg-edge quotation)))
-
-(define-integrable (unset-quotation-fg-entry! quotation)
- (set-quotation-fg-edge! quotation false))
\ No newline at end of file
+;;;; Expression
+
+(define-rvalue expression
+ block
+ continuation
+ entry-edge
+ label)
+
+(define *expressions*)
+
+(define (make-expression block continuation scfg)
+ (let ((expression
+ (make-rvalue expression-tag block continuation
+ (node->edge (cfg-entry-node scfg))
+ (generate-label 'EXPRESSION))))
+ (set! *expressions* (cons expression *expressions*))
+ (set-block-procedure! block expression)
+ expression))
+
+(define-integrable (rvalue/expression? rvalue)
+ (eq? (tagged-vector/tag rvalue) expression-tag))
+
+(define-integrable (expression-entry-node expression)
+ (edge-next-node (expression-entry-edge expression)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.1 1987/12/04 20:04:59 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; SCode Interface
+
+(declare (usual-integrations))
+\f
+(let-syntax ((define-scode-operators
+ (macro names
+ `(BEGIN ,@(map (lambda (name)
+ `(DEFINE ,(symbol-append 'SCODE/ name)
+ (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT)))
+ names)))))
+ (define-scode-operators
+ make-access access? access-components
+ access-environment access-name
+ make-assignment assignment? assignment-components
+ assignment-name assignment-value
+ make-combination combination? combination-components
+ combination-operator combination-operands
+ make-comment comment? comment-components
+ comment-expression comment-text
+ make-conditional conditional? conditional-components
+ conditional-predicate conditional-consequent conditional-alternative
+ make-declaration declaration? declaration-components
+ declaration-expression declaration-text
+ make-definition definition? definition-components
+ definition-name definition-value
+ make-delay delay? delay-components
+ delay-expression
+ make-disjunction disjunction? disjunction-components
+ conditional-predicate conditional-alternative
+ make-in-package in-package? in-package-components
+ in-package-environment in-package-expression
+ make-lambda lambda? lambda-components
+ make-open-block open-block? open-block-components
+ primitive-procedure?
+ make-quotation quotation? quotation-expression
+ make-sequence sequence-actions
+ symbol?
+ make-the-environment the-environment?
+ make-unassigned-object unassigned-object?
+ make-unassigned? unassigned?? unassigned?-name
+ make-unbound? unbound?? unbound?-name
+ make-variable variable? variable-components variable-name
+ ))
+
+(define-integrable (scode/make-constant const)
+ const)
+
+(define scode/constant?
+ (access scode-constant? system-global-environment))
+
+(define-integrable (scode/constant-value const)
+ const)
+\f
+;;;; Absolute variables and combinations
+
+(define (scode/make-absolute-reference variable-name)
+ (scode/make-access '() variable-name))
+
+(define (scode/absolute-reference? object)
+ (and (scode/access? object)
+ (null? (scode/access-environment object))))
+
+(define (scode/absolute-reference-name reference)
+ (scode/access-name reference))
+
+(define (scode/make-absolute-combination name operands)
+ (scode/make-combination (scode/make-absolute-reference name) operands))
+
+(define (scode/absolute-combination? object)
+ (and (scode/combination? object)
+ (scode/absolute-reference? (scode/combination-operator object))))
+
+(define (scode/absolute-combination-components combination receiver)
+ (scode/combination-components combination
+ (lambda (operator operands)
+ (receiver (scode/absolute-reference-name operator) operands))))
+
+(define scode/error-combination?
+ (type-object-predicate error-combination-type))
+
+(define (scode/error-combination-components combination receiver)
+ (scode/combination-components combination
+ (lambda (operator operands)
+ (receiver (car operands)
+ (let ((irritant (cadr operands)))
+ (cond ((scode/access? irritant) '())
+ ((scode/absolute-combination? irritant)
+ (scode/absolute-combination-components irritant
+ (lambda (name operands)
+ (if (eq? name 'LIST)
+ operands
+ (list irritant)))))
+ (else (list irritant))))))))
+
+(define (scode/make-error-combination message operand)
+ (scode/make-absolute-combination
+ 'ERROR-PROCEDURE
+ (list message operand (scode/make-the-environment))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/sets.scm,v 1.2 1987/06/26 02:22:12 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/sets.scm,v 4.1 1987/12/04 20:05:03 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (eqv-set-same-set? x y)
(and (eqv-set-subset? x y)
- (eqv-set-subset? y x)))
\ No newline at end of file
+ (eqv-set-subset? y x)))
+\f
+(define (list->eq-set elements)
+ (if (null? elements)
+ '()
+ (eq-set-adjoin (car elements)
+ (list->eq-set (cdr elements)))))
+
+(define (list->eqv-set elements)
+ (if (null? elements)
+ '()
+ (eqv-set-adjoin (car elements)
+ (list->eqv-set (cdr elements)))))
+
+(define (map->eq-set procedure items)
+ (let loop ((items items))
+ (if (null? items)
+ '()
+ (eq-set-adjoin (procedure (car items))
+ (loop (cdr items))))))
+
+(define (map->eqv-set procedure items)
+ (let loop ((items items))
+ (if (null? items)
+ '()
+ (eqv-set-adjoin (procedure (car items))
+ (loop (cdr items))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.1 1987/12/04 20:05:10 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Subproblem Type
+
+(declare (usual-integrations))
+\f
+#|
+
+Subproblems come in two forms, canonical and non-canonical. In a
+canonical subproblem, the `prefix' is always exited by a return
+statement whose operator is the subproblem's `continuation'. The
+`rvalue' is always the parameter of the `continuation'.
+
+In a non-canonical subproblem, there is no `continuation' -- the
+`rvalue' is sufficiently simple that no complex computation is
+required to compute its value. Instead, the `prefix' is some setup
+code that must be executed for effect, while the value of the
+subproblem is just `rvalue'.
+
+The non-canonical subproblem is used as an optimization by several
+parts of the compiler, where better code can be generated if it is
+known that the continuation need not be used.
+
+|#
+\f
+(define-structure (subproblem
+ (constructor make-subproblem
+ (prefix continuation rvalue)))
+ (prefix false read-only true)
+ (continuation false read-only true)
+ (rvalue false read-only true)
+ (simple? 'UNKNOWN))
+
+(set-type-object-description!
+ subproblem
+ (lambda (subproblem)
+ (descriptor-list subproblem prefix continuation rvalue simple?)))
+
+(define-integrable (subproblem-entry-node subproblem)
+ (cfg-entry-node (subproblem-prefix subproblem)))
+
+(define-integrable (subproblem-canonical? subproblem)
+ (procedure? (subproblem-continuation subproblem)))
+
+(define-integrable (subproblem-block subproblem)
+ ;; This is defined only for non-canonical subproblems.
+ (virtual-continuation/block (subproblem-continuation subproblem)))
+
+(define (subproblem-type subproblem)
+ (let ((continuation (subproblem-continuation subproblem)))
+ (if (procedure? continuation)
+ (continuation/type continuation)
+ (virtual-continuation/type continuation))))
+
+(define (set-subproblem-type! subproblem type)
+ (let ((continuation (subproblem-continuation subproblem)))
+ (if (procedure? continuation)
+ (set-continuation/type! continuation type)
+ (set-virtual-continuation/type! continuation type))))
+
+(define-integrable (subproblem-register subproblem)
+ (continuation*/register (subproblem-continuation subproblem)))
+
+(define (continuation*/register continuation)
+ (if (procedure? continuation)
+ (continuation/register continuation)
+ (virtual-continuation/register continuation)))
+\f
+;;;; Virtual Continuations
+
+;;; These are constructed in the FG generation phase for the purpose
+;;; of delaying generation of real continuations until the last
+;;; possible moment. After the FG generation, non-reified virtual
+;;; continuations are used to hold several values that normally would
+;;; have resided in the real continuation.
+
+(define-structure (virtual-continuation
+ (constructor virtual-continuation/%make (block parent type))
+ (conc-name virtual-continuation/)
+ (print-procedure
+ (standard-unparser 'VIRTUAL-CONTINUATION
+ (lambda (continuation)
+ (let ((type (virtual-continuation/type continuation)))
+ (if type
+ (write
+ (enumeration/index->name continuation-types
+ type))))))))
+ block
+ parent
+ type)
+
+(set-type-object-description!
+ virtual-continuation
+ (lambda (continuation)
+ `((VIRTUAL-CONTINUATION/BLOCK ,(virtual-continuation/block continuation))
+ (VIRTUAL-CONTINUATION/PARENT ,(virtual-continuation/parent continuation))
+ (VIRTUAL-CONTINUATION/TYPE ,(virtual-continuation/type continuation)))))
+
+(define-integrable (virtual-continuation/make block type)
+ ;; Used exclusively after FG generation.
+ (virtual-continuation/%make block false type))
+
+(define-integrable (virtual-continuation/reified? continuation)
+ (not (virtual-continuation/type continuation)))
+
+(define-integrable virtual-continuation/reification
+ virtual-continuation/block)
+\f
+(define (virtual-continuation/reify! continuation)
+ ;; This is used only during FG generation when it is decided that we
+ ;; need a real continuation to handle a subproblem.
+ (if (virtual-continuation/type continuation)
+ (let ((reification
+ (make-continuation (virtual-continuation/block continuation)
+ (virtual-continuation/parent continuation)
+ (virtual-continuation/type continuation))))
+ (set-virtual-continuation/block! continuation reification)
+ (set-virtual-continuation/parent! continuation false)
+ (set-virtual-continuation/type! continuation false)
+ reification)
+ (virtual-continuation/block continuation)))
+
+(define (virtual-continuation/register continuation)
+ (or (virtual-continuation/parent continuation)
+ (let ((register (rtl:make-pseudo-register)))
+ (set-virtual-continuation/parent! continuation register)
+ register)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.1 1987/12/04 20:05:15 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler Option Switches
+
+(declare (usual-integrations))
+\f
+(define compiler:enable-integration-declarations? false)
+(define compiler:enable-expansion-declarations? false)
+(define compiler:preserve-data-structures? true)
+(define compiler:code-compression? true)
+(define compiler:cache-free-variables? true)
+(define compiler:implicit-self-static? false)
+(define compiler:cse? true)
+(define compiler:open-code-primitives? true)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.1 1987/12/04 20:05:18 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler Top Level
+
+(declare (usual-integrations))
+\f
+;;; Global variables
+(define *input-scode*)
+(define *ic-procedure-headers*)
+(define *root-block*)
+(define *root-expression*)
+(define *rtl-expression*)
+(define *rtl-procedures*)
+(define *rtl-continuations*)
+(define *rtl-graphs*)
+
+;;; These variable names mistakenly use the format "compiler:..."
+;;; instead of the correct format, which is "*...*". Fix it sometime.
+(define compiler:continuation-fp-offsets)
+(define compiler:external-labels)
+(define compiler:label-bindings)
+
+(define compiler:phase-wrapper false)
+(define compiler:compile-time 0)
+\f
+(define (compile-bin-file input-string #!optional output-string)
+ (compiler-pathnames input-string
+ (and (not (unassigned? output-string)) output-string)
+ (make-pathname false false false "bin" 'NEWEST)
+ (lambda (input-pathname output-pathname)
+ (compile-scode (compiler-fasload input-pathname)
+ (pathname-new-type output-pathname "brtl")
+ (pathname-new-type output-pathname "binf")))))
+
+(define (compiler-fasload pathname)
+ (let ((scode
+ (let ((scode (fasload pathname)))
+ (if (scode/comment? scode)
+ (scode/comment-expression scode)
+ scode))))
+ (if (scode/open-block? scode)
+ (scode/open-block-components scode
+ (lambda (names declarations body)
+ (if (null? names)
+ (scan-defines body
+ (lambda (names declarations* body)
+ (make-open-block names
+ (append declarations declarations*)
+ body)))
+ scode)))
+ (scan-defines scode make-open-block))))
+\f
+(define (compile-procedure procedure)
+ (scode-eval (compile-scode (procedure-lambda procedure))
+ (procedure-environment procedure)))
+
+(define (compiler-pathnames input-string output-string default transform)
+ (let ((input-pathname
+ (pathname->input-truename
+ (merge-pathnames (->pathname input-string) default))))
+ (if (not input-pathname)
+ (error "File does not exist" input-string))
+ (let ((output-pathname
+ (let ((output-pathname (pathname-new-type input-pathname "com")))
+ (if output-string
+ (merge-pathnames (->pathname output-string) output-pathname)
+ output-pathname))))
+ (newline)
+ (write-string "Compile File: ")
+ (write (pathname->string input-pathname))
+ (write-string " => ")
+ (write (pathname->string output-pathname))
+ (fasdump (transform input-pathname output-pathname) output-pathname))))
+\f
+(define (compile-scode scode
+ #!optional
+ rtl-output-pathname
+ info-output-pathname)
+
+ (if (unassigned? rtl-output-pathname)
+ (set! rtl-output-pathname false))
+ (if (unassigned? info-output-pathname)
+ (set! info-output-pathname false))
+
+ (in-compiler
+ (lambda ()
+ (set! *input-scode* scode)
+ (phase/fg-generation)
+ (phase/simulate-application)
+ (phase/outer-analysis)
+ (phase/fold-constants)
+ (phase/open-coding-analysis)
+ (phase/operator-analysis)
+ (phase/identify-closure-limits)
+ (phase/setup-block-types)
+ (phase/continuation-analysis)
+ (phase/simplicity-analysis)
+ (phase/subproblem-ordering)
+ (phase/design-environment-frames)
+ (phase/rtl-generation)
+ (let ((n-registers
+ (map (lambda (rgraph)
+ (- (rgraph-n-registers rgraph)
+ number-of-machine-registers))
+ *rtl-graphs*)))
+ (newline)
+ (write-string "Registers used: ")
+ (write (apply max n-registers))
+ (write-string " max, ")
+ (write (apply min n-registers))
+ (write-string " min, ")
+ (write (/ (apply + n-registers) (length n-registers)))
+ (write-string " mean"))
+#|
+ (if info-output-pathname
+ (compiler:info-generation-1 info-output-pathname))
+ (compiler:rtl-generation-cleanup)
+ (if compiler:cse?
+ (compiler:cse))
+ (compiler:lifetime-analysis)
+ (if compiler:code-compression?
+ (compiler:code-compression))
+ (if rtl-output-pathname
+ (compiler:rtl-file-output rtl-output-pathname))
+ (compiler:register-allocation)
+ (compiler:rtl-optimization-cleanup)
+ (compiler:bit-generation)
+ (compiler:bit-linearization)
+ (compiler:assemble)
+ (if info-output-pathname
+ (compiler:info-generation-2 info-output-pathname))
+ (compiler:link)
+ compiler:expression
+|#
+ )))
+\f
+(define (in-compiler thunk)
+ (fluid-let ((compiler:compile-time 0)
+ #|(*input-scode*)
+ (*current-label-number*)
+ (*constants*)
+ (*blocks*)
+ (*expressions*)
+ (*procedures*)
+ (*lvalues*)
+ (*applications*)
+ (*parallels*)
+ (*assignments*)
+ (*ic-procedure-headers*)
+ (*root-expression*)
+ (*root-block*)
+ (*rtl-expression*)
+ (*rtl-procedures*)
+ (*rtl-continuations*)
+ (*rtl-graphs*)
+ (compiler:continuation-fp-offsets)
+ (compiler:external-labels)
+ (compiler:label-bindings)|#)
+ (compiler:reset!)
+ (let ((value (thunk)))
+; (compiler:reset!)
+ (newline)
+ (write-string "Total compilation time: ")
+ (write compiler:compile-time)
+ value)))
+
+(define (compiler:reset!)
+ (set! *input-scode*)
+ (set! *current-label-number*)
+ (set! *constants*)
+ (set! *blocks*)
+ (set! *expressions*)
+ (set! *procedures*)
+ (set! *lvalues*)
+ (set! *applications*)
+ (set! *parallels*)
+ (set! *assignments*)
+ (set! *ic-procedure-headers*)
+ (set! *root-expression*)
+ (set! *root-block*)
+ (set! *rtl-expression*)
+ (set! *rtl-procedures*)
+ (set! *rtl-continuations*)
+ (set! *rtl-graphs*)
+ (set! compiler:continuation-fp-offsets)
+ (set! compiler:external-labels)
+ (set! compiler:label-bindings))
+\f
+(define (compiler-phase name thunk)
+ (write-line name)
+ (let ((delta
+ (let ((start-time (runtime)))
+ (if compiler:phase-wrapper
+ (compiler:phase-wrapper thunk)
+ (thunk))
+ (- (runtime) start-time))))
+ (set! compiler:compile-time (+ delta compiler:compile-time))
+ (newline)
+ (write-string "Time taken: ")
+ (write delta)))
+#|
+(define-macro (last-reference name)
+ (let ((temp (generate-uninterned-symbol)))
+ `(IF COMPILER:PRESERVE-DATA-STRUCTURES?
+ ,name
+ (LET ((,temp name))
+ (set! ,name)
+ ,temp))))
+|#
+\f
+(define (phase/fg-generation)
+ (compiler-phase 'FG-GENERATION
+ (lambda ()
+ (set! *current-label-number* 0)
+ (set! *constants* '())
+ (set! *blocks* '())
+ (set! *expressions* '())
+ (set! *procedures* '())
+ (set! *lvalues* '())
+ (set! *applications* '())
+ (set! *parallels* '())
+ (set! *assignments* '())
+ (set! *root-expression*
+ ((access construct-graph fg-generator-package) *input-scode*))
+ (set! *root-block* (expression-block *root-expression*))
+ (if (or (null? *expressions*)
+ (not (null? (cdr *expressions*))))
+ (error "Multiple expressions"))
+ (set! *expressions*))))
+
+(define (phase/simulate-application)
+ (compiler-phase 'SIMULATE-APPLICATION
+ (lambda ()
+ ((access simulate-application fg-analyzer-package)
+ *lvalues*
+ *applications*))))
+
+(define (phase/outer-analysis)
+ (compiler-phase 'OUTER-ANALYSIS
+ (lambda ()
+ ((access outer-analysis fg-analyzer-package)
+ *root-expression*
+ *procedures*
+ *applications*))))
+
+(define (phase/fold-constants)
+ (compiler-phase 'FOLD-CONSTANTS
+ (lambda ()
+ ((access fold-constants fg-analyzer-package)
+ *lvalues*
+ *applications*))))
+\f
+(define (phase/open-coding-analysis)
+ (compiler-phase 'OPEN-CODING-ANALYSIS
+ (lambda ()
+ ((access open-coding-analysis rtl-generator-package)
+ *applications*))))
+
+(define (phase/operator-analysis)
+ (compiler-phase 'OPERATOR-ANALYSIS
+ (lambda ()
+ ((access operator-analysis fg-analyzer-package)
+ *procedures*
+ *applications*))))
+
+(define (phase/identify-closure-limits)
+ (compiler-phase 'IDENTIFY-CLOSURE-LIMITS
+ (lambda ()
+ ((access identify-closure-limits! fg-analyzer-package)
+ *procedures*
+ *applications*
+ *assignments*))))
+
+(define (phase/setup-block-types)
+ (compiler-phase 'SETUP-BLOCK-TYPES
+ (lambda ()
+ ((access setup-block-types! fg-analyzer-package)
+ *root-block*))))
+
+(define (phase/continuation-analysis)
+ (compiler-phase 'CONTINUATION-ANALYSIS
+ (lambda ()
+ ((access continuation-analysis fg-analyzer-package)
+ *blocks*
+ *procedures*))))
+
+(define (phase/simplicity-analysis)
+ (compiler-phase 'SIMPLICITY-ANALYSIS
+ (lambda ()
+ ((access simplicity-analysis fg-analyzer-package)
+ *parallels*))))
+
+(define (phase/subproblem-ordering)
+ (compiler-phase 'SUBPROBLEM-ORDERING
+ (lambda ()
+ ((access subproblem-ordering fg-analyzer-package)
+ *parallels*))))
+
+(define (phase/design-environment-frames)
+ (compiler-phase 'DESIGN-ENVIRONMENT-FRAMES
+ (lambda ()
+ ((access design-environment-frames! fg-analyzer-package)
+ *blocks*))))
+\f
+(define (phase/rtl-generation)
+ (compiler-phase 'RTL-GENERATION
+ (lambda ()
+ (set! *rtl-procedures* '())
+ (set! *rtl-continuations* '())
+ (set! *rtl-graphs* '())
+ ((access generate/top-level rtl-generator-package) *root-expression*))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 1.92 1987/11/21 18:43:08 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.1 1987/12/04 20:05:24 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
set*-only)))))))
(loop set (list-copy set*) receiver)))
+(define (discriminate-items items predicate)
+ (let loop ((items items) (passed '()) (failed '()))
+ (cond ((null? items)
+ (return-2 passed failed))
+ ((predicate (car items))
+ (loop (cdr items) (cons (car items) passed) failed))
+ (else
+ (loop (cdr items) passed (cons (car items) failed))))))
+
(define (generate-label #!optional prefix)
(if (unassigned? prefix) (set! prefix 'LABEL))
(string->symbol
'FLUID-LET)
(else prefix)))
"-"
- (number->string (generate-label-number)))))
+ (number->string (generate-label-number) 10))))
(define *current-label-number*)
(let ((value (thunk)))
(write-line (- (runtime) start))
value)))
+
+(define (list-filter-indices items indices)
+ (let loop ((items items) (indices indices) (index 0))
+ (cond ((null? indices) '())
+ ((= (car indices) index)
+ (cons (car items)
+ (loop (cdr items) (cdr indices) (1+ index))))
+ (else
+ (loop (cdr items) indices (1+ index))))))
+\f
+(define (there-exists? items predicate)
+ (let loop ((items items))
+ (and (not (null? items))
+ (or (predicate (car items))
+ (loop (cdr items))))))
+
+(define (for-all? items predicate)
+ (let loop ((items items))
+ (or (null? items)
+ (and (predicate (car items))
+ (loop (cdr items))))))
+
+(define (all-eq? items)
+ (if (null? items)
+ (error "ALL-EQ? undefined for empty set"))
+ (or (null? (cdr items))
+ (for-all? (cdr items)
+ (let ((item (car items)))
+ (lambda (item*)
+ (eq? item item))))))
+
+(define (all-eq-map? items map)
+ (if (null? items)
+ (error "ALL-EQ-MAP? undefined for empty set"))
+ (let ((item (map (car items))))
+ (if (or (null? (cdr items))
+ (for-all? (cdr items) (lambda (item*) (eq? item (map item*)))))
+ (return-2 true item)
+ (return-2 false false))))
+
+(define (eq-set-union* set sets)
+ (let loop ((set set) (sets sets) (accum '()))
+ (if (null? sets)
+ (eq-set-union set accum)
+ (loop (car sets) (cdr sets) (eq-set-union set accum)))))
+\f
+(package (transitive-closure enqueue-node! enqueue-nodes!)
+
+(define *queue*)
+
+(define-export (transitive-closure initialization process-node nodes)
+ (fluid-let ((*queue* true))
+ (if initialization (initialization))
+ (set! *queue* nodes)
+ (let loop ()
+ (if (not (null? *queue*))
+ (begin (let ((node (car *queue*)))
+ (set! *queue* (cdr *queue*))
+ (process-node node))
+ (loop))))))
+
+(define-export (enqueue-node! node)
+ (if (and (not (eq? *queue* true))
+ (not (memq node *queue*)))
+ (set! *queue* (cons node *queue*))))
+
+(define-export (enqueue-nodes! nodes)
+ (if (not (eq? *queue* true))
+ (set! *queue* (eq-set-union nodes *queue*))))
+
+)
\f
;;;; Symbol Hash Tables
(define-integrable string-hash-mod
(ucode-primitive string-hash-mod))
\f
-;;;; SCode Interface
-
-(let-syntax ((define-scode-operator
- (macro (name)
- `(DEFINE ,(symbol-append 'SCODE/ name)
- (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT)))))
- (define-scode-operator access-components)
- (define-scode-operator access?)
- (define-scode-operator assignment?)
- (define-scode-operator assignment-components)
- (define-scode-operator assignment-name)
- (define-scode-operator assignment-value)
- (define-scode-operator combination-components)
- (define-scode-operator combination?)
- (define-scode-operator comment-expression)
- (define-scode-operator comment-text)
- (define-scode-operator comment?)
- (define-scode-operator conditional-components)
- (define-scode-operator definition-components)
- (define-scode-operator delay?)
- (define-scode-operator delay-expression)
- (define-scode-operator disjunction-components)
- (define-scode-operator in-package-components)
- (define-scode-operator lambda-components)
- (define-scode-operator lambda?)
- (define-scode-operator make-access)
- (define-scode-operator make-assignment)
- (define-scode-operator make-combination)
- (define-scode-operator make-comment)
- (define-scode-operator make-conditional)
- (define-scode-operator make-declaration)
- (define-scode-operator make-definition)
- (define-scode-operator make-disjunction)
- (define-scode-operator make-lambda)
- (define-scode-operator make-quotation)
- (define-scode-operator make-sequence)
- (define-scode-operator make-the-environment)
- (define-scode-operator make-variable)
- (define-scode-operator make-unassigned-object)
- (define-scode-operator open-block-components)
- (define-scode-operator open-block?)
- (define-scode-operator primitive-procedure?)
- (define-scode-operator procedure?)
- (define-scode-operator quotation-expression)
- (define-scode-operator sequence-actions)
- (define-scode-operator unassigned-object?)
- (define-scode-operator unassigned?-name)
- (define-scode-operator unbound?-name)
- (define-scode-operator variable-name)
- (define-scode-operator variable?))
-\f
-;;; Scode constants
-
-(define scode/constant?
- (access scode-constant? system-global-environment))
-
-(define scode/constant?
- (access scode-constant? system-global-environment))
-
-(define-integrable (scode/constant-value const)
- const)
-
-(define-integrable (scode/make-constant const)
- const)
-
-;;; Abolute variables and combinations
-
-(define (scode/make-absolute-reference variable-name)
- (scode/make-access '() variable-name))
-
-(define (scode/absolute-reference? obj)
- (and (scode/access? obj)
- (scode/access-components
- obj
- (lambda (environment name)
- (null? environment)))))
-
-(define (scode/absolute-reference-name obj)
- (scode/access-components obj (lambda (ignore name) name)))
-
-(define (scode/make-absolute-combination name operands)
- (scode/make-combination (scode/make-absolute-reference name) operands))
-
-(define (scode/absolute-combination? obj)
- (and (scode/combination? obj)
- (scode/combination-components
- obj
- (lambda (op ops)
- (scode/absolute-reference? obj)))))
+;;;; Type Codes
-(define (scode/absolute-combination-components obj receiver)
- (scode/combination-components
- obj
- (lambda (op ops)
- (receiver (scode/absolute-reference-name op) ops))))
-\f
-(define (scode/error-combination-components combination receiver)
- (scode/combination-components combination
- (lambda (operator operands)
- (receiver (car operands)
- (let ((irritant (cadr operands)))
- (cond ((scode/access? irritant) '())
- ((scode/absolute-combination? irritant)
- (scode/absolute-combination-components irritant
- (lambda (name operands)
- (if (eq? name 'LIST)
- operands
- (list irritant)))))
- (else (list irritant))))))))
-
-(define (scode/make-error-combination message operand)
- (scode/make-absolute-combination
- 'ERROR-PROCEDURE
- (list message operand (scode/make-the-environment))))
+(let-syntax ((define-type-code
+ (macro (var-name #!optional type-name)
+ (if (unassigned? type-name) (set! type-name var-name))
+ `(DEFINE-INTEGRABLE ,(symbol-append 'TYPE-CODE: var-name)
+ ',(microcode-type type-name)))))
+ (define-type-code lambda)
+ (define-type-code extended-lambda)
+ (define-type-code procedure)
+ (define-type-code extended-procedure)
+ (define-type-code cell)
+ (define-type-code compiled-expression)
+ (define-type-code compiler-link)
+ (define-type-code compiled-procedure)
+ (define-type-code environment)
+ (define-type-code stack-environment)
+ (define-type-code return-address compiler-return-address)
+ (define-type-code unassigned))
(define (scode/procedure-type-code *lambda)
(cond ((primitive-type? type-code:lambda *lambda)
type-code:extended-procedure)
(else
(error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda))))
-
-(define (scode/make-let names values body)
- (scode/make-combination (scode/make-lambda lambda-tag:let names '() false '()
- '() body)
- values))
\f
-;;;; Type Codes
+;;;; Primitive Procedures
-(let-syntax ((define-type-code
- (macro (var-name type-name)
- `(define-integrable ,var-name ',(microcode-type type-name)))))
-
-(define-type-code type-code:lambda LAMBDA)
-(define-type-code type-code:extended-lambda EXTENDED-LAMBDA)
-(define-type-code type-code:procedure PROCEDURE)
-(define-type-code type-code:extended-procedure EXTENDED-PROCEDURE)
-(define-type-code type-code:cell CELL)
-(define-type-code type-code:compiled-expression COMPILED-EXPRESSION)
-(define-type-code type-code:compiler-link COMPILER-LINK)
-(define-type-code type-code:compiled-procedure COMPILED-PROCEDURE)
-(define-type-code type-code:environment ENVIRONMENT)
-(define-type-code type-code:stack-environment STACK-ENVIRONMENT)
-(define-type-code type-code:return-address COMPILER-RETURN-ADDRESS)
-(define-type-code type-code:unassigned UNASSIGNED)
-)
-\f
-;;; Disgusting hack to replace microcode implementation.
+(define (primitive-procedure? object)
+ (or (eq? compiled-error-procedure object)
+ (scode/primitive-procedure? object)))
+
+(define (normal-primitive-procedure? object)
+ (or (eq? compiled-error-procedure object)
+ (and (scode/primitive-procedure? object)
+ (primitive-procedure-safe? object))))
+
+(define (primitive-arity-correct? primitive argument-count)
+ (if (eq? primitive compiled-error-procedure)
+ (> argument-count 1)
+ (let ((arity (primitive-procedure-arity primitive)))
+ (or (= arity -1)
+ (= arity argument-count)))))
(define (primitive-procedure-safe? object)
(and (primitive-type? (ucode-type primitive) object)
(define lambda-tag:delay
(make-named-tag "DELAY-LAMBDA"))
-;; Primitives are non pointers, but need to be updated by the fasloader;
-;; they cannot appear as immediate constants in the instruction stream.
-;; Therefore, for the purposes of compilation, they are treated as pointers.
-
(define (non-pointer-object? object)
(or (primitive-type? (ucode-type false) object)
(primitive-type? (ucode-type true) object)
(eq? object compiled-error-procedure)))
(define (operator-constant-foldable? operator)
- (memq operator constant-foldable-operators))
-
-(define constant-foldable-operators
- (list primitive-type primitive-type?
- eq? null? pair? number? complex? real? rational? integer?
- zero? positive? negative? odd? even? exact? inexact?
- = < > <= >= max min
- + - * / 1+ -1+ abs quotient remainder modulo integer-divide
- gcd lcm floor ceiling truncate round
- exp log expt sqrt sin cos tan asin acos atan
- (ucode-primitive &+) (ucode-primitive &-)
- (ucode-primitive &*) (ucode-primitive &/)
- (ucode-primitive &<) (ucode-primitive &>)
- (ucode-primitive &=) (ucode-primitive &atan)))
\ No newline at end of file
+ (memq operator constant-foldable-primitives))
+
+(define constant-foldable-primitives
+ (append!
+ (list-transform-positive
+ (map (lambda (name)
+ (lexical-reference system-global-environment name))
+ '(PRIMITIVE-TYPE PRIMITIVE-TYPE?
+ EQ? NULL? PAIR? NUMBER? COMPLEX? REAL? RATIONAL? INTEGER?
+ ZERO? POSITIVE? NEGATIVE? ODD? EVEN? EXACT? INEXACT?
+ = < > <= >= MAX MIN
+ + - * / 1+ -1+ ABS QUOTIENT REMAINDER MODULO INTEGER-DIVIDE
+ GCD LCM FLOOR CEILING TRUNCATE ROUND
+ EXP LOG EXPT SQRT SIN COS TAN ASIN ACOS ATAN))
+ (access primitive-procedure? system-global-environment))
+ (list
+ (ucode-primitive &+) (ucode-primitive &-)
+ (ucode-primitive &*) (ucode-primitive &/)
+ (ucode-primitive &<) (ucode-primitive &>)
+ (ucode-primitive &=) (ucode-primitive &atan))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff