--- /dev/null
+#| -*-Scheme-*-
+
+$Id: asstop.scm,v 1.1 1994/11/19 02:01:20 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; Assembler and Linker top level
+;;; package: (compiler top-level)
+
+(declare (usual-integrations))
+\f
+;;;; Exports to the compiler
+
+(define compiled-output-extension "com")
+
+(define (compiler-file-output object pathname)
+ (fasdump object pathname))
+
+(define (compiler-output->procedure scode environment)
+ (scode-eval scode environment))
+
+(define (compiler-output->compiled-expression cexp)
+ cexp)
+
+(define (compile-scode/internal/hook action)
+ (action))
+
+;;; Global variables for the assembler and linker
+
+(define *recursive-compilation-results*)
+
+;; First set: phase/rtl-generation
+;; Last used: phase/link
+(define *block-label*)
+
+;; First set: phase/lap-generation
+;; Last used: phase/info-generation-2
+(define *external-labels*)
+
+;; First set: phase/assemble
+;; Last used: phase/link
+(define *label-bindings*)
+(define *code-vector*)
+(define *entry-points*)
+
+;; First set: phase/link
+;; Last used: result of compilation
+(define *result*)
+
+(define (assemble&link info-output-pathname)
+ (phase/assemble)
+ (if compiler:cross-compiling?
+ (begin
+ (if info-output-pathname
+ (cross-compiler-phase/info-generation-2 info-output-pathname))
+ (cross-compiler-phase/link))
+ (begin
+ (if info-output-pathname
+ (phase/info-generation-2 info-output-pathname))
+ (phase/link)))
+ *result*)
+
+(define (wrap-lap entry-label some-lap)
+ (LAP ,@(if *procedure-result?*
+ (LAP (ENTRY-POINT ,entry-label))
+ (lap:make-entry-point entry-label *block-label*))
+ ,@some-lap))
+\f
+(define (bind-assembler&linker-top-level-variables thunk)
+ (fluid-let ((*recursive-compilation-results* '()))
+ (thunk)))
+
+(define (bind-assembler&linker-variables thunk)
+ (fluid-let ((*block-associations*)
+ (*block-label*)
+ (*external-labels*)
+ (*end-of-block-code*)
+ (*next-constant*)
+ (*interned-assignments*)
+ (*interned-constants*)
+ (*interned-global-links*)
+ (*interned-static-variables*)
+ (*interned-uuo-links*)
+ (*interned-variables*)
+ (*label-bindings*)
+ (*code-vector*)
+ (*entry-points*)
+ (*result*))
+ (thunk)))
+
+(define (assembler&linker-reset!)
+ (set! *recursive-compilation-results* '())
+ (set! *block-associations*)
+ (set! *block-label*)
+ (set! *external-labels*)
+ (set! *end-of-block-code*)
+ (set! *next-constant*)
+ (set! *interned-assignments*)
+ (set! *interned-constants*)
+ (set! *interned-global-links*)
+ (set! *interned-static-variables*)
+ (set! *interned-uuo-links*)
+ (set! *interned-variables*)
+ (set! *label-bindings*)
+ (set! *code-vector*)
+ (set! *entry-points*)
+ (set! *result*)
+ unspecific)
+
+(define (initialize-back-end!)
+ (set! *block-associations* '())
+ (set! *block-label* (generate-label))
+ (set! *external-labels* '())
+ (set! *end-of-block-code* '())
+ (set! *next-constant* 0)
+ (set! *interned-assignments* '())
+ (set! *interned-constants* '())
+ (set! *interned-global-links* '())
+ (set! *interned-static-variables* '())
+ (set! *interned-uuo-links* '())
+ (set! *interned-variables* '())
+ unspecific)
+\f
+;;;; Assembler and linker
+
+(define (phase/assemble)
+ (compiler-phase
+ "Assembly"
+ (lambda ()
+ (with-values (lambda () (assemble *block-label* (last-reference *lap*)))
+ (lambda (count code-vector labels bindings)
+ (set! *code-vector* code-vector)
+ (set! *entry-points* labels)
+ (set! *label-bindings* bindings)
+ (if compiler:show-phases?
+ (begin
+ (newline)
+ (write-string *output-prefix*)
+ (write-string " Branch tensioning done in ")
+ (write (1+ count))
+ (write-string
+ (if (zero? count) " iteration." " iterations.")))))))))
+
+(define (phase/link)
+ (compiler-phase
+ "Linkification"
+ (lambda ()
+ ;; This has sections locked against GC to prevent relocation
+ ;; while computing addresses.
+ (let* ((label->offset
+ (lambda (label)
+ (cdr (or (assq label *label-bindings*)
+ (error "Missing entry point" label)))))
+ (bindings
+ (map (lambda (label)
+ (cons
+ label
+ (with-absolutely-no-interrupts
+ (lambda ()
+ ((ucode-primitive primitive-object-set-type)
+ type-code:compiled-entry
+ (make-non-pointer-object
+ (+ (label->offset label)
+ (object-datum *code-vector*))))))))
+ *entry-points*))
+ (label->address
+ (lambda (label)
+ (cdr (or (assq label bindings)
+ (error "Label not defined as entry point"
+ label))))))
+ (set! *result*
+ (if *procedure-result?*
+ (let ((linking-info *subprocedure-linking-info*))
+ (let ((compiled-procedure (label->address *entry-label*))
+ (translate-label
+ (let ((block-offset (label->offset *block-label*)))
+ (lambda (index)
+ (let ((label (vector-ref linking-info index)))
+ (and label
+ (- (label->offset label)
+ block-offset)))))))
+ (cons compiled-procedure
+ (vector
+ (compiled-code-address->block compiled-procedure)
+ (translate-label 0)
+ (translate-label 1)
+ (vector-ref linking-info 2)))))
+ (label->address *entry-label*)))
+ (for-each (lambda (entry)
+ (set-lambda-body! (car entry)
+ (label->address (cdr entry))))
+ *ic-procedure-headers*))
+ ((ucode-primitive declare-compiled-code-block 1) *code-vector*)
+ (if (not compiler:preserve-data-structures?)
+ (begin
+ (set! *code-vector*)
+ (set! *entry-points*)
+ (set! *subprocedure-linking-info*)
+ (set! *label-bindings*)
+ (set! *block-label*)
+ (set! *entry-label*)
+ (set! *ic-procedure-headers*)
+ unspecific)))))
+\f
+;;;; Dumping the assembler's symbol table to the debugging file...
+
+(define (phase/info-generation-2 pathname)
+ (info-generation-2 pathname set-compiled-code-block/debugging-info!))
+
+(define (info-generation-2 pathname set-debugging-info!)
+ (compiler-phase "Debugging Information Generation"
+ (lambda ()
+ (set-debugging-info!
+ *code-vector*
+ (and *use-debugging-info?*
+ (let ((info
+ (info-generation-phase-3
+ (last-reference *dbg-expression*)
+ (last-reference *dbg-procedures*)
+ (last-reference *dbg-continuations*)
+ *label-bindings*
+ (last-reference *external-labels*))))
+ (cond ((eq? pathname 'KEEP) ; for dynamic execution
+ info)
+ ((eq? pathname 'RECURSIVE) ; recursive compilation
+ (set! *recursive-compilation-results*
+ (cons (vector *recursive-compilation-number*
+ info
+ *code-vector*)
+ *recursive-compilation-results*))
+ (cons *info-output-filename*
+ *recursive-compilation-number*))
+ (else
+ (compiler:dump-info-file
+ (let ((others (recursive-compilation-results)))
+ (if (null? others)
+ info
+ (list->vector
+ (cons info
+ (map (lambda (other) (vector-ref other 1))
+ others)))))
+ pathname)
+ *info-output-filename*))))))))
+
+(define (recursive-compilation-results)
+ (sort *recursive-compilation-results*
+ (lambda (x y)
+ (< (vector-ref x 0)
+ (vector-ref y 0)))))
+\f
+;;; Various ways of dumping an info file
+
+(define (compiler:dump-inf-file binf pathname)
+ (fasdump binf pathname true)
+ (announce-info-files pathname))
+
+(define (compiler:dump-bif/bsm-files binf pathname)
+ (let ((bif-path (pathname-new-type pathname "bif"))
+ (bsm-path (pathname-new-type pathname "bsm")))
+ (let ((bsm (split-inf-structure! binf bsm-path)))
+ (fasdump binf bif-path true)
+ (fasdump bsm bsm-path true))
+ (announce-info-files bif-path bsm-path)))
+
+(define (compiler:dump-bci/bcs-files binf pathname)
+ (let ((bci-path (pathname-new-type pathname "bci"))
+ (bcs-path (pathname-new-type pathname "bcs")))
+ (let ((bsm (split-inf-structure! binf bcs-path)))
+ (call-with-temporary-filename
+ (lambda (bif-name)
+ (fasdump binf bif-name true)
+ (compress bif-name bci-path)))
+ (call-with-temporary-filename
+ (lambda (bsm-name)
+ (fasdump bsm bsm-name true)
+ (compress bsm-name bcs-path))))
+ (announce-info-files bci-path bcs-path)))
+
+(define (compiler:dump-bci-file binf pathname)
+ (let ((bci-path (pathname-new-type pathname "bci")))
+ (split-inf-structure! binf false)
+ (call-with-temporary-filename
+ (lambda (bif-name)
+ (fasdump binf bif-name true)
+ (compress bif-name bci-path)))
+ (announce-info-files bci-path)))
+
+(define (announce-info-files . files)
+ (if compiler:noisy?
+ (let ((port (nearest-cmdl/port)))
+ (let loop ((files files))
+ (if (null? files)
+ unspecific
+ (begin
+ (fresh-line port)
+ (write-string ";")
+ (write (->namestring (car files)))
+ (write-string " dumped ")
+ (loop (cdr files))))))))
+
+(define compiler:dump-info-file
+ compiler:dump-bci-file)
+\f
+;;;; LAP->CODE
+;;; Example of `lap->code' usage (MC68020):
+
+#|
+(define bar
+ ;; defines bar to be a procedure that adds 1 to its argument
+ ;; with no type or range checks.
+ (scode-eval
+ (lap->code
+ 'start
+ `((entry-point start)
+ (dc uw #xffff)
+ (block-offset start)
+ (label start)
+ (pea (@pcr proc))
+ (or b (& ,(* (microcode-type 'compiled-entry) 4)) (@a 7))
+ (mov l (@a+ 7) (@ao 6 8))
+ (and b (& #x3) (@a 7))
+ (rts)
+ (dc uw #x0202)
+ (block-offset proc)
+ (label proc)
+ (mov l (@a+ 7) (d 0))
+ (addq l (& 1) (d 0))
+ (mov l (d 0) (@ao 6 8))
+ (and b (& #x3) (@a 7))
+ (rts)))
+ '()))
+|#
+
+(define (lap->code label instructions)
+ (in-compiler
+ (lambda ()
+ (set! *lap* instructions)
+ (set! *entry-label* label)
+ (set! *current-label-number* 0)
+ (set! *next-constant* 0)
+ (set! *interned-assignments* '())
+ (set! *interned-constants* '())
+ (set! *interned-global-links* '())
+ (set! *interned-static-variables* '())
+ (set! *interned-uuo-links* '())
+ (set! *interned-variables* '())
+ (set! *block-label* (generate-label))
+ (set! *external-labels* '())
+ (set! *ic-procedure-headers* '())
+ (phase/assemble)
+ (phase/link)
+ *result*)))
+
+(define (canonicalize-label-name name)
+ ;; The Scheme assembler allows any Scheme symbol as a label
+ name)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/blocks.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988, 1989, 1990 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
+;;; package: (compiler)
+
+(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 or any children
+ variables-nontransitively-free
+ ;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
+ debugging-info ;dbg-block, if used
+ (stack-link ;for stack block, adjacent block on stack
+ shared-block) ;for multi closures, the official block
+ (static-link? ;for stack block, true iff static link to parent
+ entry-number) ;for multi closures, entry number
+ (popping-limits ;for stack block (see continuation analysis)
+ grafted-blocks) ;for multi closures, list of blocks that share
+ popping-limit ;for stack block (see continuation analysis)
+ layout-frozen? ;used by frame reuse to tell parameter
+ ;analysis not to alter this block's layout
+ ;(i.e., don't make any of the block's
+ ;procedure's parameters be passed by register)
+ )
+
+(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 'UNKNOWN 'UNKNOWN false)))
+ (if parent
+ (set-block-children! parent (cons block (block-children parent))))
+ (set! *blocks* (cons block *blocks*))
+ block))
+
+(define-vector-tag-unparser block-tag
+ (lambda (state block)
+ ((standard-unparser
+ (symbol->string 'BLOCK)
+ (lambda (state block)
+ (unparse-object state
+ (enumeration/index->name block-types
+ (block-type block)))
+ (let ((procedure (block-procedure block)))
+ (if (and procedure (rvalue/procedure? procedure))
+ (begin
+ (unparse-string state " ")
+ (unparse-label state (procedure-label procedure)))))))
+ state block)))
+
+(define-integrable (rvalue/block? rvalue)
+ (eq? (tagged-vector/tag rvalue) block-tag))
+
+(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 (ic-block? block)
+ (let ((type (block-type block)))
+ (or (eq? type block-type/ic)
+ (eq? type block-type/expression))))
+
+(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 (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)
+ (let loop ((block (block-parent block)) (path (list block)))
+ (if block
+ (loop (block-parent block) (cons block path))
+ path)))
+
+(define (block-partial-ancestry block ancestor)
+ ;; (assert (or (not ancestor) (block-ancestor-or-self? block ancestor)))
+ (if (eq? block ancestor)
+ '()
+ (let loop ((block (block-parent block)) (path (list block)))
+ (if (eq? block ancestor)
+ path
+ (loop (block-parent block) (cons block path))))))
+
+(define (find-outermost-block block)
+ ;; Should this check whether it is an expression/ic block or not?
+ (if (block-parent block)
+ (find-outermost-block (block-parent block))
+ block))
+\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-descendant! block procedure)
+ (let loop ((block block))
+ (procedure block)
+ (for-each loop (block-children block))))
+
+(define-integrable (stack-block/static-link? block)
+ (block-static-link? block))
+
+(define-integrable (stack-block/continuation-lvalue block)
+ (procedure-continuation-lvalue (block-procedure block)))
+
+(define (block/dynamic-link? block)
+ (and (stack-block? block)
+ (stack-block/dynamic-link? block)))
+
+(define (stack-block/dynamic-link? block)
+ (and (stack-parent? block)
+ (internal-block/dynamic-link? block)))
+
+(define-integrable (internal-block/dynamic-link? block)
+ (not (block-popping-limit block)))
+
+(define-integrable (original-block-parent block)
+ ;; This only works for the invocation blocks of procedures (not
+ ;; continuations), and it assumes that all procedures' target-block
+ ;; fields have been initialized (i.e. the environment optimizer has
+ ;; been run).
+ (let ((procedure (block-procedure block)))
+ (and procedure
+ (rvalue/procedure? procedure)
+ (procedure-target-block procedure))))
+
+#|
+(define (disown-block-child! block child)
+ (set-block-children! block (delq! child (block-children block)))
+ (if (eq? block (original-block-parent child))
+ (set-block-disowned-children! block
+ (cons child (block-disowned-children block))))
+ unspecific)
+
+(define (own-block-child! block child)
+ (set-block-parent! child block)
+ (set-block-children! block (cons child (block-children block)))
+ (if (eq? block (original-block-parent child))
+ (set-block-disowned-children! block
+ (delq! child (block-disowned-children block))))
+ unspecific)
+|#
+
+(define (transfer-block-child! child block block*)
+ ;; equivalent to
+ ;; (begin
+ ;; (disown-block-child! block child)
+ ;; (own-block-child! block* child))
+ ;; but faster.
+ (let ((original-parent (original-block-parent child)))
+ (set-block-children! block (delq! child (block-children block)))
+ (if (eq? block original-parent)
+ (set-block-disowned-children!
+ block
+ (cons child (block-disowned-children block))))
+ (set-block-parent! child block*)
+ (if block*
+ (begin
+ (set-block-children! block* (cons child (block-children block*)))
+ (if (eq? block* original-parent)
+ (set-block-disowned-children!
+ block*
+ (delq! child (block-disowned-children block*))))))))
+
+(define-integrable (block-number-of-entries block)
+ (block-entry-number block))
+
+(define (closure-block-entry-number block)
+ (if (eq? block (block-shared-block block))
+ 0
+ (block-entry-number block)))
+
+(define (closure-block-first-offset block)
+ (let ((block* (block-shared-block block)))
+ (closure-first-offset (block-entry-number block*)
+ (if (eq? block block*)
+ 0
+ (block-entry-number block)))))
+
+(define (block-nearest-closure-ancestor block)
+ (let loop ((block block) (last false))
+ (and block
+ (if (stack-block? block)
+ (loop (block-parent block) block)
+ (and (closure-block? block)
+ last)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/cfg1.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1987, 1989 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. |#
+
+;;;; Control Flow Graph Abstraction
+
+(declare (usual-integrations))
+\f
+;;;; Node Datatypes
+
+(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 alist previous-edges)
+
+(set-vector-tag-description!
+ cfg-node-tag
+ (lambda (node)
+ (descriptor-list node generation alist previous-edges)))
+
+(define snode-tag (make-vector-tag cfg-node-tag 'SNODE false))
+(define snode? (tagged-vector/subclass-predicate snode-tag))
+(define-vector-slots snode 4 next-edge)
+
+;;; converted to a macro.
+;;; (define (make-snode tag . extra)
+;;; (list->vector (cons* tag false '() '() false extra)))
+
+(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 false))
+(define pnode? (tagged-vector/subclass-predicate pnode-tag))
+(define-vector-slots pnode 4 consequent-edge alternative-edge)
+
+;;; converted to a macro.
+;;; (define (make-pnode tag . extra)
+;;; (list->vector (cons* tag false '() '() false false extra)))
+
+(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-integrable (snode-next snode)
+ (edge-next-node (snode-next-edge snode)))
+
+(define-integrable (pnode-consequent pnode)
+ (edge-next-node (pnode-consequent-edge pnode)))
+
+(define-integrable (pnode-alternative pnode)
+ (edge-next-node (pnode-alternative-edge pnode)))
+
+(define (cfg-node-get node key)
+ (let ((entry (assq key (node-alist node))))
+ (and entry
+ (cdr entry))))
+
+(define (cfg-node-put! node key item)
+ (let ((entry (assq key (node-alist node))))
+ (if entry
+ (set-cdr! entry item)
+ (set-node-alist! node (cons (cons key item) (node-alist node))))))
+
+(define (cfg-node-remove! node key)
+ (set-node-alist! node (del-assq! key (node-alist node))))
+\f
+;;;; Edge Datatype
+
+(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
+ (add-node-previous-edge! right-node edge))
+ edge))
+
+(define-integrable (node->edge node)
+ (create-edge! false false node))
+
+(define (edge-next-node edge)
+ (and edge (edge-right-node edge)))
+
+(define (edge-connect-left! edge left-node left-connect)
+ (if (edge-left-node edge)
+ (error "Attempt to doubly connect left node of edge" edge))
+ (if left-node
+ (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)
+ (if (edge-right-node edge)
+ (error "Attempt to doubly connect right node of edge" edge))
+ (if right-node
+ (begin
+ (set-edge-right-node! edge right-node)
+ (add-node-previous-edge! right-node edge))))
+
+(define (edge-disconnect-left! edge)
+ (let ((left-node (edge-left-node edge))
+ (left-connect (edge-left-connect edge)))
+ (if left-node
+ (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 (edge-right-node edge)))
+ (if right-node
+ (begin
+ (set-edge-right-node! edge false)
+ (delete-node-previous-edge! right-node edge)))))
+
+(define (edge-disconnect! edge)
+ (edge-disconnect-left! edge)
+ (edge-disconnect-right! edge))
+
+(define (edge-replace-left! edge left-node left-connect)
+ (edge-disconnect-left! edge)
+ (edge-connect-left! edge left-node left-connect))
+
+(define (edge-replace-right! edge right-node)
+ (edge-disconnect-right! edge)
+ (edge-connect-right! edge right-node))
+
+(define (edges-connect-right! edges right-node)
+ (for-each (lambda (edge) (edge-connect-right! edge right-node)) edges))
+
+(define (edges-disconnect-right! edges)
+ (for-each edge-disconnect-right! edges))
+
+(define (edges-replace-right! edges right-node)
+ (for-each (lambda (edge) (edge-replace-right! edge right-node)) edges))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/cfg2.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1987, 1989 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. |#
+
+;;;; Control Flow Graph Abstraction
+
+(declare (usual-integrations))
+\f
+;;;; Editing
+
+(define (snode-delete! snode)
+ (let ((next-edge (snode-next-edge snode)))
+ (if next-edge
+ (begin
+ (edges-replace-right! (node-previous-edges snode)
+ (edge-right-node next-edge))
+ (edge-disconnect! next-edge))
+ (edges-disconnect-right! (node-previous-edges snode)))))
+
+(define (edge-insert-snode! edge snode)
+ (let ((next (edge-right-node edge)))
+ (edge-replace-right! edge snode)
+ (create-edge! snode set-snode-next-edge! next)))
+
+(define (node-insert-snode! node snode)
+ (edges-replace-right! (node-previous-edges node) snode)
+ (create-edge! snode set-snode-next-edge! node))
+
+(define-integrable (node-disconnect-on-right! node)
+ (edges-disconnect-right! (node-previous-edges node)))
+
+(define (node-disconnect-on-left! node)
+ (if (snode? node)
+ (snode-disconnect-on-left! node)
+ (pnode-disconnect-on-left! node)))
+
+(define (snode-disconnect-on-left! node)
+ (let ((edge (snode-next-edge node)))
+ (if edge
+ (edge-disconnect-left! edge))))
+
+(define (pnode-disconnect-on-left! node)
+ (let ((edge (pnode-consequent-edge node)))
+ (if edge
+ (edge-disconnect-left! edge)))
+ (let ((edge (pnode-alternative-edge node)))
+ (if edge
+ (edge-disconnect-left! edge))))
+
+(define (node-replace! old-node new-node)
+ (if (snode? old-node)
+ (snode-replace! old-node new-node)
+ (pnode-replace! old-node new-node)))
+
+(define (snode-replace! old-node new-node)
+ (node-replace-on-right! old-node new-node)
+ (snode-replace-on-left! old-node new-node))
+
+(define (pnode-replace! old-node new-node)
+ (node-replace-on-right! old-node new-node)
+ (pnode-replace-on-left! old-node new-node))
+
+(define-integrable (node-replace-on-right! old-node new-node)
+ (edges-replace-right! (node-previous-edges old-node) new-node))
+
+(define (node-replace-on-left! old-node new-node)
+ (if (snode? old-node)
+ (snode-replace-on-left! old-node new-node)
+ (pnode-replace-on-left! old-node new-node)))
+
+(define (snode-replace-on-left! old-node new-node)
+ (let ((edge (snode-next-edge old-node)))
+ (if edge
+ (edge-replace-left! edge new-node set-snode-next-edge!))))
+
+(define (pnode-replace-on-left! old-node new-node)
+ (let ((edge (pnode-consequent-edge old-node)))
+ (if edge
+ (edge-replace-left! edge new-node set-pnode-consequent-edge!)))
+ (let ((edge (pnode-alternative-edge old-node)))
+ (if edge
+ (edge-replace-left! edge new-node set-pnode-alternative-edge!))))
+\f
+;;;; Previous Connections
+
+(define-integrable (node-previous=0? node)
+ (edges=0? (node-previous-edges node)))
+
+(define (edges=0? edges)
+ (cond ((null? edges) true)
+ ((edge-left-node (car edges)) false)
+ (else (edges=0? (cdr edges)))))
+
+(define-integrable (node-previous>0? node)
+ (edges>0? (node-previous-edges node)))
+
+(define (edges>0? edges)
+ (cond ((null? edges) false)
+ ((edge-left-node (car edges)) true)
+ (else (edges>0? (cdr edges)))))
+
+(define-integrable (node-previous=1? node)
+ (edges=1? (node-previous-edges node)))
+
+(define (edges=1? edges)
+ (if (null? edges)
+ false
+ ((if (edge-left-node (car edges)) edges=0? edges=1?) (cdr edges))))
+
+(define-integrable (node-previous>1? node)
+ (edges>1? (node-previous-edges node)))
+
+(define (edges>1? edges)
+ (if (null? edges)
+ false
+ ((if (edge-left-node (car edges)) edges>0? edges>1?) (cdr edges))))
+
+(define-integrable (node-previous-first node)
+ (edges-first-node (node-previous-edges node)))
+
+(define (edges-first-node edges)
+ (if (null? edges)
+ (error "No first hook")
+ (or (edge-left-node (car edges))
+ (edges-first-node (cdr edges)))))
+
+(define (for-each-previous-node node procedure)
+ (for-each (lambda (edge)
+ (let ((node (edge-left-node edge)))
+ (if node
+ (procedure node))))
+ (node-previous-edges node)))
+\f
+;;;; Noops
+
+(package (cfg-node-tag/noop! cfg-node-tag/noop?)
+
+(define-export (cfg-node-tag/noop! tag)
+ (vector-tag-put! tag noop-tag-property true))
+
+(define-export (cfg-node-tag/noop? tag)
+ (vector-tag-get tag noop-tag-property))
+
+(define noop-tag-property
+ "noop-tag-property")
+
+)
+
+(define-integrable (cfg-node/noop? node)
+ (cfg-node-tag/noop? (tagged-vector/tag node)))
+
+(define noop-node-tag
+ (make-vector-tag snode-tag 'NOOP false))
+
+(cfg-node-tag/noop! noop-node-tag)
+
+(define-integrable (make-noop-node)
+ (let ((node (make-snode noop-node-tag)))
+ (set! *noop-nodes* (cons node *noop-nodes*))
+ node))
+
+(define *noop-nodes*)
+
+(define (cleanup-noop-nodes thunk)
+ (fluid-let ((*noop-nodes* '()))
+ (let ((value (thunk)))
+ (for-each snode-delete! *noop-nodes*)
+ value)))
+
+(define (make-false-pcfg)
+ (snode->pcfg-false (make-noop-node)))
+
+(define (make-true-pcfg)
+ (snode->pcfg-true (make-noop-node)))
+\f
+;;;; Miscellaneous
+
+(package (with-new-node-marks
+ node-marked?
+ node-mark!)
+
+(define *generation*)
+
+(define-export (with-new-node-marks thunk)
+ (fluid-let ((*generation* (make-generation)))
+ (thunk)))
+
+(define make-generation
+ (let ((generation 0))
+ (named-lambda (make-generation)
+ (let ((value generation))
+ (set! generation (1+ generation))
+ value))))
+
+(define-export (node-marked? node)
+ (eq? (node-generation node) *generation*))
+
+(define-export (node-mark! node)
+ (set-node-generation! node *generation*))
+
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/cfg3.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1987, 1989 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. |#
+
+;;;; Control Flow Graph Abstraction
+
+(declare (usual-integrations))
+\f
+;;;; CFG Datatypes
+
+;;; A CFG is a compound CFG-node, so there are different types of CFG
+;;; corresponding to the (connective-wise) different types of
+;;; CFG-node. One may insert a particular type of CFG anywhere in a
+;;; graph that its corresponding node may be inserted.
+
+(define-integrable (make-scfg node next-hooks)
+ (vector 'SNODE-CFG node next-hooks))
+
+(define-integrable (make-scfg* node consequent-hooks alternative-hooks)
+ (make-scfg node (hooks-union consequent-hooks alternative-hooks)))
+
+(define-integrable (make-pcfg node consequent-hooks alternative-hooks)
+ (vector 'PNODE-CFG node consequent-hooks alternative-hooks))
+
+(define-integrable (cfg-tag cfg)
+ (vector-ref cfg 0))
+
+(define-integrable (cfg-entry-node cfg)
+ (vector-ref cfg 1))
+
+(define-integrable (scfg-next-hooks scfg)
+ (vector-ref scfg 2))
+
+(define-integrable (pcfg-consequent-hooks pcfg)
+ (vector-ref pcfg 2))
+
+(define-integrable (pcfg-alternative-hooks pcfg)
+ (vector-ref pcfg 3))
+
+(define-integrable (make-null-cfg) false)
+(define-integrable cfg-null? false?)
+
+(define-integrable (cfg-entry-edge cfg)
+ (node->edge (cfg-entry-node cfg)))
+\f
+(define-integrable (snode->scfg snode)
+ (node->scfg snode set-snode-next-edge!))
+
+(define (node->scfg node set-node-next!)
+ (make-scfg node
+ (list (make-hook node set-node-next!))))
+
+(define-integrable (pnode->pcfg pnode)
+ (node->pcfg pnode
+ set-pnode-consequent-edge!
+ set-pnode-alternative-edge!))
+
+(define (node->pcfg node set-node-consequent! set-node-alternative!)
+ (make-pcfg node
+ (list (make-hook node set-node-consequent!))
+ (list (make-hook node set-node-alternative!))))
+
+(define (snode->pcfg-false snode)
+ (make-pcfg snode
+ (make-null-hooks)
+ (list (make-hook snode set-snode-next-edge!))))
+
+(define (snode->pcfg-true snode)
+ (make-pcfg snode
+ (list (make-hook snode set-snode-next-edge!))
+ (make-null-hooks)))
+
+(define (pcfg-invert pcfg)
+ (make-pcfg (cfg-entry-node pcfg)
+ (pcfg-alternative-hooks pcfg)
+ (pcfg-consequent-hooks pcfg)))
+\f
+;;;; Hook Datatype
+
+(define-integrable make-hook cons)
+(define-integrable hook-node car)
+(define-integrable hook-connect cdr)
+
+(define (hook=? x y)
+ (and (eq? (hook-node x) (hook-node y))
+ (eq? (hook-connect x) (hook-connect y))))
+
+(define hook-member?
+ (member-procedure hook=?))
+
+(define-integrable (make-null-hooks)
+ '())
+
+(define-integrable hooks-null?
+ null?)
+
+(define (hooks-union x y)
+ (let loop ((x x))
+ (cond ((null? x) y)
+ ((hook-member? (car x) y) (loop (cdr x)))
+ (else (cons (car x) (loop (cdr x)))))))
+
+(define (hooks-connect! hooks node)
+ (for-each (lambda (hook)
+ (hook-connect! hook node))
+ hooks))
+
+(define (hook-connect! hook node)
+ (create-edge! (hook-node hook) (hook-connect hook) node))
+\f
+;;;; Simplicity Tests
+
+(define (scfg-simple? scfg)
+ (cfg-branch-simple? (cfg-entry-node scfg) (scfg-next-hooks scfg)))
+
+(define (pcfg-simple? pcfg)
+ (let ((entry-node (cfg-entry-node pcfg)))
+ (and (cfg-branch-simple? entry-node (pcfg-consequent-hooks pcfg))
+ (cfg-branch-simple? entry-node (pcfg-alternative-hooks pcfg)))))
+
+(define (cfg-branch-simple? entry-node hooks)
+ (and (not (null? hooks))
+ (null? (cdr hooks))
+ (eq? entry-node (hook-node (car hooks)))))
+
+(define (scfg-null? scfg)
+ (or (cfg-null? scfg)
+ (cfg-branch-null? (cfg-entry-node scfg)
+ (scfg-next-hooks scfg))))
+
+(define (pcfg-true? pcfg)
+ (and (hooks-null? (pcfg-alternative-hooks pcfg))
+ (cfg-branch-null? (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks pcfg))))
+
+(define (pcfg-false? pcfg)
+ (and (hooks-null? (pcfg-consequent-hooks pcfg))
+ (cfg-branch-null? (cfg-entry-node pcfg)
+ (pcfg-alternative-hooks pcfg))))
+
+(define (cfg-branch-null? entry-node hooks)
+ (and (cfg-branch-simple? entry-node hooks)
+ (cfg-node/noop? entry-node)))
+\f
+;;;; Node-result Constructors
+
+(define (scfg*node->node! scfg next-node)
+ (if (scfg-null? scfg)
+ next-node
+ (begin
+ (hooks-connect! (scfg-next-hooks scfg) next-node)
+ (cfg-entry-node scfg))))
+
+(define (pcfg*node->node! pcfg consequent-node alternative-node)
+ (if (cfg-null? pcfg)
+ (error "PCFG*NODE->NODE!: Can't have null predicate"))
+ (cond ((pcfg-true? pcfg) consequent-node)
+ ((pcfg-false? pcfg) alternative-node)
+ (else
+ (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node)
+ (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node)
+ (cfg-entry-node pcfg))))
+\f
+;;;; CFG Construction
+
+(define-integrable (scfg-next-connect! scfg cfg)
+ (hooks-connect! (scfg-next-hooks scfg) (cfg-entry-node cfg)))
+
+(define-integrable (pcfg-consequent-connect! pcfg cfg)
+ (hooks-connect! (pcfg-consequent-hooks pcfg) (cfg-entry-node cfg)))
+
+(define-integrable (pcfg-alternative-connect! pcfg cfg)
+ (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg)))
+
+(define (scfg*scfg->scfg! scfg scfg*)
+ (cond ((scfg-null? scfg) scfg*)
+ ((scfg-null? scfg*) scfg)
+ (else
+ (scfg-next-connect! scfg scfg*)
+ (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*)))))
+
+(define (scfg-append! . scfgs)
+ (scfg*->scfg! scfgs))
+
+(define scfg*->scfg!
+ (let ()
+ (define (find-non-null scfgs)
+ (if (and (not (null? scfgs))
+ (scfg-null? (car scfgs)))
+ (find-non-null (cdr scfgs))
+ scfgs))
+
+ (define (loop first second rest)
+ (scfg-next-connect! first second)
+ (if (null? rest)
+ second
+ (loop second (car rest) (find-non-null (cdr rest)))))
+
+ (named-lambda (scfg*->scfg! scfgs)
+ (let ((first (find-non-null scfgs)))
+ (if (null? first)
+ (make-null-cfg)
+ (let ((second (find-non-null (cdr first))))
+ (if (null? second)
+ (car first)
+ (make-scfg (cfg-entry-node (car first))
+ (scfg-next-hooks
+ (loop (car first)
+ (car second)
+ (find-non-null (cdr second))))))))))))
+\f
+(package (scfg*pcfg->pcfg! scfg*pcfg->scfg!)
+
+(define ((scfg*pcfg->cfg! constructor) scfg pcfg)
+ (if (cfg-null? pcfg)
+ (error "SCFG*PCFG->CFG!: Can't have null predicate"))
+ (cond ((scfg-null? scfg)
+ (constructor (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks pcfg)
+ (pcfg-alternative-hooks pcfg)))
+ ((pcfg-true? pcfg)
+ (constructor (cfg-entry-node scfg)
+ (scfg-next-hooks scfg)
+ (make-null-hooks)))
+ ((pcfg-false? pcfg)
+ (constructor (cfg-entry-node scfg)
+ (make-null-hooks)
+ (scfg-next-hooks scfg)))
+ (else
+ (scfg-next-connect! scfg pcfg)
+ (constructor (cfg-entry-node scfg)
+ (pcfg-consequent-hooks pcfg)
+ (pcfg-alternative-hooks pcfg)))))
+
+(define-export scfg*pcfg->pcfg!
+ (scfg*pcfg->cfg! make-pcfg))
+
+(define-export scfg*pcfg->scfg!
+ (scfg*pcfg->cfg! make-scfg*))
+
+)
+\f
+(package (pcfg*scfg->pcfg! pcfg*scfg->scfg!)
+
+(define ((pcfg*scfg->cfg! constructor) pcfg consequent alternative)
+ (if (cfg-null? pcfg)
+ (error "PCFG*SCFG->CFG!: Can't have null predicate"))
+ (cond ((pcfg-true? pcfg)
+ (constructor (cfg-entry-node consequent)
+ (scfg-next-hooks consequent)
+ (make-null-hooks)))
+ ((pcfg-false? pcfg)
+ (constructor (cfg-entry-node alternative)
+ (make-null-hooks)
+ (scfg-next-hooks alternative)))
+ (else
+ (constructor (cfg-entry-node pcfg)
+ (connect! (pcfg-consequent-hooks pcfg) consequent)
+ (connect! (pcfg-alternative-hooks pcfg) alternative)))))
+
+(define (connect! hooks scfg)
+ (if (or (hooks-null? hooks)
+ (scfg-null? scfg))
+ hooks
+ (begin
+ (hooks-connect! hooks (cfg-entry-node scfg))
+ (scfg-next-hooks scfg))))
+
+(define-export pcfg*scfg->pcfg!
+ (pcfg*scfg->cfg! make-pcfg))
+
+(define-export pcfg*scfg->scfg!
+ (pcfg*scfg->cfg! make-scfg*))
+
+)
+\f
+(package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!)
+
+(define ((pcfg*pcfg->cfg! constructor) pcfg consequent alternative)
+ (if (cfg-null? pcfg)
+ (error "PCFG*PCFG->CFG!: Can't have null predicate"))
+ (cond ((pcfg-true? pcfg)
+ (constructor (cfg-entry-node consequent)
+ (pcfg-consequent-hooks consequent)
+ (pcfg-alternative-hooks consequent)))
+ ((pcfg-false? pcfg)
+ (constructor (cfg-entry-node alternative)
+ (pcfg-consequent-hooks alternative)
+ (pcfg-alternative-hooks alternative)))
+ (else
+ (connect! (pcfg-consequent-hooks pcfg)
+ consequent
+ consequent-select
+ (lambda (cchooks cahooks)
+ (connect! (pcfg-alternative-hooks pcfg)
+ alternative
+ alternative-select
+ (lambda (achooks aahooks)
+ (constructor (cfg-entry-node pcfg)
+ (hooks-union cchooks achooks)
+ (hooks-union cahooks aahooks)))))))))
+
+(define (connect! hooks pcfg select receiver)
+ (cond ((hooks-null? hooks) (receiver (make-null-hooks) (make-null-hooks)))
+ ((cfg-null? pcfg) (select receiver hooks))
+ ((pcfg-true? pcfg) (consequent-select receiver hooks))
+ ((pcfg-false? pcfg) (alternative-select receiver hooks))
+ (else
+ (hooks-connect! hooks (cfg-entry-node pcfg))
+ (receiver (pcfg-consequent-hooks pcfg)
+ (pcfg-alternative-hooks pcfg)))))
+
+(define-integrable (consequent-select receiver hooks)
+ (receiver hooks (make-null-hooks)))
+
+(define-integrable (alternative-select receiver hooks)
+ (receiver (make-null-hooks) hooks))
+
+(define-export pcfg*pcfg->pcfg!
+ (pcfg*pcfg->cfg! make-pcfg))
+
+(define-export pcfg*pcfg->scfg!
+ (pcfg*pcfg->cfg! make-scfg*))
+
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/constr.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1989-91 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. |#
+\f
+;;; Procedures for managing a set of ordering constraints
+
+(define-structure (constraint
+ (conc-name constraint/)
+ (constructor
+ &make-constraint (element)))
+ (element false read-only true)
+ (graph-head false)
+ (afters '())
+ (generation)
+ (closed? true))
+
+(define-structure (constraint-graph
+ (conc-name constraint-graph/)
+ (constructor make-constraint-graph ()))
+ (entry-nodes '())
+ (closed? true))
+
+(define (make-constraint element #!optional graph-head afters)
+ (let ((constraint (&make-constraint element)))
+ (if (and (not (default-object? graph-head))
+ (constraint-graph? graph-head))
+ (begin
+ (set-constraint/graph-head! constraint graph-head)
+ (set-constraint-graph/entry-nodes!
+ graph-head
+ (cons constraint (constraint-graph/entry-nodes graph-head)))))
+ (if (not (default-object? afters))
+ (for-each
+ (lambda (after) (constraint-add! constraint after))
+ afters))
+ constraint))
+
+(define (find-constraint element graph-head)
+
+ (define (loop children)
+ (if (pair? children)
+ (or (search (car children))
+ (loop (cdr children)))
+ false))
+
+ (define (search constraint)
+ (if (eqv? element (constraint/element constraint))
+ constraint
+ (loop (constraint/afters constraint))))
+
+ (loop (constraint-graph/entry-nodes graph-head)))
+
+(define (find-or-make-constraint element graph-head
+ #!optional afters)
+ (or (find-constraint element graph-head)
+ (if (default-object? afters)
+ (make-constraint element graph-head)
+ (make-constraint element graph-head afters))))
+
+\f
+(define (constraint-add! before after)
+ (if (eq? (constraint/element before) (constraint/element after))
+ (error "A node cannot be constrained to come after itself" after))
+ (set-constraint/afters! before (cons after (constraint/afters before)))
+ (let ((c-graph (constraint/graph-head after)))
+ (if c-graph
+ (set-constraint-graph/entry-nodes!
+ c-graph
+ (delq! after (constraint-graph/entry-nodes c-graph)))))
+ (set-constraint/closed?! before false)
+ (if (constraint/graph-head before)
+ (set-constraint-graph/closed?!
+ (constraint/graph-head before)
+ false)))
+
+(define (add-constraint-element! before-element after-element
+ graph-head)
+ (find-or-make-constraint
+ before-element
+ graph-head
+ (list after-element)))
+
+(define (add-constraint-set! befores afters graph-head)
+ (let ((after-constraints
+ (map (lambda (after)
+ (find-or-make-constraint after graph-head))
+ afters)))
+ (for-each
+ (lambda (before)
+ (find-or-make-constraint before graph-head after-constraints))
+ befores)))
+\f
+(define (close-constraint-graph! c-graph)
+ (with-new-constraint-marks
+ (lambda ()
+ (for-each close-constraint-node!
+ (constraint-graph/entry-nodes c-graph))))
+ (set-constraint-graph/closed?! c-graph true))
+
+(define (close-constraint-node! node)
+ (with-new-constraint-marks
+ (lambda ()
+ (&close-constraint-node! node))))
+
+(define (&close-constraint-node! node)
+ (transitively-close-dag!
+ node
+ constraint/afters
+ (lambda (before afters)
+ (set-constraint/afters!
+ before
+ (append
+ (constraint/afters before)
+ (if (memq node afters)
+ (error
+ "Illegal cycle in constraint graph involving node:"
+ node)
+ afters))))
+ constraint-marked?
+ (lambda (node)
+ (constraint-mark! node)
+ (set-constraint/closed?! node true))))
+
+(define (transitively-close-dag! node select update! marked? mark!)
+ (let transitively-close*! ((node node))
+ (let ((elements (select node)))
+ (if (or (null? elements) (marked? node))
+ elements
+ (begin
+ (mark! node)
+ (update! node (append-map transitively-close*! elements))
+ (select node))))))
+\f
+(define (order-per-constraints elements constraint-graph)
+ (order-per-constraints/extracted
+ elements
+ constraint-graph
+ identity-procedure))
+
+(define (order-per-constraints/extracted things
+ constraint-graph
+ element-extractor)
+;;; This orders a set of things according to the constraints where the
+;;; things are not elements of the constraint-graph nodes but elements
+;;; can be extracted from the things by element-extractor
+ (let loop ((linearized-constraints
+ (reverse-postorder
+ (constraint-graph/entry-nodes constraint-graph)
+ constraint/afters
+ with-new-constraint-marks
+ constraint-mark!
+ constraint-marked?))
+ (things things)
+ (result '()))
+ (if (and (pair? linearized-constraints)
+ (pair? things))
+ (let ((match (list-search-positive
+ things
+ (lambda (thing)
+ (eqv?
+ (constraint/element
+ (car linearized-constraints))
+ (element-extractor thing))))))
+ (loop (cdr linearized-constraints)
+ (delv match things)
+ (if (and match
+ (not (memv match result)))
+ (cons match result)
+ result)))
+ (reverse! result))))
+
+(define (legal-ordering-per-constraints? element-ordering constraint-graph)
+ (let loop ((ordering element-ordering)
+ (nodes (constraint-graph/entry-nodes constraint-graph)))
+
+ (define (depth-first-search? node)
+ (if (or (null? node) (constraint-marked? node))
+ false
+ (begin
+ (constraint-mark! node)
+ (if (eq? (constraint/element node) (car ordering))
+ (loop (cdr ordering) (constraint/afters node))
+ (multiple-search? (constraint/afters node))))))
+
+ (define (multiple-search? nodes)
+ (if (null? nodes)
+ false
+ (or (depth-first-search? (car nodes))
+ (multiple-search? (cdr nodes)))))
+
+ (if (null? ordering)
+ true
+ (with-new-constraint-marks
+ (lambda ()
+ (multiple-search? nodes))))))
+\f
+(define (reverse-postorder entry-nodes get-children
+ with-new-node-marks node-mark!
+ node-marked?)
+
+ (define result)
+
+ (define (loop node)
+ (node-mark! node)
+ (for-each next (get-children node))
+ (set! result (cons node result)))
+
+ (define (next node)
+ (and node
+ (not (node-marked? node))
+ (loop node)))
+
+ (define (doit node)
+ (set! result '())
+ (loop node)
+ (reverse! result))
+
+ (with-new-node-marks
+ (lambda ()
+ (append-map! doit entry-nodes))))
+
+(define *constraint-generation*)
+
+(define (with-new-constraint-marks thunk)
+ (fluid-let ((*constraint-generation* (make-constraint-generation)))
+ (thunk)))
+
+(define make-constraint-generation
+ (let ((constraint-generation 0))
+ (named-lambda (make-constraint/generation)
+ (let ((value constraint-generation))
+ (set! constraint-generation (1+ constraint-generation))
+ value))))
+
+(define (constraint-marked? constraint)
+ (eq? (constraint/generation constraint) *constraint-generation*))
+
+(define (constraint-mark! constraint)
+ (set-constraint/generation! constraint *constraint-generation*))
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/crsend.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1992 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. |#
+
+;;;; Cross Compiler End
+;;; This program does not need the rest of the compiler, but should
+;;; match the version of the same name in crstop.scm and toplev.scm
+
+(declare (usual-integrations))
+\f
+(define (cross-compile-bin-file-end input-string #!optional output-string)
+ (compiler-pathnames input-string
+ (and (not (default-object? output-string)) output-string)
+ (make-pathname false false false false "moc" 'NEWEST)
+ (lambda (input-pathname output-pathname)
+ output-pathname ;ignore
+ (cross-compile-scode-end (fasload input-pathname)))))
+
+(define (compiler-pathnames input-string output-string default transform)
+ (let ((kernel
+ (lambda (input-string)
+ (let ((input-pathname (merge-pathnames input-string default)))
+ (let ((output-pathname
+ (let ((output-pathname
+ (pathname-new-type input-pathname "com")))
+ (if output-string
+ (merge-pathnames output-string output-pathname)
+ output-pathname))))
+ (newline)
+ (write-string "Compile File: ")
+ (write (enough-namestring input-pathname))
+ (write-string " => ")
+ (write (enough-namestring output-pathname))
+ (fasdump (transform input-pathname output-pathname)
+ output-pathname))))))
+ (if (pair? input-string)
+ (for-each kernel input-string)
+ (kernel input-string))))
+
+(define (cross-compile-scode-end cross-compilation)
+ (let ((compile-by-procedures? (vector-ref cross-compilation 0))
+ (expression (cross-link-end (vector-ref cross-compilation 1)))
+ (others (map cross-link-end (vector-ref cross-compilation 2))))
+ (if (null? others)
+ expression
+ (scode/make-comment
+ (make-dbg-info-vector
+ (let ((all-blocks
+ (list->vector
+ (cons
+ (compiled-code-address->block expression)
+ others))))
+ (if compile-by-procedures?
+ (list 'COMPILED-BY-PROCEDURES
+ all-blocks
+ (list->vector others))
+ all-blocks)))
+ expression))))
+\f
+(define-structure (cc-code-block (type vector)
+ (conc-name cc-code-block/))
+ (debugging-info false read-only false)
+ (bit-string false read-only true)
+ (objects false read-only true)
+ (object-width false read-only true))
+
+(define-structure (cc-vector (type vector)
+ (constructor cc-vector/make)
+ (conc-name cc-vector/))
+ (code-vector false read-only true)
+ (entry-label false read-only true)
+ (entry-points false read-only true)
+ (label-bindings false read-only true)
+ (ic-procedure-headers false read-only true))
+
+(define (cross-link-end object)
+ (let ((code-vector (cc-vector/code-vector object)))
+ (cross-link/process-code-vector
+ (cond ((compiled-code-block? code-vector)
+ code-vector)
+ ((vector? code-vector)
+ (let ((new-code-vector (cross-link/finish-assembly
+ (cc-code-block/bit-string code-vector)
+ (cc-code-block/objects code-vector)
+ (cc-code-block/object-width code-vector))))
+ (set-compiled-code-block/debugging-info!
+ new-code-vector
+ (cc-code-block/debugging-info code-vector))
+ new-code-vector))
+ (else
+ (error "cross-link-end: Unexpected code-vector"
+ code-vector object)))
+ object)))
+
+(define (cross-link/process-code-vector code-vector cc-vector)
+ (let ((bindings
+ (let ((label-bindings (cc-vector/label-bindings cc-vector)))
+ (map (lambda (label)
+ (cons
+ label
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let-syntax ((ucode-primitive
+ (macro (name)
+ (make-primitive-procedure name)))
+ (ucode-type
+ (macro (name)
+ (microcode-type name))))
+ ((ucode-primitive PRIMITIVE-OBJECT-SET-TYPE)
+ (ucode-type COMPILED-ENTRY)
+ (make-non-pointer-object
+ (+ (cdr (or (assq label label-bindings)
+ (error "Missing entry point" label)))
+ (object-datum code-vector)))))))))
+ (cc-vector/entry-points cc-vector)))))
+ (let ((label->expression
+ (lambda (label)
+ (cdr (or (assq label bindings)
+ (error "Label not defined as entry point" label))))))
+ (let ((expression (label->expression (cc-vector/entry-label cc-vector))))
+ (for-each (lambda (entry)
+ (set-lambda-body! (car entry)
+ (label->expression (cdr entry))))
+ (cc-vector/ic-procedure-headers cc-vector))
+ expression))))
+\f
+(define (cross-link/finish-assembly code-block objects scheme-object-width)
+ (let-syntax ((ucode-primitive
+ (macro (name)
+ (make-primitive-procedure name)))
+ (ucode-type
+ (macro (name)
+ (microcode-type name))))
+ (let* ((bl (quotient (bit-string-length code-block)
+ scheme-object-width))
+ (non-pointer-length
+ ((ucode-primitive make-non-pointer-object) bl))
+ (output-block (make-vector (1+ (+ (length objects) bl)))))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (vector-set! output-block 0
+ ((ucode-primitive primitive-object-set-type)
+ (ucode-type manifest-nm-vector)
+ non-pointer-length))))
+ (write-bits! output-block
+ ;; After header just inserted.
+ (* scheme-object-width 2)
+ code-block)
+ (insert-objects! output-block objects (1+ bl))
+ (object-new-type (ucode-type compiled-code-block)
+ output-block))))
+
+(define (insert-objects! v objects where)
+ (cond ((not (null? objects))
+ (vector-set! v where (cadar objects))
+ (insert-objects! v (cdr objects) (1+ where)))
+ ((not (= where (vector-length v)))
+ (error "insert-objects!: object phase error" where))
+ (else
+ unspecific)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: crstop.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1992 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. |#
+
+;;;; Cross Compiler Top Level.
+;;; This code shares and should be merged with "toplev.scm".
+;;; Many of the procedures only differ in the default extensions.
+
+(declare (usual-integrations))
+\f
+(define (cross-compile-bin-file-end input-string #!optional output-string)
+ (compiler-pathnames
+ input-string
+ (and (not (default-object? output-string)) output-string)
+ (make-pathname false false false false "moc" 'NEWEST)
+ (lambda (input-pathname output-pathname)
+ output-pathname ; ignored
+ (cross-compile-scode-end (compiler-fasload input-pathname)))))
+
+(define (cross-compile-scode-end cross-compilation)
+ (in-compiler
+ (lambda ()
+ (cross-link-end cross-compilation)
+ *result*)))
+\f
+(define-structure (cc-code-block (type vector)
+ (conc-name cc-code-block/))
+ (debugging-info false read-only false)
+ (bit-string false read-only true)
+ (objects false read-only true)
+ (object-width false read-only true))
+
+(define-structure (cc-vector (type vector)
+ (constructor cc-vector/make)
+ (conc-name cc-vector/))
+ (code-vector false read-only true)
+ (entry-label false read-only true)
+ (entry-points false read-only true)
+ (label-bindings false read-only true)
+ (ic-procedure-headers false read-only true))
+
+(define (cross-compiler-phase/info-generation-2 pathname)
+ (info-generation-2 pathname set-cc-code-block/debugging-info!))
+
+(define (cross-compiler-phase/link)
+ (compiler-phase
+ "Cross Linkification"
+ (lambda ()
+ (set! *result*
+ (cc-vector/make *code-vector*
+ (last-reference *entry-label*)
+ (last-reference *entry-points*)
+ (last-reference *label-bindings*)
+ (last-reference *ic-procedure-headers*)))
+ unspecific)))
+
+(define (cross-link-end cc-vector)
+ (set! *code-vector* (cc-vector/code-vector cc-vector))
+ (set! *entry-label* (cc-vector/entry-label cc-vector))
+ (set! *entry-points* (cc-vector/entry-points cc-vector))
+ (set! *label-bindings* (cc-vector/label-bindings cc-vector))
+ (set! *ic-procedure-headers* (cc-vector/ic-procedure-headers cc-vector))
+ (phase/link))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: debug.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1994 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 (debug/find-procedure name)
+ (let loop ((procedures *procedures*))
+ (and (not (null? procedures))
+ (if (and (not (procedure-continuation? (car procedures)))
+ (or (eq? name (procedure-name (car procedures)))
+ (eq? name (procedure-label (car procedures)))))
+ (car procedures)
+ (loop (cdr procedures))))))
+
+(define (debug/find-continuation number)
+ (let ((label
+ (intern (string-append "continuation-" (number->string number)))))
+ (let loop ((procedures *procedures*))
+ (and (not (null? procedures))
+ (if (and (procedure-continuation? (car procedures))
+ (eq? label (procedure-label (car procedures))))
+ (car procedures)
+ (loop (cdr procedures)))))))
+
+(define (debug/find-entry-node node)
+ (let ((node (->tagged-vector node)))
+ (if (eq? (expression-entry-node *root-expression*) node)
+ (write-line *root-expression*))
+ (for-each (lambda (procedure)
+ (if (eq? (procedure-entry-node procedure) node)
+ (write-line procedure)))
+ *procedures*)))
+
+(define (debug/where object)
+ (cond ((compiled-code-block? object)
+ (write-line (compiled-code-block/debugging-info object)))
+ ((compiled-code-address? object)
+ (write-line
+ (compiled-code-block/debugging-info
+ (compiled-code-address->block object)))
+ (write-string "\nOffset: ")
+ (write-string
+ (number->string (compiled-code-address->offset object) 16)))
+ (else
+ (error "debug/where -- what?" object))))
+\f
+(define (write-rtl-instructions rtl port)
+ (write-instructions
+ (lambda ()
+ (with-output-to-port port
+ (lambda ()
+ (for-each show-rtl-instruction rtl))))))
+
+(define (dump-rtl filename)
+ (write-instructions
+ (lambda ()
+ (with-output-to-file (pathname-new-type (->pathname filename) "rtl")
+ (lambda ()
+ (for-each show-rtl-instruction
+ (linearize-rtl *rtl-graphs*
+ '()
+ '()
+ false)))))))
+
+(define (show-rtl rtl)
+ (newline)
+ (pp-instructions
+ (lambda ()
+ (for-each show-rtl-instruction rtl))))
+
+(define (show-bblock-rtl bblock)
+ (newline)
+ (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)
+ (*unparser-radix* 16)
+ (*unparse-uninterned-symbols-by-name?* true))
+ (thunk)))
+
+(define (pp-instructions thunk)
+ (fluid-let ((*show-instruction* pretty-print)
+ (*pp-primitives-by-name* false)
+ (*unparser-radix* 16)
+ (*unparse-uninterned-symbols-by-name?* true))
+ (thunk)))
+
+(define *show-instruction*)
+
+(define (show-rtl-instruction rtl)
+ (if (memq (car rtl)
+ '(LABEL CONTINUATION-ENTRY CONTINUATION-HEADER IC-PROCEDURE-HEADER
+ OPEN-PROCEDURE-HEADER PROCEDURE-HEADER CLOSURE-HEADER
+ ;; New stuff
+ RETURN-ADDRESS PROCEDURE TRIVIAL-CLOSURE CLOSURE
+ EXPRESSION
+ ))
+ (newline))
+ (*show-instruction* rtl)
+ (newline))
+\f
+(define procedure-queue)
+(define procedures-located)
+
+(define (show-fg)
+ (fluid-let ((procedure-queue (make-queue))
+ (procedures-located '()))
+ (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!/unsafe 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 (show-fg-node node)
+ (fluid-let ((procedure-queue false))
+ (with-new-node-marks
+ (lambda ()
+ (fg/print-entry-node
+ (let ((node (->tagged-vector node)))
+ (if (procedure? node)
+ (procedure-entry-node node)
+ node)))))))
+
+(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 (and node
+ (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)))
+ ((STACK-OVERWRITE FG-NOOP)
+ (fg/print-node (snode-next node)))))))
+
+(define (fg/print-rvalue rvalue)
+ (if procedure-queue
+ (let ((rvalue (rvalue-known-value rvalue)))
+ (if (and rvalue
+ (rvalue/procedure? rvalue)
+ (not (memq rvalue procedures-located)))
+ (begin
+ (set! procedures-located (cons rvalue procedures-located))
+ (enqueue!/unsafe 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)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/enumer.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988, 1989 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 (symbol->string 'ENUMERAND)
+ (lambda (state enumerand)
+ (unparse-object state (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
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: infnew.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; Debugging Information
+;;; package: (compiler debugging-information)
+
+(declare (usual-integrations))
+\f
+(define (info-generation-phase-1 expression procedures)
+ (fluid-let ((*integrated-variables* '()))
+ (set-expression-debugging-info!
+ expression
+ (make-dbg-expression (block->dbg-block (expression-block expression))
+ (expression-label expression)))
+ (for-each
+ (lambda (procedure)
+ (if (procedure-continuation? procedure)
+ (set-continuation/debugging-info!
+ procedure
+ (let ((block (block->dbg-block (continuation/block procedure))))
+ (let ((continuation
+ (make-dbg-continuation
+ block
+ (continuation/label procedure)
+ (enumeration/index->name continuation-types
+ (continuation/type procedure))
+ (continuation/offset procedure)
+ (continuation/debugging-info procedure))))
+ (set-dbg-block/procedure! block continuation)
+ continuation)))
+ (set-procedure-debugging-info!
+ procedure
+ (let ((block (block->dbg-block (procedure-block procedure))))
+ (let ((procedure
+ (make-dbg-procedure
+ block
+ (procedure-label procedure)
+ (procedure/type procedure)
+ (procedure-name procedure)
+ (map variable->dbg-variable
+ (cdr (procedure-original-required procedure)))
+ (map variable->dbg-variable
+ (procedure-original-optional procedure))
+ (let ((rest (procedure-original-rest procedure)))
+ (and rest (variable->dbg-variable rest)))
+ (map variable->dbg-variable (procedure-names procedure))
+ (procedure-debugging-info procedure))))
+ (set-dbg-block/procedure! block procedure)
+ procedure)))))
+ procedures)
+ (for-each process-integrated-variable! *integrated-variables*)))
+
+(define (generated-dbg-continuation context label)
+ (let ((block
+ (make-dbg-block/continuation (reference-context/block context)
+ false)))
+ (let ((continuation
+ (make-dbg-continuation block
+ label
+ 'GENERATED
+ (reference-context/offset context)
+ false)))
+ (set-dbg-block/procedure! block continuation)
+ continuation)))
+\f
+(define (block->dbg-block block)
+ (and block
+ (or (block-debugging-info block)
+ (let ((dbg-block
+ (enumeration-case block-type (block-type block)
+ ((STACK) (stack-block->dbg-block block))
+ ((CONTINUATION) (continuation-block->dbg-block block))
+ ((CLOSURE) (closure-block->dbg-block block))
+ ((IC) (ic-block->dbg-block block))
+ (else
+ (error "BLOCK->DBG-BLOCK: Illegal block type" block)))))
+ (set-block-debugging-info! block dbg-block)
+ dbg-block))))
+
+(define (stack-block->dbg-block block)
+ (let ((parent (block-parent block))
+ (frame-size (block-frame-size block))
+ (procedure (block-procedure block)))
+ (let ((layout (make-layout frame-size)))
+ (for-each (lambda (variable)
+ (if (not (continuation-variable? variable))
+ (layout-set! layout
+ (variable-normal-offset variable)
+ (variable->dbg-variable variable))))
+ (block-bound-variables block))
+ (if (procedure/closure? procedure)
+ (if (closure-procedure-needs-operator? procedure)
+ (layout-set! layout
+ (procedure-closure-offset procedure)
+ dbg-block-name/normal-closure))
+ (if (stack-block/static-link? block)
+ (layout-set! layout
+ (-1+ frame-size)
+ dbg-block-name/static-link)))
+ (make-dbg-block 'STACK
+ (block->dbg-block parent)
+ (if (procedure/closure? procedure)
+ (block->dbg-block
+ (reference-context/block
+ (procedure-closure-context procedure)))
+ (block->dbg-block
+ (procedure-target-block procedure)))
+ layout
+ (block->dbg-block (block-stack-link block))))))
+
+(define (continuation-block->dbg-block block)
+ (make-dbg-block/continuation
+ (block-parent block)
+ (continuation/always-known-operator? (block-procedure block))))
+
+(define (make-dbg-block/continuation parent always-known?)
+ (let ((dbg-parent (block->dbg-block parent)))
+ (make-dbg-block
+ 'CONTINUATION
+ dbg-parent
+ false
+ (let ((names
+ (append (if always-known?
+ '()
+ (list dbg-block-name/return-address))
+ (if (block/dynamic-link? parent)
+ (list dbg-block-name/dynamic-link)
+ '())
+ (if (ic-block? parent)
+ (list dbg-block-name/ic-parent)
+ '()))))
+ (let ((layout (make-layout (length names))))
+ (do ((names names (cdr names))
+ (index 0 (1+ index)))
+ ((null? names))
+ (layout-set! layout index (car names)))
+ layout))
+ dbg-parent)))
+\f
+(define (closure-block->dbg-block block)
+ (let ((parent (block-parent block))
+ (start-offset
+ (closure-object-first-offset
+ (block-entry-number (block-shared-block block))))
+ (offsets
+ (map (lambda (offset)
+ (cons (car offset)
+ (- (cdr offset)
+ (closure-block-first-offset block))))
+ (block-closure-offsets block))))
+ (let ((layout (make-layout (1+ (apply max (map cdr offsets))))))
+ (for-each (lambda (offset)
+ (layout-set! layout
+ (cdr offset)
+ (variable->dbg-variable (car offset))))
+ offsets)
+ (if (and parent (ic-block/use-lookup? parent))
+ (layout-set! layout 0 dbg-block-name/ic-parent))
+ (make-dbg-block 'CLOSURE (block->dbg-block parent) false
+ (cons start-offset layout)
+ false))))
+
+(define (ic-block->dbg-block block)
+ (make-dbg-block 'IC (block->dbg-block (block-parent block))
+ false false false))
+
+(define-integrable (make-layout length)
+ (make-vector length false))
+
+(define (layout-set! layout index name)
+ (let ((name* (vector-ref layout index)))
+ (if name* (error "LAYOUT-SET!: reusing layout slot" name* name)))
+ (vector-set! layout index name)
+ unspecific)
+
+(define *integrated-variables*)
+
+(define (variable->dbg-variable variable)
+ (or (lvalue-get variable dbg-variable-tag)
+ (let ((integrated? (lvalue-integrated? variable))
+ (indirection (variable-indirection variable)))
+ (let ((dbg-variable
+ (make-dbg-variable
+ (variable-name variable)
+ (cond (integrated? 'INTEGRATED)
+ (indirection 'INDIRECTED)
+ ((variable-in-cell? variable) 'CELL)
+ (else 'NORMAL))
+ (cond (integrated?
+ (lvalue-known-value variable))
+ (indirection
+ ;; This currently does not examine whether it is a
+ ;; simple indirection, or a closure indirection.
+ ;; The value displayed will be incorrect if it
+ ;; is a closure indirection, but...
+ (variable->dbg-variable (car indirection)))
+ (else
+ false)))))
+ (if integrated?
+ (set! *integrated-variables*
+ (cons dbg-variable *integrated-variables*)))
+ (lvalue-put! variable dbg-variable-tag dbg-variable)
+ dbg-variable))))
+
+(define dbg-variable-tag
+ "dbg-variable-tag")
+
+(define (process-integrated-variable! variable)
+ (set-dbg-variable/value!
+ variable
+ (let ((rvalue (dbg-variable/value variable)))
+ (cond ((rvalue/constant? rvalue) (constant-value rvalue))
+ ((rvalue/procedure? rvalue) (procedure-debugging-info rvalue))
+ (else (error "Illegal variable value" rvalue))))))
+\f
+(define (info-generation-phase-2 expression procedures continuations)
+ (let ((debug-info
+ (lambda (selector object)
+ (or (selector object)
+ (error "Missing debugging info" object)))))
+ (values
+ (and expression (debug-info rtl-expr/debugging-info expression))
+ (map (lambda (procedure)
+ (let ((info (debug-info rtl-procedure/debugging-info procedure)))
+ (set-dbg-procedure/external-label!
+ info
+ (rtl-procedure/%external-label procedure))
+ info))
+ procedures)
+ (map (lambda (continuation)
+ (debug-info rtl-continuation/debugging-info continuation))
+ continuations))))
+
+(define (info-generation-phase-3 expression procedures continuations
+ label-bindings external-labels)
+ (let ((label-bindings (labels->dbg-labels label-bindings))
+ (no-datum '(NO-DATUM)))
+ (let ((labels (make-string-hash-table)))
+ (for-each (lambda (label-binding)
+ (for-each (lambda (key)
+ (let ((datum
+ (hash-table/get labels key no-datum)))
+ (if (not (eq? datum no-datum))
+ (error "Redefining label:" key datum)))
+ (hash-table/put! labels
+ key
+ (cdr label-binding)))
+ (car label-binding)))
+ label-bindings)
+ (let ((map-label/fail
+ (lambda (label)
+ (let ((key (system-pair-car label)))
+ (let ((datum (hash-table/get labels key no-datum)))
+ (if (eq? datum no-datum)
+ (error "Missing label:" key))
+ datum))))
+ (map-label/false
+ (lambda (label)
+ (hash-table/get labels (system-pair-car label) #f))))
+ (for-each (lambda (label)
+ (set-dbg-label/external?! (map-label/fail label) true))
+ external-labels)
+ (if expression
+ (set-dbg-expression/label!
+ expression
+ (map-label/fail (dbg-expression/label expression))))
+ (for-each
+ (lambda (procedure)
+ (let* ((internal-label (dbg-procedure/label procedure))
+ (mapped-label (map-label/false internal-label)))
+ (set-dbg-procedure/label! procedure mapped-label)
+ (cond ((dbg-procedure/external-label procedure)
+ => (lambda (label)
+ (set-dbg-procedure/external-label!
+ procedure
+ (map-label/fail label))))
+ ((not mapped-label)
+ (error "Missing label" internal-label)))))
+ procedures)
+ (for-each
+ (lambda (continuation)
+ (set-dbg-continuation/label!
+ continuation
+ (map-label/fail (dbg-continuation/label continuation))))
+ continuations)))
+ (make-dbg-info
+ expression
+ (list->vector (sort procedures dbg-procedure<?))
+ (list->vector (sort continuations dbg-continuation<?))
+ (list->vector (map cdr label-bindings)))))
+\f
+(define (labels->dbg-labels label-bindings)
+ (map (lambda (offset-binding)
+ (let ((names (cdr offset-binding)))
+ (cons names
+ (make-dbg-label-2 (choose-distinguished-label names)
+ (car offset-binding)))))
+ (let ((offsets (make-rb-tree = <)))
+ (for-each (lambda (binding)
+ (let ((offset (cdr binding))
+ (name (system-pair-car (car binding))))
+ (let ((datum (rb-tree/lookup offsets offset #f)))
+ (if datum
+ (set-cdr! datum (cons name (cdr datum)))
+ (rb-tree/insert! offsets offset (list name))))))
+ label-bindings)
+ (rb-tree->alist offsets))))
+
+(define (choose-distinguished-label names)
+ (if (null? (cdr names))
+ (car names)
+ (let ((distinguished
+ (list-transform-negative names
+ (lambda (name)
+ (or (standard-name? name "label")
+ (standard-name? name "end-label"))))))
+ (cond ((null? distinguished)
+ (min-suffix names))
+ ((null? (cdr distinguished))
+ (car distinguished))
+ (else
+ (min-suffix distinguished))))))
+
+(define char-set:label-separators
+ (char-set #\- #\_))
+
+(define (min-suffix names)
+ (let ((suffix-number
+ (lambda (name)
+ (let ((index (string-find-previous-char-in-set
+ name
+ char-set:label-separators)))
+ (if (not index)
+ (error "Illegal label name" name))
+ (let ((suffix (string-tail name (1+ index))))
+ (let ((result (string->number suffix)))
+ (if (not result)
+ (error "Illegal label suffix" suffix))
+ result))))))
+ (car (sort names (lambda (x y)
+ (< (suffix-number x)
+ (suffix-number y)))))))
+
+(define (standard-name? string prefix)
+ (let ((index (string-match-forward-ci string prefix))
+ (end (string-length string)))
+ (and (= index (string-length prefix))
+ (>= (- end index) 2)
+ (let ((next (string-ref string index)))
+ (or (char=? #\- next)
+ (char=? #\_ next)))
+ (let loop ((index (1+ index)))
+ (or (= index end)
+ (and (char-numeric? (string-ref string index))
+ (loop (1+ index))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: macros.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1993 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 Macros
+;;; package: (compiler macros)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (for-each (lambda (entry)
+ (syntax-table-define compiler-syntax-table (car entry)
+ (cadr entry)))
+ `((CFG-NODE-CASE ,transform/cfg-node-case)
+ (DEFINE-ENUMERATION ,transform/define-enumeration)
+ (DEFINE-EXPORT ,transform/define-export)
+ (DEFINE-LVALUE ,transform/define-lvalue)
+ (DEFINE-PNODE ,transform/define-pnode)
+ (DEFINE-ROOT-TYPE ,transform/define-root-type)
+ (DEFINE-RTL-EXPRESSION ,transform/define-rtl-expression)
+ (DEFINE-RTL-PREDICATE ,transform/define-rtl-predicate)
+ (DEFINE-RTL-STATEMENT ,transform/define-rtl-statement)
+ (DEFINE-RULE ,transform/define-rule)
+ (DEFINE-RVALUE ,transform/define-rvalue)
+ (DEFINE-SNODE ,transform/define-snode)
+ (DEFINE-VECTOR-SLOTS ,transform/define-vector-slots)
+ (DESCRIPTOR-LIST ,transform/descriptor-list)
+ (ENUMERATION-CASE ,transform/enumeration-case)
+ (INST-EA ,transform/inst-ea)
+ (LAP ,transform/lap)
+ (LAST-REFERENCE ,transform/last-reference)
+ (MAKE-LVALUE ,transform/make-lvalue)
+ (MAKE-PNODE ,transform/make-pnode)
+ (MAKE-RVALUE ,transform/make-rvalue)
+ (MAKE-SNODE ,transform/make-snode)
+ (PACKAGE ,transform/package)))
+ (syntax-table-define lap-generator-syntax-table 'DEFINE-RULE
+ transform/define-rule))
+
+(define compiler-syntax-table
+ (make-syntax-table syntax-table/system-internal))
+
+(define lap-generator-syntax-table
+ (make-syntax-table compiler-syntax-table))
+
+(define assembler-syntax-table
+ (make-syntax-table compiler-syntax-table))
+
+(define early-syntax-table
+ (make-syntax-table compiler-syntax-table))
+\f
+(define transform/last-reference
+ (macro (name)
+ (let ((x (generate-uninterned-symbol)))
+ `(IF COMPILER:PRESERVE-DATA-STRUCTURES?
+ ,name
+ (LET ((,x ,name))
+ (SET! ,name)
+ ,x)))))
+
+(define (transform/package names . body)
+ (make-syntax-closure
+ (make-sequence
+ `(,@(map (lambda (name)
+ (make-definition name (make-unassigned-reference-trap)))
+ names)
+ ,(make-combination
+ (let ((block (syntax* body)))
+ (if (open-block? block)
+ (open-block-components block
+ (lambda (names* declarations body)
+ (make-lambda lambda-tag:let '() '() false
+ (list-transform-negative names*
+ (lambda (name)
+ (memq name names)))
+ declarations
+ body)))
+ (make-lambda lambda-tag:let '() '() false '()
+ '() block)))
+ '())))))
+
+(define transform/define-export
+ (macro (pattern . body)
+ (parse-define-syntax pattern body
+ (lambda (name body)
+ name
+ `(SET! ,pattern ,@body))
+ (lambda (pattern body)
+ `(SET! ,(car pattern)
+ (NAMED-LAMBDA ,pattern ,@body))))))
+\f
+(define transform/define-vector-slots
+ (macro (class index . slots)
+ (define (loop slots n)
+ (if (null? slots)
+ '()
+ (let ((make-defs
+ (lambda (slot)
+ (let ((ref-name (symbol-append class '- slot)))
+ `(BEGIN
+ (DEFINE-INTEGRABLE (,ref-name ,class)
+ (VECTOR-REF ,class ,n))
+ (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!)
+ ,class ,slot)
+ (VECTOR-SET! ,class ,n ,slot))))))
+ (rest (loop (cdr slots) (1+ n))))
+ (if (pair? (car slots))
+ (map* rest make-defs (car slots))
+ (cons (make-defs (car slots)) rest)))))
+ (if (null? slots)
+ '*THE-NON-PRINTING-OBJECT*
+ `(BEGIN ,@(loop slots index)))))
+
+(define transform/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)))))))
+
+(define transform/descriptor-list
+ (macro (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-syntax
+ ((define-type-definition
+ (macro (name reserved enumeration)
+ (let ((parent (symbol-append name '-TAG)))
+ `(DEFINE ,(symbol-append 'TRANSFORM/DEFINE- name)
+ (macro (type . slots)
+ (let ((tag-name (symbol-append type '-TAG)))
+ `(BEGIN (DEFINE ,tag-name
+ (MAKE-VECTOR-TAG ,',parent ',type ,',enumeration))
+ (DEFINE ,(symbol-append type '?)
+ (TAGGED-VECTOR/PREDICATE ,tag-name))
+ (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
+ (SET-VECTOR-TAG-DESCRIPTION!
+ ,tag-name
+ (LAMBDA (,type)
+ (APPEND!
+ ((VECTOR-TAG-DESCRIPTION ,',parent) ,type)
+ (DESCRIPTOR-LIST ,type ,@slots))))))))))))
+ (define-type-definition snode 5 false)
+ (define-type-definition pnode 6 false)
+ (define-type-definition rvalue 2 rvalue-types)
+ (define-type-definition lvalue 14 false))
+
+;;; Kludge to make these compile efficiently.
+
+(define transform/make-snode
+ (macro (tag . extra)
+ `((ACCESS VECTOR ,system-global-environment)
+ ,tag FALSE '() '() FALSE ,@extra)))
+
+(define transform/make-pnode
+ (macro (tag . extra)
+ `((ACCESS VECTOR ,system-global-environment)
+ ,tag FALSE '() '() FALSE FALSE ,@extra)))
+
+(define transform/make-rvalue
+ (macro (tag . extra)
+ `((ACCESS VECTOR ,system-global-environment)
+ ,tag FALSE ,@extra)))
+
+(define transform/make-lvalue
+ (macro (tag . extra)
+ (let ((result (generate-uninterned-symbol)))
+ `(let ((,result
+ ((ACCESS VECTOR ,system-global-environment)
+ ,tag FALSE '() '() '() '() '() '() 'NOT-CACHED
+ FALSE '() FALSE FALSE '() ,@extra)))
+ (SET! *LVALUES* (CONS ,result *LVALUES*))
+ ,result))))
+\f
+(define transform/define-rtl-expression)
+(define transform/define-rtl-statement)
+(define transform/define-rtl-predicate)
+(let ((rtl-common
+ (lambda (type prefix components wrap-constructor types)
+ `(BEGIN
+ (SET! ,types (CONS ',type ,types))
+ (DEFINE-INTEGRABLE
+ (,(symbol-append prefix 'MAKE- type) ,@components)
+ ,(wrap-constructor `(LIST ',type ,@components)))
+ (DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION)
+ (EQ? (CAR EXPRESSION) ',type))
+ ,@(let loop ((components components)
+ (ref-index 6)
+ (set-index 2))
+ (if (null? components)
+ '()
+ (let* ((slot (car components))
+ (name (symbol-append type '- slot)))
+ `((DEFINE-INTEGRABLE (,(symbol-append 'RTL: name) ,type)
+ (GENERAL-CAR-CDR ,type ,ref-index))
+ ,(let ((slot (if (eq? slot type)
+ (symbol-append slot '-VALUE)
+ slot)))
+ `(DEFINE-INTEGRABLE
+ (,(symbol-append 'RTL:SET- name '!)
+ ,type ,slot)
+ (SET-CAR! (GENERAL-CAR-CDR ,type ,set-index)
+ ,slot)))
+ ,@(loop (cdr components)
+ (* ref-index 2)
+ (* set-index 2))))))))))
+ (set! transform/define-rtl-expression
+ (macro (type prefix . components)
+ (rtl-common type prefix components
+ identity-procedure
+ 'RTL:EXPRESSION-TYPES)))
+
+ (set! transform/define-rtl-statement
+ (macro (type prefix . components)
+ (rtl-common type prefix components
+ (lambda (expression) `(STATEMENT->SRTL ,expression))
+ 'RTL:STATEMENT-TYPES)))
+
+ (set! transform/define-rtl-predicate
+ (macro (type prefix . components)
+ (rtl-common type prefix components
+ (lambda (expression) `(PREDICATE->PRTL ,expression))
+ 'RTL:PREDICATE-TYPES))))
+
+;(define transform/define-rule
+; (macro (type pattern . body)
+; (parse-rule pattern body
+; (lambda (pattern variables qualifier actions)
+; `(,(case type
+; ((STATEMENT) 'ADD-STATEMENT-RULE!)
+; ((PREDICATE) 'ADD-STATEMENT-RULE!)
+; ((REWRITING) 'ADD-REWRITING-RULE!)
+; (else type))
+; ',pattern
+; ,(rule-result-expression variables qualifier
+; `(BEGIN ,@actions)))))))
+
+(define transform/define-rule
+ (macro (type pattern . body)
+ (parse-rule pattern body
+ (lambda (pattern variables qualifier actions)
+ `(,(case type
+ ((STATEMENT) 'ADD-STATEMENT-RULE!)
+ ((PREDICATE) 'ADD-STATEMENT-RULE!)
+ ((REWRITING) 'ADD-REWRITING-RULE!)
+ (else type))
+ ',pattern
+ ,(compile-pattern
+ pattern
+ (rule-result-expression variables qualifier
+ `(BEGIN ,@actions))))))))
+\f
+;;;; Lap instruction sequences.
+
+(define transform/lap
+ (macro some-instructions
+ (list 'QUASIQUOTE some-instructions)))
+
+(define transform/inst-ea
+ (macro (ea)
+ (list 'QUASIQUOTE ea)))
+
+(define transform/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)))))
+
+(define transform/enumeration-case
+ (macro (name expression . clauses)
+ (macros/case-macro expression
+ clauses
+ (lambda (expression element)
+ `(EQ? ,expression ,(symbol-append name '/ element)))
+ (lambda (expression)
+ expression
+ '()))))
+
+(define transform/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
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: make.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1994 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: System Construction
+
+(declare (usual-integrations))
+
+(lambda (architecture-name)
+ (let ((core
+ (lambda ()
+ (load-option 'COMPRESS)
+ (load-option 'HASH-TABLE)
+ (load-option 'RB-TREE)
+ (package/system-loader "compiler" '() 'QUERY))))
+ #|
+ ((access with-directory-rewriting-rule
+ (->environment '(RUNTIME COMPILER-INFO)))
+ (working-directory-pathname)
+ (pathname-as-directory "compiler")
+ core)
+ |#
+ (core)
+ (let ((initialize-package!
+ (lambda (package-name)
+ ((environment-lookup (->environment package-name)
+ 'INITIALIZE-PACKAGE!)))))
+ (initialize-package! '(COMPILER MACROS))
+ (initialize-package! '(COMPILER DECLARATIONS)))
+ (add-system!
+ (make-system (string-append "Liar ("
+ (if (procedure? architecture-name)
+ (architecture-name)
+ architecture-name)
+ ")")
+ 5 0
+ '()))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/mvalue.scm,v 1.1 1994/11/19 02:02:36 adams 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. |#
+
+;;;; Multiple Value Support
+
+(declare (usual-integrations))
+\f
+(define (transmit-values transmitter receiver)
+ (transmitter receiver))
+
+(define (multiple-value-list transmitter)
+ (transmitter list))
+
+(define (return . values)
+ (lambda (receiver)
+ (apply receiver values)))
+
+;;; For efficiency:
+
+(define (return-2 v0 v1)
+ (lambda (receiver)
+ (receiver v0 v1)))
+
+(define (return-3 v0 v1 v2)
+ (lambda (receiver)
+ (receiver v0 v1 v2)))
+
+(define (return-4 v0 v1 v2 v3)
+ (lambda (receiver)
+ (receiver v0 v1 v2 v3)))
+
+(define (return-5 v0 v1 v2 v3 v4)
+ (lambda (receiver)
+ (receiver v0 v1 v2 v3 v4)))
+
+(define (return-6 v0 v1 v2 v3 v4 v5)
+ (lambda (receiver)
+ (receiver v0 v1 v2 v3 v4 v5)))
+
+(define (list-multiple first . rest)
+ (apply call-multiple list first rest))
+
+(define (cons-multiple cars cdrs)
+ (call-multiple cons cars cdrs))
+
+(define (call-multiple procedure . transmitters)
+ (apply return
+ (apply map
+ procedure
+ (map multiple-value-list transmitters))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/object.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988, 1989 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 tagged objects
+
+(declare (usual-integrations))
+\f
+(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 (state object)
+ ((standard-unparser
+ (symbol->string (vector-tag-name (tagged-vector/tag object)))
+ false)
+ state 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)))))
+ (unparser/set-tagged-vector-method! 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)))))
+
+(define (vector-tag-put! tag key value)
+ (let ((entry (assq key (vector-tag-method-alist tag))))
+ (if entry
+ (set-cdr! entry value)
+ (set-vector-tag-method-alist! tag
+ (cons (cons key value)
+ (vector-tag-method-alist tag))))))
+
+(define (vector-tag-get tag key)
+ (let ((value
+ (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 (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" name tag)))
+\f
+(define-integrable make-tagged-vector
+ vector)
+
+(define-integrable (tagged-vector/tag vector)
+ (vector-ref vector 0))
+
+(define-integrable (tagged-vector/index vector)
+ (vector-tag-index (tagged-vector/tag vector)))
+
+(define-integrable (tagged-vector/unparser vector)
+ (vector-tag-unparser (tagged-vector/tag vector)))
+
+(define (tagged-vector? object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (vector-tag? (tagged-vector/tag object))))
+
+(define (->tagged-vector object)
+ (let ((object
+ (if (exact-nonnegative-integer? object)
+ (unhash object)
+ object)))
+ (and (or (tagged-vector? object)
+ (named-structure? object))
+ object)))
+
+(define (tagged-vector/predicate tag)
+ (lambda (object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (eq? tag (tagged-vector/tag object)))))
+
+(define (tagged-vector/subclass-predicate tag)
+ (lambda (object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (let loop ((tag* (tagged-vector/tag object)))
+ (and (vector-tag? tag*)
+ (or (eq? tag tag*)
+ (loop (vector-tag-parent tag*))))))))
+
+(define (tagged-vector/description object)
+ (cond ((named-structure? object)
+ named-structure/description)
+ ((tagged-vector? object)
+ (vector-tag-description (tagged-vector/tag object)))
+ (else
+ (error "Not a tagged vector" object))))
+
+(define (standard-unparser name unparser)
+ (let ((name (string-append (symbol->string 'LIAR) ":" name)))
+ (if unparser
+ (unparser/standard-method name unparser)
+ (unparser/standard-method name))))
+
+(define (tagged-vector/unparse state vector)
+ (fluid-let ((*unparser-radix* 16))
+ ((tagged-vector/unparser vector) state vector)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: parass.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Parallel assignment code
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+(define (parallel-assignment dependencies)
+ ;; Each dependency is a list whose car is the target and
+ ;; whose cdr is the list of locations containing the (old)
+ ;; values needed to compute the new contents of the target.
+ (let ((pairs (map (lambda (dependency)
+ (cons (car dependency)
+ (topo-node/make dependency)))
+ dependencies)))
+ (for-each
+ (lambda (pair)
+ (let ((before (cdr pair)))
+ (for-each
+ (lambda (dependent)
+ (let ((pair (assq dependent pairs)))
+ (and pair
+ (let ((after (cdr pair)))
+ ;; For parallel assignment,
+ ;; self-dependence is irrelevant.
+ (and (not (eq? after before))
+ (set-topo-node/before!
+ after
+ (cons before (topo-node/before after)))
+ (set-topo-node/after!
+ before
+ (cons after (topo-node/after before))))))))
+ (cdr (topo-node/contents before)))))
+ pairs)
+ ;; *** This should use the heuristics for n < 6 ***
+ (let loop ((nodes* (reverse (sort-topologically (map cdr pairs))))
+ (result '())
+ (needed-to-right '()))
+ (if (null? nodes*)
+ result
+ (let* ((node (car nodes*))
+ (dependency (topo-node/contents node))
+ (references (cdr dependency)))
+ (loop (cdr nodes*)
+ (cons (vector (topo-node/early? node)
+ dependency
+ (eq-set-difference references needed-to-right))
+ result)
+ (eq-set-union references needed-to-right)))))))
+\f
+(define-structure (topo-node
+ (conc-name topo-node/)
+ (constructor topo-node/make (contents)))
+ (contents false read-only true)
+ (before '() read-only false)
+ (after '() read-only false)
+ (nbefore false read-only false)
+ (early? false read-only false)
+ (dequeued false read-only false))
+
+(define (sort-topologically nodes)
+ (let* ((nnodes (length nodes))
+ (buckets (make-vector (+ 1 nnodes) '())))
+ (define (update! node)
+ (set-topo-node/dequeued! node true)
+ (for-each (lambda (node*)
+ (if (not (topo-node/dequeued node*))
+ (let* ((nbefore (topo-node/nbefore node*))
+ (nbefore* (- nbefore 1)))
+ (set-topo-node/nbefore! node* nbefore*)
+ (vector-set! buckets
+ nbefore
+ (delq node*
+ (vector-ref buckets nbefore)))
+ (vector-set! buckets
+ nbefore*
+ (cons node*
+ (vector-ref buckets nbefore*))))))
+ (topo-node/after node)))
+
+ (define (phase-2 left accum)
+ ;; There must be a cycle, remove an early block
+ ;; (bkpt "Foo")
+ (let loop ((index 1))
+ (cond ((>= index nnodes)
+ (error "Could not find a node, but some are left" left))
+ ((null? (vector-ref buckets index))
+ (loop (+ index 1)))
+ (else
+ (let* ((bucket (vector-ref buckets index))
+ (node (car bucket)))
+ (set-topo-node/early?! node true)
+ (vector-set! buckets index (cdr bucket))
+ (update! node)
+ (phase-1 (- left 1) (cons node accum)))))))
+
+ (define (phase-1 left accum)
+ (cond ((= left 0)
+ (reverse accum))
+ ((null? (vector-ref buckets 0))
+ (phase-2 left accum))
+ (else
+ (let ((node (car (vector-ref buckets 0))))
+ (vector-set! buckets 0 (cdr (vector-ref buckets 0)))
+ (update! node)
+ (phase-1 (- left 1) (cons node accum))))))
+
+ (for-each (lambda (node)
+ (let ((n (length (topo-node/before node))))
+ (set-topo-node/nbefore! node n)
+ (vector-set! buckets
+ n
+ (cons node (vector-ref buckets n)))))
+ nodes)
+ (phase-1 nnodes '())))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/pmerly.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988 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. |#
+
+;;;; Very Simple Pattern Matcher: Early rule compilation and lookup
+
+(declare (usual-integrations))
+\f
+;;;; Database construction
+
+(define (early-make-rule pattern variables body)
+ (list pattern variables body))
+
+(define (early-parse-rule pattern receiver)
+ (extract-variables pattern receiver))
+
+(define (extract-variables pattern receiver)
+ (cond ((not (pair? pattern))
+ (receiver pattern '()))
+ ((eq? (car pattern) '@)
+ (error "early-parse-rule: ?@ is not an implemented pattern"
+ pattern))
+ ((eq? (car pattern) '?)
+ (receiver (make-pattern-variable (cadr pattern))
+ (list (cons (cadr pattern)
+ (if (null? (cddr pattern))
+ '()
+ (list (cons (car pattern)
+ (cddr pattern))))))))
+ (else
+ (extract-variables (car pattern)
+ (lambda (car-pattern car-variables)
+ (extract-variables (cdr pattern)
+ (lambda (cdr-pattern cdr-variables)
+ (receiver (cons car-pattern cdr-pattern)
+ (merge-variables-lists car-variables
+ cdr-variables)))))))))
+
+(define (merge-variables-lists x y)
+ (cond ((null? x) y)
+ ((null? y) x)
+ (else
+ (let ((entry (assq (caar x) y)))
+ (if entry
+ #|
+ (cons (append! (car x) (cdr entry))
+ (merge-variables-lists (cdr x)
+ (delq! entry y)))
+ |#
+ (error "early-parse-rule: repeated variables not supported"
+ (list (caar x) entry))
+ (cons (car x)
+ (merge-variables-lists (cdr x)
+ y)))))))
+\f
+;;;; Early rule processing and code compilation
+
+(define (early-pattern-lookup rules instance #!optional transformers unparsed
+ receiver limit)
+ (if (default-object? limit) (set! limit *rule-limit*))
+ (if (or (default-object? receiver) (null? receiver))
+ (set! receiver
+ (lambda (result code)
+ (cond ((false? result)
+ (error "early-pattern-lookup: No pattern matches"
+ instance))
+ ((eq? result 'TOO-MANY)
+ (error "early-pattern-lookup: Too many patterns match"
+ limit instance))
+ (else code)))))
+ (parse-instance instance
+ (lambda (expression bindings)
+ (apply (lambda (result program)
+ (receiver result
+ (if (or (eq? result true) (eq? result 'MAYBE))
+ (scode/make-block bindings '() program)
+ false)))
+ (fluid-let ((*rule-limit* limit)
+ (*transformers* (if (default-object? transformers)
+ '()
+ transformers)))
+ (try-rules rules expression
+ (scode/make-error-combination
+ "early-pattern-lookup: No pattern matches"
+ (if (or (default-object? unparsed) (null? unparsed))
+ (scode/make-constant instance)
+ unparsed))
+ list))))))
+
+(define (parse-instance instance receiver)
+ (cond ((not (pair? instance))
+ (receiver instance '()))
+ ((eq? (car instance) 'UNQUOTE)
+ ;; Shadowing may not permit the optimization below.
+ ;; I think the code is being careful, but...
+ (let ((expression (cadr instance)))
+ (if (scode/variable? expression)
+ (receiver (make-evaluation expression) '())
+ (let ((var (make-variable-name 'RESULT)))
+ (receiver (make-evaluation (scode/make-variable var))
+ (list (scode/make-binding var expression)))))))
+ ((eq? (car instance) 'UNQUOTE-SPLICING)
+ (error "parse-instance: unquote-splicing not supported" instance))
+ (else (parse-instance (car instance)
+ (lambda (instance-car car-bindings)
+ (parse-instance (cdr instance)
+ (lambda (instance-cdr cdr-bindings)
+ (receiver (cons instance-car instance-cdr)
+ (append car-bindings cdr-bindings)))))))))
+\f
+;;;; Find matching rules and collect them
+
+(define *rule-limit* '())
+
+(define (try-rules rules expression null-form receiver)
+ (define (loop rules null-form bindings nrules)
+ (cond ((and (not (null? *rule-limit*))
+ (> nrules *rule-limit*))
+ (receiver 'TOO-MANY false))
+ ((not (null? rules))
+ (try-rule (car rules)
+ expression
+ null-form
+ (lambda (result code)
+ (cond ((false? result)
+ (loop (cdr rules) null-form bindings nrules))
+ ((eq? result 'MAYBE)
+ (let ((var (make-variable-name 'TRY-NEXT-RULE-)))
+ (loop (cdr rules)
+ (scode/make-combination (scode/make-variable var)
+ '())
+ (cons (cons var code)
+ bindings)
+ (1+ nrules))))
+ (else (receiver true code))))))
+ ((null? bindings)
+ (receiver false null-form))
+ ((null? (cdr bindings))
+ (receiver 'MAYBE (cdar bindings)))
+ (else
+ (receiver 'MAYBE
+ (scode/make-letrec
+ (map (lambda (pair)
+ (scode/make-binding
+ (car pair)
+ (scode/make-thunk (cdr pair))))
+ bindings)
+ null-form)))))
+ (loop rules null-form '() 0))
+\f
+;;;; Match one rule
+
+(define (try-rule rule expression null-form continuation)
+ (define (try pattern expression receiver)
+ (cond ((evaluation? expression)
+ (receiver '() (list (cons expression pattern))))
+ ((not (pair? pattern))
+ (if (eqv? pattern expression)
+ (receiver '() '())
+ (continuation false null-form)))
+ ((pattern-variable? pattern)
+ (receiver (list (cons (pattern-variable-name pattern) expression))
+ '()))
+ ((not (pair? expression))
+ (continuation false null-form))
+ (else
+ (try (car pattern)
+ (car expression)
+ (lambda (car-bindings car-evaluations)
+ (try (cdr pattern)
+ (cdr expression)
+ (lambda (cdr-bindings cdr-evaluations)
+ (receiver (append car-bindings cdr-bindings)
+ (append car-evaluations
+ cdr-evaluations)))))))))
+ (try (car rule)
+ expression
+ (lambda (bindings evaluations)
+ (match-bind bindings evaluations
+ (cadr rule) (caddr rule)
+ null-form continuation))))
+\f
+;;;; Early rule processing
+
+(define (match-bind bindings evaluations variables body null-form receiver)
+ (process-evaluations evaluations true bindings
+ (lambda (outer-test bindings)
+ (define (find-early-bindings original test bindings)
+ (if (null? original)
+ (generate-match-code outer-test test
+ bindings body
+ null-form receiver)
+ (bind-variable-early (car original)
+ variables
+ (lambda (var-test var-bindings)
+ (if (false? var-test)
+ (receiver false null-form)
+ (find-early-bindings (cdr original)
+ (scode/merge-tests var-test test)
+ (append var-bindings bindings)))))))
+ (if (false? outer-test)
+ (receiver false null-form)
+ (find-early-bindings bindings true '())))))
+
+(define (process-evaluations evaluations test bindings receiver)
+ (if (null? evaluations)
+ (receiver test bindings)
+ (let ((evaluation (car evaluations)))
+ (build-comparison (cdr evaluation)
+ (cdar evaluation)
+ (lambda (new-test new-bindings)
+ (process-evaluations
+ (cdr evaluations)
+ (scode/merge-tests new-test test)
+ (append new-bindings bindings)
+ receiver))))))
+\f
+;;;; Early variable processing
+
+(define (bind-variable-early var+pattern variables receiver)
+ (let ((name (car var+pattern))
+ (expression (cdr var+pattern)))
+ (let ((var (assq name variables)))
+ (cond ((not var)
+ (error "match-bind: nonexistent variable"
+ name variables))
+ ((null? (cdr var))
+ (let ((exp (unevaluate expression)))
+ (receiver true
+ (list
+ (if (scode/constant? exp)
+ (make-early-binding name exp)
+ (make-outer-binding name exp))))))
+ (else
+ (if (not (eq? (caadr var) '?))
+ (error "match-bind: ?@ unimplemented" var))
+ (let ((transformer (cadr (cadr var)))
+ (rename (if (null? (cddr (cadr var)))
+ name
+ (caddr (cadr var)))))
+ (apply-transformer-early transformer name rename
+ expression receiver)))))))
+
+(define (unevaluate exp)
+ (cond ((not (pair? exp))
+ (scode/make-constant exp))
+ ((evaluation? exp)
+ (evaluation-expression exp))
+ (else
+ (let ((the-car (unevaluate (car exp)))
+ (the-cdr (unevaluate (cdr exp))))
+ (if (and (scode/constant? the-car)
+ (scode/constant? the-cdr))
+ (scode/make-constant (cons (scode/constant-value the-car)
+ (scode/constant-value the-cdr)))
+ (scode/make-absolute-combination 'CONS
+ (list the-car the-cdr)))))))
+\f
+;;;; Rule output code
+
+(define (generate-match-code testo testi bindings body null-form receiver)
+ (define (scode/make-test test body)
+ (if (eq? test true)
+ body
+ (scode/make-conditional test body null-form)))
+
+ (define (collect-bindings bindings outer late early outer-names early-names)
+ (if (null? bindings)
+ (receiver
+ (if (and (eq? testo true) (eq? testi true))
+ true
+ 'MAYBE)
+ (scode/make-test
+ testo
+ (scode/make-block
+ outer outer-names
+ (scode/make-block late '()
+ (scode/make-test
+ testi
+ (scode/make-block early early-names
+ body))))))
+ (let ((binding (cdar bindings)))
+ (case (caar bindings)
+ ((OUTER)
+ (collect-bindings
+ (cdr bindings) (cons binding outer)
+ late early
+ (if (or (scode/constant? (scode/binding-value binding))
+ (scode/variable? (scode/binding-value binding)))
+ (cons (scode/binding-variable binding)
+ outer-names)
+ outer-names)
+ early-names))
+ ((LATE)
+ (collect-bindings (cdr bindings) outer
+ (cons binding late) early
+ outer-names early-names))
+ ((EARLY)
+ (collect-bindings (cdr bindings) outer
+ late (cons binding early)
+ outer-names
+ (cons (scode/binding-variable binding)
+ early-names)))
+ (else (error "collect bindings: Unknown type of binding"
+ (caar bindings)))))))
+ (collect-bindings bindings '() '() '() '() '()))
+
+(define ((make-binding-procedure keyword) name exp)
+ (cons keyword (scode/make-binding name exp)))
+
+(define make-early-binding (make-binding-procedure 'EARLY))
+(define make-late-binding (make-binding-procedure 'LATE))
+(define make-outer-binding (make-binding-procedure 'OUTER))
+\f
+;;;; Compiled pattern match
+
+(define (build-comparison pattern expression receiver)
+ (define (merge-path path expression)
+ (if (null? path)
+ expression
+ (scode/make-absolute-combination path (list expression))))
+
+ (define (walk pattern path expression receiver)
+ (cond ((not (pair? pattern))
+ (receiver true
+ (scode/make-absolute-combination 'EQ?
+ (list
+ (scode/make-constant pattern)
+ (merge-path path expression)))
+ '()))
+ ((pattern-variable? pattern)
+ (receiver false true
+ (list `(,(pattern-variable-name pattern)
+ ,@(make-evaluation
+ (merge-path path expression))))))
+ (else
+ (path-step 'CAR path expression
+ (lambda (car-path car-expression)
+ (walk (car pattern) car-path car-expression
+ (lambda (car-pure? car-test car-bindings)
+ (path-step 'CDR path expression
+ (lambda (cdr-path cdr-expression)
+ (walk (cdr pattern) cdr-path cdr-expression
+ (lambda (cdr-pure? cdr-test cdr-bindings)
+ (let ((result (and car-pure? cdr-pure?)))
+ (receiver
+ result
+ (build-pair-test result car-test cdr-test
+ (merge-path path expression))
+ (append car-bindings cdr-bindings))))))))))))))
+
+ (walk pattern '() expression
+ (lambda (pure? test bindings)
+ pure?
+ (receiver test bindings))))
+
+;;; car/cdr decomposition
+
+(define (build-pair-test pure? car-test cdr-test expression)
+ (if (not pure?)
+ (scode/merge-tests (scode/make-absolute-combination 'PAIR?
+ (list expression))
+ (scode/merge-tests car-test cdr-test))
+ (combination-components car-test
+ (lambda (car-operator car-operands)
+ car-operator
+ (combination-components cdr-test
+ (lambda (cdr-operator cdr-operands)
+ cdr-operator
+ (scode/make-absolute-combination 'EQUAL?
+ (list
+ (scode/make-constant
+ (cons (scode/constant-value (car car-operands))
+ (scode/constant-value (car cdr-operands))))
+ expression))))))))
+\f
+;;;; car/cdr path compression
+
+;; The rest of the elements are provided for canonicalization, not used.
+
+(define path-compressions
+ '((car (caar . cdar) car)
+ (cdr (cadr . cddr) cdr)
+
+ (caar (caaar . cdaar) car car)
+ (cadr (caadr . cdadr) car cdr)
+ (cdar (cadar . cddar) cdr car)
+ (cddr (caddr . cdddr) cdr cdr)
+
+ (caaar (caaaar . cdaaar) car caar)
+ (caadr (caaadr . cdaadr) car cadr)
+ (cadar (caadar . cdadar) car cdar)
+ (caddr (caaddr . cdaddr) car cddr)
+ (cdaar (cadaar . cddaar) cdr caar)
+ (cdadr (cadadr . cddadr) cdr cadr)
+ (cddar (caddar . cdddar) cdr cdar)
+ (cdddr (cadddr . cddddr) cdr cddr)
+
+ (caaaar () car caaar)
+ (caaadr () car caadr)
+ (caadar () car cadar)
+ (caaddr () car caddr)
+ (cadaar () car cdaar)
+ (cadadr () car cdadr)
+ (caddar () car cddar)
+ (cadddr () car cdddr)
+ (cdaaar () cdr caaar)
+ (cdaadr () cdr caadr)
+ (cdadar () cdr cadar)
+ (cdaddr () cdr caddr)
+ (cddaar () cdr cdaar)
+ (cddadr () cdr cdadr)
+ (cdddar () cdr cddar)
+ (cddddr () cdr cdddr)))
+
+(define (path-step step path expression receiver)
+ (let ((info (assq path path-compressions)))
+ (cond ((not info)
+ (receiver step expression))
+ ((null? (cadr info))
+ (receiver step
+ (scode/make-absolute-combination path (list expression))))
+ (else
+ (receiver (if (eq? step 'CAR) (caadr info) (cdadr info))
+ expression)))))
+\f
+;;;; Transformers
+
+(define (apply-transformer-early trans-exp name rename exp receiver)
+ (let ((transformer (find-transformer trans-exp)))
+ (if transformer
+ (transformer trans-exp name rename exp receiver)
+ (apply-transformer trans-exp name rename exp receiver))))
+
+(define (apply-transformer transformer name rename exp receiver)
+ (receiver (scode/make-variable name)
+ (transformer-bindings name rename (unevaluate exp)
+ (lambda (exp)
+ (scode/make-combination (scode/make-variable transformer)
+ (list exp))))))
+
+(define (transformer-bindings name rename expression mapper)
+ (if (eq? rename name)
+ (list (make-outer-binding name (mapper expression)))
+ (list (make-outer-binding rename expression)
+ (make-late-binding name (mapper (scode/make-variable rename))))))
+
+(define *transformers*)
+
+(define (find-transformer expression)
+ (and (symbol? expression)
+ (let ((place (assq expression *transformers*)))
+ (and place
+ (cdr place)))))
+\f
+;;;; Database transformers
+
+(define (make-database-transformer database)
+ (lambda (texp name rename exp receiver)
+ (let ((null-form
+ (scode/make-constant (generate-uninterned-symbol 'NOT-FOUND-))))
+ (try-rules database exp null-form
+ (lambda (result code)
+ (define (possible test make-binding)
+ (receiver test
+ (cons (make-binding rename code)
+ (if (eq? name rename)
+ '()
+ (list (make-binding name
+ (unevaluate exp)))))))
+
+ (cond ((false? result)
+ (transformer-fail receiver))
+ ((eq? result 'TOO-MANY)
+ (apply-transformer texp name rename exp receiver))
+ ((eq? result 'MAYBE)
+ (possible (make-simple-transformer-test name null-form)
+ make-outer-binding))
+ ((can-integrate? code)
+ (possible true make-early-binding))
+ (else
+ (possible true make-late-binding))))))))
+
+;; Mega kludge!
+
+(define (can-integrate? code)
+ (if (not (scode/let? code))
+ true
+ (scode/let-components
+ code
+ (lambda (names values decls body)
+ values
+ (and (not (null? names))
+ (let ((place (assq 'INTEGRATE decls)))
+ (and (not (null? place))
+ (let ((integrated (cdr place)))
+ (let loop ((left names))
+ (cond ((null? left)
+ (can-integrate? body))
+ ((memq (car left) integrated)
+ (loop (cdr left)))
+ (else false)))))))))))
+
+(define-integrable (make-simple-transformer-test name tag)
+ (scode/make-absolute-combination 'NOT
+ (list (scode/make-absolute-combination 'EQ?
+ (list
+ (scode/make-variable name)
+ tag)))))
+
+(define-integrable (transformer-fail receiver)
+ (receiver false false))
+
+(define-integrable (transformer-result receiver name rename out in)
+ (receiver true
+ (cons (make-early-binding name (scode/make-constant out))
+ (if (eq? name rename)
+ '()
+ (list (make-early-binding rename
+ (scode/make-constant in)))))))
+\f
+;;;; Symbol transformers
+
+(define (make-symbol-transformer alist)
+ (lambda (texp name rename exp receiver)
+ texp
+ (cond ((null? alist)
+ (receiver false false))
+ ((symbol? exp)
+ (let ((pair (assq exp alist)))
+ (if (not pair)
+ (transformer-fail receiver)
+ (transformer-result receiver name rename (cdr pair) exp))))
+ ((evaluation? exp)
+ (let ((tag (generate-uninterned-symbol 'NOT-FOUND-)))
+ (receiver
+ (make-simple-transformer-test name (scode/make-constant tag))
+ (transformer-bindings name
+ rename
+ (evaluation-expression exp)
+ (lambda (expr)
+ (runtime-symbol-lookup tag
+ expr
+ alist))))))
+ (else (transformer-fail receiver)))))
+
+(define (runtime-symbol-lookup not-found-tag expression alist)
+ (if (>= (length alist) 4)
+ (scode/make-absolute-combination 'CDR
+ (list
+ (scode/make-disjunction
+ (scode/make-absolute-combination 'ASSQ
+ (list expression
+ (scode/make-constant alist)))
+ (scode/make-constant `(() . ,not-found-tag)))))
+ (scode/make-case-expression
+ expression
+ (scode/make-constant not-found-tag)
+ (map (lambda (pair)
+ (list (list (car pair))
+ (scode/make-constant (cdr pair))))
+ alist))))
+\f
+;;;; Accumulation transformers
+
+(define (make-bit-mask-transformer size alist)
+ (lambda (texp name rename exp receiver)
+ (cond ((null? alist)
+ (transformer-fail receiver))
+ ((evaluation? exp)
+ (apply-transformer texp name rename exp receiver))
+ (else
+ (let ((mask (make-bit-string size #!FALSE)))
+ (define (loop symbols)
+ (cond ((null? symbols)
+ (transformer-result receiver name rename mask exp))
+ ((not (pair? symbols))
+ (transformer-fail receiver))
+ ((not (symbol? (car symbols)))
+ (apply-transformer texp name rename exp receiver))
+ (else
+ (let ((place (assq (car symbols) alist)))
+ (if (not place)
+ (transformer-fail receiver)
+ (begin (bit-string-set! mask (cdr place))
+ (loop (cdr symbols))))))))
+ (loop exp))))))
+\f
+;;;; Scode utilities
+
+(define-integrable scode/make-binding cons)
+(define-integrable scode/binding-variable car)
+(define-integrable scode/binding-value cdr)
+
+(define-integrable (scode/make-conjunction t1 t2)
+ (scode/make-conditional t1 t2 (scode/make-constant false)))
+
+(define (scode/merge-tests t1 t2)
+ (cond ((eq? t1 true) t2)
+ ((eq? t2 true) t1)
+ (else (scode/make-conjunction t1 t2))))
+
+(define (scode/make-thunk body)
+ (scode/make-lambda lambda-tag:unnamed '() '() false '() '() body))
+
+(define (scode/let? obj)
+ (and (scode/combination? obj)
+ (scode/combination-components
+ obj
+ (lambda (operator operands)
+ operands
+ (and (scode/lambda? operator)
+ (scode/lambda-components
+ operator
+ (lambda (name . ignore)
+ ignore
+ (eq? name lambda-tag:let))))))))
+
+(define (scode/make-let names values declarations body)
+ (scode/make-combination
+ (scode/make-lambda lambda-tag:let
+ names
+ '()
+ false
+ '()
+ declarations
+ body)
+ values))
+
+(define (scode/let-components lcomb receiver)
+ (scode/combination-components lcomb
+ (lambda (operator values)
+ (scode/lambda-components operator
+ (lambda (tag names opt rest aux decls body)
+ tag opt rest aux
+ (receiver names values decls body))))))
+\f
+;;;; Scode utilities (continued)
+
+(define (scode/make-block bindings integrated body)
+ (if (null? bindings)
+ body
+ (scode/make-let (map scode/binding-variable bindings)
+ (map scode/binding-value bindings)
+ (if (null? integrated)
+ '()
+ `((INTEGRATE ,@integrated)))
+ body)))
+
+(define (scode/make-letrec bindings body)
+ (scode/make-let
+ (map scode/binding-variable bindings)
+ (make-list (length bindings)
+ (make-unassigned-reference-trap))
+ '()
+ (scode/make-sequence
+ (map* body
+ (lambda (binding)
+ (scode/make-assignment (scode/binding-variable binding)
+ (scode/binding-value binding)))
+ bindings))))
+\f
+(define (scode/make-case-expression expression default clauses)
+ (define (kernel case-selector)
+ (define (process clauses)
+ (if (null? clauses)
+ default
+ (let ((selector (caar clauses)))
+ (scode/make-conditional
+ (if (null? (cdr selector))
+ (scode/make-absolute-combination 'EQ?
+ (list case-selector
+ (scode/make-constant (car selector))))
+ (scode/make-absolute-combination 'MEMQ
+ (list case-selector
+ (scode/make-constant selector))))
+ (cadar clauses)
+ (process (cdr clauses))))))
+ (process clauses))
+
+ (if (scode/variable? expression)
+ (kernel expression)
+ (let ((var (make-variable-name 'CASE-SELECTOR-)))
+ (scode/make-let (list var) (list expression) '()
+ (kernel (scode/make-variable var))))))
+
+(define make-variable-name generate-uninterned-symbol)
+
+(define evaluation-tag (list '*EVALUATION*))
+
+(define (evaluation? exp)
+ (and (pair? exp)
+ (eq? (car exp) evaluation-tag)))
+
+(define-integrable (make-evaluation name)
+ (cons evaluation-tag name))
+
+(define-integrable (evaluation-expression exp)
+ (cdr exp))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pmlook.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1992 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. |#
+
+;;;; Very Simple Pattern Matcher: Lookup
+;;; package: (compiler pattern-matcher/lookup)
+
+(declare (usual-integrations))
+\f
+(define pattern-variable-tag
+ (intern "#[(compiler pattern-matcher/lookup)pattern-variable]"))
+
+;;; PATTERN-LOOKUP returns either false or a pair whose car is the
+;;; item matched and whose cdr is the list of variable values. Use
+;;; PATTERN-VARIABLES to get a list of names that is in the same order
+;;; as the list of values.
+
+(define (pattern-lookup entries instance)
+ (define (lookup-loop entries)
+ (and (not (null? entries))
+ (or ((cdar entries) instance)
+ (lookup-loop (cdr entries)))))
+ (lookup-loop entries))
+
+(define-integrable (pattern-lookup/bind binder values)
+ (apply binder values))
+
+(define (pattern-variables pattern)
+ (let ((variables '()))
+ (define (loop pattern)
+ (if (pair? pattern)
+ (if (eq? (car pattern) pattern-variable-tag)
+ (if (not (memq (cdr pattern) variables))
+ (set! variables (cons (cdr pattern) variables)))
+ (begin (loop (car pattern))
+ (loop (cdr pattern))))))
+ (loop pattern)
+ variables))
+
+(define-integrable (make-pattern-variable name)
+ (cons pattern-variable-tag name))
+
+(define (pattern-variable? object)
+ (and (pair? object)
+ (eq? (car object) pattern-variable-tag)))
+
+(define-integrable (pattern-variable-name var)
+ (cdr var))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: pmpars.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988 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. |#
+
+;;;; Very Simple Pattern Matcher: Parser
+
+(declare (usual-integrations))
+\f
+;;; PARSE-RULE and RULE-RESULT-EXPRESSION are used together to parse
+;;; pattern/body definitions, producing Scheme code which can then be
+;;; compiled.
+
+;;; PARSE-RULE, given a PATTERN and a BODY, returns: (1) a pattern for
+;;; use with the matcher; (2) the variables in the pattern, in the
+;;; order that the matcher will produce their corresponding values;
+;;; (3) a list of qualifier expressions; and (4) a list of actions
+;;; which should be executed sequentially when the rule fires.
+
+;;; RULE-RESULT-EXPRESSION is used to generate a lambda expression
+;;; which, when passed the values resulting from the match as its
+;;; arguments, will return either false, indicating that the
+;;; qualifications failed, or the result of the body.
+
+;;; COMPILE-PATTERN takes a pattern produced by PARSE-RULE and a
+;;; binder-experssion produced by RULE-RESULT-EXPRESSION and produced
+;;; a compound expression that matches the rule and calls the result
+;;; expression.
+
+
+(define (compile-pattern pattern binder-expression)
+ `(LAMBDA (INSTANCE)
+ (,(compile-pattern-match pattern)
+ INSTANCE
+ ,binder-expression)))
+
+(define (parse-rule pattern body receiver)
+ (extract-variables
+ pattern
+ (lambda (pattern variables)
+ (extract-qualifier
+ body
+ (lambda (qualifiers actions)
+ (let ((names (pattern-variables pattern)))
+ (receiver pattern
+ (reorder-variables variables names)
+ qualifiers
+ actions)))))))
+
+(define (extract-variables pattern receiver)
+ (if (pair? pattern)
+ (if (memq (car pattern) '(? ?@))
+ (receiver (make-pattern-variable (cadr pattern))
+ (list (cons (cadr pattern)
+ (if (null? (cddr pattern))
+ '()
+ (list (cons (car pattern)
+ (cddr pattern)))))))
+ (extract-variables (car pattern)
+ (lambda (car-pattern car-variables)
+ (extract-variables (cdr pattern)
+ (lambda (cdr-pattern cdr-variables)
+ (receiver (cons car-pattern cdr-pattern)
+ (merge-variables-lists car-variables
+ cdr-variables)))))))
+ (receiver pattern '())))
+
+(define (merge-variables-lists x y)
+ (cond ((null? x) y)
+ ((null? y) x)
+ (else
+ (let ((entry (assq (caar x) y)))
+ (if entry
+ (cons (append! (car x) (cdr entry))
+ (merge-variables-lists (cdr x)
+ (delq! entry y)))
+ (cons (car x)
+ (merge-variables-lists (cdr x)
+ y)))))))
+\f
+(define (compile-pattern-match pattern)
+ (let ((bindings '())
+ (values '())
+ (tests '())
+ (var-tests '()))
+
+ (define (add-test! test)
+ (if (eq? (car test) 'eqv?)
+ (set! var-tests (cons test var-tests))
+ (set! tests (cons test tests))))
+
+ (define (make-eqv? path constant)
+ (cond ((number? constant) `(EQV? ,path ',constant))
+ ((null? constant) `(NULL? ,path))
+ (else `(EQ? ,path ',constant))))
+
+ (define (match pattern path)
+ (if (pair? pattern)
+ (if (pattern-variable? pattern)
+ (let ((entry (memq (cdr pattern) bindings)))
+ (if (not entry)
+ (begin (set! bindings (cons (cdr pattern) bindings))
+ (set! values (cons path values))
+ true)
+ (add-test! `(EQV? ,path
+ ,(list-ref values
+ (- (length bindings)
+ (length entry)))))))
+ (begin
+ (add-test! `(PAIR? ,path))
+ (match (car pattern) `(CAR ,path))
+ (match (cdr pattern) `(CDR ,path))))
+ (add-test! (make-eqv? path pattern))))
+
+ (match pattern 'INSTANCE)
+
+ `(LAMBDA (INSTANCE BINDER)
+ (AND ,@(reverse tests)
+ ,(if (null? var-tests)
+ `(BINDER ,@values)
+ `((LAMBDA ,bindings
+ (AND ,@(reverse var-tests)
+ (BINDER ,@bindings)))
+ ,@values))))))
+
+\f
+(define (extract-qualifier body receiver)
+ (if (and (pair? (car body))
+ (eq? (caar body) 'QUALIFIER))
+ (receiver (cdar body) (cdr body))
+ (receiver '() body)))
+
+(define (reorder-variables variables names)
+ (map (lambda (name) (assq name variables))
+ names))
+
+(define (rule-result-expression variables qualifiers body)
+ (let ((body `(lambda () ,body)))
+ (process-transformations variables
+ (lambda (outer-vars inner-vars xforms xqualifiers)
+ (if (null? inner-vars)
+ `(lambda ,outer-vars
+ ,(if (null? qualifiers)
+ body
+ `(and ,@qualifiers ,body)))
+ `(lambda ,outer-vars
+ (let ,(map list inner-vars xforms)
+ (and ,@xqualifiers
+ ,@qualifiers
+ ,body))))))))
+
+(define (process-transformations variables receiver)
+ (if (null? variables)
+ (receiver '() '() '() '())
+ (process-transformations (cdr variables)
+ (lambda (outer inner xform qual)
+ (let ((name (caar variables))
+ (variable (cdar variables)))
+ (cond ((null? variable)
+ (receiver (cons name outer)
+ inner
+ xform
+ qual))
+ ((not (null? (cdr variable)))
+ (error "process-trasformations: Multiple qualifiers"
+ (car variables)))
+ (else
+ (let ((var (car variable)))
+ (define (handle-xform rename)
+ (if (eq? (car var) '?)
+ (receiver (cons rename outer)
+ (cons name inner)
+ (cons `(,(cadr var) ,rename)
+ xform)
+ (cons name qual))
+ (receiver (cons rename outer)
+ (cons name inner)
+ (cons `(MAP ,(cadr var) ,rename)
+ xform)
+ (cons `(APPLY BOOLEAN/AND ,name) qual))))
+ (handle-xform
+ (if (null? (cddr var))
+ name
+ (caddr var)))))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: scode.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1993 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
+ disjunction-predicate disjunction-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? procedure?
+ make-quotation quotation? quotation-expression
+ make-sequence sequence? sequence-actions sequence-components
+ symbol?
+ make-the-environment the-environment?
+ make-unassigned? unassigned?? unassigned?-name
+ make-variable variable? variable-components variable-name
+ ))
+
+(define-integrable (scode/make-constant value) value)
+(define-integrable (scode/constant-value constant) constant)
+(define scode/constant? (access scode-constant? system-global-environment))
+
+(define-integrable (scode/quotation-components quot recvr)
+ (recvr (scode/quotation-expression quot)))
+
+(define comment-tag:directive
+ (intern "#[(compiler)comment-tag:directive]"))
+
+(define (scode/make-directive code directive original-code)
+ (scode/make-comment
+ (list comment-tag:directive
+ directive
+ (scode/original-expression original-code))
+ code))
+
+(define (scode/original-expression scode)
+ (if (and (scode/comment? scode)
+ (scode/comment-directive? (scode/comment-text scode)))
+ (caddr (scode/comment-text scode))
+ scode))
+
+(define (scode/comment-directive? text . kinds)
+ (and (pair? text)
+ (eq? (car text) comment-tag:directive)
+ (or (null? kinds)
+ (memq (caadr text) kinds))))
+
+(define (scode/make-let names values . body)
+ (scan-defines (scode/make-sequence body)
+ (lambda (auxiliary declarations body)
+ (scode/make-combination
+ (scode/make-lambda lambda-tag:let names '() false
+ auxiliary declarations body)
+ values))))
+\f
+;;;; Absolute variables and combinations
+
+(define-integrable (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-integrable (scode/absolute-reference-name reference)
+ (scode/access-name reference))
+
+(define-integrable (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-integrable (scode/absolute-combination-name combination)
+ (scode/absolute-reference-name (scode/combination-operator combination)))
+
+(define-integrable (scode/absolute-combination-operands combination)
+ (scode/combination-operands combination))
+
+(define (scode/absolute-combination-components combination receiver)
+ (receiver (scode/absolute-combination-name combination)
+ (scode/absolute-combination-operands combination)))
+
+(define (scode/error-combination? object)
+ (or (and (scode/combination? object)
+ (eq? (scode/combination-operator object) error-procedure))
+ (and (scode/absolute-combination? object)
+ (eq? (scode/absolute-combination-name object) 'ERROR-PROCEDURE))))
+
+(define (scode/error-combination-components combination receiver)
+ (scode/combination-components combination
+ (lambda (operator operands)
+ operator
+ (receiver
+ (car operands)
+ (let loop ((irritants (cadr operands)))
+ (cond ((null? irritants) '())
+ ((and (scode/absolute-combination? irritants)
+ (eq? (scode/absolute-combination-name irritants) 'LIST))
+ (scode/absolute-combination-operands irritants))
+ ((and (scode/combination? irritants)
+ (eq? (scode/combination-operator irritants) cons))
+ (let ((operands (scode/combination-operands irritants)))
+ (cons (car operands)
+ (loop (cadr operands)))))
+ (else
+ (cadr operands))))))))
+
+(define (scode/make-error-combination message operand)
+ (scode/make-absolute-combination
+ 'ERROR-PROCEDURE
+ (list message
+ (scode/make-combination cons (list operand '()))
+ (scode/make-the-environment))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/base/sets.scm,v 1.1 1994/11/19 02:02:36 adams 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. |#
+
+;;;; Simple Set Abstraction
+
+(declare (usual-integrations))
+\f
+(define (eq-set-adjoin element set)
+ (if (memq element set)
+ set
+ (cons element set)))
+
+(define (eqv-set-adjoin element set)
+ (if (memv element set)
+ set
+ (cons element set)))
+
+(define (eq-set-delete set item)
+ (define (loop set)
+ (cond ((null? set) '())
+ ((eq? (car set) item) (cdr set))
+ (else (cons (car set) (loop (cdr set))))))
+ (loop set))
+
+(define (eqv-set-delete set item)
+ (define (loop set)
+ (cond ((null? set) '())
+ ((eqv? (car set) item) (cdr set))
+ (else (cons (car set) (loop (cdr set))))))
+ (loop set))
+
+(define (eq-set-substitute set old new)
+ (define (loop set)
+ (cond ((null? set) '())
+ ((eq? (car set) old) (cons new (cdr set)))
+ (else (cons (car set) (loop (cdr set))))))
+ (loop set))
+
+(define (eqv-set-substitute set old new)
+ (define (loop set)
+ (cond ((null? set) '())
+ ((eqv? (car set) old) (cons new (cdr set)))
+ (else (cons (car set) (loop (cdr set))))))
+ (loop set))
+
+(define (set-search set procedure)
+ (define (loop items)
+ (and (not (null? items))
+ (or (procedure (car items))
+ (loop (cdr items)))))
+ (loop set))
+\f
+;;; The dataflow analyzer assumes that
+;;; (eq? (list-tail (eq-set-union x y) n) y) for some n.
+
+(define (eq-set-union x y)
+ (if (null? y)
+ x
+ (let loop ((x x) (y y))
+ (if (null? x)
+ y
+ (loop (cdr x)
+ (if (memq (car x) y)
+ y
+ (cons (car x) y)))))))
+
+(define (eqv-set-union x y)
+ (if (null? y)
+ x
+ (let loop ((x x) (y y))
+ (if (null? x)
+ y
+ (loop (cdr x)
+ (if (memv (car x) y)
+ y
+ (cons (car x) y)))))))
+
+(define (eq-set-difference x y)
+ (define (loop x)
+ (cond ((null? x) '())
+ ((memq (car x) y) (loop (cdr x)))
+ (else (cons (car x) (loop (cdr x))))))
+ (loop x))
+
+(define (eqv-set-difference x y)
+ (define (loop x)
+ (cond ((null? x) '())
+ ((memv (car x) y) (loop (cdr x)))
+ (else (cons (car x) (loop (cdr x))))))
+ (loop x))
+
+(define (eq-set-intersection x y)
+ (define (loop x)
+ (cond ((null? x) '())
+ ((memq (car x) y) (cons (car x) (loop (cdr x))))
+ (else (loop (cdr x)))))
+ (loop x))
+
+(define (eqv-set-intersection x y)
+ (define (loop x)
+ (cond ((null? x) '())
+ ((memv (car x) y) (cons (car x) (loop (cdr x))))
+ (else (loop (cdr x)))))
+ (loop x))
+\f
+(define (eq-set-disjoint? x y)
+ (define (loop x)
+ (cond ((null? x) true)
+ ((memq (car x) y) false)
+ (else (loop (cdr x)))))
+ (loop x))
+
+(define (eqv-set-disjoint? x y)
+ (define (loop x)
+ (cond ((null? x) true)
+ ((memv (car x) y) false)
+ (else (loop (cdr x)))))
+ (loop x))
+
+(define (eq-set-subset? x y)
+ (define (loop x)
+ (cond ((null? x) true)
+ ((memq (car x) y) (loop (cdr x)))
+ (else false)))
+ (loop x))
+
+(define (eqv-set-subset? x y)
+ (define (loop x)
+ (cond ((null? x) true)
+ ((memv (car x) y) (loop (cdr x)))
+ (else false)))
+ (loop x))
+
+(define (eq-set-same-set? x y)
+ (and (eq-set-subset? x y)
+ (eq-set-subset? y x)))
+
+(define (eqv-set-same-set? x y)
+ (and (eqv-set-subset? x y)
+ (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-*-
+
+$Id: switch.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1994 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
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;; Binary switches
+
+(define compiler:enable-integration-declarations? true)
+(define compiler:enable-expansion-declarations? false)
+(define compiler:compile-by-procedures? true)
+(define compiler:noisy? true)
+(define compiler:show-time-reports? false)
+(define compiler:show-procedures? true)
+(define compiler:show-phases? false)
+(define compiler:show-subphases? false)
+(define compiler:preserve-data-structures? false)
+(define compiler:code-compression? true)
+(define compiler:cache-free-variables? true)
+(define compiler:implicit-self-static? true)
+(define compiler:optimize-environments? true)
+(define compiler:analyze-side-effects? true)
+(define compiler:cse? true)
+(define compiler:open-code-primitives? true)
+(define compiler:generate-kmp-files? false)
+(define compiler:generate-rtl-files? false)
+(define compiler:generate-lap-files? false)
+(define compiler:intersperse-rtl-in-lap? true)
+(define compiler:generate-range-checks? false)
+(define compiler:generate-type-checks? false)
+(define compiler:generate-stack-checks? true)
+(define compiler:open-code-flonum-checks? false)
+(define compiler:use-multiclosures? true)
+(define compiler:coalescing-constant-warnings? true)
+(define compiler:cross-compiling? false)
+(define compiler:compress-top-level? false)
+(define compiler:avoid-scode? true)
+
+;; If true, the compiler is allowed to assume that fixnum operations
+;; are only applied to inputs for which the operation is closed, i.e.
+;; generates a valid fixnum. If false, the compiler will ensure that
+;; the result of a fixnum operation is a fixnum, although it may be an
+;; incorrect result for screw cases.
+
+(define compiler:assume-safe-fixnums? true)
+
+;;
+(define compiler:generate-trap-on-null-valued-conditional? false)
+
+
+;; The switch COMPILER:OPEN-CODE-FLOATING-POINT-ARITHMETIC? is in machin.scm.
+
+;;; Nary switches
+
+(define compiler:package-optimization-level
+ ;; Possible values: NONE LOW HYBRID HIGH
+ 'HYBRID)
+
+(define compiler:default-top-level-declarations
+ '((UUO-LINK ALL)))
+
+;;; Hook: bind this to a procedure of one argument and it will receive
+;;; each phase of the compiler as a thunk. It is expected to call the
+;;; thunk after any appropriate processing.
+(define compiler:phase-wrapper
+ false)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: toplev.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1988-1994 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
+;;; package: (compiler top-level)
+
+(declare (usual-integrations))
+\f
+;;;; Usual Entry Point: File Compilation
+
+(define (make-cf compile-bin-file)
+ (lambda (input #!optional output)
+ (let ((kernel
+ (lambda (source-file)
+ (with-values
+ (lambda () (sf/pathname-defaulting source-file false false))
+ (lambda (source-pathname bin-pathname spec-pathname)
+ ;; Maybe this should be done only if scode-file
+ ;; does not exist or is older than source-file.
+ (sf source-pathname bin-pathname spec-pathname)
+ (if (default-object? output)
+ (compile-bin-file bin-pathname)
+ (compile-bin-file bin-pathname output)))))))
+ (if (pair? input)
+ (for-each kernel input)
+ (kernel input)))))
+
+(define (make-cbf compile-bin-file)
+ (lambda (input . rest)
+ (apply compile-bin-file input rest)))
+
+(define (make-compile-bin-file compile-scode/internal)
+ (lambda (input-string #!optional output-string)
+ (let ((input-default
+ (make-pathname false false false false "bin" 'NEWEST))
+ (output-default
+ (if compiler:cross-compiling?
+ (make-pathname false false false false "moc" false)
+ #F))
+ (inf-file-type (if compiler:cross-compiling? "fni" "inf")))
+ (perhaps-issue-compatibility-warning)
+ (compiler-pathnames
+ input-string
+ (if compiler:cross-compiling?
+ (if (not (default-object? output-string))
+ output-string
+ (merge-pathnames output-default
+ (merge-pathnames input-string input-default)))
+ (and (not (default-object? output-string)) output-string))
+ (make-pathname false false false false "bin" 'NEWEST)
+ (lambda (input-pathname output-pathname)
+ (maybe-open-file
+ compiler:generate-kmp-files?
+ (pathname-new-type output-pathname "kmp")
+ (lambda (kmp-output-port)
+ (maybe-open-file
+ compiler:generate-rtl-files?
+ (pathname-new-type output-pathname "rtl")
+ (lambda (rtl-output-port)
+ (maybe-open-file
+ compiler:generate-lap-files?
+ (pathname-new-type output-pathname "lap")
+ (lambda (lap-output-port)
+ (compile-scode/internal
+ (compiler-fasload input-pathname)
+ (pathname-new-type output-pathname inf-file-type)
+ kmp-output-port
+ rtl-output-port
+ lap-output-port)))))))))
+ unspecific)))
+
+(define (maybe-open-file open? pathname receiver)
+ (if open?
+ (call-with-output-file pathname receiver)
+ (receiver false)))
+\f
+(define (make-compile-expression compile-scode)
+ (perhaps-issue-compatibility-warning)
+ (lambda (expression #!optional declarations)
+ (let ((declarations (if (default-object? declarations)
+ '((usual-integrations))
+ declarations)))
+ (compile-scode (syntax&integrate expression declarations)
+ 'KEEP))))
+
+(define (make-compile-procedure compile-scode)
+ (lambda (procedure #!optional keep-debugging-info?)
+ (perhaps-issue-compatibility-warning)
+ (compiler-output->procedure
+ (compile-scode
+ (procedure-lambda procedure)
+ (and (or (default-object? keep-debugging-info?)
+ keep-debugging-info?)
+ 'KEEP))
+ (procedure-environment procedure))))
+\f
+(define (compiler-pathnames input-string output-string default transform)
+ (let* ((core
+ (lambda (input-string)
+ (let ((input-pathname (merge-pathnames input-string default)))
+ (let ((output-pathname
+ (let ((output-pathname
+ (pathname-new-type input-pathname
+ compiled-output-extension)))
+ (if output-string
+ (merge-pathnames output-string output-pathname)
+ output-pathname))))
+ (if compiler:noisy?
+ (begin
+ (newline)
+ (write-string "Compile File: ")
+ (write (enough-namestring input-pathname))
+ (write-string " => ")
+ (write (enough-namestring output-pathname))))
+ (compiler-file-output
+ (transform input-pathname output-pathname)
+ output-pathname)))))
+ (kernel
+ (if compiler:batch-mode?
+ (batch-kernel core)
+ core)))
+ (if (pair? input-string)
+ (for-each kernel input-string)
+ (kernel input-string))))
+
+(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
+;;;; Alternate Entry Points
+
+(define (compile-scode/new scode #!optional keep-debugging-info?)
+ keep-debugging-info? ; ignored
+ (perhaps-issue-compatibility-warning)
+ (compile-scode/%new scode))
+
+(define compatibility-detection-frob (vector #F '()))
+
+(define (perhaps-issue-compatibility-warning)
+ (if (eq? (vector-ref compatibility-detection-frob 0)
+ (vector-ref compatibility-detection-frob 1))
+ (begin
+ (warn "!! You are compiling while in compatibility mode,")
+ (warn "!! where #F is the !! same as '().")
+ (warn "!! The compiled code will be incorrect for the")
+ (warn "!! standard environment."))))
+
+(define (compile-scode/%new scode #!optional keep-debugging-info?)
+ keep-debugging-info? ; ignored
+ (compiler-output->compiled-expression
+ (let* ((kmp-file-name (temporary-file-pathname))
+ (rtl-file-name (temporary-file-pathname))
+ (lap-file-name (temporary-file-pathname))
+ (info-output-pathname false))
+ (warn "KMP Output to temporary file" (->namestring kmp-file-name))
+ (warn "RTL Output to temporary file" (->namestring rtl-file-name))
+ (warn "LAP Output to temporary file" (->namestring lap-file-name))
+ (let ((win? false))
+ (dynamic-wind
+ (lambda () unspecific)
+ (lambda ()
+ (call-with-output-file kmp-file-name
+ (lambda (kmp-output-port)
+ (call-with-output-file rtl-file-name
+ (lambda (rtl-output-port)
+ (call-with-output-file lap-file-name
+ (lambda (lap-output-port)
+ (let ((result
+ (%compile/new scode
+ false
+ info-output-pathname
+ kmp-output-port
+ rtl-output-port
+ lap-output-port)))
+ (set! win? true)
+ result))))))))
+ (lambda ()
+ (if (not win?)
+ (begin
+ (warn "Deleting KMP, RTL and LAP output files")
+ (delete-file kmp-file-name)
+ (delete-file rtl-file-name)
+ (delete-file lap-file-name)))))))))
+
+;; First set: phase/scode->kmp
+;; Last used: phase/optimize-kmp
+(define *kmp-program*)
+
+;; First set: phase/optimize-kmp
+;; Last used: phase/kmp->rtl
+(define *optimized-kmp-program*)
+
+;; First set: phase/kmp->rtl
+;; Last used: phase/rtl-program->rtl-graph
+(define *rtl-program*)
+(define *rtl-entry-label*)
+
+(define *argument-registers* '())
+(define *use-debugging-info?* true)
+\f
+(define (%compile/new program
+ recursive?
+ info-output-pathname
+ kmp-output-port
+ rtl-output-port
+ lap-output-port)
+ (initialize-machine-register-map!)
+ (fluid-let ((*info-output-filename* info-output-pathname)
+ (*rtl-output-port* rtl-output-port)
+ (*lap-output-port* lap-output-port)
+ (*kmp-output-port* kmp-output-port)
+ (compiler:generate-lap-files? true)
+ (*use-debugging-info?* false)
+ (*argument-registers* (rtlgen/argument-registers))
+ (available-machine-registers
+ ;; Order is important!
+ (rtlgen/available-registers available-machine-registers))
+ (*strongly-heed-branch-preferences?* true)
+ (*envconv/compile-by-procedures?*
+ (if compiler:cross-compiling?
+ #F
+ compiler:compile-by-procedures?)))
+
+ ((if recursive?
+ bind-compiler-variables
+ in-compiler)
+ (lambda ()
+ (set! *current-label-number* 0)
+ (within-midend
+ recursive?
+ (lambda ()
+ (if (not recursive?)
+ (begin
+ (set! *input-scode* program)
+ (phase/scode->kmp))
+ (begin
+ (set! *kmp-program* program)))
+ (phase/optimize-kmp recursive?)
+ (phase/kmp->rtl)))
+ (if rtl-output-port
+ (phase/rtl-file-output "Original"
+ false
+ false
+ program
+ rtl-output-port
+ *rtl-program*))
+ (phase/rtl-program->rtl-graph)
+ (if rtl-output-port
+ (phase/rtl-file-output "Unoptimized"
+ false
+ false
+ program
+ rtl-output-port
+ false))
+ (phase/rtl-optimization)
+ (if rtl-output-port
+ (phase/rtl-file-output "Optimized"
+ true
+ true
+ program
+ rtl-output-port
+ false))
+ (phase/lap-generation)
+ (phase/lap-linearization)
+ (if lap-output-port
+ (phase/lap-file-output program lap-output-port))
+ (assemble&link info-output-pathname)))))
+\f
+(define (phase/scode->kmp)
+ (compiler-phase
+ "Scode->KMP"
+ (lambda ()
+ (with-kmp-output-port
+ (lambda ()
+ (write-string "Input")
+ (newline)
+ (pp *input-scode*)))
+ (set! *kmp-program*
+ (scode->kmp (last-reference *input-scode*)))
+ (with-kmp-output-port
+ (lambda ()
+ (newline)
+ (write-char #\Page)
+ (newline)
+ (write-string "Initial KMP program")
+ (newline)
+ (fluid-let (;; (*pp-uninterned-symbols-by-name* false)
+ (*pp-primitives-by-name* false))
+ (pp *kmp-program* (current-output-port) true))))
+ unspecific)))
+
+(define (phase/optimize-kmp recursive?)
+ (compiler-phase
+ "Optimize KMP"
+ (lambda ()
+ (set! *optimized-kmp-program*
+ (optimize-kmp recursive? (last-reference *kmp-program*)))
+ (with-kmp-output-port
+ (lambda ()
+ (newline)
+ (write-char #\Page)
+ (newline)
+ (write-string "Final KMP program ")
+ (write *recursive-compilation-number*)
+ (if *kmp-output-abbreviated?*
+ (begin
+ (write-string " (*kmp-output-abbreviated?* is #T)")
+ (newline)
+ (kmp/ppp *optimized-kmp-program*))
+ (fluid-let (;; (*pp-uninterned-symbols-by-name* false)
+ (*pp-primitives-by-name* false))
+ (newline)
+ (pp *optimized-kmp-program* (current-output-port) true)))))
+ unspecific)))
+
+(define (with-kmp-output-port thunk)
+ (if *kmp-output-port*
+ (begin
+ (with-output-to-port *kmp-output-port* thunk)
+ (output-port/flush-output *kmp-output-port*))))
+
+(define (phase/kmp->rtl)
+ (compiler-phase "KMP->RTL"
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (kmp->rtl (last-reference *optimized-kmp-program*)))
+ (lambda (program entry-label)
+ (set! *rtl-program* program)
+ (set! *rtl-entry-label* entry-label)
+ unspecific)))))
+
+(define (phase/rtl-program->rtl-graph)
+ (compiler-phase
+ "RTL->RTL graph"
+ (lambda ()
+ (set! *ic-procedure-headers* '())
+ (initialize-machine-register-map!)
+ (call-with-values
+ (lambda ()
+ (rtl->rtl-graph (last-reference *rtl-program*)))
+ (lambda (expression procedures continuations rgraphs)
+ (set! label->object
+ (make/label->object expression
+ procedures
+ continuations))
+ (set! *rtl-expression* expression)
+ (set! *rtl-procedures* procedures)
+ (set! *rtl-continuations* continuations)
+ (set! *rtl-graphs* rgraphs)
+ (set! *rtl-root*
+ (or expression
+ (label->object *rtl-entry-label*)))
+ unspecific)))))
+\f
+(define compile-bin-file/new
+ (make-compile-bin-file
+ (lambda (scode info-pathname kmp-port rtl-port lap-port)
+ (%compile/new scode
+ false
+ info-pathname
+ kmp-port
+ rtl-port
+ lap-port))))
+
+(define cbf/new (make-cbf compile-bin-file/new))
+(define cf/new (make-cf compile-bin-file/new))
+(define compile-expression/new (make-compile-expression compile-scode/%new))
+(define compile-procedure/new (make-compile-procedure compile-scode/%new))
+\f
+(define (compile-recursively/new kmp-program procedure-result? procedure-name)
+ ;; Used by the compiler when it wants to compile subexpressions as
+ ;; separate code-blocks.
+ ;; (values result must-be-called?)
+ (let ((my-number *recursive-compilation-count*)
+ (output? (and compiler:show-phases?
+ (not (and procedure-result?
+ compiler:show-procedures?)))))
+
+ (define (compile-it)
+ ;; (values (compiled-obj . compiled-code-block) must-call-it?)
+ (fluid-let ((*recursive-compilation-number* my-number)
+ (*procedure-result?* procedure-result?)
+ (*envconv/procedure-result?*
+ procedure-result?))
+ (let ((result
+ (%compile/new kmp-program
+ true
+ (and *info-output-filename*
+ (if (eq? *info-output-filename*
+ 'KEEP)
+ 'KEEP
+ 'RECURSIVE))
+ *kmp-output-port*
+ *rtl-output-port*
+ *lap-output-port*)))
+ (values result (not (eq? procedure-result?
+ *procedure-result?*))))))
+
+ (define (link-it)
+ ;; (values compiled-obj must-call-it?)
+ (let ((simple-link
+ (lambda ()
+ (with-values compile-it
+ (lambda (compiler-output must-call?)
+ ;; Add compiled code block for later linking
+ (set! *remote-links*
+ (cons (cdr compiler-output)
+ *remote-links*))
+ (values (car compiler-output) must-call?))))))
+ (if procedure-result?
+ (if compiler:show-procedures?
+ (compiler-phase/visible
+ (string-append
+ "Compiling procedure: "
+ (write-to-string procedure-name))
+ simple-link)
+ (simple-link))
+ (fluid-let ((*remote-links* '()))
+ (compile-it)))))
+
+ (set! *recursive-compilation-count* (1+ my-number))
+ (if output?
+ (begin
+ (newline)
+ (newline)
+ (write-string *output-prefix*)
+ (write-string "*** Recursive compilation ")
+ (write my-number)
+ (write-string " ***")))
+ (with-values link-it
+ (lambda (value must-call?)
+ (if output?
+ (begin
+ (newline)
+ (write-string *output-prefix*)
+ (write-string "*** Done with recursive compilation ")
+ (write my-number)
+ (write-string " ***")
+ (newline)))
+ (values value must-call?)))))
+
+;; End of New stuff
+\f
+(define (compiler:batch-compile input #!optional output)
+ (fluid-let ((compiler:batch-mode? true))
+ (bind-condition-handler (list condition-type:error)
+ compiler:batch-error-handler
+ (lambda ()
+ (if (default-object? output)
+ (compile-bin-file input)
+ (compile-bin-file input output))))))
+
+(define (compiler:batch-error-handler condition)
+ (let ((port (nearest-cmdl/port)))
+ (newline port)
+ (write-condition-report condition port))
+ (compiler:abort false))
+
+(define (compiler:abort value)
+ (if (not compiler:abort-handled?)
+ (error "Not set up to abort" value))
+ (newline)
+ (write-string "*** Aborting...")
+ (compiler:abort-continuation value))
+
+(define (batch-kernel real-kernel)
+ (lambda (input-string)
+ (call-with-current-continuation
+ (lambda (abort-compilation)
+ (fluid-let ((compiler:abort-continuation abort-compilation)
+ (compiler:abort-handled? true))
+ (real-kernel input-string))))))
+
+(define compiler:batch-mode? false)
+(define compiler:abort-handled? false)
+(define compiler:abort-continuation)
+\f
+;;;; Global variables
+
+(define *recursive-compilation-count*)
+(define *recursive-compilation-number*)
+(define *procedure-result?*)
+(define *remote-links*)
+(define *process-time*)
+(define *real-time*)
+
+(define *kmp-output-port* false)
+(define *kmp-output-abbreviated?* true)
+
+(define *info-output-filename* false)
+(define *rtl-output-port* false)
+(define *rtl-output-all-phases?* false)
+(define *lap-output-port* false)
+
+;; First set: input to compilation
+;; Last used: phase/canonicalize-scode
+(define *input-scode*)
+
+;; First set: phase/canonicalize-scode
+;; Last used: phase/translate-scode
+(define *scode*)
+
+;; First set: phase/translate-scode
+;; Last used: phase/fg-optimization-cleanup
+(define *root-block*)
+
+;; First set: phase/translate-scode
+;; Last used: phase/rtl-generation
+(define *root-expression*)
+(define *root-procedure*)
+
+;; First set: phase/rtl-generation
+;; Last used: phase/lap-linearization
+(define *rtl-expression*)
+(define *rtl-procedures*)
+(define *rtl-continuations*)
+(define *rtl-graphs*)
+(define label->object)
+(define *rtl-root*)
+
+;; First set: phase/rtl-generation
+;; Last used: phase/link
+(define *ic-procedure-headers*)
+(define *entry-label*)
+
+;; First set: phase/lap-generation
+;; Last used: phase/link
+(define *subprocedure-linking-info*)
+
+;; First set: phase/lap-linearization
+;; Last used: phase/assemble
+(define *lap*)
+
+;; First set: phase/lap-linearization
+;; Last used: phase/info-generation-2
+(define *dbg-expression*)
+(define *dbg-procedures*)
+(define *dbg-continuations*)
+\f
+(define (in-compiler thunk)
+ (let ((run-compiler
+ (lambda ()
+ (let ((value
+ (let ((expression (thunk)))
+ (let ((others
+ (map (lambda (other) (vector-ref other 2))
+ (recursive-compilation-results))))
+ (cond ((not (compiled-code-address? expression))
+ (vector compiler:compile-by-procedures?
+ expression
+ others))
+ ((null? others)
+ expression)
+ (else
+ (scode/make-comment
+ (make-dbg-info-vector
+ (let ((all-blocks
+ (list->vector
+ (cons
+ (compiled-code-address->block
+ expression)
+ others))))
+ (if compiler:compile-by-procedures?
+ (list 'COMPILED-BY-PROCEDURES
+ all-blocks
+ (list->vector others))
+ all-blocks)))
+ expression)))))))
+ (if compiler:show-time-reports?
+ (compiler-time-report "Total compilation time"
+ *process-time*
+ *real-time*))
+ value))))
+ (if compiler:preserve-data-structures?
+ (begin
+ (compiler:reset!)
+ (run-compiler))
+ (fluid-let ((*recursive-compilation-number* 0)
+ (*recursive-compilation-count* 1)
+ (*procedure-result?* false)
+ (*remote-links* '())
+ (*process-time* 0)
+ (*real-time* 0))
+ (bind-assembler&linker-top-level-variables
+ (lambda ()
+ (bind-compiler-variables run-compiler)))))))
+\f
+(define (bind-compiler-variables thunk)
+ ;; Split this fluid-let because compiler was choking on it.
+ (fluid-let ((*ic-procedure-headers*)
+ (*current-label-number*)
+ (*dbg-expression*)
+ (*dbg-procedures*)
+ (*dbg-continuations*)
+ (*lap*)
+ (*expressions*)
+ (*procedures*))
+ (fluid-let ((*input-scode*)
+ (*scode*)
+ (*kmp-program*)
+ (*optimized-kmp-program*)
+ (*rtl-program*)
+ (*rtl-entry-label*)
+ (*root-expression*)
+ (*root-procedure*)
+ (*root-block*)
+ (*rtl-expression*)
+ (*rtl-procedures*)
+ (*rtl-continuations*)
+ (*rtl-graphs*)
+ (label->object)
+ (*rtl-root*)
+ (*machine-register-map*)
+ (*entry-label*)
+ (*subprocedure-linking-info*))
+ (bind-assembler&linker-variables thunk))))
+\f
+(define (compiler:reset!)
+ (set! *recursive-compilation-number* 0)
+ (set! *recursive-compilation-count* 1)
+ (set! *procedure-result?* false)
+ (set! *remote-links* '())
+ (set! *process-time* 0)
+ (set! *real-time* 0)
+
+ (set! *ic-procedure-headers*)
+ (set! *current-label-number*)
+ (set! *dbg-expression*)
+ (set! *dbg-procedures*)
+ (set! *dbg-continuations*)
+ (set! *lap*)
+ (set! *expressions*)
+ (set! *procedures*)
+ (set! *input-scode*)
+ (set! *scode*)
+ (set! *kmp-program*)
+ (set! *optimized-kmp-program*)
+ (set! *rtl-program*)
+ (set! *rtl-entry-label*)
+ (set! *root-expression*)
+ (set! *root-procedure*)
+ (set! *root-block*)
+ (set! *rtl-expression*)
+ (set! *rtl-procedures*)
+ (set! *rtl-continuations*)
+ (set! *rtl-graphs*)
+ (set! label->object)
+ (set! *rtl-root*)
+ (set! *machine-register-map*)
+ (set! *entry-label*)
+ (set! *subprocedure-linking-info*)
+ (assembler&linker-reset!))
+\f
+(define (compiler-phase name thunk)
+ (if compiler:show-phases?
+ (compiler-phase/visible name
+ (lambda ()
+ (compiler-phase/invisible thunk)))
+ (compiler-phase/invisible thunk)))
+
+(define (compiler-superphase name thunk)
+ (if compiler:show-subphases?
+ (thunk)
+ (compiler-phase name thunk)))
+
+(define (compiler-subphase name thunk)
+ (if compiler:show-subphases?
+ (compiler-phase name thunk)
+ (compiler-phase/invisible thunk)))
+
+(define (compiler-phase/visible name thunk)
+ (fluid-let ((*output-prefix* (string-append " " *output-prefix*)))
+ (newline)
+ (write-string *output-prefix*)
+ (write-string name)
+ (write-string "...")
+ (if compiler:show-time-reports?
+ (let ((process-start *process-time*)
+ (real-start *real-time*))
+ (let ((value (thunk)))
+ (compiler-time-report " Time taken"
+ (- *process-time* process-start)
+ (- *real-time* real-start))
+ value))
+ (thunk))))
+
+(define *output-prefix* "")
+(define *phase-level* 0)
+
+(define (compiler-phase/invisible thunk)
+ (fluid-let ((*phase-level* (1+ *phase-level*)))
+ (let ((do-it
+ (if compiler:phase-wrapper
+ (lambda () (compiler:phase-wrapper thunk))
+ thunk)))
+ (if (= 1 *phase-level*)
+ (let ((process-start (process-time-clock))
+ (real-start (real-time-clock)))
+ (let ((value (do-it)))
+ (let ((process-delta (- (process-time-clock) process-start))
+ (real-delta (- (real-time-clock) real-start)))
+ (set! *process-time* (+ process-delta *process-time*))
+ (set! *real-time* (+ real-delta *real-time*)))
+ value))
+ (do-it)))))
+
+(define (compiler-time-report prefix process-time real-time)
+ (newline)
+ (write-string *output-prefix*)
+ (write-string prefix)
+ (write-string ": ")
+ (write (/ (exact->inexact process-time) 1000))
+ (write-string " (process time); ")
+ (write (/ (exact->inexact real-time) 1000))
+ (write-string " (real time)"))
+\f
+(define (phase/canonicalize-scode)
+ (compiler-subphase "Scode Canonicalization"
+ (lambda ()
+ (set! *scode* (canonicalize/top-level (last-reference *input-scode*)))
+ unspecific)))
+\f
+(define (phase/rtl-optimization)
+ (compiler-superphase "RTL Optimization"
+ (lambda ()
+ (phase/rtl-dataflow-analysis)
+ (phase/rtl-rewriting rtl-rewriting:pre-cse)
+ (if (and *rtl-output-all-phases?* *rtl-output-port*)
+ (phase/rtl-file-output "Post Rtl-rewriting:pre-cse"
+ false
+ false
+ false
+ *rtl-output-port*
+ false))
+ (if compiler:cse?
+ (phase/common-subexpression-elimination))
+ (if *rtl-output-port*
+ (phase/rtl-file-output "Post CSE"
+ false
+ false
+ false
+ *rtl-output-port*
+ false))
+ (phase/invertible-expression-elimination)
+ (if (and *rtl-output-all-phases?* *rtl-output-port*)
+ (phase/rtl-file-output "Post Invertible-Expression-Elimination"
+ false
+ false
+ false
+ *rtl-output-port*
+ false))
+ (phase/rtl-rewriting rtl-rewriting:post-cse)
+ (phase/common-suffix-merging)
+ (phase/linearization-analysis)
+ (phase/lifetime-analysis)
+ (if (and *rtl-output-all-phases?* *rtl-output-port*)
+ (phase/rtl-file-output "Post Lifetime-Analysis"
+ false
+ false
+ false
+ *rtl-output-port*
+ false))
+ (if compiler:code-compression?
+ (phase/code-compression))
+ (phase/register-allocation)
+ (phase/rtl-optimization-cleanup))))
+\f
+(define (phase/rtl-dataflow-analysis)
+ (compiler-subphase "RTL Dataflow Analysis"
+ (lambda ()
+ (rtl-dataflow-analysis *rtl-graphs*))))
+
+(define (phase/rtl-rewriting rtl-rewriting)
+ (compiler-subphase "RTL Rewriting"
+ (lambda ()
+ (rtl-rewriting *rtl-graphs*))))
+
+(define (phase/common-subexpression-elimination)
+ (compiler-subphase "Common Subexpression Elimination"
+ (lambda ()
+ (common-subexpression-elimination *rtl-graphs*))))
+
+(define (phase/invertible-expression-elimination)
+ (compiler-subphase "Invertible Expression Elimination"
+ (lambda ()
+ (invertible-expression-elimination *rtl-graphs*))))
+
+(define (phase/common-suffix-merging)
+ (compiler-subphase "Common Suffix Merging"
+ (lambda ()
+ (merge-common-suffixes! *rtl-graphs*))))
+
+(define (phase/lifetime-analysis)
+ (compiler-subphase "Lifetime Analysis"
+ (lambda ()
+ (lifetime-analysis *rtl-graphs*))))
+
+(define (phase/code-compression)
+ (compiler-subphase "Instruction Combination"
+ (lambda ()
+ (code-compression *rtl-graphs*))))
+
+(define (phase/linearization-analysis)
+ (compiler-subphase "Linearization Analysis"
+ (lambda ()
+ (setup-bblock-continuations! *rtl-graphs*))))
+
+(define (phase/register-allocation)
+ (compiler-subphase "Register Allocation"
+ (lambda ()
+ (register-allocation *rtl-graphs*))))
+
+(define (phase/rtl-optimization-cleanup)
+ (if (not compiler:preserve-data-structures?)
+ (for-each (lambda (rgraph)
+ (set-rgraph-bblocks! rgraph false)
+ ;; **** this slot is reused. ****
+ ;;(set-rgraph-register-bblock! rgraph false)
+ (set-rgraph-register-crosses-call?! rgraph false)
+ (set-rgraph-register-n-deaths! rgraph false)
+ (set-rgraph-register-live-length! rgraph false)
+ (set-rgraph-register-n-refs! rgraph false)
+ (set-rgraph-register-known-values! rgraph false)
+ (set-rgraph-register-known-expressions! rgraph false))
+ *rtl-graphs*)))
+
+(define (phase/rtl-file-output class continuations-linked?
+ last-for-this-scode? scode port code)
+ (compiler-phase "RTL File Output"
+ (lambda ()
+ (write-string class port)
+ (write-string " RTL for object " port)
+ (write *recursive-compilation-number* port)
+ (newline port)
+ (if scode
+ (begin (pp scode port #t 4)
+ (newline port)
+ (newline port)))
+ (write-rtl-instructions (or code
+ (linearize-rtl *rtl-root*
+ *rtl-procedures*
+ *rtl-continuations*
+ continuations-linked?))
+ port)
+ (if (or (not (zero? *recursive-compilation-number*))
+ (not last-for-this-scode?))
+ (begin
+ (write-char #\page port)
+ (newline port)))
+ (output-port/flush-output port))))
+\f
+(define (phase/lap-generation)
+ (compiler-phase "LAP Generation"
+ (lambda ()
+ (initialize-back-end!)
+ (if *procedure-result?*
+ (generate-lap *rtl-graphs* '()
+ (lambda (prefix environment-label free-ref-label n-sections)
+ (node-insert-snode! (rtl-procedure/entry-node *rtl-root*)
+ (make-sblock prefix))
+ (set! *entry-label*
+ (rtl-procedure/external-label *rtl-root*))
+ (set! *subprocedure-linking-info*
+ (vector environment-label free-ref-label n-sections))
+ unspecific))
+ (begin
+ (let ((prefix (generate-lap *rtl-graphs* *remote-links* false)))
+ (node-insert-snode! (rtl-expr/entry-node *rtl-root*)
+ (make-sblock prefix)))
+ (set! *entry-label* (rtl-expr/label *rtl-root*))
+ unspecific)))))
+
+(define (phase/lap-linearization)
+ (compiler-phase "LAP Linearization"
+ (lambda ()
+ (set! *lap*
+ (optimize-linear-lap
+ (wrap-lap *entry-label*
+ (linearize-lap *rtl-root*
+ *rtl-procedures*
+ *rtl-continuations*
+ true))))
+ (if *use-debugging-info?*
+ (with-values
+ (lambda ()
+ (info-generation-phase-2 *rtl-expression*
+ *rtl-procedures*
+ *rtl-continuations*))
+ (lambda (expression procedures continuations)
+ (set! *dbg-expression* expression)
+ (set! *dbg-procedures* procedures)
+ (set! *dbg-continuations* continuations)
+ unspecific)))
+ (if (not compiler:preserve-data-structures?)
+ (begin
+ (set! *rtl-expression*)
+ (set! *rtl-procedures*)
+ (set! *rtl-continuations*)
+ (set! *rtl-graphs*)
+ (set! label->object)
+ (set! *rtl-root*)
+ unspecific)))))
+\f
+(define (phase/lap-file-output scode port)
+ (compiler-phase "LAP File Output"
+ (lambda ()
+ (fluid-let ((*unparser-radix* 16)
+ (*unparse-uninterned-symbols-by-name?* true))
+ (with-output-to-port port
+ (lambda ()
+ (define (hack-rtl rtl)
+ (if (pair? rtl)
+ (cond ((eq? (car rtl) 'REGISTER)
+ (string->uninterned-symbol
+ (with-output-to-string
+ (lambda () (display "r") (display (cadr rtl))))))
+ ((eq? (car rtl) 'CONSTANT)
+ rtl)
+ (else
+ (map hack-rtl rtl)))
+ rtl))
+
+ (write-string "LAP for object ")
+ (write *recursive-compilation-number*)
+ (newline)
+ (pp scode (current-output-port) #T 4)
+ (newline)
+ (newline)
+ (newline)
+ (for-each
+ (lambda (instruction)
+ (cond ((and (pair? instruction)
+ (eq? (car instruction) 'LABEL))
+ (write (cadr instruction))
+ (write-char #\:))
+ ((and (pair? instruction)
+ (eq? (car instruction) 'COMMENT))
+ (write-char #\tab)
+ (write-string ";;")
+ (for-each (lambda (frob)
+ (write-string " ")
+ (write (if (and (pair? frob)
+ (eq? (car frob) 'RTL))
+ (hack-rtl (cadr frob))
+ frob)))
+ (cdr instruction)))
+ (else
+ (write-char #\tab)
+ (write instruction)))
+ (newline))
+ *lap*)
+ (if (not (zero? *recursive-compilation-number*))
+ (begin
+ (write-char #\page)
+ (newline)))
+ (output-port/flush-output port)))))))
+
+(define compile-bin-file compile-bin-file/new)
+(define cbf cbf/new)
+(define cf cf/new)
+(define compile-expression compile-expression/new)
+(define compile-procedure compile-procedure/new)
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: utils.scm,v 1.1 1994/11/19 02:02:36 adams Exp $
+
+Copyright (c) 1987-1994 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 Utilities
+;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;;; Miscellaneous
+
+(define (three-way-sort = set set* receiver)
+ (let ((member? (member-procedure =)))
+ (define (loop set set* receiver)
+ (if (null? set)
+ (receiver '() '() set*)
+ (let ((item (member? (car set) set*)))
+ (if item
+ (loop (cdr set) (delq! (car item) set*)
+ (lambda (set-only both set*-only)
+ (receiver set-only
+ (cons (cons (car set) (car item)) both)
+ set*-only)))
+ (loop (cdr set) set*
+ (lambda (set-only both set*-only)
+ (receiver (cons (car set) set-only)
+ both
+ set*-only)))))))
+ (loop set (list-copy set*) receiver)))
+
+(define (discriminate-items items predicate)
+ (let loop ((items items) (passed '()) (failed '()))
+ (cond ((null? items)
+ (values (reverse! passed) (reverse! 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 (default-object? prefix) (set! prefix 'LABEL))
+ (string->uninterned-symbol
+ (canonicalize-label-name
+ (string-append
+ (symbol->string
+ (cond ((eq? prefix lambda-tag:unnamed) 'LAMBDA)
+ ((eq? prefix lambda-tag:let) 'LET)
+ ((eq? prefix lambda-tag:make-environment) 'MAKE-ENVIRONMENT)
+ ((eq? prefix lambda-tag:fluid-let) 'FLUID-LET)
+ (else prefix)))
+ "-"
+ (number->string (generate-label-number))))))
+
+(define *current-label-number*)
+
+(define (generate-label-number)
+ (let ((number *current-label-number*))
+ (set! *current-label-number* (1+ *current-label-number*))
+ number))
+\f
+(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))))))
+
+(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*)))))
+ (values true item)
+ (values 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
+;;;; Type Codes
+
+(let-syntax ((define-type-code
+ (macro (var-name #!optional type-name)
+ (if (default-object? 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 environment)
+ (define-type-code unassigned)
+ (define-type-code stack-environment)
+ (define-type-code compiled-entry))
+
+(define (scode/procedure-type-code *lambda)
+ (cond ((object-type? type-code:lambda *lambda)
+ type-code:procedure)
+ ((object-type? type-code:extended-lambda *lambda)
+ type-code:extended-procedure)
+ (else
+ (error "SCODE/PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda))))
+
+;;; Primitive Procedures
+
+(define (primitive-procedure? object)
+ (or (eq? compiled-error-procedure object)
+ (scode/primitive-procedure? object)))
+
+(define (primitive-arity-correct? primitive argument-count)
+ (if (eq? primitive compiled-error-procedure)
+ (positive? argument-count)
+ (let ((arity (primitive-procedure-arity primitive)))
+ (or (= arity -1)
+ (= arity argument-count)))))
+\f
+;;;; Special Compiler Support
+
+(define compiled-error-procedure
+ "Compiled error procedure")
+
+(define lambda-tag:delay
+ (intern "#[delay-lambda]"))
+
+(define (non-pointer-object? object)
+ ;; Any reason not to use `object/non-pointer?' here? -- cph
+ (or (object-type? (ucode-type false) object)
+ (object-type? (ucode-type true) object)
+ (fix:fixnum? object)
+ (object-type? (ucode-type character) object)
+ (object-type? (ucode-type unassigned) object)
+ (object-type? (ucode-type the-environment) object)
+ (object-type? (ucode-type manifest-nm-vector) object)
+ (object-type? (ucode-type manifest-special-nm-vector) object)))
+
+(define (object-immutable? object)
+ (or (non-pointer-object? object)
+ (number? object)
+ (symbol? object)
+ (scode/primitive-procedure? object)
+ (eq? object compiled-error-procedure)))
+\f
+(define boolean-valued-function-names
+ '(
+ OBJECT-TYPE? EQ? FALSE? NULL? PAIR? VECTOR? SYMBOL? STRING?
+ NUMBER? CHAR? PROMISE? BIT-STRING? CELL?
+ COMPLEX? REAL? RATIONAL? INTEGER? EXACT? INEXACT?
+ ZERO? POSITIVE? NEGATIVE? ODD? EVEN?
+ = < > <= >=
+ INDEX-FIXNUM?
+ FIX:FIXNUM? FIX:ZERO? FIX:NEGATIVE? FIX:POSITIVE? FIX:= FIX:< FIX:>
+ FLO:FLONUM? FLO:ZERO? FLO:NEGATIVE? FLO:POSITIVE? FLO:= FLO:< FLO:>
+ INT:INTEGER? INT:ZERO? INT:NEGATIVE? INT:POSITIVE? INT:= INT:< INT:>
+ NOT BIT-STRING-REF
+ ))
+
+(define function-names
+ (append
+ boolean-valued-function-names
+ '(
+ ;; Numbers
+ MAX MIN + - * / 1+ -1+ CONJUGATE ABS QUOTIENT REMAINDER MODULO
+ INTEGER-DIVIDE GCD LCM NUMERATOR DENOMINATOR FLOOR CEILING TRUNCATE ROUND
+ FLOOR->EXACT CEILING->EXACT TRUNCATE->EXACT ROUND->EXACT
+ RATIONALIZE RATIONALIZE->EXACT SIMPLEST-RATIONAL SIMPLEST-EXACT-RATIONAL
+ EXP LOG SIN COS TAN ASIN ACOS ATAN SQRT EXPT MAKE-RECTANGULAR MAKE-POLAR
+ REAL-PART IMAG-PART MAGNITUDE ANGLE EXACT->INEXACT INEXACT->EXACT
+ FIX:1+ FIX:-1+ FIX:+ FIX:- FIX:*
+ FIX:DIVIDE FIX:GCD FIX:QUOTIENT FIX:REMAINDER
+ FIX:AND FIX:ANDC FIX:NOT FIX:OR FIX:XOR
+
+ INT:+ INT:- INT:* INT:DIVIDE INT:QUOTIENT INT:REMAINDER INT:ABS
+ INT:1+ INT:-1+ INT:NEGATE
+ FLO:+ FLO:- FLO:* FLO:/ FLO:NEGATE FLO:ABS FLO:EXP FLO:LOG FLO:SIN FLO:COS
+ FLO:TAN FLO:ASIN FLO:ACOS FLO:ATAN FLO:ATAN2 FLO:SQRT FLO:EXPT FLO:FLOOR
+ FLO:CEILING FLO:TRUNCATE FLO:ROUND FLO:FLOOR->EXACT FLO:CEILING->EXACT
+ FLO:TRUNCATE->EXACT FLO:ROUND->EXACT
+
+ ;; Random
+ OBJECT-TYPE CHAR-ASCII? ASCII->CHAR CHAR->INTEGER CHAR-BITS CHAR-CODE
+ CHAR-DOWNCASE CHAR-UPCASE INTEGER->CHAR MAKE-CHAR
+ PRIMITIVE-PROCEDURE-ARITY
+
+ ;; References (assumes immediate constants are immutable)
+ CAR CDR LENGTH
+ VECTOR-REF VECTOR-LENGTH
+ STRING-REF STRING-LENGTH STRING-MAXIMUM-LENGTH
+ BIT-STRING-LENGTH
+ )))
+
+;; The following definition is used to avoid computation if possible.
+;; Not to avoid recomputation. To avoid recomputation, function-names
+;; should be used.
+;;
+;; Example: CONS has no side effects, yet it is not a function.
+;; Thus if the result of a CONS is not going to be used, we can avoid the
+;; CONS operation, yet we can't reuse its result even when given the same
+;; arguments again because the two pairs should not be EQ?.
+
+(define side-effect-free-additional-names
+ `(
+ ;; Constructors
+ CONS LIST CONS* MAKE-STRING VECTOR MAKE-VECTOR LIST-COPY VECTOR-COPY
+ LIST->VECTOR VECTOR->LIST MAKE-BIT-STRING MAKE-CELL STRING->SYMBOL
+ ))
+
+(define additional-boolean-valued-function-primitives
+ (list (ucode-primitive zero?)
+ (ucode-primitive positive?)
+ (ucode-primitive negative?)
+ (ucode-primitive &=)
+ (ucode-primitive &<)
+ (ucode-primitive &>)))
+
+(define additional-function-primitives
+ (list (ucode-primitive 1+)
+ (ucode-primitive -1+)
+ (ucode-primitive &+)
+ (ucode-primitive &-)
+ (ucode-primitive &*)
+ (ucode-primitive &/)))
+\f
+;;;; "Foldable" and side-effect-free operators
+
+(define boolean-valued-function-variables)
+(define function-variables)
+(define side-effect-free-variables)
+(define boolean-valued-function-primitives)
+(define function-primitives)
+(define side-effect-free-primitives)
+
+(let ((global-valued
+ (lambda (names)
+ (list-transform-negative names
+ (lambda (name)
+ (lexical-unreferenceable? system-global-environment name)))))
+ (global-value
+ (lambda (name)
+ (lexical-reference system-global-environment name)))
+ (primitives
+ (let ((primitive-procedure?
+ (lexical-reference system-global-environment
+ 'PRIMITIVE-PROCEDURE?)))
+ (lambda (procedures)
+ (list-transform-positive procedures primitive-procedure?)))))
+ (let ((names (global-valued boolean-valued-function-names)))
+ (let ((procedures (map global-value names)))
+ (set! boolean-valued-function-variables (map cons names procedures))
+ (set! boolean-valued-function-primitives
+ (append! (primitives procedures)
+ additional-boolean-valued-function-primitives))))
+ (let ((names (global-valued function-names)))
+ (let ((procedures (map global-value names)))
+ (set! function-variables
+ (map* boolean-valued-function-variables cons names procedures))
+ (set! function-primitives
+ (append! (primitives procedures)
+ (append additional-function-primitives
+ boolean-valued-function-primitives)))))
+ (let ((names (global-valued side-effect-free-additional-names)))
+ (let ((procedures (map global-value names)))
+ (set! side-effect-free-variables
+ (map* function-variables cons names procedures))
+ (set! side-effect-free-primitives
+ (append! (primitives procedures)
+ function-primitives))
+ unspecific)))
+
+(define-integrable (boolean-valued-function-variable? name)
+ (assq name boolean-valued-function-variables))
+
+(define-integrable (constant-foldable-variable? name)
+ (assq name function-variables))
+
+(define-integrable (side-effect-free-variable? name)
+ (assq name side-effect-free-variables))
+
+(define (variable-usual-definition name)
+ (let ((place (assq name side-effect-free-variables)))
+ (and place
+ (cdr place))))
+
+(define-integrable (boolean-valued-function-primitive? operator)
+ (memq operator boolean-valued-function-primitives))
+
+(define-integrable (constant-foldable-primitive? operator)
+ (memq operator function-primitives))
+
+(define-integrable (side-effect-free-primitive? operator)
+ (memq operator side-effect-free-primitives))
+
+(define procedure-object?
+ (lexical-reference system-global-environment 'PROCEDURE?))
+
+;;!(define (careful-object-datum object)
+;;! ;; This works correctly when cross-compiling.
+;;! (if (and (object-type? (ucode-type fixnum) object)
+;;! (negative? object))
+;;! (+ object unsigned-fixnum/upper-limit)
+;;! (object-datum object)))
+
+(define (careful-object-datum object)
+ ;; This works correctly when cross-compiling.
+ (if (and (fix:fixnum? object)
+ (negative? object))
+ (+ object unsigned-fixnum/upper-limit)
+ (object-datum object)))
+\f
+(define (list-split ol predicate)
+ ;; (values yes no)
+ (let loop ((l (reverse ol))
+ (yes '())
+ (no '()))
+ (cond ((null? l)
+ (values yes no))
+ ((predicate (car l))
+ (loop (cdr l) (cons (car l) yes) no))
+ (else
+ (loop (cdr l) yes (cons (car l) no))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/assmd.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+$MC68020-Header: assmd.scm,v 1.36 89/08/28 18:33:33 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 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. |#
+
+;;;; Assembler Machine Dependencies
+
+(declare (usual-integrations))
+\f
+(let-syntax ((ucode-type (macro (name) `',(microcode-type name))))
+
+(define-integrable maximum-padding-length
+ ;; Instruction length is always a multiple of 32 bits
+ ;; Would 0 work here?
+ 32)
+
+(define padding-string
+ ;; Pad with `DIAG SCM' instructions
+ (unsigned-integer->bit-string maximum-padding-length
+ #b00010100010100110100001101001101))
+
+(define-integrable block-offset-width
+ ;; Block offsets are always 16 bit words
+ 16)
+
+(define-integrable maximum-block-offset
+ ;; PC always aligned on longword boundary. Use the extra bit.
+ (- (expt 2 (1+ block-offset-width)) 4))
+
+(define (block-offset->bit-string offset start?)
+ (unsigned-integer->bit-string block-offset-width
+ (+ (quotient offset 2)
+ (if start? 0 1))))
+
+(define (make-nmv-header n)
+ (bit-string-append (unsigned-integer->bit-string scheme-datum-width n)
+ nmv-type-string))
+
+(define nmv-type-string
+ (unsigned-integer->bit-string scheme-type-width
+ (ucode-type manifest-nm-vector)))
+
+(define (object->bit-string object)
+ (bit-string-append
+ (unsigned-integer->bit-string scheme-datum-width
+ (careful-object-datum object))
+ (unsigned-integer->bit-string scheme-type-width (object-type object))))
+
+;;; Machine dependent instruction order
+
+(define (instruction-insert! bits block position receiver)
+ (let* ((l (bit-string-length bits))
+ (new-position (- position l)))
+ (bit-substring-move-right! bits 0 l block new-position)
+ (receiver new-position)))
+
+(define instruction-initial-position bit-string-length)
+(define-integrable instruction-append bit-string-append-reversed)
+
+;;; end let-syntax
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/coerce.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+$MC68020-Header: coerce.scm,v 1.10 88/08/31 05:56:37 GMT cph Exp $
+
+Copyright (c) 1987, 1988, 1989, 1990 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. |#
+
+(declare (usual-integrations))
+\f
+;;;; Strange hppa coercions
+
+(define (coerce-right-signed nbits)
+ (let ((offset (1+ (expt 2 nbits))))
+ (lambda (n)
+ (unsigned-integer->bit-string nbits
+ (if (negative? n)
+ (+ (* n 2) offset)
+ (* n 2))))))
+
+(define (coerce-assemble12:x nbits)
+ (let ((range (expt 2 11)))
+ (lambda (n)
+ (let ((n (machine-word-offset n range))
+ (r (unsigned-integer->bit-string nbits 0)))
+ (bit-substring-move-right! n 0 10 r 1)
+ (bit-substring-move-right! n 10 11 r 0)
+ r))))
+
+(define (coerce-assemble12:y nbits)
+ (let ((range (expt 2 11)))
+ (lambda (n)
+ (let ((r (unsigned-integer->bit-string nbits 0)))
+ (bit-substring-move-right! (machine-word-offset n range) 11 12 r 0)
+ r))))
+
+(define (coerce-assemble17:x nbits)
+ (let ((range (expt 2 16)))
+ (lambda (n)
+ (let ((r (unsigned-integer->bit-string nbits 0)))
+ (bit-substring-move-right! (machine-word-offset n range) 11 16 r 0)
+ r))))
+
+(define (coerce-assemble17:y nbits)
+ (let ((range (expt 2 16)))
+ (lambda (n)
+ (let ((n (machine-word-offset n range))
+ (r (unsigned-integer->bit-string nbits 0)))
+ (bit-substring-move-right! n 0 10 r 1)
+ (bit-substring-move-right! n 10 11 r 0)
+ r))))
+
+(define (coerce-assemble17:z nbits)
+ (let ((range (expt 2 16)))
+ (lambda (n)
+ (let ((r (unsigned-integer->bit-string nbits 0)))
+ (bit-substring-move-right! (machine-word-offset n range) 16 17 r 0)
+ r))))
+
+(define (coerce-assemble21:x nbits)
+ ;; This one does not check for range. Should it?
+ (lambda (n)
+ (let ((n (integer->word n))
+ (r (unsigned-integer->bit-string nbits 0)))
+ (bit-substring-move-right! n 0 2 r 12)
+ (bit-substring-move-right! n 2 7 r 16)
+ (bit-substring-move-right! n 7 9 r 14)
+ (bit-substring-move-right! n 9 20 r 1)
+ (bit-substring-move-right! n 20 21 r 0)
+ r)))
+
+(define (machine-word-offset n range)
+ (let ((value (integer-divide n 4)))
+ (if (not (zero? (integer-divide-remainder value)))
+ (error "machine-word-offset: Invalid offset" n))
+ (let ((result (integer-divide-quotient value)))
+ (if (and (< result range)
+ (>= result (- range)))
+ (integer->word result)
+ (error "machine-word-offset: Doesn't fit" n range)))))
+
+(define (integer->word x)
+ (unsigned-integer->bit-string
+ 32
+ (let ((x (if (negative? x) (+ x #x100000000) x)))
+ (if (not (and (not (negative? x)) (< x #x100000000)))
+ (error "Integer too large to be encoded" x))
+ x)))
+\f
+;;; Coercion top level
+
+(define make-coercion
+ (coercion-maker
+ `((ASSEMBLE12:X . ,coerce-assemble12:x)
+ (ASSEMBLE12:Y . ,coerce-assemble12:y)
+ (ASSEMBLE17:X . ,coerce-assemble17:x)
+ (ASSEMBLE17:Y . ,coerce-assemble17:y)
+ (ASSEMBLE17:Z . ,coerce-assemble17:z)
+ (ASSEMBLE21:X . ,coerce-assemble21:x)
+ (RIGHT-SIGNED . ,coerce-right-signed)
+ (UNSIGNED . ,coerce-unsigned-integer)
+ (SIGNED . ,coerce-signed-integer))))
+
+(define coerce-1-bit-unsigned (make-coercion 'UNSIGNED 1))
+(define coerce-2-bit-unsigned (make-coercion 'UNSIGNED 2))
+(define coerce-3-bit-unsigned (make-coercion 'UNSIGNED 3))
+(define coerce-4-bit-unsigned (make-coercion 'UNSIGNED 4))
+(define coerce-5-bit-unsigned (make-coercion 'UNSIGNED 5))
+(define coerce-6-bit-unsigned (make-coercion 'UNSIGNED 6))
+(define coerce-7-bit-unsigned (make-coercion 'UNSIGNED 7))
+(define coerce-8-bit-unsigned (make-coercion 'UNSIGNED 8))
+(define coerce-9-bit-unsigned (make-coercion 'UNSIGNED 9))
+(define coerce-10-bit-unsigned (make-coercion 'UNSIGNED 10))
+(define coerce-11-bit-unsigned (make-coercion 'UNSIGNED 11))
+(define coerce-12-bit-unsigned (make-coercion 'UNSIGNED 12))
+(define coerce-13-bit-unsigned (make-coercion 'UNSIGNED 13))
+(define coerce-14-bit-unsigned (make-coercion 'UNSIGNED 14))
+(define coerce-15-bit-unsigned (make-coercion 'UNSIGNED 15))
+(define coerce-16-bit-unsigned (make-coercion 'UNSIGNED 16))
+(define coerce-32-bit-unsigned (make-coercion 'UNSIGNED 32))
+
+(define coerce-8-bit-signed (make-coercion 'SIGNED 8))
+(define coerce-16-bit-signed (make-coercion 'SIGNED 16))
+(define coerce-32-bit-signed (make-coercion 'SIGNED 32))
+
+(define coerce-5-bit-right-signed (make-coercion 'RIGHT-SIGNED 5))
+(define coerce-11-bit-right-signed (make-coercion 'RIGHT-SIGNED 11))
+(define coerce-14-bit-right-signed (make-coercion 'RIGHT-SIGNED 14))
+(define coerce-11-bit-assemble12:x (make-coercion 'ASSEMBLE12:X 11))
+(define coerce-1-bit-assemble12:y (make-coercion 'ASSEMBLE12:Y 1))
+(define coerce-5-bit-assemble17:x (make-coercion 'ASSEMBLE17:X 5))
+(define coerce-11-bit-assemble17:y (make-coercion 'ASSEMBLE17:Y 11))
+(define coerce-1-bit-assemble17:z (make-coercion 'ASSEMBLE17:Z 1))
+(define coerce-21-bit-assemble21:x (make-coercion 'ASSEMBLE21:X 21))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compiler.cbf,v 1.1 1994/11/19 02:11:31 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; Script to incrementally compile the compiler (from .bins)
+
+(fluid-let ((compiler:coalescing-constant-warnings? #f))
+ (for-each compile-directory
+ '("back"
+ "base"
+ "machines/spectrum"
+ "rtlbase"
+ ; unused "rtlgen"
+ "rtlopt"
+ "midend"
+ ; unused "fggen"
+ ; unused "fgopt"
+ )))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compiler.pkg,v 1.1 1994/11/19 02:09:58 adams Exp $
+
+Copyright (c) 1988-1994 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 Packaging
+\f
+(global-definitions "../runtime/runtime")
+
+(define-package (compiler)
+ (files "base/switch"
+ "base/object" ;tagged object support
+ "base/enumer" ;enumerations
+ "base/sets" ;set abstraction
+ "base/mvalue" ;multiple-value support
+ "base/scode" ;SCode abstraction
+ "machines/spectrum/machin" ;machine dependent stuff
+ "back/asutl" ;back-end odds and ends
+ "base/utils" ;odds and ends
+
+ "base/cfg1" ;control flow graph
+ "base/cfg2"
+ "base/cfg3"
+
+ "base/ctypes" ;CFG datatypes
+
+ "base/rvalue" ;Right hand values
+ "base/lvalue" ;Left hand values
+ "base/blocks" ;rvalue: blocks
+ "base/proced" ;rvalue: procedures
+ "base/contin" ;rvalue: continuations
+
+ "base/subprb" ;subproblem datatype
+
+ "rtlbase/rgraph" ;program graph abstraction
+ "rtlbase/rtlty1" ;RTL: type definitions
+ "rtlbase/rtlty2" ;RTL: type definitions
+ "rtlbase/rtlexp" ;RTL: expression operations
+ "rtlbase/rtlcon" ;RTL: complex constructors
+ "rtlbase/rtlreg" ;RTL: registers
+ "rtlbase/rtlcfg" ;RTL: CFG types
+ "rtlbase/rtlobj" ;RTL: CFG objects
+ "rtlbase/regset" ;RTL: register sets
+ "rtlbase/valclass" ;RTL: value classes
+
+ "back/insseq" ;LAP instruction sequences
+ ;; New stuff
+ "base/parass" ;parallel assignment
+ ;; End of new stuff
+ )
+ (parent ())
+ (export ()
+ compiler:analyze-side-effects?
+ compiler:assume-safe-fixnums?
+ compiler:cache-free-variables?
+ compiler:coalescing-constant-warnings?
+ compiler:code-compression?
+ compiler:compile-by-procedures?
+ compiler:cse?
+ compiler:default-top-level-declarations
+ compiler:enable-expansion-declarations?
+ compiler:enable-integration-declarations?
+ compiler:generate-kmp-files?
+ compiler:generate-lap-files?
+ compiler:generate-range-checks?
+ compiler:generate-rtl-files?
+ compiler:generate-stack-checks?
+ compiler:generate-type-checks?
+ compiler:implicit-self-static?
+ compiler:intersperse-rtl-in-lap?
+ compiler:noisy?
+ compiler:open-code-flonum-checks?
+ compiler:open-code-primitives?
+ compiler:optimize-environments?
+ compiler:package-optimization-level
+ compiler:preserve-data-structures?
+ compiler:show-phases?
+ compiler:show-procedures?
+ compiler:show-subphases?
+ compiler:show-time-reports?
+ compiler:use-multiclosures?))
+\f
+(define-package (compiler reference-contexts)
+ (files "base/refctx")
+ (parent (compiler))
+ (export (compiler)
+ add-reference-context/adjacent-parents!
+ initialize-reference-contexts!
+ make-reference-context
+ modify-reference-contexts!
+ reference-context/adjacent-parent?
+ reference-context/block
+ reference-context/offset
+ reference-context/procedure
+ reference-context?
+ set-reference-context/offset!))
+
+(define-package (compiler macros)
+ (files "base/macros")
+ (parent ())
+ (export (compiler)
+ assembler-syntax-table
+ compiler-syntax-table
+ early-syntax-table
+ lap-generator-syntax-table)
+ (import (runtime macros)
+ parse-define-syntax)
+ (initialization (initialize-package!)))
+
+(define-package (compiler declarations)
+ (files "machines/spectrum/decls")
+ (parent (compiler))
+ (export (compiler)
+ sc
+ syntax-files!)
+ (import (scode-optimizer top-level)
+ sf/internal)
+ (initialization (initialize-package!)))
+
+(define-package (compiler top-level)
+ (files "base/toplev"
+ "base/crstop"
+ "base/asstop")
+ (parent (compiler))
+ (export ()
+ ;; New stuff
+ cbf/new
+ cf/new
+ compile-bin-file/new
+ compile-expression/new
+ compile-procedure/new
+ compile-scode/new
+ ;; End of new stuff
+ cbf
+ cf
+ compile-bin-file
+ compile-expression
+ compile-procedure
+ compile-scode
+ compiler:dump-bci-file
+ compiler:dump-bci/bcs-files
+ compiler:dump-bif/bsm-files
+ compiler:dump-inf-file
+ compiler:dump-info-file
+ compiler:reset!
+ cross-compile-bin-file
+ cross-compile-bin-file-end)
+ (export (compiler)
+ canonicalize-label-name
+ ;; New stuff
+ *argument-registers*
+ ;; End of new stuff
+ *procedure-result?*
+ )
+ (export (compiler midend)
+ *kmp-output-abbreviated?*
+ with-kmp-output-port
+ compile-recursively/new)
+; (export (compiler fg-generator)
+; compile-recursively)
+ (export (compiler rtl-generator)
+ *ic-procedure-headers*
+ *rtl-continuations*
+ *rtl-expression*
+ *rtl-graphs*
+ *rtl-procedures*)
+ (export (compiler lap-syntaxer)
+ *block-label*
+ *external-labels*
+ label->object)
+ (export (compiler debug)
+ *root-expression*
+ *rtl-procedures*
+ *rtl-graphs*)
+ (import (runtime compiler-info)
+ make-dbg-info-vector
+ split-inf-structure!)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
+\f
+(define-package (compiler debug)
+ (files "base/debug")
+ (parent (compiler))
+ (export ()
+ debug/find-continuation
+ debug/find-entry-node
+ debug/find-procedure
+ debug/where
+ dump-rtl
+ po
+ show-bblock-rtl
+ show-fg
+ show-fg-node
+ show-rtl
+ write-rtl-instructions)
+ (import (runtime pretty-printer)
+ *pp-primitives-by-name*)
+ (import (runtime unparser)
+ *unparse-uninterned-symbols-by-name?*))
+
+(define-package (compiler pattern-matcher/lookup)
+ (files "base/pmlook")
+ (parent (compiler))
+ (export (compiler)
+ make-pattern-variable
+ pattern-lookup
+ pattern-variable-name
+ pattern-variable?
+ pattern-variables))
+
+(define-package (compiler pattern-matcher/parser)
+ (files "base/pmpars")
+ (parent (compiler))
+ (export (compiler)
+ parse-rule
+ compile-pattern
+ rule-result-expression)
+ (export (compiler macros)
+ parse-rule
+ compile-pattern
+ rule-result-expression))
+
+(define-package (compiler pattern-matcher/early)
+ (files "base/pmerly")
+ (parent (compiler))
+ (export (compiler)
+ early-parse-rule
+ early-pattern-lookup
+ early-make-rule
+ make-database-transformer
+ make-symbol-transformer
+ make-bit-mask-transformer))
+\f
+(define-package (compiler debugging-information)
+ (files "base/infnew")
+ (parent (compiler))
+ (export (compiler top-level)
+ info-generation-phase-1
+ info-generation-phase-2
+ info-generation-phase-3)
+ (export (compiler rtl-generator)
+ generated-dbg-continuation)
+ (import (runtime compiler-info)
+ make-dbg-info
+
+ make-dbg-expression
+ dbg-expression/block
+ dbg-expression/label
+ set-dbg-expression/label!
+
+ make-dbg-procedure
+ dbg-procedure/block
+ dbg-procedure/label
+ set-dbg-procedure/label!
+ dbg-procedure/name
+ dbg-procedure/required
+ dbg-procedure/optional
+ dbg-procedure/rest
+ dbg-procedure/auxiliary
+ dbg-procedure/external-label
+ set-dbg-procedure/external-label!
+ dbg-procedure<?
+
+ make-dbg-continuation
+ dbg-continuation/block
+ dbg-continuation/label
+ set-dbg-continuation/label!
+ dbg-continuation<?
+
+ make-dbg-block
+ dbg-block/parent
+ dbg-block/layout
+ dbg-block/stack-link
+ set-dbg-block/procedure!
+
+ make-dbg-variable
+ dbg-variable/value
+ set-dbg-variable/value!
+
+ dbg-block-name/dynamic-link
+ dbg-block-name/ic-parent
+ dbg-block-name/normal-closure
+ dbg-block-name/return-address
+ dbg-block-name/static-link
+
+ make-dbg-label-2
+ dbg-label/offset
+ set-dbg-label/external?!))
+
+(define-package (compiler constraints)
+ (files "base/constr")
+ (parent (compiler))
+ (export (compiler)
+ make-constraint
+ constraint/element
+ constraint/graph-head
+ constraint/afters
+ constraint/closed?
+ constraint-add!
+ add-constraint-element!
+ add-constraint-set!
+ make-constraint-graph
+ constraint-graph/entry-nodes
+ constraint-graph/closed?
+ close-constraint-graph!
+ close-constraint-node!
+ order-per-constraints
+ order-per-constraints/extracted
+ legal-ordering-per-constraints?
+ with-new-constraint-marks
+ constraint-marked?
+ constraint-mark!
+ transitively-close-dag!
+ reverse-postorder))
+\f
+#| Old flow-graph not used in new compiler
+ (define-package (compiler fg-generator)
+ (files "fggen/canon" ;SCode canonicalizer
+ "fggen/fggen" ;SCode->flow-graph converter
+ "fggen/declar" ;Declaration handling
+ )
+ (parent (compiler))
+ (export (compiler top-level)
+ canonicalize/top-level
+ construct-graph)
+ (import (runtime scode-data)
+ &pair-car
+ &pair-cdr
+ &triple-first
+ &triple-second
+ &triple-third))
+
+ (define-package (compiler fg-optimizer)
+ (files "fgopt/outer" ;outer analysis
+ "fgopt/sideff" ;side effect analysis
+ )
+ (parent (compiler))
+ (export (compiler top-level)
+ clear-call-graph!
+ compute-call-graph!
+ outer-analysis
+ side-effect-analysis))
+
+ (define-package (compiler fg-optimizer fold-constants)
+ (files "fgopt/folcon")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) fold-constants))
+
+ (define-package (compiler fg-optimizer operator-analysis)
+ (files "fgopt/operan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) operator-analysis))
+
+ (define-package (compiler fg-optimizer variable-indirection)
+ (files "fgopt/varind")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) initialize-variable-indirections!))
+
+ (define-package (compiler fg-optimizer environment-optimization)
+ (files "fgopt/envopt")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) optimize-environments!))
+
+ (define-package (compiler fg-optimizer closure-analysis)
+ (files "fgopt/closan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) identify-closure-limits!))
+
+ (define-package (compiler fg-optimizer continuation-analysis)
+ (files "fgopt/contan")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level)
+ continuation-analysis
+ setup-block-static-links!))
+
+ (define-package (compiler fg-optimizer compute-node-offsets)
+ (files "fgopt/offset")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) compute-node-offsets))
+ \f
+ (define-package (compiler fg-optimizer connectivity-analysis)
+ (files "fgopt/conect")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) connectivity-analysis))
+
+ (define-package (compiler fg-optimizer delete-integrated-parameters)
+ (files "fgopt/delint")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) delete-integrated-parameters))
+
+ (define-package (compiler fg-optimizer design-environment-frames)
+ (files "fgopt/desenv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) design-environment-frames!))
+
+ (define-package (compiler fg-optimizer setup-block-types)
+ (files "fgopt/blktyp")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level)
+ setup-block-types!
+ setup-closure-contexts!)
+ (export (compiler)
+ indirection-block-procedure))
+
+ (define-package (compiler fg-optimizer simplicity-analysis)
+ (files "fgopt/simple")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) simplicity-analysis)
+ (export (compiler fg-optimizer subproblem-ordering)
+ new-subproblem/compute-simplicity!))
+
+ (define-package (compiler fg-optimizer simulate-application)
+ (files "fgopt/simapp")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) simulate-application))
+
+ (define-package (compiler fg-optimizer subproblem-free-variables)
+ (files "fgopt/subfre")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) compute-subproblem-free-variables)
+ (export (compiler fg-optimizer) map-union)
+ (export (compiler fg-optimizer subproblem-ordering)
+ new-subproblem/compute-free-variables!))
+
+ (define-package (compiler fg-optimizer subproblem-ordering)
+ (files "fgopt/order")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) subproblem-ordering))
+
+ (define-package (compiler fg-optimizer subproblem-ordering reuse-frames)
+ (files "fgopt/reord" "fgopt/reuse")
+ (parent (compiler fg-optimizer subproblem-ordering))
+ (export (compiler top-level) setup-frame-adjustments)
+ (export (compiler fg-optimizer subproblem-ordering)
+ order-subproblems/maybe-overwrite-block))
+
+ (define-package (compiler fg-optimizer subproblem-ordering parameter-analysis)
+ (files "fgopt/param")
+ (parent (compiler fg-optimizer subproblem-ordering))
+ (export (compiler fg-optimizer subproblem-ordering)
+ parameter-analysis))
+
+ (define-package (compiler fg-optimizer return-equivalencing)
+ (files "fgopt/reteqv")
+ (parent (compiler fg-optimizer))
+ (export (compiler top-level) find-equivalent-returns!))
+|#
+\f
+(define-package (compiler rtl-generator)
+ (files
+ "rtlbase/rtline" ;linearizer
+ )
+ (parent (compiler))
+ (export (compiler)
+ make-linearizer)
+ (export (compiler top-level)
+ linearize-rtl
+ setup-bblock-continuations!
+ )
+ (export (compiler debug)
+ linearize-rtl)
+ (import (compiler top-level)
+ label->object))
+\f
+(define-package (compiler rtl-cse)
+ (files "rtlopt/rcse1" ;RTL common subexpression eliminator
+ "rtlopt/rcse2"
+ "rtlopt/rcsemrg" ;CSE control-flow merge
+ "rtlopt/rcseep" ;CSE expression predicates
+ "rtlopt/rcseht" ;CSE hash table
+ "rtlopt/rcserq" ;CSE register/quantity abstractions
+ "rtlopt/rcsesr" ;CSE stack references
+ )
+ (parent (compiler))
+ (export (compiler top-level) common-subexpression-elimination))
+
+(define-package (compiler rtl-optimizer)
+ (files "rtlopt/rdebug")
+ (parent (compiler)))
+
+(define-package (compiler rtl-optimizer invertible-expression-elimination)
+ (files "rtlopt/rinvex")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) invertible-expression-elimination))
+
+(define-package (compiler rtl-optimizer common-suffix-merging)
+ (files "rtlopt/rtlcsm")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) merge-common-suffixes!))
+
+(define-package (compiler rtl-optimizer rtl-dataflow-analysis)
+ (files "rtlopt/rdflow")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) rtl-dataflow-analysis))
+
+(define-package (compiler rtl-optimizer rtl-rewriting)
+ (files "rtlopt/rerite")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level)
+ rtl-rewriting:post-cse
+ rtl-rewriting:pre-cse)
+ (export (compiler lap-syntaxer)
+ add-pre-cse-rewriting-rule!
+ add-rewriting-rule!))
+
+(define-package (compiler rtl-optimizer lifetime-analysis)
+ (files "rtlopt/rlife")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) lifetime-analysis)
+ (export (compiler rtl-optimizer code-compression) mark-set-registers!))
+
+(define-package (compiler rtl-optimizer code-compression)
+ (files "rtlopt/rcompr")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) code-compression))
+
+(define-package (compiler rtl-optimizer register-allocation)
+ (files "rtlopt/ralloc")
+ (parent (compiler rtl-optimizer))
+ (export (compiler top-level) register-allocation))
+\f
+(define-package (compiler lap-syntaxer)
+ (files "back/lapgn1" ;LAP generator
+ "back/lapgn2" ; " "
+ "back/lapgn3" ; " "
+ "back/regmap" ;Hardware register allocator
+ "machines/spectrum/lapgen" ;code generation rules
+ "machines/spectrum/rules1" ; " " "
+ "machines/spectrum/rules2" ; " " "
+ "machines/spectrum/rules3" ; " " "
+ "machines/spectrum/rules4" ; " " "
+ "machines/spectrum/rulfix" ; " " "
+ "machines/spectrum/rulflo" ; " " "
+ "machines/spectrum/rulrew" ;code rewriting rules
+ "back/syntax" ;Generic syntax phase
+ "back/syerly" ;Early binding version
+ "machines/spectrum/coerce" ;Coercions: integer -> bit string
+ "back/asmmac" ;Macros for hairy syntax
+ "machines/spectrum/insmac" ;Macros for hairy syntax
+ "machines/spectrum/inerly" ;Early binding version
+ "machines/spectrum/instr1" ;Spectrum instruction utilities
+ "machines/spectrum/instr2" ;Spectrum instructions
+ "machines/spectrum/instr3" ; " "
+ )
+ (parent (compiler))
+ (export (compiler)
+ available-machine-registers
+ pseudo-register-offset
+ interpreter-memtop-pointer
+ fits-in-5-bits-signed?
+ lap-generator/match-rtl-instruction
+ lap:make-entry-point
+ lap:make-label-statement
+ lap:make-unconditional-branch
+ lap:syntax-instruction)
+ (export (compiler top-level)
+ *block-associations*
+ *interned-assignments*
+ *interned-constants*
+ *interned-global-links*
+ *interned-uuo-links*
+ *interned-static-variables*
+ *interned-variables*
+ *next-constant*
+ generate-lap)
+ (import (scode-optimizer expansion)
+ scode->scode-expander))
+
+(define-package (compiler lap-syntaxer map-merger)
+ (files "back/mermap")
+ (parent (compiler lap-syntaxer))
+ (export (compiler lap-syntaxer)
+ merge-register-maps))
+
+(define-package (compiler lap-syntaxer linearizer)
+ (files "back/linear")
+ (parent (compiler lap-syntaxer))
+ (export (compiler lap-syntaxer)
+ add-end-of-block-code!
+ add-extra-code!
+ bblock-linearize-lap
+ extra-code-block/xtra
+ declare-extra-code-block!
+ find-extra-code-block
+ linearize-lap
+ set-current-branches!
+ set-extra-code-block/xtra!)
+ ;; New stuff
+ (export (compiler)
+ *strongly-heed-branch-preferences?*)
+ ;; End of new stuff
+ (export (compiler top-level)
+ *end-of-block-code*
+ linearize-lap))
+
+(define-package (compiler lap-optimizer)
+ (files "machines/spectrum/lapopt")
+ (parent (compiler))
+ (import (compiler lap-syntaxer)
+ entry->address
+ invert-condition)
+ (export (compiler lap-syntaxer)
+ lap:mark-preferred-branch!)
+ (export (compiler top-level)
+ optimize-linear-lap))
+
+(define-package (compiler assembler)
+ (files "machines/spectrum/assmd" ;Machine dependent
+ "back/symtab" ;Symbol tables
+ "back/bitutl" ;Assembly blocks
+ "back/bittop" ;Assembler top level
+ )
+ (parent (compiler))
+ (export (compiler)
+ instruction-append)
+ (export (compiler top-level)
+ assemble))
+
+(define-package (compiler disassembler)
+ (files "machines/spectrum/dassm1"
+ "machines/spectrum/dassm2"
+ "machines/spectrum/dassm3")
+ (parent (compiler))
+ (export ()
+ compiler:write-lap-file
+ compiler:disassemble
+ compiler:disassemble-memory)
+ (import (compiler lap-syntaxer)
+ code:-alist
+ hook:-alist)
+ (import (runtime compiler-info)
+ compiled-code-block/dbg-info
+ dbg-info-vector/blocks-vector
+ dbg-info-vector?
+ dbg-info/labels
+ dbg-label/external?
+ dbg-label/name
+ dbg-labels/find-offset))
+\f
+;;; New stuff
+
+(define-package (compiler midend)
+ (files "midend/graph"
+ "midend/synutl"
+ "midend/midend"
+ "midend/utils"
+ "midend/fakeprim"
+ "midend/dbgstr"
+ "midend/inlate"
+ "midend/envconv"
+ "midend/alpha"
+ "midend/expand"
+ "midend/assconv"
+ "midend/cleanup"
+ "midend/earlyrew"
+ "midend/lamlift"
+ "midend/closconv"
+ ;; "midend/staticfy" ; broken, for now
+ "midend/applicat"
+ "midend/simplify"
+ "midend/cpsconv"
+ "midend/laterew"
+ "midend/compat" ; compatibility with current compiler
+ "midend/stackopt"
+ "midend/indexify"
+ "midend/rtlgen"
+ "midend/copier"
+ "midend/dataflow"
+ "midend/split"
+ "midend/widen")
+ (parent (compiler))
+ (export (compiler top-level)
+ kmp/pp kmp/ppp
+ *envconv/compile-by-procedures?*
+ *envconv/procedure-result?*
+ kmp->rtl
+ optimize-kmp
+ rtlgen/top-level
+ rtlgen/argument-registers
+ rtlgen/available-registers
+ scode->kmp
+ within-midend)
+ (export (compiler)
+ internal-error
+ internal-warning))
+
+(define-package (compiler rtl-parser)
+ (files "rtlbase/rtlpars")
+ (parent (compiler))
+ (export (compiler)
+ rtl->rtl-graph))
+
+;; End of New stuff
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compiler.sf,v 1.1 1994/11/19 02:09:58 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; Script to incrementally syntax the compiler
+\f
+;; Guarantee that the package modeller is loaded.
+(if (not (name->package '(CROSS-REFERENCE)))
+ (with-working-directory-pathname "../cref" (lambda () (load "make"))))
+
+;; Guarantee that the compiler's package structure exists.
+(if (not (name->package '(COMPILER)))
+ (begin
+ ;; If there is no existing package constructor, generate one.
+ (if (not (file-exists? "compiler.bcon"))
+ (begin
+ ((access cref/generate-trivial-constructor
+ (->environment '(CROSS-REFERENCE)))
+ "compiler")
+ (sf "compiler.con" "compiler.bcon")))
+ (load "compiler.bcon")))
+
+;; Guarantee that the necessary syntactic transforms and optimizers
+;; are loaded.
+(if (lexical-unreferenceable? (->environment '(COMPILER)) 'SYNTAX-FILES!)
+ (let ((sf-and-load
+ (lambda (files package)
+ (sf-conditionally files)
+ (for-each (lambda (file)
+ (load (string-append file ".bin") package))
+ files))))
+ (load-option 'HASH-TABLE)
+ (write-string "\n\n---- Loading compile-time files ----")
+ (sf-and-load '("midend/synutl") '()) ;; This should go elsewhere!
+ (sf-and-load '("base/switch") '(COMPILER))
+ (sf-and-load '("base/macros") '(COMPILER MACROS))
+ ((access initialize-package! (->environment '(COMPILER MACROS))))
+ (sf-and-load '("machines/spectrum/decls") '(COMPILER DECLARATIONS))
+ (let ((environment (->environment '(COMPILER DECLARATIONS))))
+ (set! (access source-file-expression environment) "*.scm")
+ ((access initialize-package! environment)))
+ (sf-and-load '("base/pmlook") '(COMPILER PATTERN-MATCHER/LOOKUP))
+ (sf-and-load '("base/pmpars") '(COMPILER PATTERN-MATCHER/PARSER))
+ (fluid-let ((sf/default-syntax-table
+ (access compiler-syntax-table
+ (->environment '(COMPILER MACROS)))))
+ (sf-and-load '("machines/spectrum/machin") '(COMPILER)))
+ (fluid-let ((sf/default-declarations
+ '((integrate-external "insseq")
+ (integrate-external "machin")
+ (usual-definition (set expt)))))
+ (sf-and-load '("machines/spectrum/assmd") '(COMPILER ASSEMBLER)))
+ (sf-and-load '("back/syntax") '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("machines/spectrum/coerce" "back/asmmac"
+ "machines/spectrum/insmac")
+ '(COMPILER LAP-SYNTAXER))
+ (sf-and-load '("base/scode") '(COMPILER))
+ (sf-and-load '("base/pmerly") '(COMPILER PATTERN-MATCHER/EARLY))
+ (sf-and-load '("machines/spectrum/inerly" "back/syerly")
+ '(COMPILER LAP-SYNTAXER))))
+
+;; Load the assembler instruction database.
+(in-package (->environment '(COMPILER LAP-SYNTAXER))
+ (if (and compiler:enable-expansion-declarations?
+ (null? early-instructions))
+ (fluid-let ((load-noisily? false)
+ (load/suppress-loading-message? false))
+ (write-string "\n\n---- Pre-loading instruction sets ----")
+ (for-each (lambda (name)
+ (load (string-append "machines/spectrum/" name ".scm")
+ '(COMPILER LAP-SYNTAXER)
+ early-syntax-table))
+ '("instr1" "instr2" "instr3")))))
+
+;; Resyntax any files that need it.
+((access syntax-files! (->environment '(COMPILER))))
+
+;; Rebuild the package constructors and cref.
+(cref/generate-constructors "compiler")
+(sf "compiler.con" "compiler.bcon")
+(sf "compiler.ldr" "compiler.bldr")
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: dassm1.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; Disassembler: User Level
+;;; package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+;;; Flags that control disassembler behavior
+
+(define disassembler/symbolize-output? true)
+(define disassembler/compiled-code-heuristics? true)
+(define disassembler/write-offsets? true)
+(define disassembler/write-addresses? false)
+
+;;;; Top level entries
+
+(define (compiler:write-lap-file filename #!optional symbol-table?)
+ (let ((pathname (->pathname filename))
+ (symbol-table?
+ (if (default-object? symbol-table?) true symbol-table?)))
+ (with-output-to-file (pathname-new-type pathname "lap")
+ (lambda ()
+ (let ((com-file (pathname-new-type pathname "com")))
+ (let ((object (fasload com-file)))
+ (if (compiled-code-address? object)
+ (let ((block (compiled-code-address->block object)))
+ (disassembler/write-compiled-code-block
+ block
+ (compiled-code-block/dbg-info block symbol-table?)))
+ (begin
+ (if (not
+ (and (scode/comment? object)
+ (dbg-info-vector? (scode/comment-text object))))
+ (error "Not a compiled file" com-file))
+ (let ((blocks
+ (vector->list
+ (dbg-info-vector/blocks-vector
+ (scode/comment-text object)))))
+ (if (not (null? blocks))
+ (do ((blocks blocks (cdr blocks)))
+ ((null? blocks) unspecific)
+ (disassembler/write-compiled-code-block
+ (car blocks)
+ (compiled-code-block/dbg-info (car blocks)
+ symbol-table?))
+ (if (not (null? (cdr blocks)))
+ (begin
+ (write-char #\page)
+ (newline))))))))))))))
+
+(define disassembler/base-address)
+
+(define (compiler:disassemble entry)
+ (let ((block (compiled-entry/block entry)))
+ (let ((info (compiled-code-block/dbg-info block true)))
+ (fluid-let ((disassembler/write-offsets? true)
+ (disassembler/write-addresses? true)
+ (disassembler/base-address (object-datum block)))
+ (newline)
+ (newline)
+ (disassembler/write-compiled-code-block block info)))))
+
+(define (compiler:disassemble-memory start words)
+ (fluid-let ((disassembler/write-offsets? false)
+ (disassembler/write-addresses? true)
+ (disassembler/base-address start))
+ (newline)
+ (newline)
+ (disassembler/write-instruction-stream
+ #F
+ (disassembler/instructions/address start (+ start (* 4 words))))))
+\f
+(define (disassembler/write-compiled-code-block block info)
+ (let ((symbol-table (and info (dbg-info/labels info))))
+ (write-string "Disassembly of ")
+ (write block)
+ (let loop ((info (compiled-code-block/debugging-info block)))
+ (cond ((string? info)
+ (write-string " (")
+ (write-string info)
+ (write-string ")"))
+ ((not (pair? info)))
+ ((vector? (car info))
+ (loop (cdr info)))
+ (else
+ (write-string " (Block ")
+ (write (cdr info))
+ (write-string " in ")
+ (write-string (car info))
+ (write-string ")"))))
+ (write-string ":\n")
+ (write-string "Code:\n\n")
+ (disassembler/write-instruction-stream
+ symbol-table
+ (disassembler/instructions/compiled-code-block block symbol-table))
+ (write-string "\nConstants:\n\n")
+ (disassembler/write-constants-block block symbol-table)
+ (newline)))
+
+(define (disassembler/instructions/compiled-code-block block symbol-table)
+ (disassembler/instructions block
+ (compiled-code-block/code-start block)
+ (compiled-code-block/code-end block)
+ symbol-table))
+
+(define (disassembler/instructions/address start-address end-address)
+ (disassembler/instructions false start-address end-address false))
+
+(define (disassembler/write-instruction-stream symbol-table instruction-stream)
+ (fluid-let ((*unparser-radix* 16))
+ (disassembler/for-each-instruction instruction-stream
+ (lambda (offset instruction)
+ (disassembler/write-instruction symbol-table
+ offset
+ (lambda () (display-instruction offset instruction)))))))
+
+(define (disassembler/for-each-instruction instruction-stream procedure)
+ (let loop ((instruction-stream instruction-stream))
+ (if (not (disassembler/instructions/null? instruction-stream))
+ (disassembler/instructions/read instruction-stream
+ (lambda (offset instruction instruction-stream)
+ (procedure offset instruction)
+ (loop (instruction-stream)))))))
+\f
+(define (disassembler/write-constants-block block symbol-table)
+ (fluid-let ((*unparser-radix* 16))
+ (let ((end (system-vector-length block)))
+ (let loop ((index (compiled-code-block/constants-start block)))
+ (cond ((not (< index end)) 'DONE)
+ ((object-type?
+ (let-syntax ((ucode-type
+ (macro (name) (microcode-type name))))
+ (ucode-type linkage-section))
+ (system-vector-ref block index))
+ (loop (disassembler/write-linkage-section block
+ symbol-table
+ index)))
+ ((object-type?
+ (let-syntax ((ucode-type
+ (macro (name) (microcode-type name))))
+ (ucode-type manifest-closure))
+ (system-vector-ref block index))
+ (loop (disassembler/write-manifest-closure-pattern block
+ symbol-table
+ index)))
+ (else
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-constant block
+ symbol-table
+ (system-vector-ref block index))))
+ (loop (1+ index))))))))
+
+(define (write-constant block symbol-table constant)
+ (write-string (cdr (write-to-string constant 60)))
+ (cond ((lambda? constant)
+ (let ((expression (lambda-body constant)))
+ (if (and (compiled-code-address? expression)
+ (eq? (compiled-code-address->block expression) block))
+ (begin
+ (write-string " (")
+ (let ((offset (compiled-code-address->offset expression)))
+ (let ((label
+ (disassembler/lookup-symbol symbol-table offset)))
+ (if label
+ (write-string label)
+ (write offset))))
+ (write-string ")")))))
+ ((compiled-code-address? constant)
+ (write-string " (offset ")
+ (write (compiled-code-address->offset constant))
+ (write-string " in ")
+ (write (compiled-code-address->block constant))
+ (write-string ")"))
+ (else false)))
+\f
+(define (disassembler/write-linkage-section block symbol-table index)
+ (let* ((field (object-datum (system-vector-ref block index)))
+ (descriptor (integer-divide field #x10000)))
+ (let ((kind (integer-divide-quotient descriptor))
+ (length (integer-divide-remainder descriptor)))
+
+ (define (write-caches offset size writer)
+ (let loop ((index (1+ (+ offset index)))
+ (how-many (quotient (- length offset) size)))
+ (if (zero? how-many)
+ 'DONE
+ (begin
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (writer block index)))
+ (loop (+ size index) (-1+ how-many))))))
+
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-string "#[LINKAGE-SECTION ")
+ (write field)
+ (write-string "]")))
+ (case kind
+ ((0 3)
+ (write-caches
+ compiled-code-block/procedure-cache-offset
+ compiled-code-block/objects-per-procedure-cache
+ disassembler/write-procedure-cache))
+ ((1)
+ (write-caches
+ 0
+ compiled-code-block/objects-per-variable-cache
+ (lambda (block index)
+ (disassembler/write-variable-cache "Reference" block index))))
+ ((2)
+ (write-caches
+ 0
+ compiled-code-block/objects-per-variable-cache
+ (lambda (block index)
+ (disassembler/write-variable-cache "Assignment" block index))))
+ ((4)
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset (1+ index))
+ (lambda ()
+ (write-string "Closure linkage cache"))))
+ (else
+ (error "disassembler/write-linkage-section: Unknown section kind"
+ kind)))
+ (1+ (+ index length)))))
+
+\f
+(define-integrable (variable-cache-name cache)
+ ((ucode-primitive primitive-object-ref 2) cache 1))
+
+(define (disassembler/write-variable-cache kind block index)
+ (write-string kind)
+ (write-string " cache to ")
+ (write (variable-cache-name (disassembler/read-variable-cache block index))))
+
+(define (disassembler/write-procedure-cache block index)
+ (let ((result (disassembler/read-procedure-cache block index)))
+ (write (vector-ref result 2))
+ (write-string " argument procedure cache to ")
+ (case (vector-ref result 0)
+ ((COMPILED INTERPRETED)
+ (write (vector-ref result 1)))
+ ((VARIABLE)
+ (write-string "variable ")
+ (write (vector-ref result 1)))
+ (else
+ (error "disassembler/write-procedure-cache: Unknown cache kind"
+ (vector-ref result 0))))))
+\f
+(define closure-entry-size 4)
+
+(define (disassembler/write-manifest-closure-pattern block symbol-table index)
+ (let* ((descriptor (integer-divide (system-vector-ref block (+ index 1))
+ #x10000))
+ (offset (integer-divide-remainder descriptor))
+ (multiclosure? (= offset 0))
+ (closures (if multiclosure?
+ (integer-divide-quotient descriptor)
+ 1))
+ (pattern-len (if multiclosure?
+ (+ 1 (* closures closure-entry-size))
+ closure-entry-size))
+ (closure-len (object-datum (system-vector-ref block index)))
+ (free-vars (- closure-len pattern-len)))
+ (disassembler/write-instruction
+ symbol-table
+ (compiled-code-block/index->offset index)
+ (lambda ()
+ (write-string "#[MANIFEST-CLOSURE-PATTERN ")
+ (write closure-len)
+ (if multiclosure?
+ (begin (write-string " ")
+ (write closures)
+ (write-string "-closure")))
+ (write-string " with ")
+ (write free-vars)
+ (write-string " free variable")
+ (if (not (= free-vars 1))
+ (write-string "s"))
+ (write-string "]")))
+ (+ index pattern-len 1)))
+\f
+(define (disassembler/write-instruction symbol-table offset write-instruction)
+ (if symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table offset)))
+ (if label
+ (begin
+ (write-char #\Tab)
+ (write-string (dbg-label/name label))
+ (write-char #\:)
+ (newline)))))
+
+ (if disassembler/write-addresses?
+ (begin
+ (write-string
+ (number->string (+ offset disassembler/base-address) 16))
+ (write-char #\Tab)))
+
+ (if disassembler/write-offsets?
+ (begin
+ (write-string (number->string offset 16))
+ (write-char #\Tab)))
+
+ (if symbol-table
+ (write-string " "))
+ (write-instruction)
+ (newline))
+
+(let-syntax ((define-codes
+ (macro (start . names)
+ (define (loop names index assocs)
+ (if (null? names)
+ `((DEFINE CODE:COMPILER-XXX-ALIST ',assocs))
+ (loop (cdr names) (1+ index)
+ (cons (cons index (car names)) assocs))))
+ `(BEGIN ,@(loop names start '())))))
+ ;; Copied from lapgen.scm
+ (define-codes #x012
+ primitive-apply primitive-lexpr-apply
+ apply error lexpr-apply link
+ interrupt-closure interrupt-dlink interrupt-procedure
+ interrupt-continuation interrupt-ic-procedure
+ assignment-trap cache-reference-apply
+ reference-trap safe-reference-trap unassigned?-trap
+ -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
+ access lookup safe-lookup unassigned? unbound?
+ set! define lookup-apply primitive-error
+ quotient remainder modulo
+ reflect-to-interface interrupt-continuation-2
+ compiled-code-bkpt compiled-closure-bkpt
+ new-interrupt-procedure))
+
+(let-syntax ((define-hooks
+ (macro (start . names)
+ (define (loop names index assocs)
+ (if (null? names)
+ `((DEFINE HOOK:COMPILER-XXX-ALIST ',assocs))
+ (loop (cdr names) (+ 8 index)
+ (cons (cons index (car names)) assocs))))
+ `(BEGIN ,@(loop names start '())))))
+ ;; Copied from lapgen.scm
+ (define-hooks 100
+ store-closure-code
+ store-closure-entry ; newer version of store-closure-code.
+ multiply-fixnum
+ fixnum-quotient
+ fixnum-remainder
+ fixnum-lsh
+ &+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ shortcircuit-apply
+ shortcircuit-apply-1
+ shortcircuit-apply-2
+ shortcircuit-apply-3
+ shortcircuit-apply-4
+ shortcircuit-apply-5
+ shortcircuit-apply-6
+ shortcircuit-apply-7
+ shortcircuit-apply-8
+ stack-and-interrupt-check
+ invoke-primitive
+ vector-cons
+ string-allocate
+ floating-vector-cons
+ flonum-sin
+ flonum-cos
+ flonum-tan
+ flonum-asin
+ flonum-acos
+ flonum-atan
+ flonum-exp
+ flonum-log
+ flonum-truncate
+ flonum-ceiling
+ flonum-floor
+ flonum-atan2
+ compiled-code-bkpt
+ compiled-closure-bkpt
+ copy-closure-pattern
+ copy-multiclosure-pattern
+ closure-entry-bkpt-hook
+ interrupt-procedure/new
+ interrupt-continuation/new
+ quotient
+ remainder
+ interpreter-call))
+
+(define display-instruction
+ (let ((prev-instruction '())
+ (prev-prev-instruction '()))
+ (lambda (offset instruction)
+
+ (define (unannotated) (display instruction))
+
+ (define (annotated)
+ (let ((s (with-output-to-string (lambda() (display instruction)))))
+ (write-string s)
+ (write-string (make-string (max 1 (- 40 (string-length s))) #\Space))
+ (write-string ";")))
+
+ (define (annotate-with-name name)
+ (annotated)
+ (write-string " ")
+ (display name))
+
+ (define (annotate-with-target address)
+ (annotated)
+ (write-string " ")
+ (write-string (number->string address 16)))
+
+ (define (match? pat obj)
+ (or (eq? pat '?)
+ (and (eq? pat '?n) (number? obj))
+ (and (pair? pat) (pair? obj)
+ (match? (car pat) (car obj))
+ (match? (cdr pat) (cdr obj)))
+ (equal? pat obj)))
+
+ (define (code?)
+ (match? '(ble ? (offset ? 4 3)) instruction))
+ (define (code-name)
+ (let ((id.name (assoc (second (third instruction))
+ hook:compiler-xxx-alist)))
+ (and id.name
+ (cdr id.name))))
+
+ (define (hook?)
+ (and (or (equal? '(ble () (offset 0 4 3)) prev-instruction)
+ (equal? '(ble () (offset 12 4 3)) prev-instruction))
+ (match? '(ldi () ? 28) instruction)))
+ (define (hook-name)
+ (let ((id.name (assoc (third instruction) code:compiler-xxx-alist)))
+ (and id.name
+ (cdr id.name))))
+
+ (define (external-label?)
+ (match? '(external-label . ?) instruction))
+
+ (define (offset->address field adjustment)
+ (+ (+ offset disassembler/base-address) field adjustment))
+ (define (offset-targets)
+ (let ((res
+ (map (lambda (@pco.n)
+ (offset->address (second @pco.n) 8))
+ (list-transform-positive instruction
+ (lambda (part) (and (pair? part)
+ (eq? (car part) '@pco)
+ (not (equal? (cadr part) 0))))))))
+ (if (null? res) #f res)))
+
+ (define (special-offset-target)
+ (cond ((and (match? '(bl () ? (@pco 0)) prev-instruction)
+ (match? '(? ? (offset ?n 0 ?) ?) instruction)
+ (eqv? (third prev-instruction) (fourth (third instruction))))
+ (offset->address (second (third instruction)) (+ 8 -4 3)))
+ ((match? '(uword () ?n) instruction)
+ (offset->address (third instruction) 3))
+ (else #f)))
+
+ (cond ((and (code?) (code-name)) => annotate-with-name)
+ ((and (hook?) (hook-name)) => annotate-with-name)
+ ((external-label?) (unannotated))
+ ((special-offset-target) => annotate-with-target)
+ ((offset-targets) => (lambda (x)
+ (annotate-with-target (car x))))
+ (else (unannotated)))
+
+ (set! prev-prev-instruction prev-instruction)
+ (set! prev-instruction instruction))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: dassm2.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1993 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. |#
+
+;;;; Spectrum Disassembler: Top Level
+;;; package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+(define (disassembler/read-variable-cache block index)
+ (let-syntax ((ucode-type
+ (macro (name) (microcode-type name)))
+ (ucode-primitive
+ (macro (name arity)
+ (make-primitive-procedure name arity))))
+ ((ucode-primitive primitive-object-set-type 2)
+ (ucode-type quad)
+ (system-vector-ref block index))))
+
+(define (disassembler/read-procedure-cache block index)
+ (fluid-let ((*block block))
+ (let* ((offset (compiled-code-block/index->offset index))
+ (opcode (fix:lsh (read-unsigned-integer offset 8) -2)))
+ (case opcode
+ ((#x08) ; LDIL
+ ;; This should learn how to decode trampolines.
+ (vector 'COMPILED
+ (read-procedure offset)
+ (read-unsigned-integer (+ offset 10) 16)))
+ (else
+ (error "disassembler/read-procedure-cache: Unknown opcode"
+ opcode block index))))))
+
+(define (disassembler/instructions block start-offset end-offset symbol-table)
+ (let loop ((offset start-offset) (state (disassembler/initial-state)))
+ (if (and end-offset (< offset end-offset))
+ (disassemble-one-instruction
+ block offset symbol-table state
+ (lambda (offset* instruction state)
+ (make-instruction offset
+ instruction
+ (lambda () (loop offset* state)))))
+ '())))
+
+(define (disassembler/instructions/null? obj)
+ (null? obj))
+
+(define (disassembler/instructions/read instruction-stream receiver)
+ (receiver (instruction-offset instruction-stream)
+ (instruction-instruction instruction-stream)
+ (instruction-next instruction-stream)))
+
+(define-structure (instruction (type vector))
+ (offset false read-only true)
+ (instruction false read-only true)
+ (next false read-only true))
+
+(define *block)
+(define *current-offset)
+(define *symbol-table)
+(define *ir)
+(define *valid?)
+
+(define (disassemble-one-instruction block offset symbol-table state receiver)
+ (fluid-let ((*block block)
+ (*current-offset offset)
+ (*symbol-table symbol-table)
+ (*ir)
+ (*valid? true))
+ (set! *ir (get-longword))
+ (let ((start-offset *current-offset))
+ (if (external-label-marker? symbol-table offset state)
+ (receiver start-offset
+ (make-external-label *ir start-offset)
+ 'INSTRUCTION)
+ (let ((instruction (disassemble-word *ir)))
+ (if (not *valid?)
+ (let ((inst (make-word *ir)))
+ (receiver start-offset
+ inst
+ (disassembler/next-state inst state)))
+ (let ((next-state (disassembler/next-state instruction state)))
+ (receiver
+ *current-offset
+ (if (and (pair? state)
+ (eq? (car state) 'PC-REL-OFFSET))
+ (pc-relative-inst offset instruction (cdr state))
+ instruction)
+ next-state))))))))
+\f
+(define-integrable *privilege-level* 3)
+
+(define (pc-relative-inst start-address instruction base-reg)
+ (let ((opcode (car instruction)))
+ (if (not (memq opcode '(LDO LDW)))
+ instruction
+ (let ((offset-exp (caddr instruction))
+ (target (cadddr instruction)))
+ (let ((offset (cadr offset-exp))
+ (space-reg (caddr offset-exp))
+ (base-reg* (cadddr offset-exp)))
+ (if (not (= base-reg* base-reg))
+ instruction
+ (let* ((real-address
+ (+ start-address
+ (- offset *privilege-level*)
+ #|
+ (if (not left-side)
+ 0
+ (- (let ((val (* left-side #x800)))
+ (if (>= val #x80000000)
+ (- val #x100000000)
+ val))
+ 4))
+ |#
+ ))
+ (label
+ (disassembler/lookup-symbol *symbol-table real-address)))
+ (if (not label)
+ instruction
+ `(,opcode () (OFFSET `(- ,label *PC*)
+ #|
+ ,(if left-side
+ `(RIGHT (- ,label (- *PC* 4)))
+ `(- ,label *PC*))
+ |#
+ ,space-reg
+ ,base-reg)
+ ,target)))))))))
+
+(define (disassembler/initial-state)
+ 'INSTRUCTION-NEXT)
+
+(define (disassembler/next-state instruction state)
+ (cond ((not disassembler/compiled-code-heuristics?)
+ 'INSTRUCTION)
+ ((and (eq? state 'INSTRUCTION)
+ (eq? (list-ref instruction 0) 'BL)
+ (equal? (list-ref instruction 3) '(@PCO 0)))
+ (cons 'PC-REL-OFFSET (list-ref instruction 2)))
+ ((memq (car instruction) '(B BV BLE))
+ (if (memq 'N (cadr instruction))
+ 'EXTERNAL-LABEL
+ 'DELAY-SLOT))
+ ((eq? state 'DELAY-SLOT)
+ 'EXTERNAL-LABEL)
+ (else
+ 'INSTRUCTION)))
+\f
+(define (disassembler/lookup-symbol symbol-table offset)
+ (and symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table offset)))
+ (and label
+ (dbg-label/name label)))))
+
+(define (external-label-marker? symbol-table offset state)
+ (if symbol-table
+ (let ((label (dbg-labels/find-offset symbol-table (+ offset 4))))
+ (and label
+ (dbg-label/external? label)))
+ (and *block
+ (eq? state 'EXTERNAL-LABEL)
+ (let loop ((offset (+ offset 4)))
+ (let* ((contents (read-bits (- offset 2) 16))
+ (odd? (bit-string-clear! contents 0))
+ (delta (* 2 (bit-string->unsigned-integer contents))))
+ (if odd?
+ (let ((offset1 (- offset delta)))
+ (and (positive? offset1)
+ (not (= offset1 offset))
+ (loop offset1)))
+ (= offset delta)) )))))
+
+(define (make-word bit-string)
+ `(UWORD () ,(bit-string->unsigned-integer bit-string)))
+
+(define (make-external-label bit-string offset)
+ `(EXTERNAL-LABEL ()
+ ,(extract bit-string 16 32)
+ ,(offset->pc-relative (* 4 (extract bit-string 1 16))
+ offset)))
+
+(define (read-procedure offset)
+ (define (bit-string-andc-bang x y)
+ (bit-string-andc! x y)
+ x)
+
+ (define-integrable (low-21-bits offset)
+ #|
+ (bit-string->unsigned-integer
+ (bit-string-andc-bang (read-bits offset 32)
+ #*11111111111000000000000000000000))
+ |#
+ (fix:and (read-unsigned-integer (1+ offset) 24) #x1FFFFF))
+
+ (define (assemble-21 val)
+ (fix:or (fix:or (fix:lsh (fix:and val 1) 20)
+ (fix:lsh (fix:and val #xffe) 8))
+ (fix:or (fix:or (fix:lsh (fix:and val #xc000) -7)
+ (fix:lsh (fix:and val #x1f0000) -14))
+ (fix:lsh (fix:and val #x3000) -12))))
+
+
+ (define (assemble-17 val)
+ (fix:or (fix:or (fix:lsh (fix:and val 1) 16)
+ (fix:lsh (fix:and val #x1f0000) -5))
+ (fix:or (fix:lsh (fix:and val #x4) 8)
+ (fix:lsh (fix:and val #x1ff8) -3))))
+
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let* ((address
+ (+ (* (assemble-21 (low-21-bits offset)) #x800)
+ (fix:lsh (assemble-17 (low-21-bits (+ offset 4))) 2)))
+ (bitstr (bit-string-andc-bang
+ (unsigned-integer->bit-string 32 address)
+ #*11111100000000000000000000000000)))
+ (let-syntax ((ucode-type
+ (macro (name) (microcode-type name)))
+ (ucode-primitive
+ (macro (name arity)
+ (make-primitive-procedure name arity))))
+ ((ucode-primitive primitive-object-set-type 2)
+ (ucode-type compiled-entry)
+ ((ucode-primitive make-non-pointer-object 1)
+ (bit-string->unsigned-integer bitstr))))))))
+
+(define (read-unsigned-integer offset size)
+ (bit-string->unsigned-integer (read-bits offset size)))
+
+(define (read-bits offset size-in-bits)
+ (let ((word (bit-string-allocate size-in-bits))
+ (bit-offset (* offset addressing-granularity)))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (if *block
+ (read-bits! *block bit-offset word)
+ (read-bits! offset 0 word))))
+ word))
+
+(define (invalid-instruction)
+ (set! *valid? false)
+ false)
+
+(define (offset->pc-relative pco reference-offset)
+ (if (not disassembler/symbolize-output?)
+ `(@PCO ,pco)
+ ;; Only add 4 because it has already been bumped to the
+ ;; next instruction.
+ (let* ((absolute (+ pco (+ 4 reference-offset)))
+ (label (disassembler/lookup-symbol *symbol-table absolute)))
+ (if label
+ `(@PCR ,label)
+ `(@PCO ,pco)))))
+
+(define compiled-code-block/procedure-cache-offset 0)
+(define compiled-code-block/objects-per-procedure-cache 3)
+(define compiled-code-block/objects-per-variable-cache 1)
+
+;; global variable used by runtime/udata.scm -- Moby yuck!
+
+(set! compiled-code-block/bytes-per-object 4)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/dassm3.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1987, 1989, 1990 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. |#
+
+;;; Spectrum Disassembler: Internals
+;;; package: (compiler disassembler)
+
+(declare (usual-integrations))
+\f
+;;;; Utilities
+
+(define (get-longword)
+ (let ((word (read-bits *current-offset 32)))
+ (set! *current-offset (+ *current-offset 4))
+ word))
+
+(declare (integrate-operator extract))
+
+(define (extract bit-string start end)
+ (declare (integrate bit-string start end))
+ (bit-string->unsigned-integer (bit-substring bit-string start end)))
+
+#|
+(define disassembly '())
+
+(define (verify-instruction instruction)
+ (let ((bits (car (syntax-instruction instruction))))
+ (if (and (bit-string? bits)
+ (= (bit-string-length bits) 32))
+ (begin (set! disassembly (disassemble-word bits))
+ (newline)
+ (newline)
+ (if (equal? instruction disassembly)
+ (write "EQUAL")
+ (write "************************* NOT EQUAL"))
+ (newline)
+ (newline)
+ (write instruction)
+ (newline)
+ (newline)
+ (write "Disassembly: ")
+ (write disassembly)))))
+
+(define v verify-instruction)
+|#
+
+(define-integrable Mask-2-9 #b0011111111000000)
+(define-integrable Mask-2-16 #b0011111111111111)
+(define-integrable Mask-3-14 #b0001111111111100)
+(define-integrable Mask-3-10 #b0001111111100000)
+(define-integrable Mask-3-5 #b0001110000000000)
+(define-integrable Mask-4-10 #b0000111111100000)
+(define-integrable Mask-4-5 #b0000110000000000)
+(define-integrable Mask-6-9 #b0000001111000000)
+(define-integrable Mask-6-10 #b0000001111100000)
+(define-integrable Mask-11-15 #b0000000000011111)
+(define-integrable mask-copr #b0000000111000000)
+\f
+;;;; The disassembler proper
+
+(define (disassemble-word word)
+ (let ((hi-halfword (extract word 16 32))
+ (lo-halfword (extract word 0 16)))
+ (let ((opcode (fix:quotient hi-halfword #x400)))
+ ((case opcode
+ ((#x00) sysctl-1)
+ ((#x01) sysctl-2)
+ ((#x02) arith&log)
+ ((#x03) indexed-mem)
+ ((#x04) #| SFUop |# unknown-major-opcode)
+ ((#x05)
+ (lambda (opcode hi lo)
+ opcode hi lo ;ignore
+ `(DIAG () ,(extract word 0 26))))
+ ((#x08 #x0a) ldil&addil)
+ ((#x09 #x0b) #| COPR-w and COPR-dw |# float-mem)
+ ((#x0c) #| COPRop |# float-op)
+ ((#x0d #x10 #x11 #x12 #x13) scalar-load)
+ ((#x18 #x19 #x1a #x1b) scalar-store)
+ ((#x20 #x21 #x22 #x23 #x28 #x29 #x2a #x2b #x30 #x31 #x32 #x33)
+ cond-branch)
+ ((#x24 #x25 #x2c #x2d) addi&subi)
+ ((#x34 #x35) extr&dep)
+ ((#x38 #x39) be&ble)
+ ((#x3a) branch)
+ (else unknown-major-opcode))
+ opcode hi-halfword lo-halfword))))
+
+(define (unknown-major-opcode opcode hi lo)
+ opcode hi lo ;ignore
+ (invalid-instruction))
+\f
+(define (sysctl-1 opcode hi-halfword lo-halfword)
+ ;; BREAK SYNC MFSP MFCTL MTSP MTCTL LDSID
+ ;; Missing other system control:
+ ;; MTSM, RSM, SSM, RFI.
+ opcode ;ignore
+ (let ((opcode-extn (fix:quotient (fix:and lo-halfword Mask-3-10) #x20)))
+ (case opcode-extn
+ ((#x00)
+ (let ((immed-13-hi (fix:and hi-halfword 1023))
+ (immed-13-lo (fix:quotient lo-halfword #x2000))
+ (immed-5 (fix:and lo-halfword #x1f)))
+ `(BREAK () ,immed-5 ,(+ (* immed-13-hi #x100) immed-13-lo))))
+ ((#x20)
+ `(SYNC ()))
+ ((#x25)
+ (let ((target-reg (fix:and hi-halfword #x1f))
+ (space-reg (fix:quotient lo-halfword #x2000)))
+ `(MFSP () ,space-reg ,target-reg)))
+ ((#x45)
+ (let ((ctl-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (target-reg (fix:and lo-halfword #x1f)))
+ `(MFCTL () ,ctl-reg ,target-reg)))
+ ((#xc1)
+ (let ((source-reg hi-halfword)
+ (space-reg (fix:quotient lo-halfword #x2000)))
+ `(MTSP () ,source-reg ,space-reg)))
+ ((#xc2)
+ (let ((ctl-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (source-reg (fix:and hi-halfword #x1f)))
+ `(MTCTL () ,source-reg ,ctl-reg)))
+ ((#x85)
+ (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (space-spec (fix:quotient lo-halfword #x4000))
+ (target-reg (fix:and lo-halfword #x1f)))
+ `(LDSID () (OFFSET ,space-spec ,base-reg)
+ ,target-reg)))
+ (else
+ (invalid-instruction)))))
+\f
+(define (sysctl-2 opcode hi-halfword lo-halfword)
+ ;; PROBER PROBERI PROBEW PROBEWI
+ ;; Missing other system control:
+ ;; LPA, LHA, PDTLB, PITLB, PDTLBE, PITLBE, IDTLBA, IITLBA,
+ ;; IDTLBP, IITLBP, PDC, FDC, FIC, FDCE, FICE.
+ opcode ;ignore
+ (let ((opcode-extn (fix:quotient (fix:and lo-halfword Mask-2-9) #x40)))
+ (let ((mnemonic (case opcode-extn
+ ((#x46) 'PROBER)
+ ((#xc6) 'PROBERI)
+ ((#x47) 'PROBEW)
+ ((#xc7) 'PROBEWI)
+ (else (invalid-instruction))))
+ (base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (priv-reg (fix:and hi-halfword #x1f))
+ (space-spec (fix:quotient lo-halfword #x4000))
+ (target-reg (fix:and lo-halfword #x1f)))
+ `(,mnemonic () (OFFSET ,space-spec ,base-reg)
+ ,priv-reg ,target-reg))))
+\f
+(define (arith&log opcode hi-halfword lo-halfword)
+ opcode ;ignore
+ (let ((opcode-extn (fix:quotient (fix:and Mask-4-10 lo-halfword) #x20)))
+ (let ((source-reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (source-reg-1 (fix:and hi-halfword #x1f))
+ (target-reg (fix:and lo-halfword #x1f))
+ (completer (x-arith-log-completer lo-halfword opcode-extn))
+ (mnemonic
+ (case opcode-extn
+ ((#x00) 'ANDCM)
+ ((#x10) 'AND)
+ ((#x12) 'OR)
+ ((#x14) 'XOR)
+ ((#x1c) 'UXOR)
+ ((#x20) 'SUB)
+ ((#x22) 'DS)
+ ((#x26) 'SUBT)
+ ((#x28) 'SUBB)
+ ((#x30) 'ADD)
+ ((#x32) 'SH1ADD)
+ ((#x34) 'SH2ADD)
+ ((#x36) 'SH3ADD)
+ ((#x38) 'ADDC)
+ ((#x44) 'COMCLR)
+ ((#x4c) 'UADDCM)
+ ((#x4e) 'UADDCMT)
+ ((#x50) 'ADDL)
+ ((#x52) 'SH1ADDL)
+ ((#x54) 'SH2ADDL)
+ ((#x56) 'SH3ADDL)
+ ((#x5c) 'DCOR)
+ ((#x5e) 'IDCOR)
+ ((#x60) 'SUBO)
+ ((#x66) 'SUBTO)
+ ((#x68) 'SUBBO)
+ ((#x70) 'ADDO)
+ ((#x72) 'SH1ADDO)
+ ((#x74) 'SH2ADDO)
+ ((#x76) 'SH3ADDO)
+ ((#x78) 'ADDCO)
+ (else (invalid-instruction)))))
+ (cond ((or (eq? mnemonic 'DCOR) (eq? mnemonic 'IDCOR))
+ `(,mnemonic ,completer ,source-reg-2 ,target-reg))
+ ((and (eq? mnemonic 'OR) (zero? source-reg-2))
+ (if (and (zero? source-reg-1) (zero? target-reg))
+ `(NOP ,completer)
+ `(COPY ,completer ,source-reg-1 ,target-reg)))
+ (else
+ `(,mnemonic ,completer ,source-reg-1 ,source-reg-2
+ ,target-reg))))))
+\f
+(define (indexed-mem opcode hi-halfword lo-halfword)
+ ;; LDBX/S LDHX/S LDWX/S LDCWX/S STWS STHS STBS STBYS
+ opcode ;ignore
+ (let ((short-flag (fix:and lo-halfword #x1000)))
+ (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (index-or-source (fix:and hi-halfword #x1f))
+ (space-spec (fix:quotient lo-halfword #x4000))
+ (opcode-extn (fix:quotient (fix:and lo-halfword Mask-6-9) #x40))
+ (target-or-index (fix:and lo-halfword #x1f))
+ (cc-print-completer (cc-completer lo-halfword))
+ (um-print-completer (um-completer short-flag lo-halfword)))
+ (let ((mnemonic
+ (if (zero? short-flag)
+ (case opcode-extn
+ ((#x0) 'LDBX)
+ ((#x1) 'LDHX)
+ ((#x2) 'LDWX)
+ ((#x7) 'LDCWX)
+ (else (invalid-instruction)))
+ (case opcode-extn
+ ((#x0) 'LDBS)
+ ((#x1) 'LDHS)
+ ((#x2) 'LDWS)
+ ((#x7) 'LDCWS)
+ ((#x8) 'STBS)
+ ((#x9) 'STHS)
+ ((#xa) 'STWS)
+ ((#xc) 'STBYS)
+ (else (invalid-instruction))))))
+ (if (< opcode-extn 8)
+ `(,mnemonic (,@um-print-completer ,@cc-print-completer)
+ (,(if (zero? short-flag) 'INDEX 'OFFSET)
+ ,(if (zero? short-flag)
+ index-or-source
+ (X-Signed-5-Bit index-or-source))
+ ,space-spec ,base-reg)
+ ,target-or-index)
+ `(,mnemonic (,@um-print-completer ,@cc-print-completer)
+ ,index-or-source
+ (,(if (zero? short-flag) 'INDEX 'OFFSET)
+ ,(if (zero? short-flag)
+ target-or-index
+ (X-Signed-5-Bit target-or-index))
+ ,space-spec ,base-reg)))))))
+\f
+(define (ldil&addil opcode hi-halfword lo-halfword)
+ ;; LDIL ADDIL
+ (let* ((reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
+ (hi-immed (fix:and hi-halfword #x1f))
+ (immed (assemble-21 (+ (* hi-immed #x10000) lo-halfword))))
+ `(,(if (= opcode #x08) 'LDIL 'ADDIL) () ,immed ,reg)))
+
+(define (float-mem opcode hi-halfword lo-halfword)
+ ;; FLDWX/S FLDDX/S FSTWX/S FSTDX/S
+ (let ((short-flag (fix:and lo-halfword #x1000))
+ (index (fix:and hi-halfword #x1f)))
+ (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
+ (index (if (zero? short-flag)
+ index
+ (X-Signed-5-Bit index)))
+ (space-spec (fix:quotient lo-halfword #x4000))
+ (opcode-extn (fix:quotient (fix:and lo-halfword Mask-6-9) #x40))
+ (source-or-target (fix:and lo-halfword #x1f))
+ (cc-print-completer (cc-completer lo-halfword))
+ (um-print-completer (um-completer short-flag lo-halfword)))
+ (let ((mnemonic
+ (if (zero? short-flag)
+ (if (= opcode #x09)
+ (if (= opcode-extn 0) 'FLDWX 'FSTWX)
+ (if (= opcode-extn 0) 'FLDDX 'FSTDX))
+ (if (= opcode #x09)
+ (if (= opcode-extn 0) 'FLDWS 'FSTWS)
+ (if (= opcode-extn 0) 'FLDDS 'FSTDS)))))
+ (if (< opcode-extn 8)
+ `(,mnemonic (,@um-print-completer ,@cc-print-completer)
+ (,(if (zero? short-flag) 'INDEX 'OFFSET)
+ ,index ,space-spec ,base-reg)
+ ,source-or-target)
+ `(,mnemonic (,@um-print-completer ,@cc-print-completer)
+ ,source-or-target
+ (,(if (zero? short-flag) 'INDEX 'OFFSET)
+ ,index ,space-spec ,base-reg)))))))
+
+(define (scalar-load opcode hi-halfword lo-halfword)
+ ;; LDO LDB LDH LDW LDWM
+ (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
+ (space-spec (fix:quotient lo-halfword #x4000))
+ (target-reg (fix:and hi-halfword #x1f))
+ (displacement (XRight2s (fix:and lo-halfword Mask-2-16)))
+ (mnemonic
+ (case opcode
+ ((#x0d) 'LDO)
+ ((#x10) 'LDB)
+ ((#x11) 'LDH)
+ ((#x12) 'LDW)
+ ((#x13) 'LDWM)
+ (else (invalid-instruction)))))
+ (cond ((not (eq? mnemonic 'LDO))
+ `(,mnemonic ()
+ (OFFSET ,displacement ,space-spec ,base-reg)
+ ,target-reg))
+ ((zero? base-reg)
+ `(LDI () ,displacement ,target-reg))
+ (else
+ `(,mnemonic ()
+ (OFFSET ,displacement 0 ,base-reg)
+ ,target-reg)))))
+\f
+(define (scalar-store opcode hi-halfword lo-halfword)
+ ;; STB STH STW STWM
+ (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (space-spec (fix:quotient lo-halfword #x4000))
+ (source-reg (fix:and hi-halfword #x1f))
+ (displacement (XRight2s (fix:and lo-halfword Mask-2-16)))
+ (mnemonic
+ (case opcode
+ ((#x18) 'STB)
+ ((#x19) 'STH)
+ ((#x1a) 'STW)
+ ((#x1b) 'STWM)
+ (else (invalid-instruction)))))
+ `(,mnemonic () ,source-reg
+ (OFFSET ,displacement ,space-spec ,base-reg))))
+
+(define (cond-branch opcode hi-halfword lo-halfword)
+ ;; MOVB MOVIB COMB COMIB ADDB ADDIB BVB BB
+ (let* ((reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
+ (reg-1 (if (and (not (= opcode #x31))
+ (odd? opcode))
+ ;; For odd opcodes, this is immed-5 data, not reg-1
+ (X-Signed-5-Bit (fix:and hi-halfword #x1f))
+ (fix:and hi-halfword #x1f)))
+ (c (fix:quotient lo-halfword #x2000))
+ (word-displacement (collect-14 lo-halfword))
+ (null-completer (nullify-bit lo-halfword))
+ (mnemonic (case opcode
+ ((#x20) 'COMBT)
+ ((#x21) 'COMIBT)
+ ((#x22) 'COMBF)
+ ((#x23) 'COMIBF)
+ ((#x28) 'ADDBT)
+ ((#x29) 'ADDIBT)
+ ((#x2a) 'ADDBF)
+ ((#x2b) 'ADDIBF)
+ ((#x30) 'BVB)
+ ((#x31) 'BB)
+ ((#x32) 'MOVB)
+ ((#x33) 'MOVIB)
+ (else (invalid-instruction))))
+ (completer-symbol
+ (X-Extract-Deposit-Completers c)))
+ (if (eq? mnemonic 'BVB)
+ `(,mnemonic (,@completer-symbol ,@null-completer) ,reg-1
+ ,word-displacement)
+ `(,mnemonic (,@completer-symbol ,@null-completer) ,reg-1 ,reg-2
+ ,word-displacement))))
+\f
+(define (addi&subi opcode hi-halfword lo-halfword)
+ ;; ADDI-T-O SUBI-O COMICLR
+ (let ((opcode-extn (fix:quotient (fix:and 2048 lo-halfword) #x800)))
+ (let ((source-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (target-reg (fix:and hi-halfword #x1f))
+ (immed-value (X-Signed-11-Bit (fix:and lo-halfword 2047)))
+ (completer-symbol (x-arith-log-completer lo-halfword opcode))
+ (mnemonic
+ (if (= opcode-extn 0)
+ (case opcode
+ ((#x24) 'COMICLR)
+ ((#x25) 'SUBI)
+ ((#x2c) 'ADDIT)
+ ((#x2d) 'ADDI)
+ (else (invalid-instruction)))
+ (case opcode
+ ((#x25) 'SUBIO)
+ ((#x2c) 'ADDITO)
+ ((#x2d) 'ADDIO)
+ (else (invalid-instruction))))))
+ `(,mnemonic ,completer-symbol ,immed-value
+ ,source-reg ,target-reg))))
+
+(define (extr&dep opcode hi-halfword lo-halfword)
+ ;; VEXTRU VEXTRS VDEP ZVDEP
+ (let* ((reg-2 (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
+ (reg-1 (fix:and hi-halfword #x1f))
+ (c (fix:quotient lo-halfword #x2000))
+ (opcode-extn (fix:quotient (fix:and lo-halfword Mask-3-5) #x400))
+ (cp (fix:quotient (fix:and lo-halfword Mask-6-10) #x20))
+ (clen (fix:and lo-halfword #x1f))
+ (completer-symbol (X-Extract-Deposit-Completers c))
+ (mnemonic
+ (vector-ref (if (= opcode #x34)
+ '#(VSHD *INVALID* SHD *INVALID*
+ VEXTRU VEXTRS EXTRU EXTRS)
+ '#(ZVDEP VDEP ZDEP DEP
+ ZVDEPI VDEPI ZDEPI DEPI))
+ opcode-extn)))
+
+ (define (process reg-1 reg-2)
+ (cond ((or (<= 4 opcode-extn 5)
+ (and (= opcode #x35)
+ (< opcode-extn 2)))
+ ;; Variable dep/ext
+ `(,mnemonic ,completer-symbol ,reg-1 ,(- 32 clen) ,reg-2))
+ ((eq? mnemonic 'VSHD)
+ `(,mnemonic ,completer-symbol ,reg-1 ,reg-2 ,clen))
+ ((eq? mnemonic 'SHD)
+ `(,mnemonic ,completer-symbol ,reg-1 ,reg-2 ,(- 31 cp) ,clen))
+ (else
+ `(,mnemonic ,completer-symbol
+ ,reg-1
+ ,(if (= opcode #x34) cp (- 31 cp))
+ ,(- 32 clen) ,
+ reg-2))))
+
+ (cond ((eq? mnemonic '*INVALID*)
+ (invalid-instruction))
+ ((<= opcode-extn 3)
+ (process reg-1 reg-2))
+ ((= opcode #x34)
+ (process reg-2 reg-1))
+ (else
+ (process (X-Signed-5-Bit reg-1) reg-2)))))
+\f
+(define (be&ble opcode hi-halfword lo-halfword)
+ ;; BE BLE
+ (let ((base-reg (fix:quotient (fix:and Mask-6-10 hi-halfword) #x20))
+ (space-reg (Assemble-3 (fix:quotient lo-halfword #x2000)))
+ (null-completer (nullify-bit lo-halfword))
+ (word-displacement (collect-19 lo-halfword hi-halfword false))
+ (mnemonic (if (= opcode #x38) 'BE 'BLE)))
+ `(,mnemonic ,null-completer
+ (OFFSET ,word-displacement ,space-reg ,base-reg))))
+
+(define (branch opcode hi-halfword lo-halfword)
+ ;; B, BL, BLR, BV, GATE
+ opcode ;ignore
+ (let ((opcode-extension (fix:quotient lo-halfword #x2000)))
+ (case opcode-extension
+ ((0 1)
+ ;; B BL GATE
+ (let ((return-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (word-displacement (collect-19 lo-halfword hi-halfword true))
+ (null-completer (nullify-bit lo-halfword)))
+ (let ((mnemonic (cond ((= opcode-extension 1) 'GATE)
+ ((= return-reg 0) 'B)
+ (else 'BL))))
+ (if (eq? mnemonic 'B)
+ `(,mnemonic ,null-completer ,word-displacement)
+ `(,mnemonic ,null-completer ,return-reg ,word-displacement)))))
+ ((2 6)
+ ;; BLR BV
+ (let ((return-reg (fix:quotient (fix:and Mask-6-10 hi-halfword)
+ #x20))
+ (offset-reg (fix:and hi-halfword #x1f))
+ (null-completer (nullify-bit lo-halfword))
+ (mnemonic (if (= opcode-extension 2)
+ 'BLR
+ 'BV)))
+ `(,mnemonic ,null-completer ,offset-reg ,return-reg)))
+ (else (invalid-instruction)))))
+\f
+;;;; FLoating point operations
+
+(define (float-op opcode hi-halfword lo-halfword)
+ ;; Copr 0 is the floating point copr.
+ opcode ;ignore
+ (if (not (zero? (fix:and (fix:quotient lo-halfword #x40) 7)))
+ (invalid-instruction)
+ ((case (fix:and (fix:quotient lo-halfword #x200) 3)
+ ((0) float-op0)
+ ((1) float-op1)
+ ((2) float-op2)
+ (else float-op3))
+ hi-halfword lo-halfword)))
+
+(define (float-op0 hi-halfword lo-halfword)
+ (let ((mnemonic
+ (vector-ref '#(COPR *INVALID* FCPY FABS FSQRT FRND
+ *INVALID* *INVALID*)
+ (fix:quotient lo-halfword #x2000)))
+ (fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3)))
+ (r (fix:and (fix:quotient hi-halfword #x20) #x1f))
+ (t (fix:and lo-halfword #x1f)))
+ (if (eq? mnemonic '*INVALID*)
+ (invalid-instruction)
+ `(,mnemonic (,fmt) ,r ,t))))
+
+(define (float-op1 hi-halfword lo-halfword)
+ (let ((mnemonic
+ (vector-ref '#(FCNVFF FCNVXF FCNVFX FCNVFXT)
+ (+ (* 2 (fix:and hi-halfword 1))
+ (fix:quotient lo-halfword #x8000))))
+ (sf (floating-format (fix:and (fix:quotient lo-halfword #x800) 3)))
+ (df (floating-format (fix:and (fix:quotient lo-halfword #x2000) 3)))
+ (r (fix:and (fix:quotient hi-halfword #x20) #x1f))
+ (t (fix:and lo-halfword #x1f)))
+ `(,mnemonic (,sf ,df) ,r ,t)))
+
+(define (float-op2 hi-halfword lo-halfword)
+ (case (fix:quotient lo-halfword #x2000)
+ ((0)
+ (let ((fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3)))
+ (r1 (fix:and (fix:quotient hi-halfword #x20) #x1f))
+ (r2 (fix:and hi-halfword #x1f))
+ (c (float-completer (fix:and lo-halfword #x1f))))
+ `(FCMP (,c ,fmt) ,r1 ,r2)))
+ ((1)
+ `(FTEST))
+ (else
+ (invalid-instruction))))
+
+(define (float-op3 hi-halfword lo-halfword)
+ (let ((mnemonic
+ (vector-ref '#(FADD FSUB FMPY FDIV FREM *INVALID* *INVALID* *INVALID*)
+ (fix:quotient lo-halfword #x2000)))
+ (fmt (floating-format (fix:and (fix:quotient lo-halfword #x800) 3)))
+ (r1 (fix:and (fix:quotient hi-halfword #x20) #x1f))
+ (r2 (fix:and hi-halfword #x1f))
+ (t (fix:and lo-halfword #x1f)))
+ (if (eq? mnemonic '*INVALID*)
+ (invalid-instruction)
+ `(,mnemonic (,fmt) ,r1 ,r2 ,t))))
+\f
+;;;; Field extraction
+
+(define (assemble-3 x)
+ (let ((split (integer-divide x 2)))
+ (+ (* (integer-divide-remainder split) 4)
+ (integer-divide-quotient split))))
+
+(define (assemble-12 x y)
+ (let ((split (integer-divide x 2)))
+ (+ (* y #x800)
+ (* (integer-divide-remainder split) #x400)
+ (integer-divide-quotient split))))
+
+(define (assemble-17 x y z)
+ (let ((split (integer-divide y 2)))
+ (+ (* z #x10000)
+ (* x #x800)
+ (* (integer-divide-remainder split) #x400)
+ (integer-divide-quotient split))))
+
+#|
+(define (assemble-21 x) ; Source Dest
+ (+ (* (* (fix:and x 1) #x10000) #x10) ; bit 20 bit 0
+ (* (fix:and x #xffe) #x100) ; bits 9-19 bits 1-11
+ (fix:quotient (fix:and x #xc000) #x80) ; bits 5-6 bits 12-13
+ (fix:quotient (fix:and x #x1f0000) #x4000) ; bits 0-4 bits 14-18
+ (fix:quotient (fix:and x #x3000) #x1000))) ; bits 7-8 bits 19-20
+|#
+
+(define (assemble-21 x)
+ (let ((b (unsigned-integer->bit-string 21 x)))
+ (+ (* (extract b 0 1) #x100000)
+ (* (extract b 1 12) #x200)
+ (* (extract b 14 16) #x80)
+ (* (extract b 16 21) #x4)
+ (extract b 12 14))))
+
+(define (x-signed-5-bit x) ; Sign bit is lo.
+ (let ((sign-bit (fix:and x 1))
+ (hi-bits (fix:quotient x 2)))
+ (if (= sign-bit 0)
+ hi-bits
+ (- hi-bits 16))))
+
+(define (x-signed-11-bit x) ; Sign bit is lo.
+ (let ((sign-bit (fix:and x 1))
+ (hi-bits (fix:quotient x 2)))
+ (if (= sign-bit 0)
+ hi-bits
+ (- hi-bits #x400))))
+
+(define (xright2s d)
+ (let ((sign-bit (fix:and d 1)))
+ (- (fix:quotient d 2)
+ (if (= sign-bit 0)
+ 0
+ #x2000))))
+
+(define-integrable (make-pc-relative value)
+ (offset->pc-relative value *current-offset))
+
+(define (collect-14 lo-halfword)
+ (let* ((sign (fix:and lo-halfword 1))
+ (w (* 4 (assemble-12 (fix:quotient (fix:and lo-halfword #x1ffc) 4)
+ sign))))
+ (make-pc-relative (if (= sign 1)
+ (- w #x4000) ; (expt 2 14)
+ w))))
+
+(define (collect-19 lo-halfword hi-halfword pc-rel?)
+ (let* ((sign (fix:and 1 lo-halfword))
+ (w (* 4 (assemble-17 (fix:and Mask-11-15 hi-halfword)
+ (fix:quotient (fix:and Mask-3-14 lo-halfword)
+ 4)
+ sign)))
+ (disp (if (= sign 1)
+ (- w #x80000) ; (expt 2 19)
+ w)))
+ (if pc-rel?
+ (make-pc-relative disp)
+ disp)))
+\f
+;;;; Completers (modifier suffixes)
+
+(define (x-arith-log-completer lo-halfword xtra)
+ ;; c is 3-bit, f 1-bit
+ (let ((c (fix:quotient lo-halfword #x2000))
+ (f (fix:quotient (fix:and lo-halfword 4096) #x1000)))
+ (let ((index (+ (* f 8) c)))
+ (case xtra
+ ((#x2c #x2d #x30 #x32 #x34 #x36 #x38 #x4c #x4e
+ #x50 #x52 #x54 #x56 #x70 #x72 #x74 #x76 #x78)
+ ;; adds: #x2c #x2d are ADDI
+ (vector-ref
+ '#(() (=) (<) (<=) (NUV) (ZNV) (SV) (OD)
+ (TR) (<>) (>=) (>) (UV) (VNZ) (NSV) (EV))
+ #|
+ '#(() (Eq) (Lt) (LtEq) (NUV) (ZNV) (SV) (OD)
+ (TR) (LtGt) (GtEq) (Gt) (UV) (VNZ) (NSV) (EV))
+ |#
+ index))
+ ((#x20 #x22 #x24 #x25 #x26 #x28 #x44 #x60 #x66 #x68)
+ ;; subtract/compare: #x24 #x25 are SUBI
+ (vector-ref
+ '#(() (=) (<) (<=) (<<) (<<=) (SV) (OD)
+ (TR) (<>) (>=) (>) (>>=) (>>) (NSV) (EV))
+ #|
+ '#(() (Eq) (Lt) (LtEq) (LtLt) (LtLtEq) (SV) (OD)
+ (TR) (LtGt) (GtEq) (Gt) (GtGtEq) (GtGt) (NSV) (EV))
+ |#
+ index))
+ ((0 #x10 #x12 #x14 #x1c)
+ ;; logical
+ (vector-ref
+ '#(() (=) (<) (<=) () () () (OD)
+ (TR) (<>) (>=) (>) () () () (EV))
+ #|
+ '#(() (Eq) (Lt) (LtEq) () () () (OD)
+ (TR) (LtGt) (GtEq) (Gt) () () () (EV))
+ |#
+ index))
+ ((#x5c #x5e)
+ ;; unit
+ (vector-ref '#(() () (SBZ) (SHZ) (SDC) () (SBC) (SHC)
+ (TR) () (NBZ) (NHZ) (NDC) () (NBC) (NHC))
+ index))))))
+\f
+(define (X-Extract-Deposit-Completers c)
+ (vector-ref '#(() (=) (<) (OD) (TR) (<>) (>=) (EV))
+ #| '#(() (Eq) (Lt) (OD) (TR) (LtGt) (GtEq) (EV)) |#
+ c))
+
+(define (cc-completer lo-halfword)
+ (vector-ref '#(() (C) (Q) (P))
+ (fix:quotient (fix:and lo-halfword Mask-4-5) #x400)))
+
+(define (um-completer short-flag lo-halfword)
+ (let ((u-completer (fix:and lo-halfword #x2000))
+ (m-completer (fix:and lo-halfword #x20)))
+ (if (zero? short-flag)
+ (if (zero? u-completer)
+ (if (zero? m-completer) '() '(M))
+ (if (zero? m-completer) '(S) '(SM)))
+ (if (zero? m-completer)
+ '()
+ (if (zero? u-completer) '(MA) '(MB))))))
+
+(define-integrable (nullify-bit lo-halfword)
+ (if (= (fix:and lo-halfword 2) 2) '(N) '()))
+
+(define-integrable (floating-format value)
+ (vector-ref '#(SGL DBL FMT=2 QUAD) value))
+
+(define-integrable (float-completer value)
+ (vector-ref '#(false? false ? !<=> = =T ?= !<> !?>= < ?< !>= !?> <= ?<= !>
+ !?<= > ?> !<= !?< >= ?>= !< !?= <> != !=T !? <=> true? true)
+ value))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: decls.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1994 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 File Dependencies
+;;; package: (compiler declarations)
+
+(declare (usual-integrations))
+\f
+(define (initialize-package!)
+ (add-event-receiver! event:after-restore reset-source-nodes!)
+ (reset-source-nodes!))
+
+(define (reset-source-nodes!)
+ (set! source-filenames '())
+ (set! source-hash)
+ (set! source-nodes)
+ (set! source-nodes/by-rank)
+ unspecific)
+
+(define (maybe-setup-source-nodes!)
+ (if (null? source-filenames)
+ (setup-source-nodes!)))
+
+(define (setup-source-nodes!)
+ (let ((filenames
+ (append-map!
+ (lambda (subdirectory)
+ (map (lambda (pathname)
+ (string-append subdirectory
+ "/"
+ (pathname-name pathname)))
+ (directory-read
+ (string-append subdirectory
+ "/"
+ source-file-expression))))
+ '("back" "base"
+ ;;"fggen" "fgopt"
+ "midend"
+ "rtlbase"
+ ;;"rtlgen"
+ "rtlopt"
+ "machines/spectrum"))))
+ (if (null? filenames)
+ (error "Can't find source files of compiler"))
+ (set! source-filenames filenames))
+ (set! source-hash (make-string-hash-table))
+ (set! source-nodes
+ (map (lambda (filename)
+ (let ((node (make/source-node filename)))
+ (hash-table/put! source-hash filename node)
+ node))
+ source-filenames))
+ (initialize/syntax-dependencies!)
+ (initialize/integration-dependencies!)
+ (initialize/expansion-dependencies!)
+ (source-nodes/rank!))
+
+(define source-file-expression "*.scm")
+(define source-filenames)
+(define source-hash)
+(define source-nodes)
+(define source-nodes/by-rank)
+
+(define (filename/append directory . names)
+ (map (lambda (name) (string-append directory "/" name)) names))
+\f
+(define-structure (source-node
+ (conc-name source-node/)
+ (constructor make/source-node (filename)))
+ (filename false read-only true)
+ (pathname (->pathname filename) read-only true)
+ (forward-links '())
+ (backward-links '())
+ (forward-closure '())
+ (backward-closure '())
+ (dependencies '())
+ (dependents '())
+ (rank false)
+ (syntax-table false)
+ (declarations '())
+ (modification-time false))
+
+(define (filename->source-node filename)
+ (let ((node (hash-table/get source-hash filename #f)))
+ (if (not node)
+ (error "Unknown source file:" filename))
+ node))
+
+(define (source-node/circular? node)
+ (memq node (source-node/backward-closure node)))
+
+(define (source-node/link! node dependency)
+ (if (not (memq dependency (source-node/backward-links node)))
+ (begin
+ (set-source-node/backward-links!
+ node
+ (cons dependency (source-node/backward-links node)))
+ (set-source-node/forward-links!
+ dependency
+ (cons node (source-node/forward-links dependency)))
+ (source-node/close! node dependency))))
+
+(define (source-node/close! node dependency)
+ (if (not (memq dependency (source-node/backward-closure node)))
+ (begin
+ (set-source-node/backward-closure!
+ node
+ (cons dependency (source-node/backward-closure node)))
+ (set-source-node/forward-closure!
+ dependency
+ (cons node (source-node/forward-closure dependency)))
+ (for-each (lambda (dependency)
+ (source-node/close! node dependency))
+ (source-node/backward-closure dependency))
+ (for-each (lambda (node)
+ (source-node/close! node dependency))
+ (source-node/forward-closure node)))))
+\f
+;;;; Rank
+
+(define (source-nodes/rank!)
+ (compute-dependencies! source-nodes)
+ (compute-ranks! source-nodes)
+ (set! source-nodes/by-rank (source-nodes/sort-by-rank source-nodes))
+ unspecific)
+
+(define (compute-dependencies! nodes)
+ (for-each (lambda (node)
+ (set-source-node/dependencies!
+ node
+ (list-transform-negative (source-node/backward-closure node)
+ (lambda (node*)
+ (memq node (source-node/backward-closure node*)))))
+ (set-source-node/dependents!
+ node
+ (list-transform-negative (source-node/forward-closure node)
+ (lambda (node*)
+ (memq node (source-node/forward-closure node*))))))
+ nodes))
+
+(define (compute-ranks! nodes)
+ (let loop ((nodes nodes) (unranked-nodes '()))
+ (if (null? nodes)
+ (if (not (null? unranked-nodes))
+ (loop unranked-nodes '()))
+ (loop (cdr nodes)
+ (let ((node (car nodes)))
+ (let ((rank (source-node/rank* node)))
+ (if rank
+ (begin
+ (set-source-node/rank! node rank)
+ unranked-nodes)
+ (cons node unranked-nodes))))))))
+
+(define (source-node/rank* node)
+ (let loop ((nodes (source-node/dependencies node)) (rank -1))
+ (if (null? nodes)
+ (1+ rank)
+ (let ((rank* (source-node/rank (car nodes))))
+ (and rank*
+ (loop (cdr nodes) (max rank rank*)))))))
+
+(define (source-nodes/sort-by-rank nodes)
+ (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y)))))
+\f
+;;;; File Syntaxer
+
+(define (syntax-files!)
+ (maybe-setup-source-nodes!)
+ (for-each
+ (lambda (node)
+ (let ((modification-time
+ (let ((source (modification-time node "scm"))
+ (binary (modification-time node "bin")))
+ (if (not source)
+ (error "Missing source file" (source-node/filename node)))
+ (and binary (< source binary) binary))))
+ (set-source-node/modification-time! node modification-time)
+ (if (not modification-time)
+ (begin (write-string "\nSource file newer than binary: ")
+ (write (source-node/filename node))))))
+ source-nodes)
+ (if compiler:enable-integration-declarations?
+ (begin
+ (for-each
+ (lambda (node)
+ (let ((time (source-node/modification-time node)))
+ (if (and time
+ (there-exists? (source-node/dependencies node)
+ (lambda (node*)
+ (let ((newer?
+ (let ((time*
+ (source-node/modification-time node*)))
+ (or (not time*)
+ (> time* time)))))
+ (if newer?
+ (begin
+ (write-string "\nBinary file ")
+ (write (source-node/filename node))
+ (write-string " newer than dependency ")
+ (write (source-node/filename node*))))
+ newer?))))
+ (set-source-node/modification-time! node false))))
+ source-nodes)
+ (for-each
+ (lambda (node)
+ (if (not (source-node/modification-time node))
+ (for-each (lambda (node*)
+ (if (source-node/modification-time node*)
+ (begin
+ (write-string "\nBinary file ")
+ (write (source-node/filename node*))
+ (write-string " depends on ")
+ (write (source-node/filename node))))
+ (set-source-node/modification-time! node* false))
+ (source-node/forward-closure node))))
+ source-nodes)))
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (pathname-delete!
+ (pathname-new-type (source-node/pathname node) "ext"))))
+ source-nodes/by-rank)
+ (write-string "\n\nBegin pass 1:")
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (source-node/syntax! node)))
+ source-nodes/by-rank)
+ (if (there-exists? source-nodes/by-rank
+ (lambda (node)
+ (and (not (source-node/modification-time node))
+ (source-node/circular? node))))
+ (begin
+ (write-string "\n\nBegin pass 2:")
+ (for-each (lambda (node)
+ (if (not (source-node/modification-time node))
+ (if (source-node/circular? node)
+ (source-node/syntax! node)
+ (source-node/touch! node))))
+ source-nodes/by-rank))))
+\f
+(define (source-node/touch! node)
+ (with-values
+ (lambda ()
+ (sf/pathname-defaulting (source-node/pathname node) "" false))
+ (lambda (input-pathname bin-pathname spec-pathname)
+ input-pathname
+ (pathname-touch! bin-pathname)
+ (pathname-touch! (pathname-new-type bin-pathname "ext"))
+ (if spec-pathname (pathname-touch! spec-pathname)))))
+
+(define (pathname-touch! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-string "\nTouch file: ")
+ (write (enough-namestring pathname))
+ (file-touch pathname))))
+
+(define (pathname-delete! pathname)
+ (if (file-exists? pathname)
+ (begin
+ (write-string "\nDelete file: ")
+ (write (enough-namestring pathname))
+ (delete-file pathname))))
+
+(define (sc filename)
+ (maybe-setup-source-nodes!)
+ (source-node/syntax! (filename->source-node filename)))
+
+(define (source-node/syntax! node)
+ (with-values
+ (lambda ()
+ (sf/pathname-defaulting (source-node/pathname node) "" false))
+ (lambda (input-pathname bin-pathname spec-pathname)
+ (sf/internal
+ input-pathname bin-pathname spec-pathname
+ (source-node/syntax-table node)
+ ((if compiler:enable-integration-declarations?
+ identity-procedure
+ (lambda (declarations)
+ (list-transform-negative declarations
+ integration-declaration?)))
+ ((if compiler:enable-expansion-declarations?
+ identity-procedure
+ (lambda (declarations)
+ (list-transform-negative declarations
+ expansion-declaration?)))
+ (source-node/declarations node)))))))
+
+(define-integrable (modification-time node type)
+ (file-modification-time
+ (pathname-new-type (source-node/pathname node) type)))
+\f
+;;;; Syntax dependencies
+
+(define (initialize/syntax-dependencies!)
+ (let ((file-dependency/syntax/join
+ (lambda (filenames syntax-table)
+ (for-each (lambda (filename)
+ (set-source-node/syntax-table!
+ (filename->source-node filename)
+ syntax-table))
+ filenames))))
+ (file-dependency/syntax/join
+ (append (filename/append "base"
+ "toplev" "asstop" "crstop"
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "ctypes" "debug" "enumer"
+ "infnew" "lvalue" "object" "pmerly" "proced"
+ "refctx" "rvalue" "scode" "sets" "subprb"
+ "switch" "utils")
+ (filename/append "back"
+ "asmmac" "bittop" "bitutl" "insseq" "lapgn1"
+ "lapgn2" "lapgn3" "linear" "regmap" "symtab"
+ "syntax")
+ (filename/append "machines/spectrum"
+ "dassm1" "insmac" "lapopt" "machin" "rgspcm"
+ "rulrew")
+ ;;(filename/append "fggen"
+ ;; "declar" "fggen" "canon")
+ ;;(filename/append "fgopt"
+ ;; "blktyp" "closan" "conect" "contan" "delint"
+ ;; "desenv" "envopt" "folcon" "offset" "operan"
+ ;; "order" "outer" "param" "reord" "reteqv" "reuse"
+ ;; "sideff" "simapp" "simple" "subfre" "varind")
+ (filename/append "midend"
+ "alpha" "applicat" "assconv" "cleanup"
+ "closconv" "compat" "copier" "cpsconv"
+ "dataflow" "dbgstr" "debug" "earlyrew"
+ "envconv" "expand" "fakeprim" "graph"
+ "indexify" "inlate" "lamlift" "laterew"
+ "load" "midend" "rtlgen" "simplify"
+ "split" "stackopt" "staticfy" "synutl"
+ "triveval" "utils" "widen"
+ )
+ (filename/append "rtlbase"
+ "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
+ "rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2"
+ "valclass"
+ ;; New stuff
+ "rtlpars"
+ ;; End of New stuff
+ )
+ ;;(filename/append "rtlgen"
+ ;; "fndblk" "fndvar" "opncod" "rgcomb" "rgproc"
+ ;; "rgretn" "rgrval" "rgstmt" "rtlgen")
+ (filename/append "rtlopt"
+ "ralloc" "rcompr" "rcse1" "rcse2" "rcseep"
+ "rcseht" "rcserq" "rcsesr" "rcsemrg"
+ "rdebug" "rdflow" "rerite" "rinvex"
+ "rlife" "rtlcsm"))
+ compiler-syntax-table)
+ (file-dependency/syntax/join
+ (filename/append "machines/spectrum"
+ "lapgen"
+ "rules1" "rules2" "rules3" "rules4" "rulfix" "rulflo")
+ lap-generator-syntax-table)
+ (file-dependency/syntax/join
+ (filename/append "machines/spectrum" "instr1" "instr2" "instr3")
+ assembler-syntax-table)))
+\f
+;;;; Integration Dependencies
+
+(define (initialize/integration-dependencies!)
+ (define (add-declaration! declaration filenames)
+ (for-each (lambda (filenames)
+ (let ((node (filename->source-node filenames)))
+ (set-source-node/declarations!
+ node
+ (cons declaration
+ (source-node/declarations node)))))
+ filenames))
+
+ (let* ((front-end-base
+ (filename/append "base"
+ "blocks" "cfg1" "cfg2" "cfg3"
+ "contin" "ctypes" "enumer" "lvalue"
+ "object" "proced" "rvalue"
+ "scode" "subprb" "utils"))
+ (midend-base
+ (filename/append "midend"
+ "fakeprim" "utils"))
+ (spectrum-base
+ (append (filename/append "machines/spectrum" "machin")
+ (filename/append "back" "asutl")))
+ (rtl-base
+ (filename/append "rtlbase"
+ "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1"
+ "rtlty2"))
+ (cse-base
+ (filename/append "rtlopt"
+ "rcse1" "rcseht" "rcserq" "rcsesr"))
+ (cse-all
+ (append (filename/append "rtlopt"
+ "rcse2" "rcsemrg" "rcseep")
+ cse-base))
+ (instruction-base
+ (filename/append "machines/spectrum" "assmd" "machin"))
+ (lapgen-base
+ (append (filename/append "back" "linear" "regmap")
+ (filename/append "machines/spectrum" "lapgen")))
+ (assembler-base
+ (append (filename/append "back" "symtab")
+ (filename/append "machines/spectrum" "instr1")))
+ (lapgen-body
+ (append
+ (filename/append "back" "lapgn1" "lapgn2" "syntax")
+ (filename/append "machines/spectrum"
+ "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo")))
+ (assembler-body
+ (append
+ (filename/append "back" "bittop")
+ (filename/append "machines/spectrum"
+ "instr1" "instr2" "instr3"))))
+
+ (define (file-dependency/integration/join filenames dependencies)
+ (for-each (lambda (filename)
+ (file-dependency/integration/make filename dependencies))
+ filenames))
+
+ (define (file-dependency/integration/make filename dependencies)
+ (let ((node (filename->source-node filename)))
+ (for-each (lambda (dependency)
+ (let ((node* (filename->source-node dependency)))
+ (if (not (eq? node node*))
+ (source-node/link! node node*))))
+ dependencies)))
+
+ (define (define-integration-dependencies directory name directory* . names)
+ (file-dependency/integration/make
+ (string-append directory "/" name)
+ (apply filename/append directory* names)))
+
+ (define-integration-dependencies "machines/spectrum" "machin" "back" "asutl")
+ (define-integration-dependencies "base" "object" "base" "enumer")
+ (define-integration-dependencies "base" "enumer" "base" "object")
+ (define-integration-dependencies "base" "utils" "base" "scode")
+ (define-integration-dependencies "base" "cfg1" "base" "object")
+ (define-integration-dependencies "base" "cfg2" "base"
+ "cfg1" "cfg3" "object")
+ (define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "base" "ctypes" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb")
+ (define-integration-dependencies "base" "rvalue" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils")
+ (define-integration-dependencies "base" "lvalue" "base"
+ "blocks" "object" "proced" "rvalue" "utils")
+ (define-integration-dependencies "base" "blocks" "base"
+ "enumer" "lvalue" "object" "proced" "rvalue" "scode")
+ (define-integration-dependencies "base" "proced" "base"
+ "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object"
+ "rvalue" "utils")
+ (define-integration-dependencies "base" "contin" "base"
+ "blocks" "cfg3" "ctypes")
+ (define-integration-dependencies "base" "subprb" "base"
+ "cfg3" "contin" "enumer" "object" "proced")
+
+ (define-integration-dependencies "machines/spectrum" "machin" "rtlbase"
+ "rtlreg" "rtlty1" "rtlty2")
+
+ (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rgraph" "machines/spectrum"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlcfg" "base"
+ "cfg1" "cfg2" "cfg3")
+ (define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils")
+ (define-integration-dependencies "rtlbase" "rtlcon" "machines/spectrum"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlexp" "rtlbase"
+ "rtlreg" "rtlty1")
+ (define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "rtlbase" "rtline" "rtlbase"
+ "rtlcfg" "rtlty2")
+ (define-integration-dependencies "rtlbase" "rtlobj" "base"
+ "cfg1" "object" "utils")
+ (define-integration-dependencies "rtlbase" "rtlreg" "machines/spectrum"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlreg" "rtlbase"
+ "rgraph" "rtlty1")
+ (define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "rtlbase" "rtlty2" "base" "scode")
+ (define-integration-dependencies "rtlbase" "rtlty2" "machines/spectrum"
+ "machin")
+ (define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1")
+
+ (file-dependency/integration/join
+ (append
+ (filename/append "base" "refctx")
+ ;;(filename/append "fggen"
+ ;; "declar" "fggen") ; "canon" needs no integrations
+ ;;(filename/append "fgopt"
+ ;; "blktyp" "closan" "conect" "contan" "delint" "desenv"
+ ;; "envopt" "folcon" "offset" "operan" "order" "param"
+ ;; "outer" "reuse" "reteqv" "sideff" "simapp" "simple"
+ ;; "subfre" "varind")
+ )
+ (append spectrum-base front-end-base))
+
+ ;;(define-integration-dependencies "fgopt" "reuse" "fgopt" "reord")
+
+ ;;(file-dependency/integration/join
+ ;; (filename/append "rtlgen"
+ ;; "fndblk" "fndvar" "opncod" "rgcomb" "rgproc" "rgretn"
+ ;; "rgrval" "rgstmt" "rtlgen")
+ ;;(append spectrum-base front-end-base rtl-base))
+
+ ;; New stuff
+ (file-dependency/integration/join (filename/append "rtlbase" "rtlpars")
+ rtl-base)
+ ;;(file-dependency/integration/join
+ ;; (filename/append "midend"
+ ;; "alpha" "applicat" "assconv" "cleanup"
+ ;; "closconv" "compat" "copier" "cpsconv"
+ ;; "dataflow" "dbgstr" "debug" "earlyrew"
+ ;; "envconv" "expand" "graph"
+ ;; "indexify" "inlate" "lamlift" "laterew"
+ ;; "load" "midend" "rtlgen" "simplify"
+ ;; "split" "stackopt" "staticfy" "synutl"
+ ;; "triveval" "widen")
+ ;; midend-base)
+
+ ;; End of new stuff
+
+ (file-dependency/integration/join
+ (append cse-all
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rdflow"
+ "rerite" "rinvex" "rlife" "rtlcsm")
+ (filename/append "machines/spectrum" "rulrew"))
+ (append spectrum-base rtl-base))
+
+ (file-dependency/integration/join cse-all cse-base)
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife")
+ (filename/append "rtlbase" "regset"))
+
+ (file-dependency/integration/join
+ (filename/append "rtlopt" "rcseht" "rcserq")
+ (filename/append "base" "object"))
+
+ (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2")
+
+ (let ((dependents
+ (append instruction-base
+ lapgen-base
+ lapgen-body
+ assembler-base
+ assembler-body
+ (filename/append "back" "linear" "syerly"))))
+ (add-declaration! '(USUAL-DEFINITION (SET EXPT)) dependents)
+ (file-dependency/integration/join dependents instruction-base))
+
+ (file-dependency/integration/join (append lapgen-base lapgen-body)
+ lapgen-base)
+
+ (file-dependency/integration/join (append assembler-base assembler-body)
+ assembler-base)
+
+ (define-integration-dependencies "back" "lapgn1" "base"
+ "cfg1" "cfg2" "utils")
+ (define-integration-dependencies "back" "lapgn1" "rtlbase"
+ "rgraph" "rtlcfg")
+ (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg")
+ (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2")
+ (define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg")
+ (define-integration-dependencies "back" "mermap" "back" "regmap")
+ (define-integration-dependencies "back" "regmap" "base" "utils")
+ (define-integration-dependencies "back" "symtab" "base" "utils"))
+
+ (for-each (lambda (node)
+ (let ((links (source-node/backward-links node)))
+ (if (not (null? links))
+ (set-source-node/declarations!
+ node
+ (cons (make-integration-declaration
+ (source-node/pathname node)
+ (map source-node/pathname links))
+ (source-node/declarations node))))))
+ source-nodes))
+
+(define (make-integration-declaration pathname integration-dependencies)
+ `(INTEGRATE-EXTERNAL
+ ,@(map (let ((default
+ (make-pathname
+ false
+ false
+ (cons 'RELATIVE
+ (make-list
+ (length (cdr (pathname-directory pathname)))
+ 'UP))
+ false
+ false
+ false)))
+ (lambda (pathname)
+ (merge-pathnames pathname default)))
+ integration-dependencies)))
+
+(define-integrable (integration-declaration? declaration)
+ (eq? (car declaration) 'INTEGRATE-EXTERNAL))
+\f
+;;;; Expansion Dependencies
+
+(define (initialize/expansion-dependencies!)
+ (let ((file-dependency/expansion/join
+ (lambda (filenames expansions)
+ (for-each (lambda (filename)
+ (let ((node (filename->source-node filename)))
+ (set-source-node/declarations!
+ node
+ (cons (make-expansion-declaration expansions)
+ (source-node/declarations node)))))
+ filenames))))
+ (file-dependency/expansion/join
+ (filename/append "machines/spectrum"
+ "lapgen" "rules1" "rules2" "rules3" "rules4"
+ "rulfix" "rulflo")
+ (map (lambda (entry)
+ `(,(car entry)
+ (PACKAGE/REFERENCE (FIND-PACKAGE '(COMPILER LAP-SYNTAXER))
+ ',(cadr entry))))
+ '((LAP:SYNTAX-INSTRUCTION LAP:SYNTAX-INSTRUCTION-EXPANDER)
+ (INSTRUCTION->INSTRUCTION-SEQUENCE
+ INSTRUCTION->INSTRUCTION-SEQUENCE-EXPANDER)
+ (SYNTAX-EVALUATION SYNTAX-EVALUATION-EXPANDER)
+ (CONS-SYNTAX CONS-SYNTAX-EXPANDER)
+ (OPTIMIZE-GROUP-EARLY OPTIMIZE-GROUP-EXPANDER)
+ (EA-KEYWORD-EARLY EA-KEYWORD-EXPANDER)
+ (EA-MODE-EARLY EA-MODE-EXPANDER)
+ (EA-REGISTER-EARLY EA-REGISTER-EXPANDER)
+ (EA-EXTENSION-EARLY EA-EXTENSION-EXPANDER)
+ (EA-CATEGORIES-EARLY EA-CATEGORIES-EXPANDER))))))
+
+(define-integrable (make-expansion-declaration expansions)
+ `(EXPAND-OPERATOR ,@expansions))
+
+(define-integrable (expansion-declaration? declaration)
+ (eq? (car declaration) 'EXPAND-OPERATOR))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/inerly.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+$MC68020-Header: inerly.scm,v 1.6 88/08/31 06:00:59 GMT cph Exp $
+
+Copyright (c) 1988, 1989, 1990 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. |#
+
+;;; Spectrum Instruction Set Macros. Early version
+;;; NOPs for now.
+
+(declare (usual-integrations))
+\f
+;;;; Transformers and utilities
+
+(define early-instructions '())
+(define early-transformers '())
+
+(define (define-early-transformer name transformer)
+ (set! early-transformers
+ (cons (cons name transformer)
+ early-transformers)))
+
+(define (eq-subset? s1 s2)
+ (or (null? s1)
+ (and (memq (car s1) s2)
+ (eq-subset? (cdr s1) s2))))
+
+;;; Instruction and addressing mode macros
+
+(syntax-table-define early-syntax-table 'DEFINE-INSTRUCTION
+ (macro (opcode . patterns)
+ `(SET! EARLY-INSTRUCTIONS
+ (CONS
+ (LIST ',opcode
+ ,@(map (lambda (pattern)
+ `(early-parse-rule
+ ',(car pattern)
+ (lambda (pat vars)
+ (early-make-rule
+ pat
+ vars
+ (scode-quote
+ (instruction->instruction-sequence
+ ,(parse-instruction (cadr pattern)
+ (cddr pattern)
+ true)))))))
+ patterns))
+ EARLY-INSTRUCTIONS))))
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/insmac.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988, 1989, 1990 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. |#
+
+;;;; Spectrum Instruction Set Macros
+
+(declare (usual-integrations))
+\f
+;;;; Definition macros
+
+(syntax-table-define assembler-syntax-table 'DEFINE-SYMBOL-TRANSFORMER
+ (macro (name . alist)
+ `(begin
+ (declare (integrate-operator ,name))
+ (define (,name symbol)
+ (declare (integrate symbol))
+ (let ((place (assq symbol ',alist)))
+ (if (not place)
+ #F
+ (cdr place)))))))
+
+(syntax-table-define assembler-syntax-table 'DEFINE-TRANSFORMER
+ (macro (name value)
+ `(define ,name ,value)))
+\f
+;;;; Fixed width instruction parsing
+
+(define (parse-instruction first-word tail early?)
+ (cond ((not (null? tail))
+ (error "parse-instruction: Unknown format" (cons first-word tail)))
+ ((eq? (car first-word) 'LONG)
+ (process-fields (cdr first-word) early?))
+ ((eq? (car first-word) 'VARIABLE-WIDTH)
+ (process-variable-width first-word early?))
+ (else
+ (error "parse-instruction: Unknown format" first-word))))
+
+(define (process-variable-width descriptor early?)
+ (let ((binding (cadr descriptor))
+ (clauses (cddr descriptor)))
+ `(LIST
+ ,(variable-width-expression-syntaxer
+ (car binding) ; name
+ (cadr binding) ; expression
+ (map (lambda (clause)
+ (expand-fields
+ (cdadr clause)
+ early?
+ (lambda (code size)
+ (if (not (zero? (remainder size 32)))
+ (error "process-variable-width: bad clause size" size))
+ `((LIST ,(optimize-group-syntax code early?))
+ ,size
+ ,@(car clause)))))
+ clauses)))))
+
+(define (process-fields fields early?)
+ (expand-fields fields
+ early?
+ (lambda (code size)
+ (if (not (zero? (remainder size 32)))
+ (error "process-fields: bad syllable size" size))
+ `(LIST ,(optimize-group-syntax code early?)))))
+
+(define (expand-fields fields early? receiver)
+ (define (expand first-word word-size fields receiver)
+ (if (null? fields)
+ (receiver '() 0)
+ (expand-field
+ (car fields) early?
+ (lambda (car-field car-size)
+ (if (and (eq? endianness 'LITTLE)
+ (= 32 (+ word-size car-size)))
+ (expand '() 0 (cdr fields)
+ (lambda (tail tail-size)
+ (receiver
+ (append (cons car-field first-word) tail)
+ (+ car-size tail-size))))
+ (expand (cons car-field first-word)
+ (+ car-size word-size)
+ (cdr fields)
+ (lambda (tail tail-size)
+ (receiver
+ (if (or (zero? car-size)
+ (not (eq? endianness 'LITTLE)))
+ (cons car-field tail)
+ tail)
+ (+ car-size tail-size)))))))))
+ (expand '() 0 fields receiver))
+
+(define (expand-field field early? receiver)
+ early? ; ignored for now
+ (let ((size (car field))
+ (expression (cadr field)))
+
+ (define (default type)
+ (receiver (integer-syntaxer expression type size)
+ size))
+
+ (if (null? (cddr field))
+ (default 'UNSIGNED)
+ (case (caddr field)
+ ((PC-REL)
+ (receiver
+ (integer-syntaxer ``(- ,,expression (+ *PC* 8))
+ (cadddr field)
+ size)
+ size))
+ ((BLOCK-OFFSET)
+ (receiver (list 'list ''BLOCK-OFFSET expression)
+ size))
+ (else
+ (default (caddr field)))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: instr1.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1987-1993 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. |#
+
+;;;; HP Spectrum instruction utilities
+;;; Originally from Walt Hill, who did the hard part.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define-transformer complx
+ (lambda (completer)
+ (vector (encode-S/SM completer)
+ (cc-val completer)
+ (m-val completer))))
+
+(define-transformer compls
+ (lambda (completer)
+ (vector (encode-MB completer)
+ (cc-val completer)
+ (m-val completer))))
+
+(define-transformer compledb
+ (lambda (completer)
+ (cons (encode-n completer)
+ (extract-deposit-condition completer))))
+
+(define-transformer compled
+ (lambda (completer)
+ (extract-deposit-condition completer)))
+
+(define-transformer complalb
+ (lambda (completer)
+ (cons (encode-n completer)
+ (arith-log-condition completer))))
+
+(define-transformer complaltfb
+ (lambda (completer)
+ (list (encode-n completer)
+ (let ((val (arith-log-condition completer)))
+ (if (not (zero? (cadr val)))
+ (error "complaltfb: Bad completer" completer)
+ (car val))))))
+
+(define-transformer complal
+ (lambda (completer)
+ (arith-log-condition completer)))
+
+(define-transformer complaltf
+ (lambda (completer)
+ (let ((val (arith-log-condition completer)))
+ (if (not (zero? (cadr val)))
+ (error "complaltf: Bad completer" completer)
+ val))))
+
+(define-transformer fpformat
+ (lambda (completer)
+ (encode-fpformat completer)))
+
+(define-transformer fpcond
+ (lambda (completer)
+ (encode-fpcond completer)))
+
+(define-transformer sr3
+ (lambda (value)
+ (let ((place (assq value '((0 . 0) (1 . 2) (2 . 4) (3 . 6)
+ (4 . 1) (5 . 3) (6 . 5) (7 . 7)))))
+ (if place
+ (cdr place)
+ (error "sr3: Invalid space register descriptor" value)))))
+\f
+;;;; Utilities
+
+(define-integrable (branch-extend-pco disp nullify?)
+ (if (and (= nullify? 1)
+ (negative? disp))
+ 4
+ 0))
+
+(define-integrable (branch-extend-nullify disp nullify?)
+ (if (and (= nullify? 1)
+ (not (negative? disp)))
+ 1
+ 0))
+
+(define-integrable (branch-extend-disp disp)
+ (- disp 4))
+
+(define-integrable (branch-extend-edcc cc)
+ (remainder (+ cc 4) 8))
+
+(define-integrable (encode-N completers)
+ (if (memq 'N completers)
+ 1
+ 0))
+
+(define-integrable (encode-S/SM completers)
+ (if (or (memq 'S completers) (memq 'SM completers))
+ 1
+ 0))
+
+(define-integrable (encode-MB completers)
+ (if (memq 'MB completers)
+ 1
+ 0))
+
+(define-integrable (m-val compl-list)
+ (if (or (memq 'M compl-list)
+ (memq 'SM compl-list)
+ (memq 'MA compl-list)
+ (memq 'MB compl-list))
+ 1
+ 0))
+
+(define-integrable (cc-val compl-list)
+ (cond ((memq 'P compl-list) 3)
+ ((memq 'Q compl-list) 2)
+ ((memq 'C compl-list) 1)
+ (else 0)))
+
+(define (extract-deposit-condition compl)
+ (cond ((or (null? compl) (memq 'NV compl)) 0)
+ ((or (memq 'EQ compl) (memq '= compl)) 1)
+ ((or (memq 'LT compl) (memq '< compl)) 2)
+ ((memq 'OD compl) 3)
+ ((memq 'TR compl) 4)
+ ((or (memq 'LTGT compl) (memq '<> compl)) 5)
+ ((or (memq 'GTEQ compl) (memq '>= compl)) 6)
+ ((memq 'EV compl) 7)
+ (else
+ ;; This should really error out, but it's hard to
+ ;; arrange given that the compl includes other
+ ;; fields.
+ 0)))
+
+(define-integrable (encode-fpformat compl)
+ (case compl
+ ((DBL) 1)
+ ((SGL) 0)
+ ((QUAD) 3)
+ (else
+ (error "Missing Floating Point Format" compl))))
+\f
+(define-integrable (encode-fpcond fpcond)
+ (let ((place (assq fpcond float-condition-table)))
+ (if place
+ (cadr place)
+ (error "encode-fpcond: Unknown condition" fpcond))))
+
+(define float-condition-table
+ '((false? 0)
+ (false 1)
+ (? 2)
+ (!<=> 3)
+ (= 4)
+ (=T 5)
+ (?= 6)
+ (!<> 7)
+ (!?>= 8)
+ (< 9)
+ (?< 10)
+ (!>= 11)
+ (!?> 12)
+ (<= 13)
+ (?<= 14)
+ (!> 15)
+ (!?<= 16)
+ (> 17)
+ (?> 18)
+ (!<= 19)
+ (!?< 20)
+ (>= 21)
+ (?>= 22)
+ (!< 23)
+ (!?= 24)
+ (<> 25)
+ (!= 26)
+ (!=T 27)
+ (!? 28)
+ (<=> 29)
+ (true? 30)
+ (true 31)))
+\f
+(define (arith-log-condition compl-list)
+ ;; Returns (c f)
+ (let loop ((compl-list compl-list))
+ (if (null? compl-list)
+ '(0 0)
+ (let ((val (assq (car compl-list) arith-log-condition-table)))
+ (if val
+ (cadr val)
+ (loop (cdr compl-list)))))))
+
+(define arith-log-condition-table
+ '((NV (0 0))
+ (EQ (1 0))
+ (= (1 0))
+ (LT (2 0))
+ (< (2 0))
+ (SBZ (2 0))
+ (LTEQ (3 0))
+ (<= (3 0))
+ (SHZ (3 0))
+ (LTLT (4 0))
+ (<< (4 0))
+ (NUV (4 0))
+ (SDC (4 0))
+ (LTLTEQ (5 0))
+ (<<= (5 0))
+ (ZNV (5 0))
+ (SV (6 0))
+ (SBC (6 0))
+ (OD (7 0))
+ (SHC (7 0))
+ (TR (0 1))
+ (LTGT (1 1))
+ (<> (1 1))
+ (GTEQ (2 1))
+ (>= (2 1))
+ (NBZ (2 1))
+ (GT (3 1))
+ (> (3 1))
+ (NHZ (3 1))
+ (GTGTEQ (4 1))
+ (>>= (4 1))
+ (UV (4 1))
+ (NDC (4 1))
+ (GTGT (5 1))
+ (>> (5 1))
+ (VNZ (5 1))
+ (NSV (6 1))
+ (NBC (6 1))
+ (EV (7 1))
+ (NHC (7 1))))
+
+(define-integrable (tf-adjust opcode condition)
+ (+ opcode (* 2 (cadr condition))))
+
+(define (tf-adjust-inverted opcode condition)
+ (+ opcode (* 2 (- 1 (cadr condition)))))
+\f
+(define (make-operator name handler)
+ (lambda (value)
+ (if (exact-integer? value)
+ (handler value)
+ `(,name ,value))))
+
+(let-syntax ((define-operator
+ (macro (name handler)
+ `(define ,name
+ (make-operator ',name ,handler)))))
+
+(define-operator LEFT
+ (lambda (number)
+ (bit-string->signed-integer
+ (bit-substring (signed-integer->bit-string 32 number) 11 32))))
+
+(define-operator RIGHT
+ (lambda (number)
+ (bit-string->unsigned-integer
+ (bit-substring (signed-integer->bit-string 32 number) 0 11)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: instr2.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1987-1993 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. |#
+
+;;;; HP Spectrum Instruction Set Description
+;;; Originally from Walt Hill, who did the hard part.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Memory and offset operations
+
+;;; The long forms of many of the following instructions use register
+;;; 1 -- this may be inappropriate for assembly-language programs, but
+;;; is OK for the output of the compiler.
+(let-syntax ((long-load
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (OFFSET (? offset) (? space) (? base)) (? reg))
+ (VARIABLE-WIDTH (disp offset)
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 reg)
+ (2 space)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (ADDIL () L$,offset ,base)
+ (6 #x0A)
+ (5 base)
+ (21 (quotient disp #x800) ASSEMBLE21:X)
+ ;; (LDW () (OFFSET R$,offset ,space 1) ,reg)
+ (6 ,opcode)
+ (5 1)
+ (5 reg)
+ (2 space)
+ (14 (remainder disp #x800) RIGHT-SIGNED))))))))
+
+ (long-store
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (? reg) (OFFSET (? offset) (? space) (? base)))
+ (VARIABLE-WIDTH (disp offset)
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 reg)
+ (2 space)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (ADDIL () L$,offset ,base)
+ (6 #x0A)
+ (5 base)
+ (21 (quotient disp #x800) ASSEMBLE21:X)
+ ;; (STW () ,reg (OFFSET R$,offset ,space 1))
+ (6 ,opcode)
+ (5 1)
+ (5 reg)
+ (2 space)
+ (14 (remainder disp #x800) RIGHT-SIGNED))))))))
+
+ (load-offset
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (OFFSET (? offset) 0 (? base)) (? reg))
+ (VARIABLE-WIDTH (disp offset)
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 reg)
+ (2 #b00)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (ADDIL () L$,offset ,base)
+ (6 #x0A)
+ (5 base)
+ (21 (quotient disp #x800) ASSEMBLE21:X)
+ ;; (LDO () (OFFSET R$,offset 0 1) ,reg)
+ (6 ,opcode)
+ (5 1)
+ (5 reg)
+ (2 #b00)
+ (14 (remainder disp #x800) RIGHT-SIGNED))))))))
+
+ (load-immediate
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (? offset) (? reg))
+ (VARIABLE-WIDTH (disp offset)
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 0)
+ (5 reg)
+ (2 #b00)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (LDIL () L$,offset ,base)
+ (6 #x08)
+ (5 reg)
+ (21 (quotient disp #x800) ASSEMBLE21:X)
+ ;; (LDO () (OFFSET R$,offset 0 ,reg) ,reg)
+ (6 ,opcode)
+ (5 reg)
+ (5 reg)
+ (2 #b00)
+ (14 (remainder disp #x800) RIGHT-SIGNED))))))))
+
+ (left-immediate
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (? immed-21) (? reg))
+ (LONG (6 ,opcode)
+ (5 reg)
+ (21 immed-21 ASSEMBLE21:X)))))))
+
+ (long-load LDW #x12)
+ (long-load LDWM #x13)
+ (long-load LDH #x11)
+ (long-load LDB #x10)
+
+ (long-store STW #x1a)
+ (long-store STWM #x1b)
+ (long-store STH #x19)
+ (long-store STB #x18)
+
+ (load-offset LDO #x0d)
+ (load-immediate LDI #x0d) ; pseudo-op (LDO complt (OFFSET displ 0) reg)
+
+ (left-immediate LDIL #x08)
+ (left-immediate ADDIL #x0a))
+\f
+;; In the following, the middle completer field (2 bits) appears to be zero,
+;; according to the hardware. Also, the u-bit seems not to exist in the
+;; cache instructions.
+
+(let-syntax ((indexed-load
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl complx) (INDEX (? index-reg) (? space) (? base))
+ (? reg))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 index-reg)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b0)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg))))))
+
+ (indexed-store
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl complx) (? reg)
+ (INDEX (? index-reg) (? space) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 index-reg)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b0)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg))))))
+
+ (indexed-d-cache
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl m-val) (INDEX (? index-reg) (? space) (? base)))
+ (LONG (6 #x01)
+ (5 base)
+ (5 index-reg)
+ (2 space)
+ (8 ,extn)
+ (1 compl)
+ (5 #x0))))))
+
+ (indexed-i-cache
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl m-val)
+ (INDEX (? index-reg) (? space sr3) (? base)))
+ (LONG (6 #x01)
+ (5 base)
+ (5 index-reg)
+ (3 space)
+ (7 ,extn)
+ (1 compl)
+ (5 #x0)))))))
+
+ (indexed-load LDWX #x03 #x2)
+ (indexed-load LDHX #x03 #x1)
+ (indexed-load LDBX #x03 #x0)
+ (indexed-load LDCWX #x03 #x7)
+ (indexed-load FLDWX #x09 #x0)
+ (indexed-load FLDDX #x0B #x0)
+
+ (indexed-store FSTWX #x09 #x8)
+ (indexed-store FSTDX #x0b #x8)
+
+ (indexed-d-cache PDC #x4e)
+ (indexed-d-cache FDC #x4a)
+ (indexed-i-cache FIC #x0a)
+ (indexed-d-cache FDCE #x4b)
+ (indexed-i-cache FICE #x0b))
+\f
+(let-syntax ((scalr-short-load
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compls) (OFFSET (? offset) (? space) (? base))
+ (? reg))
+ (LONG (6 #x03)
+ (5 base)
+ (5 offset RIGHT-SIGNED)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b1)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg))))))
+
+ (scalr-short-store
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compls) (? reg)
+ (OFFSET (? offset) (? space) (? base)))
+ (LONG (6 #x03)
+ (5 base)
+ (5 reg)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b1)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 offset RIGHT-SIGNED))))))
+
+ (float-short-load
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl compls) (OFFSET (? offset) (? space) (? base))
+ (? reg))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 offset RIGHT-SIGNED)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b1)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg))))))
+\f
+ (float-short-store
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl compls) (? reg)
+ (OFFSET (? offset) (? space) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 offset RIGHT-SIGNED)
+ (2 space)
+ (1 (vector-ref compl 0))
+ (1 #b1)
+ (2 (vector-ref compl 1))
+ (4 ,extn)
+ (1 (vector-ref compl 2))
+ (5 reg)))))))
+
+ (scalr-short-load LDWS #x02)
+ (scalr-short-load LDHS #x01)
+ (scalr-short-load LDBS #x00)
+ (scalr-short-load LDCWS #x07)
+
+ (scalr-short-store STWS #x0a)
+ (scalr-short-store STHS #x09)
+ (scalr-short-store STBS #x08)
+ (scalr-short-store STBYS #x0c)
+
+ (float-short-load FLDWS #x09 #x00)
+ (float-short-load FLDDS #x0b #x00)
+
+ (float-short-store FSTWS #x09 #x08)
+ (float-short-store FSTDS #x0b #x08))
+\f
+;;;; Control transfer instructions
+
+;;; Note: For the time being the unconditionaly branch instructions are not
+;;; branch tensioned since their range is pretty large (1/2 Mbyte).
+;;; They should be eventually (by using an LDIL,LDI,BLR sequence, for example).
+
+(let-syntax ((branch&link
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (? reg) (@PCR (? label)))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 label PC-REL ASSEMBLE17:X)
+ (3 ,extn)
+ (11 label PC-REL ASSEMBLE17:Y)
+ (1 0)
+ (1 label PC-REL ASSEMBLE17:Z)))
+
+ (((N) (? reg) (@PCR (? label)))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 label PC-REL ASSEMBLE17:X)
+ (3 ,extn)
+ (11 label PC-REL ASSEMBLE17:Y)
+ (1 1)
+ (1 label PC-REL ASSEMBLE17:Z)))
+
+ ((() (? reg) (@PCO (? offset)))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 offset ASSEMBLE17:X)
+ (3 ,extn)
+ (11 offset ASSEMBLE17:Y)
+ (1 0)
+ (1 offset ASSEMBLE17:Z)))
+
+ (((N) (? reg) (@PCO (? offset)))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 offset ASSEMBLE17:X)
+ (3 ,extn)
+ (11 offset ASSEMBLE17:Y)
+ (1 1)
+ (1 offset ASSEMBLE17:Z))))))
+\f
+ (branch
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (@PCR (? l)))
+ (LONG (6 #x3a)
+ (5 #b00000)
+ (5 l PC-REL ASSEMBLE17:X)
+ (3 #b000)
+ (11 l PC-REL ASSEMBLE17:Y)
+ (1 0)
+ (1 l PC-REL ASSEMBLE17:Z)))
+
+ (((N) (@PCR (? l)))
+ (LONG (6 #x3a)
+ (5 #b00000)
+ (5 l PC-REL ASSEMBLE17:X)
+ (3 #b000)
+ (11 l PC-REL ASSEMBLE17:Y)
+ (1 1)
+ (1 l PC-REL ASSEMBLE17:Z)))
+
+ ((() (@PCO (? offset)))
+ (LONG (6 #x3a)
+ (5 #b00000)
+ (5 offset ASSEMBLE17:X)
+ (3 #b000)
+ (11 offset ASSEMBLE17:Y)
+ (1 0)
+ (1 offset ASSEMBLE17:Z)))
+
+ (((N) (@PCO (? offset)))
+ (LONG (6 #x3a)
+ (5 #b00000)
+ (5 offset ASSEMBLE17:X)
+ (3 #b000)
+ (11 offset ASSEMBLE17:Y)
+ (1 1)
+ (1 offset ASSEMBLE17:Z)))))))
+
+ (branch B 0) ; pseudo-op (BL complt 0 displ)
+ (branch&link BL 0)
+ (branch&link GATE 1))
+\f
+(let-syntax ((BV&BLR
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (? offset-reg) (? reg))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 offset-reg)
+ (3 ,extn)
+ (11 #b00000000000)
+ (1 0)
+ (1 #b0)))
+
+ (((N) (? offset-reg) (? reg))
+ (LONG (6 #x3a)
+ (5 reg)
+ (5 offset-reg)
+ (3 ,extn)
+ (11 #b00000000000)
+ (1 1)
+ (1 #b0))))))
+
+ (BE&BLE
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ ((() (OFFSET (? offset) (? space sr3) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 offset ASSEMBLE17:X)
+ (3 space)
+ (11 offset ASSEMBLE17:Y)
+ (1 0)
+ (1 offset ASSEMBLE17:Z)))
+
+ (((N) (OFFSET (? offset) (? space sr3) (? base)))
+ (LONG (6 ,opcode)
+ (5 base)
+ (5 offset ASSEMBLE17:X)
+ (3 space)
+ (11 offset ASSEMBLE17:Y)
+ (1 1)
+ (1 offset ASSEMBLE17:Z)))))))
+ (BV&BLR BLR 2)
+ (BV&BLR BV 6)
+ (BE&BLE BE #x38)
+ (BE&BLE BLE #x39))
+\f
+;;;; Conditional branch instructions
+
+#|
+
+Branch tensioning notes for the conditional branch instructions:
+
+The sequence
+
+ combt,cc r1,r2,label
+ instr1
+ instr2
+
+becomes
+
+ combf,cc,n r1,r2,tlabel ; pco = 0
+ b label ; no nullification
+tlabel instr1
+ instr2
+
+The sequence
+
+ combt,cc,n r1,r2,label
+ instr1
+ instr2
+
+becomes either
+
+ combf,cc,n r1,r2,tlabel ; pco = 0
+ b,n label ; nullification
+tlabel instr1
+ instr2
+
+when label is downstream (a forwards branch)
+
+or
+
+ combf,cc,n r1,r2,tlabel ; pco = 4
+ b label ; no nullification
+ instr1
+tlabel instr2
+
+when label is upstream (a backwards branch).
+
+This adjusting of the nullify bits, the pc offset, etc. for tlabel are
+performed by the utilities branch-extend-pco, branch-extend-disp, and
+branch-extend-nullify in instr1.
+|#
+\f
+;;;; Compare/compute and branch.
+
+(let-syntax
+ ((defccbranch
+ (macro (keyword completer opcode1 opcode2 opr1)
+ `(define-instruction ,keyword
+ (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCO (? offset)))
+ (LONG (6 ,opcode1)
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (cadr compl))
+ (11 offset ASSEMBLE12:X)
+ (1 (car compl))
+ (1 offset ASSEMBLE12:Y)))
+
+ (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCR (? l)))
+ (VARIABLE-WIDTH
+ (disp `(- ,l (+ *PC* 8)))
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode1)
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (cadr compl))
+ (11 disp ASSEMBLE12:X)
+ (1 (car compl))
+ (1 disp ASSEMBLE12:Y)))
+
+ ((() ())
+ ;; See page comment above.
+ (LONG (6 ,opcode2) ; COMBF
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (cadr compl))
+ (11 (branch-extend-pco disp (car compl)) ASSEMBLE12:X)
+ (1 1)
+ (1 (branch-extend-pco disp (car compl)) ASSEMBLE12:Y)
+
+ (6 #x3a) ; B
+ (5 0)
+ (5 (branch-extend-disp disp) ASSEMBLE17:X)
+ (3 0)
+ (11 (branch-extend-disp disp) ASSEMBLE17:Y)
+ (1 (branch-extend-nullify disp (car compl)))
+ (1 (branch-extend-disp disp) ASSEMBLE17:Z)))))))))
+
+ (define-macro (defcond name opcode1 opcode2 opr1)
+ `(defccbranch ,name complaltfb ,opcode1 ,opcode2 ,opr1))
+
+ (define-macro (defpseudo name opcode opr1)
+ `(defccbranch ,name complalb
+ (TF-adjust ,opcode (cdr compl))
+ (TF-adjust-inverted ,opcode (cdr compl))
+ ,opr1))
+
+ (defcond COMBT #x20 #x22 (reg-1))
+ (defcond COMBF #x22 #x20 (reg-1))
+ (defcond ADDBT #x28 #x2a (reg-1))
+ (defcond ADDBF #x2a #x28 (reg-1))
+
+ (defcond COMIBT #x21 #x23 (immed-5 right-signed))
+ (defcond COMIBF #x23 #x21 (immed-5 right-signed))
+ (defcond ADDIBT #x29 #x2b (immed-5 right-signed))
+ (defcond ADDIBF #x2b #x29 (immed-5 right-signed))
+
+ (defpseudo COMB #x20 (reg-1))
+ (defpseudo ADDB #x28 (reg-1))
+ (defpseudo COMIB #x21 (immed-5 right-signed))
+ (defpseudo ADDIB #x29 (immed-5 right-signed)))
+\f
+;;;; Pseudo branch instructions.
+
+#|
+
+These nullify the following instruction when the branch is taken.
+irrelevant of the sign of the displacement (unlike the real instructions).
+If the displacement is positive, they use the nullify bit.
+If the displacement is negative, they use a NOP.
+
+ combn,cc r1,r2,label
+
+becomes either
+
+ comb,cc,n r1,r2,label
+
+if label is downstream (forward branch)
+
+or
+
+ comb,cc r1,r2,label
+ nop
+
+if label is upstream (backward branch)
+
+If the displacement is too large, it becomes
+
+ comb,!cc,n r1,r2,tlabel ; pco = 0
+ b,n label
+tlabel
+
+Note: Only those currently used by the code generator are implemented.
+|#
+\f
+(let-syntax
+ ((defccbranch
+ (macro (keyword completer opcode1 opcode2 opr1)
+ `(define-instruction ,keyword
+ ;; No @PCO form.
+ ;; This is a pseudo-instruction used by the code-generator
+ (((? compl ,completer) (? ,(car opr1)) (? reg-2) (@PCR (? l)))
+ (VARIABLE-WIDTH
+ (disp `(- ,l (+ *PC* 8)))
+ ((0 #x1FFF)
+ ;; Forward branch. Nullify.
+ (LONG (6 ,opcode1) ; COMB,cc,n
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (car compl))
+ (11 disp ASSEMBLE12:X)
+ (1 1)
+ (1 disp ASSEMBLE12:Y)))
+
+ ((#x-2000 -1)
+ ;; Backward branch. No nullification, insert NOP.
+ (LONG (6 ,opcode1) ; COMB,cc
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (car compl))
+ (11 disp ASSEMBLE12:X)
+ (1 0)
+ (1 disp ASSEMBLE12:Y)
+
+ (6 #x02) ; NOP (OR 0 0 0)
+ (10 #b0000000000)
+ (3 0)
+ (1 0)
+ (7 #x12)
+ (5 #b00000)))
+
+ ((() ())
+ (LONG (6 ,opcode2) ; COMB!,n
+ (5 reg-2)
+ (5 ,@opr1)
+ (3 (car compl))
+ (11 0 ASSEMBLE12:X)
+ (1 1)
+ (1 0 ASSEMBLE12:Y)
+
+ (6 #x3a) ; B,n
+ (5 0)
+ (5 (branch-extend-disp disp) ASSEMBLE17:X)
+ (3 0)
+ (11 (branch-extend-disp disp) ASSEMBLE17:Y)
+ (1 1)
+ (1 (branch-extend-disp disp) ASSEMBLE17:Z)))))))))
+
+ (define-macro (defcond name opcode1 opcode2 opr1)
+ `(defccbranch ,name complaltf ,opcode1 ,opcode2 ,opr1))
+
+ (define-macro (defpseudo name opcode opr1)
+ `(defccbranch ,name complal
+ (TF-adjust ,opcode compl)
+ (TF-adjust-inverted ,opcode compl)
+ ,opr1))
+
+ (defcond COMIBTN #x21 #x23 (immed-5 right-signed))
+ (defcond COMIBFN #x23 #x21 (immed-5 right-signed))
+
+ (defpseudo COMIBN #x21 (immed-5 right-signed))
+ (defpseudo COMBN #x20 (reg-1)))
+\f
+;;;; Miscellaneous control
+
+(let-syntax
+ ((defmovb&bb
+ (macro (name opcode opr1 opr2 field2)
+ `(define-instruction ,name
+ (((? compl compledb) (? ,(car opr1)) ,@opr2 (@PCO (? offset)))
+ (LONG (6 ,opcode)
+ (5 ,field2)
+ (5 ,@opr1)
+ (3 (cdr compl))
+ (11 offset ASSEMBLE12:X)
+ (1 (car compl))
+ (1 offset ASSEMBLE12:Y)))
+
+ (((? compl compledb) (? ,(car opr1)) ,@opr2 (@PCR (? l)))
+ (VARIABLE-WIDTH
+ (disp `(- ,l (+ *PC* 8)))
+ ((#x-2000 #x1FFF)
+ (LONG (6 ,opcode)
+ (5 ,field2)
+ (5 ,@opr1)
+ (3 (cdr compl))
+ (11 l PC-REL ASSEMBLE12:X)
+ (1 (car compl))
+ (1 l PC-REL ASSEMBLE12:Y)))
+
+ ((() ())
+ ;; See page comment above.
+ (LONG (6 ,opcode) ; MOVB
+ (5 ,field2)
+ (5 ,@opr1)
+ (3 (branch-extend-edcc (cdr compl)))
+ (11 (branch-extend-pco disp (car compl)) ASSEMBLE12:X)
+ (1 1)
+ (1 (branch-extend-pco disp (car compl)) ASSEMBLE12:Y)
+
+ (6 #x3a) ; B
+ (5 0)
+ (5 (branch-extend-disp disp) ASSEMBLE17:X)
+ (3 0)
+ (11 (branch-extend-disp disp) ASSEMBLE17:Y)
+ (1 (branch-extend-nullify disp (car compl)))
+ (1 (branch-extend-disp disp) ASSEMBLE17:Z)))))))))
+
+
+ (defmovb&bb BVB #x30 (reg) () #b00000)
+ (defmovb&bb BB #x31 (reg) ((? pos)) pos)
+ (defmovb&bb MOVB #x32 (reg-1) ((? reg-2)) reg-2)
+ (defmovb&bb MOVIB #x33 (immed-5 right-signed) ((? reg-2)) reg-2))
+\f
+;;;; Assembler pseudo-ops
+
+(define-instruction USHORT
+ ((() (? high) (? low))
+ (LONG (16 high UNSIGNED)
+ (16 low UNSIGNED))))
+
+(define-instruction WORD
+ ((() (? expression))
+ (LONG (32 expression SIGNED))))
+
+(define-instruction UWORD
+ ((() (? expression))
+ (LONG (32 expression UNSIGNED))))
+
+(define-instruction EXTERNAL-LABEL
+ ((() (? format-word) (@PCR (? label)))
+ (LONG (16 format-word UNSIGNED)
+ (16 label BLOCK-OFFSET)))
+
+ ((() (? format-word) (@PCO (? offset)))
+ (LONG (16 format-word UNSIGNED)
+ (16 offset UNSIGNED))))
+
+(define-instruction PCR-HOOK
+ ((() (? target)
+ (OFFSET (? offset) (? space sr3) (? base))
+ (@PCR (? label)))
+ (VARIABLE-WIDTH
+ (disp `(- ,label (+ *PC* 8)))
+ ((#x-2000 #x1FFF)
+ (LONG
+ ;; (BLE () (OFFSET ,offset ,space ,base))
+ (6 #x39)
+ (5 base)
+ (5 offset ASSEMBLE17:X)
+ (3 space)
+ (11 offset ASSEMBLE17:Y)
+ (1 0)
+ (1 offset ASSEMBLE17:Z)
+ ;; (LDO () (OFFSET ,disp 0 31) ,target)
+ (6 #x0D)
+ (5 31)
+ (5 target)
+ (2 #b00)
+ (14 disp RIGHT-SIGNED)))
+ ((() ())
+ (LONG
+ ;; (LDIL () L$disp-8 target)
+ (6 #x08)
+ (5 1)
+ (21 (quotient (- disp 8) #x800) ASSEMBLE21:X)
+ ;; (LDO () (OFFSET R$disp-4 0 1) target)
+ (6 #x0D)
+ (5 1)
+ (5 1)
+ (2 #b00)
+ (14 (remainder (- disp 8) #x800) RIGHT-SIGNED)
+ ;; (BLE () (OFFSET ,offset ,space ,base))
+ (6 #x39)
+ (5 base)
+ (5 offset ASSEMBLE17:X)
+ (3 space)
+ (11 offset ASSEMBLE17:Y)
+ (1 0)
+ (1 offset ASSEMBLE17:Z)
+ ;; (ADD () 31 1 target)
+ (6 #x02)
+ (5 31)
+ (5 1)
+ (3 0)
+ (1 0)
+ (7 #x30)
+ (5 target))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/spectrum/instr3.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1987, 1989, 1990 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. |#
+
+;;;; HP Spectrum Instruction Set Description
+;;; Originally from Walt Hill, who did the hard part.
+
+(declare (usual-integrations))
+\f
+;;;; Computation instructions
+
+(let-syntax ((arith-logical
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl complal) (? source-reg1) (? source-reg2)
+ (? target-reg))
+ (LONG (6 #x02)
+ (5 source-reg2)
+ (5 source-reg1)
+ (3 (car compl))
+ (1 (cadr compl))
+ (7 ,extn)
+ (5 target-reg)))))))
+
+ (arith-logical ANDCM #x00)
+ (arith-logical AND #x10)
+ (arith-logical OR #x12)
+ (arith-logical XOR #x14)
+ (arith-logical UXOR #x1c)
+ (arith-logical SUB #x20)
+ (arith-logical DS #x22)
+ (arith-logical SUBT #x26)
+ (arith-logical SUBB #x28)
+ (arith-logical ADD #x30)
+ (arith-logical SH1ADD #x32)
+ (arith-logical SH2ADD #x34)
+ (arith-logical SH3ADD #x36)
+ (arith-logical ADDC #x38)
+ (arith-logical COMCLR #x44)
+ (arith-logical UADDCM #x4c)
+ (arith-logical UADDCMT #x4e)
+ (arith-logical ADDL #x50)
+ (arith-logical SH1ADDL #x52)
+ (arith-logical SH2ADDL #x54)
+ (arith-logical SH3ADDL #x56)
+ (arith-logical SUBO #x60)
+ (arith-logical SUBTO #x66)
+ (arith-logical SUBBO #x68)
+ (arith-logical ADDO #x70)
+ (arith-logical SH1ADDO #x72)
+ (arith-logical SH2ADDO #x74)
+ (arith-logical SH3ADDO #x76)
+ (arith-logical ADDCO #x78))
+
+;; WH Maybe someday. (Spec-DefOpcode DCOR 2048 DecimalCorrect) % 02
+;; (Spec-DefOpcode IDCOR 2048 DecimalCorrect) % 02
+\f
+;;;; Assembler pseudo-ops
+
+(define-instruction NOP ; pseudo-op: (OR complt 0 0 0)
+ (((? compl complal))
+ (LONG (6 #x02)
+ (10 #b0000000000)
+ (3 (car compl))
+ (1 (cadr compl))
+ (7 #x12)
+ (5 #b00000))))
+
+(define-instruction COPY ; pseudo-op (OR complt 0 s t)
+ (((? compl complal) (? source-reg) (? target-reg))
+ (LONG (6 #x02)
+ (5 #b00000)
+ (5 source-reg)
+ (3 (car compl))
+ (1 (cadr compl))
+ (7 #x12)
+ (5 target-reg))))
+
+(define-instruction SKIP ; pseudo-op (ADD complt 0 0 0)
+ (((? compl complal))
+ (LONG (6 #x02)
+ (10 #b0000000000)
+ (3 (car compl))
+ (1 (cadr compl))
+ (7 #x30)
+ (5 #b00000))))
+\f
+(let-syntax ((immed-arith
+ (macro (keyword opcode extn)
+ `(define-instruction ,keyword
+ (((? compl complal) (? immed-11) (? source-reg)
+ (? target-reg))
+ (LONG (6 ,opcode)
+ (5 source-reg)
+ (5 target-reg)
+ (3 (car compl))
+ (1 (cadr compl))
+ (1 ,extn)
+ (11 immed-11 RIGHT-SIGNED)))))))
+ (immed-arith ADDI #x2d 0)
+ (immed-arith ADDIO #x2d 1)
+ (immed-arith ADDIT #x2c 0)
+ (immed-arith ADDITO #x2c 1)
+ (immed-arith SUBI #x25 0)
+ (immed-arith SUBIO #x25 1)
+ (immed-arith COMICLR #x24 0))
+
+(define-instruction VSHD
+ (((? compl compled) (? source-reg1) (? source-reg2)
+ (? target-reg))
+ (LONG (6 #x34)
+ (5 source-reg2)
+ (5 source-reg1)
+ (3 compl)
+ (3 0)
+ (5 #b00000)
+ (5 target-reg))))
+
+(define-instruction SHD
+ (((? compl compled) (? source-reg1) (? source-reg2) (? pos)
+ (? target-reg))
+ (LONG (6 #x34)
+ (5 source-reg2)
+ (5 source-reg1)
+ (3 compl)
+ (3 2)
+ (5 (- 31 pos))
+ (5 target-reg))))
+
+(let-syntax ((extr (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? source-reg) (? pos) (? len)
+ (? target-reg))
+ (LONG (6 #x34)
+ (5 source-reg)
+ (5 target-reg)
+ (3 compl)
+ (3 ,extn)
+ (5 pos)
+ (5 (- 32 len)))))))
+ (vextr (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? source-reg) (? len)
+ (? target-reg))
+ (LONG (6 #x34)
+ (5 source-reg)
+ (5 target-reg)
+ (3 compl)
+ (3 ,extn)
+ (5 #b00000)
+ (5 (- 32 len))))))))
+ (extr EXTRU 6)
+ (extr EXTRS 7)
+ (vextr VEXTRU 4)
+ (vextr VEXTRS 5))
+\f
+(let-syntax ((depos
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? source-reg) (? pos) (? len)
+ (? target-reg))
+ (LONG (6 #x35)
+ (5 target-reg)
+ (5 source-reg)
+ (3 compl)
+ (3 ,extn)
+ (5 (- 31 pos))
+ (5 (- 32 len)))))))
+ (vdepos
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? source-reg) (? len)
+ (? target-reg))
+ (LONG (6 #x35)
+ (5 target-reg)
+ (5 source-reg)
+ (3 compl)
+ (3 ,extn)
+ (5 #b00000)
+ (5 (- 32 len)))))))
+ (idepos
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? immed) (? pos) (? len)
+ (? target-reg))
+ (LONG (6 #x35)
+ (5 target-reg)
+ (5 immed RIGHT-SIGNED)
+ (3 compl)
+ (3 ,extn)
+ (5 (- 31 pos))
+ (5 (- 32 len)))))))
+
+ (videpos
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ (((? compl compled) (? immed) (? len)
+ (? target-reg))
+ (LONG (6 #x35)
+ (5 target-reg)
+ (5 immed RIGHT-SIGNED)
+ (3 compl)
+ (3 ,extn)
+ (5 #b00000)
+ (5 (- 32 len))))))))
+
+ (idepos DEPI 7)
+ (idepos ZDEPI 6)
+ (videpos VDEPI 5)
+ (videpos ZVDEPI 4)
+ (depos DEP 3)
+ (depos ZDEP 2)
+ (vdepos VDEP 1)
+ (vdepos ZVDEP 0))
+\f
+(let-syntax ((Probe-Read-Write
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (OFFSET 0 (? space) (? base)) (? priv-reg)
+ (? target-reg))
+ (LONG (6 1)
+ (5 base)
+ (5 priv-reg)
+ (2 space)
+ (8 ,extn)
+ (1 #b0)
+ (5 target-reg)))))))
+ (Probe-Read-Write PROBER #x46)
+ (Probe-Read-Write PROBEW #x47)
+ (Probe-Read-Write PROBERI #xc6)
+ (Probe-Read-Write PROBEWI #xc7))
+
+(define-instruction BREAK
+ ((() (? immed-5) (? immed-13))
+ (LONG (6 #b000000)
+ (13 immed-13)
+ (8 #b00000000)
+ (5 immed-5))))
+
+(define-instruction LDSID
+ ((() (OFFSET 0 (? space) (? base)) (? target-reg))
+ (LONG (6 #b000000)
+ (5 base)
+ (5 #b00000)
+ (2 space)
+ (1 #b0)
+ (8 #x85)
+ (5 target-reg))))
+
+(define-instruction MTSP
+ ((() (? source-reg) (? space-reg sr3))
+ (LONG (6 #b000000)
+ (5 #b00000)
+ (5 source-reg)
+ (3 space-reg)
+ (8 #xc1)
+ (5 #b00000))))
+
+(define-instruction MTCTL
+ ((() (? source-reg) (? control-reg))
+ (LONG (6 #b000000)
+ (5 control-reg)
+ (5 source-reg)
+ (3 #b000)
+ (8 #xc2)
+ (5 #b00000))))
+
+(define-instruction MTSAR ; pseudo-oop (MTCLT () source 11)
+ ((() (? source-reg))
+ (LONG (6 #b000000)
+ (5 #x0b)
+ (5 source-reg)
+ (3 #b000)
+ (8 #xc2)
+ (5 #b00000))))
+\f
+(define-instruction MFSP
+ ((() (? space-reg sr3) (? target-reg))
+ (LONG (16 #b0000000000000000)
+ (3 space-reg)
+ (8 #x25)
+ (5 target-reg))))
+
+(define-instruction MFCTL
+ ((() (? control-reg) (? target-reg))
+ (LONG (6 #b000000)
+ (5 control-reg)
+ (5 #b00000)
+ (3 #b000)
+ (8 #x45)
+ (5 target-reg))))
+
+(define-instruction SYNC
+ ((())
+ (LONG (16 #b0000000000000000)
+ (3 #b000)
+ (8 #x20)
+ (5 #b00000))))
+
+#|
+Missing:
+
+LPA
+LHA
+PDTLB
+PITLB
+PDTLBE
+PITLBE
+IDTLBA
+IITLBA
+IDTLBP
+IITLBP
+DIAG
+
+|#
+\f
+(let-syntax ((floatarith-1
+ (macro (keyword extn-a extn-b)
+ `(define-instruction ,keyword
+ ((((? fmt fpformat)) (? source-reg) (? target-reg))
+ (LONG (6 #x0c)
+ (5 source-reg)
+ (5 #b00000)
+ (3 ,extn-a)
+ (2 fmt)
+ (2 ,extn-b)
+ (4 #b0000)
+ (5 target-reg))))))
+ (floatarith-2
+ (macro (keyword extn-a extn-b)
+ `(define-instruction ,keyword
+ ((((? fmt fpformat)) (? source-reg1) (? source-reg2)
+ (? target-reg))
+ (LONG (6 #x0c)
+ (5 source-reg1)
+ (5 source-reg2)
+ (3 ,extn-a)
+ (2 fmt)
+ (2 ,extn-b)
+ (4 #b0000)
+ (5 target-reg)))))))
+
+ (floatarith-2 FADD 0 3)
+ (floatarith-2 FSUB 1 3)
+ (floatarith-2 FMPY 2 3)
+ (floatarith-2 FDIV 3 3)
+ (floatarith-1 FSQRT 4 0)
+ (floatarith-1 FABS 3 0)
+ (floatarith-2 FREM 4 3)
+ (floatarith-1 FRND 5 0)
+ (floatarith-1 FCPY 2 0))
+
+(define-instruction FCMP
+ ((((? condition fpcond) (? fmt fpformat)) (? reg1) (? reg2))
+ (LONG (6 #x0c)
+ (5 reg1)
+ (5 reg2)
+ (3 #b000)
+ (2 fmt)
+ (6 #b100000)
+ (5 condition))))
+
+(let-syntax ((fpconvert
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((((? sf fpformat) (? df fpformat))
+ (? source-reg1)
+ (? reg-t))
+ (LONG (6 #x0c)
+ (5 source-reg1)
+ (4 #b0000)
+ (2 ,extn)
+ (2 df)
+ (2 sf)
+ (6 #b010000)
+ (5 reg-t)))))))
+ (fpconvert FCNVFF 0)
+ (fpconvert FCNVFX 1)
+ (fpconvert FCNVXF 2)
+ (fpconvert FCNVFXT 3))
+
+(define-instruction FTEST
+ ((())
+ (LONG (6 #x0c)
+ (10 #b0000000000)
+ (16 #b0010010000100000))))
+\f
+#|
+;; What SFU is this? -- Jinx
+
+;; WARNING The SFU instruction code below should be
+;; tested before use. WLH 11/18/86
+
+(let-syntax ((multdiv
+ (macro (keyword extn)
+ `(define-instruction ,keyword
+ ((() (? reg-1) (? reg-2))
+ (LONG (6 #x04)
+ (5 reg-2)
+ (5 reg-1)
+ (5 ,extn)
+ (11 #b11000000000)))))))
+ (multdiv MPYS #x08)
+ (multdiv MPYU #x0a)
+ (multdiv MPYSCV #x0c)
+ (multdiv MPYUCV #x0e)
+ (multdiv MPYACCS #x0d)
+ (multdiv MPYACCU #x0f)
+ (multdiv DIVSIR #x00)
+ (multdiv DIVSFR #x04)
+ (multdiv DIVUIR #x03)
+ (multdiv DIVUFR #x07)
+ (multdiv DIVSIM #x01)
+ (multdiv DIVSFM #x05)
+ (multdiv MDRR #x06))
+
+(define-instruction MDRO
+ ((() (? reg))
+ (LONG (6 #x04)
+ (5 reg)
+ (5 #b00000)
+ (16 #b1000000000000000))))
+
+(let-syntax ((multdivresult
+ (macro (keyword extn-a extn-b)
+ `(define-instruction ,keyword
+ ((() (? reg-t))
+ (LONG (6 #x04)
+ (10 #b0000000000)
+ (5 ,extn-a)
+ (5 #b01000)
+ (1 ,extn-b)
+ (5 reg-t)))))))
+ (multdivresult MDLO 4 0)
+ (multdivresult MDLNV 4 1)
+ (multdivresult MDLV 5 1)
+ (multdivresult MDL 5 0)
+ (multdivresult MDHO 6 0)
+ (multdivresult MDHNV 6 1)
+ (multdivresult MDHV 7 1)
+ (multdivresult MDH 7 0)
+ (multdivresult MDSFUID 0 0))
+|#
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lapgen.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; RTL Rules for HPPA. Shared utilities.
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Register-Allocator Interface
+
+(define (register->register-transfer source target)
+ (if (not (register-types-compatible? source target))
+ (error "Moving between incompatible register types" source target))
+ (case (register-type source)
+ ((GENERAL) (copy source target))
+ ((FLOAT) (fp-copy source target))
+ (else (error "unknown register type" source))))
+
+(define (home->register-transfer source target)
+ ;;! Until untagged-fixnums allowed object<->fixnum conversions to be
+ ;; elided the following test was not necessary because there would always
+ ;; be a conversion inbetween `thinking' about a register's home and
+ ;; moving the result to the return-value register. The real issue
+ ;; is that the return-value register always lives in a machine
+ ;; register and is never stored like the other pseudo-registers.
+ ;; ?Perhaps this behaviour ought to be (or is?) codified elsewhere?
+ (if (machine-register? source)
+ (register->register-transfer source target)
+ (memory->register-transfer (pseudo-register-displacement source)
+ regnum:regs-pointer
+ target)))
+
+(define (register->home-transfer source target)
+ ;;! See above.
+ (if (machine-register? target)
+ (register->register-transfer source target)
+ (register->memory-transfer source
+ (pseudo-register-displacement target)
+ regnum:regs-pointer)))
+
+(define (reference->register-transfer source target)
+ (case (ea/mode source)
+ ((GR)
+ (copy (register-ea/register source) target))
+ ((FPR)
+ (fp-copy (fpr->float-register (register-ea/register source)) target))
+ ((OFFSET)
+ (memory->register-transfer (offset-ea/offset source)
+ (offset-ea/register source)
+ target))
+ (else
+ (error "unknown effective-address mode" source))))
+
+(define (pseudo-register-home register)
+ ;; Register block consists of 16 4-byte registers followed by 256
+ ;; 8-byte temporaries.
+ (INST-EA (OFFSET ,(pseudo-register-displacement register)
+ 0
+ ,regnum:regs-pointer)))
+\f
+(define-integrable (sort-machine-registers registers)
+ registers)
+
+;; ***
+;; Note: fp16-fp31 only exist on PA-RISC 1.1 or later.
+;; If compiling for PA-RISC 1.0, truncate this
+;; list after fp15.
+;; ***
+
+(define available-machine-registers
+ ;; g1 removed from this list since it is the target of ADDIL,
+ ;; needed to expand some rules. g31 may want to be removed
+ ;; too.
+ (list
+ ;; g0 g1 g2 g3 g4 g5
+ g6 g7 g8 g9
+ g10 g11 g12 g13 g14 g15 g16 g17
+ ;; g18: holds '()
+ ;; g19 g20 g21 g22
+ g23 g24 ;; g25
+ g26
+ ;; g27
+ g28 g29
+ ;; g30
+ g31
+ ;; fp0 fp1 fp2 fp3
+ fp12 fp13 fp14 fp15
+ fp4 fp5 fp6 fp7 fp8 fp9 fp10 fp11
+ ;; The following are only available on newer processors
+ fp16 fp17 fp18 fp19 fp20 fp21 fp22 fp23
+ fp24 fp25 fp26 fp27 fp28 fp29 fp30 fp31
+ ))
+
+(define-integrable (float-register? register)
+ (eq? (register-type register) 'FLOAT))
+
+(define-integrable (general-register? register)
+ (eq? (register-type register) 'GENERAL))
+
+(define-integrable (word-register? register)
+ (eq? (register-type register) 'GENERAL))
+
+(define (register-types-compatible? type1 type2)
+ (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
+
+(define (register-type register)
+ (cond ((machine-register? register)
+ (vector-ref
+ '#(GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL GENERAL
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT
+ FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT FLOAT)
+ register))
+ ((register-value-class=word? register) 'GENERAL)
+ ((register-value-class=float? register) 'FLOAT)
+ (else (error "unable to determine register type" register))))
+
+(define register-reference
+ (let ((references (make-vector number-of-machine-registers)))
+ (let loop ((register 0))
+ (if (< register 32)
+ (begin
+ (vector-set! references register (INST-EA (GR ,register)))
+ (loop (1+ register)))))
+ (let loop ((register 32) (fpr 0))
+ (if (< register 64)
+ (begin
+ (vector-set! references register (INST-EA (FPR ,fpr)))
+ (loop (1+ register) (1+ fpr)))))
+ (lambda (register)
+ (vector-ref references register))))
+\f
+;;;; Useful Cliches
+
+(define (memory->register-transfer offset base target)
+ (case (register-type target)
+ ((GENERAL) (load-word offset base target))
+ ((FLOAT) (fp-load-doubleword offset base target))
+ (else (error "unknown register type" target))))
+
+(define (register->memory-transfer source offset base)
+ (case (register-type source)
+ ((GENERAL) (store-word source offset base))
+ ((FLOAT) (fp-store-doubleword source offset base))
+ (else (error "unknown register type" source))))
+
+(define (load-constant constant target)
+ ;; Load a Scheme constant into a machine register.
+ (if (or (eq? constant '()) (eq? constant #F))
+ (warn "load-constant: register constant slipped through:" constant))
+ (if (non-pointer-object? constant)
+ (load-immediate (non-pointer->literal constant) target)
+ (load-pc-relative (constant->label constant) target 'CONSTANT)))
+
+(define (load-non-pointer type datum target)
+ ;; Load a Scheme non-pointer constant, defined by type and datum,
+ ;; into a machine register.
+ (load-immediate (make-non-pointer-literal type datum) target))
+
+(define (non-pointer->literal constant)
+ (make-non-pointer-literal (target-object-type constant)
+ (careful-object-datum constant)))
+
+(define-integrable (make-non-pointer-literal type datum)
+ (let ((unsigned-value (+ (* type type-scale-factor) datum)))
+ (if (<= unsigned-value #x7FFFFFFF)
+ unsigned-value
+ (- unsigned-value #x100000000))))
+
+(define-integrable type-scale-factor
+ ;; (expt 2 scheme-datum-width) ***
+ #x4000000)
+
+(define-integrable (deposit-type type target)
+ (adjust-type #F type target))
+\f
+;;;; Regularized Machine Instructions
+
+(define (copy r t)
+ (if (= r t)
+ (LAP)
+ (LAP (COPY () ,r ,t))))
+
+(define-integrable ldil-scale
+ ;; (expt 2 11) ***
+ 2048)
+
+(define (load-immediate i t)
+ (if (fits-in-14-bits-signed? i)
+ (LAP (LDI () ,i ,t))
+ (let ((split (integer-divide i ldil-scale)))
+ (LAP (LDIL () ,(integer-divide-quotient split) ,t)
+ ,@(let ((r%i (integer-divide-remainder split)))
+ (if (zero? r%i)
+ (LAP)
+ (LAP (LDO () (OFFSET ,r%i 0 ,t) ,t))))))))
+
+(define (deposit-immediate i p len t)
+ (cond ((fits-in-5-bits-signed? i)
+ (LAP (DEPI () ,i ,p ,len ,t)))
+ ((and (<= len 5)
+ (fix:fixnum? i))
+ (LAP (DEPI () ,(fix:- (fix:xor (fix:and i #b11111) #b10000) #b10000)
+ ,p ,len ,t)))
+ ((and (= len scheme-type-width)
+ (fits-in-5-bits-signed? (- i (1+ max-type-code))))
+ (LAP (DEPI () ,(- i (1+ max-type-code)) ,p ,len ,t)))
+ ;;((machine-register-containing-value-satifying
+ ;; (lambda (v) (and (fix:fixnum? v)
+ ;; (= i (fix:and v max-type-code)))))
+ ;; => (lambda (reg)
+ ;; (LAP (DEP () ,reg ,p ,len ,t))))
+ ((= i quad-mask-value)
+ (LAP (DEP () ,regnum:quad-bitmask ,p ,len ,t)))
+ (else
+ (LAP ,@(load-immediate i regnum:addil-result)
+ (DEP () ,regnum:addil-result ,p ,len ,t)))))
+
+(define (load-offset d b t)
+ (cond ((and (zero? d) (= b t))
+ (LAP))
+ ((fits-in-14-bits-signed? d)
+ (LAP (LDO () (OFFSET ,d 0 ,b) ,t)))
+ (else
+ (let ((split (integer-divide d ldil-scale)))
+ (LAP (ADDIL () ,(integer-divide-quotient split) ,b)
+ (LDO () (OFFSET ,(integer-divide-remainder split) 0 1) ,t))))))
+
+(define (load-word d b t)
+ (if (fits-in-14-bits-signed? d)
+ (LAP (LDW () (OFFSET ,d 0 ,b) ,t))
+ (let ((split (integer-divide d ldil-scale)))
+ (LAP (ADDIL () ,(integer-divide-quotient split) ,b)
+ (LDW () (OFFSET ,(integer-divide-remainder split) 0 1) ,t)))))
+
+(define (load-byte d b t)
+ (if (fits-in-14-bits-signed? d)
+ (LAP (LDB () (OFFSET ,d 0 ,b) ,t))
+ (let ((split (integer-divide d ldil-scale)))
+ (LAP (ADDIL () ,(integer-divide-quotient split) ,b)
+ (LDB () (OFFSET ,(integer-divide-remainder split) 0 1) ,t)))))
+
+(define (store-word b d t)
+ (if (fits-in-14-bits-signed? d)
+ (LAP (STW () ,b (OFFSET ,d 0 ,t)))
+ (let ((split (integer-divide d ldil-scale)))
+ (LAP (ADDIL () ,(integer-divide-quotient split) ,t)
+ (STW () ,b (OFFSET ,(integer-divide-remainder split) 0 1))))))
+
+(define (store-byte b d t)
+ (if (fits-in-14-bits-signed? d)
+ (LAP (STB () ,b (OFFSET ,d 0 ,t)))
+ (let ((split (integer-divide d ldil-scale)))
+ (LAP (ADDIL () ,(integer-divide-quotient split) ,t)
+ (STB () ,b (OFFSET ,(integer-divide-remainder split) 0 1))))))
+\f
+(define (fp-copy r t)
+ (if (= r t)
+ (LAP)
+ (LAP (FCPY (DBL) ,(float-register->fpr r) ,(float-register->fpr t)))))
+
+(define (fp-load-doubleword d b t)
+ (let ((t (float-register->fpr t)))
+ (if (fits-in-5-bits-signed? d)
+ (LAP (FLDDS () (OFFSET ,d 0 ,b) ,t))
+ (LAP ,@(load-offset d b regnum:addil-result)
+ (FLDDS () (OFFSET 0 0 ,regnum:addil-result) ,t)))))
+
+(define (fp-store-doubleword r d b)
+ (let ((r (float-register->fpr r)))
+ (if (fits-in-5-bits-signed? d)
+ (LAP (FSTDS () ,r (OFFSET ,d 0 ,b)))
+ (LAP ,@(load-offset d b regnum:addil-result)
+ (FSTDS () ,r (OFFSET 0 0 ,regnum:addil-result))))))
+
+#|
+(define (load-pc-relative label target type)
+ type ; ignored
+ ;; Load a pc-relative location's contents into a machine register.
+ ;; This assumes that the offset fits in 14 bits!
+ ;; We should have a pseudo-op for LDW that does some "branch" tensioning.
+ (LAP (BL () ,regnum:addil-result (@PCO 0))
+ ;; Clear the privilege level, making this a memory address.
+ (DEP () 0 31 2 ,regnum:addil-result)
+ (LDW () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target)))
+
+(define (load-pc-relative-address label target type)
+ type ; ignored
+ ;; Load a pc-relative address into a machine register.
+ ;; This assumes that the offset fits in 14 bits!
+ ;; We should have a pseudo-op for LDO that does some "branch" tensioning.
+ (LAP (BL () ,regnum:addil-result (@PCO 0))
+ ;; Clear the privilege level, making this a memory address.
+ (DEP () 0 31 2 ,regnum:addil-result)
+ (LDO () (OFFSET (- ,label *PC*) 0 ,regnum:addil-result) ,target)))
+|#
+\f
+;; These versions of load-pc-... remember what they obtain, to avoid
+;; doing the sequence multiple times.
+;; In addition, they assume that the code is running in the least
+;; privilege, and avoid the DEP in the sequences above.
+
+(define-integrable *privilege-level* 3)
+
+(define-integrable (close? label label*)
+ ;; Heuristic
+ label label* ; ignored
+ compiler:compile-by-procedures?)
+
+(define (load-pc-relative label target type)
+ (load-pc-relative-internal label target type
+ (lambda (offset base target)
+ (LAP (LDW () (OFFSET ,offset 0 ,base)
+ ,target)))))
+
+(define (load-pc-relative-address label target type)
+ (load-pc-relative-internal label target type
+ (lambda (offset base target)
+ (LAP (LDO () (OFFSET ,offset 0 ,base)
+ ,target)))))
+
+(define (load-pc-relative-internal label target type gen)
+ (with-values (lambda () (get-typed-label type))
+ (lambda (label* alias type*)
+ (define (closer label* alias)
+ (let ((temp (standard-temporary!)))
+ (set-typed-label! type label temp)
+ (LAP (LDO () (OFFSET (- ,label ,label*) 0 ,alias) ,temp)
+ ,@(gen 0 temp target))))
+
+ (cond ((not label*)
+ (let ((temp (standard-temporary!))
+ (here (generate-label)))
+ (let ((value `(+ ,here ,(+ 8 *privilege-level*))))
+ (set-typed-label! 'CODE value temp)
+ (LAP (LABEL ,here)
+ (BL () ,temp (@PCO 0))
+ ,@(if (or (eq? type 'CODE) (close? label label*))
+ (gen (INST-EA (- ,label ,value)) temp target)
+ (closer value temp))))))
+ ((or (eq? type* type) (close? label label*))
+ (gen (INST-EA (- ,label ,label*)) alias target))
+ (else
+ (closer label* alias))))))
+\f
+;;; Typed labels provide further optimization. There are two types,
+;;; CODE and CONSTANT, that say whether the label is located in the
+;;; code block or the constants block of the output. Statistically,
+;;; a label is likely to be closer to another label of the same type
+;;; than to a label of the other type.
+
+(define (get-typed-label type)
+ (let ((entries (register-map-labels *register-map* 'GENERAL)))
+ (let loop ((entries* entries))
+ (cond ((null? entries*)
+ ;; If no entries of the given type, use any entry that is
+ ;; available.
+ (let loop ((entries entries))
+ (cond ((null? entries)
+ (values false false false))
+ ((pair? (caar entries))
+ (values (cdaar entries) (cadar entries) (caaar entries)))
+ (else
+ (loop (cdr entries))))))
+ ((and (pair? (caar entries*))
+ (eq? type (caaar entries*)))
+ (values (cdaar entries*) (cadar entries*) type))
+ (else
+ (loop (cdr entries*)))))))
+
+(define (set-typed-label! type label alias)
+ (set! *register-map*
+ (set-machine-register-label *register-map* alias (cons type label)))
+ unspecific)
+\f
+;; COMIBTN, COMIBFN, and COMBN are pseudo-instructions that nullify
+;; the following instruction when the branch is taken. Since COMIBT,
+;; etc. nullify according to the sign of the displacement, the branch
+;; tensioner inserts NOPs as necessary (backward branches).
+
+(define (compare-immediate cc i r2)
+ (cond ((zero? i)
+ (compare cc 0 r2))
+ ((fits-in-5-bits-signed? i)
+ (let* ((inverted? (memq cc '(TR <> >= > >>= >> NSV EV
+ LTGT GTEQ GT GTGTEQ GTGT)))
+ (cc (if inverted? (invert-condition cc) cc))
+ (set-branches!
+ (lambda (if-true if-false)
+ (if inverted?
+ (set-current-branches! if-false if-true)
+ (set-current-branches! if-true if-false)))))
+
+ (set-branches!
+ (lambda (label)
+ (LAP (COMIBTN (,cc) ,i ,r2 (@PCR ,label))))
+ (lambda (label)
+ (LAP (COMIBFN (,cc) ,i ,r2 (@PCR ,label)))))
+ (LAP)))
+ ((fits-in-11-bits-signed? i)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (COMICLR (,(invert-condition cc)) ,i ,r2 0)
+ (B (N) (@PCR ,label))))
+ (lambda (label)
+ (LAP (COMICLR (,cc) ,i ,r2 0)
+ (B (N) (@PCR ,label)))))
+ (LAP))
+ (else
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-immediate i temp)
+ ,@(compare cc temp r2))))))
+
+(define (compare condition r1 r2)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (COMBN (,condition) ,r1 ,r2 (@PCR ,label))))
+ (lambda (label)
+ (LAP (COMBN (,(invert-condition condition)) ,r1 ,r2 (@PCR ,label)))))
+ (LAP))
+\f
+;;;; Conditions
+
+(define (invert-condition condition)
+ (let ((place (assq condition condition-inversion-table)))
+ (if (not place)
+ (error "unknown condition" condition))
+ (cadr place)))
+
+(define (invert-condition-noncommutative condition)
+ (let ((place (assq condition condition-inversion-table)))
+ (if (not place)
+ (error "unknown condition" condition))
+ (caddr place)))
+
+(define condition-inversion-table
+ '((= <> =)
+ (< >= >)
+ (> <= <)
+ (NUV UV NUV)
+ (TR NV TR)
+ (<< >>= >>)
+ (>> <<= <<)
+ (<> = <>)
+ (<= > >=)
+ (>= < <=)
+ (<<= >> >>=)
+ (>>= << <<=)
+ (NV TR NV)
+ (EQ LTGT EQ)
+ (LT GTEQ GT)
+ (SBZ NBZ SBZ)
+ (LTEQ GT GTEQ)
+ (SHZ NHZ SHZ)
+ (LTLT GTGTEQ GTGT)
+ (SDC NDC SDC)
+ (LTLTEQ GTGT GTGTEQ)
+ (ZNV VNZ ZNV)
+ (SV NSV SV)
+ (SBC NBC SBC)
+ (OD EV OD)
+ (SHC NHC SHC)
+ (LTGT EQ LTGT)
+ (GTEQ LT LTEQ)
+ (NBZ SBZ NBZ)
+ (GT LTEQ LT)
+ (NHZ SHZ NHZ)
+ (GTGTEQ LTLT LTLTEQ)
+ (UV NUV UV)
+ (NDC SDC NDC)
+ (GTGT LTLTEQ LTLT)
+ (VNZ ZNV NVZ)
+ (NSV SV NSV)
+ (NBC SBC NBC)
+ (EV OD EV)
+ (NHC SHC NHC)))
+\f
+;;;; Miscellaneous
+
+(define-integrable (object->datum src tgt)
+ (LAP (ZDEP () ,src 31 ,scheme-datum-width ,tgt)))
+
+(define (adjust-type from to reg)
+ ;; FROM is either a typecode if it is known that reg has that typecode,
+ ;; else it is #F. TO is a constant desired typecode
+ (cond ((eqv? from to)
+ (LAP))
+ ((or (false? from)
+ (fits-in-5-bits-signed? to)
+ (and (= scheme-type-width 6)
+ (<= (- max-type-code 15) to max-type-code)))
+ (deposit-immediate TO
+ (-1+ scheme-type-width)
+ scheme-type-width
+ reg))
+ (;; the msb is the same in both so we dont need to change it and the
+ ;; remaining bits can be set with a single DEPI
+ ;; this happens with values of the form #01xxxx
+ (and (= scheme-type-width 6)
+ (fix:= 0 (fix:and (fix:xor from to) #b100000)))
+ (deposit-immediate (fix:and TO #b011111)
+ (-1+ scheme-type-width)
+ (-1+ scheme-type-width)
+ reg))
+ (;; If the lsb is the same in both we can just set the msbs
+ (and (= scheme-type-width 6)
+ (fix:= 0 (fix:and (fix:xor from to) #b000001)))
+ (deposit-immediate (fix:lsh TO -1)
+ (- scheme-type-width 2)
+ (-1+ scheme-type-width)
+ reg))
+ (else
+ (deposit-immediate TO
+ (-1+ scheme-type-width)
+ scheme-type-width
+ reg))))
+
+(define-integrable (object->address reg)
+ (adjust-type #F quad-mask-value reg))
+
+(define-integrable (object->type src tgt)
+ (LAP (EXTRU () ,src ,(-1+ scheme-type-width) ,scheme-type-width ,tgt)))
+
+(define (standard-unary-conversion source target conversion)
+ ;; `source' is any register, `target' a pseudo register.
+ (let ((source (standard-source! source)))
+ (conversion source (standard-target! target))))
+
+(define (standard-binary-conversion source1 source2 target conversion)
+ ;; The sources are any register, `target' a pseudo register.
+ (let ((source1 (standard-source! source1))
+ (source2 (standard-source! source2)))
+ (conversion source1 source2 (standard-target! target))))
+
+(define (standard-source! register)
+ (load-alias-register! register (register-type register)))
+
+(define (standard-target! register)
+ (delete-dead-registers!)
+ (allocate-alias-register! register (register-type register)))
+
+(define-integrable (standard-temporary!)
+ (allocate-temporary-register! 'GENERAL))
+
+(define (standard-move-to-target! source target)
+ (move-to-alias-register! source (register-type source) target))
+
+(define (standard-move-to-temporary! source)
+ (move-to-temporary-register! source (register-type source)))
+
+(define (register-expression expression)
+ (case (rtl:expression-type expression)
+ ((REGISTER)
+ (rtl:register-number expression))
+ ((CONSTANT)
+ (let ((object (rtl:constant-value expression)))
+ (cond ((and (zero? (object-type object))
+ (zero? (object-datum object)))
+ 0)
+ ((eq? object #F)
+ regnum:false-value)
+ ((eq? object '())
+ regnum:empty-list)
+ (else
+ false))))
+ ((MACHINE-CONSTANT)
+ (let ((value (rtl:machine-constant-value expression)))
+ (cond ((zero? value)
+ 0)
+ (else
+ false))))
+ ((CONS-POINTER)
+ (and (let ((type (rtl:cons-pointer-type expression)))
+ (and (rtl:machine-constant? type)
+ (zero? (rtl:machine-constant-value type))))
+ (let ((datum (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? datum)
+ (zero? (rtl:machine-constant-value datum))))
+ 0))
+ (else false)))
+\f
+(define (define-arithmetic-method operator methods method)
+ (let ((entry (assq operator (cdr methods))))
+ (if entry
+ (set-cdr! entry method)
+ (set-cdr! methods (cons (cons operator method) (cdr methods)))))
+ operator)
+
+(define (lookup-arithmetic-method operator methods)
+ (cdr (or (assq operator (cdr methods))
+ (error "Unknown operator" operator))))
+
+(define-integrable (arithmetic-method? operator methods)
+ (assq operator (cdr methods)))
+
+(define (fits-in-5-bits-signed? value)
+ (<= #x-10 value #xF))
+
+(define (fits-in-11-bits-signed? value)
+ (<= #x-400 value #x3FF))
+
+(define (fits-in-14-bits-signed? value)
+ (<= #x-2000 value #x1FFF))
+
+(define-integrable (ea/mode ea) (car ea))
+(define-integrable (register-ea/register ea) (cadr ea))
+(define-integrable (offset-ea/offset ea) (cadr ea))
+(define-integrable (offset-ea/space ea) (caddr ea))
+(define-integrable (offset-ea/register ea) (cadddr ea))
+
+(define (pseudo-register-displacement register)
+ ;; Register block consists of 16 4-byte registers followed by 256
+ ;; 8-byte temporaries.
+ (+ (* 4 16) (* 8 (register-renumber register))))
+
+(define (pseudo-register-offset register)
+ ;; Like above, but in words.
+ ;;dubious. using register-renumber expects an bound *current-rgraph*
+ (+ 16 (* 2 register)))
+
+(define-integrable (float-register->fpr register)
+ ;; Float registers are represented by 32 through 47/63 in the RTL,
+ ;; corresponding to registers 0 through 15/31 in the machine.
+ (- register 32))
+
+(define-integrable (fpr->float-register register)
+ (+ register 32))
+
+(define-integrable reg:memtop
+ (INST-EA (OFFSET #x0000 0 ,regnum:regs-pointer)))
+
+(define-integrable reg:environment
+ (INST-EA (OFFSET #x000C 0 ,regnum:regs-pointer)))
+
+(define-integrable reg:lexpr-primitive-arity
+ (INST-EA (OFFSET #x001C 0 ,regnum:regs-pointer)))
+
+(define-integrable reg:stack-guard
+ (INST-EA (OFFSET #x002C 0 ,regnum:regs-pointer)))
+
+(define (lap:make-label-statement label)
+ (LAP (LABEL ,label)))
+
+(define (lap:make-unconditional-branch label)
+ (LAP (B (N) (@PCR ,label))))
+
+(define (lap:make-entry-point label block-start-label)
+ block-start-label
+ (LAP (ENTRY-POINT ,label)
+ ,@(make-external-label expression-code-word label)))
+\f
+;;;; Codes and Hooks
+
+(let-syntax ((define-codes
+ (macro (start . names)
+ (define (loop names index assocs)
+ (if (null? names)
+ '() ;;`((DEFINE CODE:COMPILER-XXX-ALIST ',assocs))
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'CODE:COMPILER-
+ (car names))
+ ,index)
+ (loop (cdr names) (1+ index)
+ (cons (cons index (car names)) assocs)))))
+ `(BEGIN ,@(loop names start '())))))
+ ;; Remember to duplicate changes to this list to the copy in dassm1.scm
+ (define-codes #x012
+ primitive-apply primitive-lexpr-apply
+ apply error lexpr-apply link
+ interrupt-closure interrupt-dlink interrupt-procedure
+ interrupt-continuation interrupt-ic-procedure
+ assignment-trap cache-reference-apply
+ reference-trap safe-reference-trap unassigned?-trap
+ -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
+ access lookup safe-lookup unassigned? unbound?
+ set! define lookup-apply primitive-error
+ quotient remainder modulo
+ reflect-to-interface interrupt-continuation-2
+ compiled-code-bkpt compiled-closure-bkpt
+ new-interrupt-procedure))
+
+(define-integrable (invoke-interface-ble code)
+ ;; Jump to scheme-to-interface-ble
+ (LAP (BLE () (OFFSET 0 4 ,regnum:scheme-to-interface-ble))
+ (LDI () ,code 28)))
+
+;;; trampoline-to-interface uses (OFFSET 4 4 ,regnum:scheme-to-interface-ble)
+
+(define-integrable (invoke-interface code)
+ ;; Jump to scheme-to-interface
+ (LAP (BLE () (OFFSET 12 4 ,regnum:scheme-to-interface-ble))
+ (LDI () ,code 28)))
+\f
+(let-syntax ((define-hooks
+ (macro (start . names)
+ (define (loop names index assocs)
+ (if (null? names)
+ '() ;;`((DEFINE HOOK:COMPILER-XXX-ALIST ',assocs))
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'HOOK:COMPILER-
+ (car names))
+ ,index)
+ (loop (cdr names) (+ 8 index)
+ (cons (cons index (car names)) assocs)))))
+ `(BEGIN ,@(loop names start '())))))
+ ;; Remember to copy this list to dassm1.scm if you change it.
+ (define-hooks 100
+ store-closure-code
+ store-closure-entry ; newer version of store-closure-code.
+ multiply-fixnum
+ fixnum-quotient
+ fixnum-remainder
+ fixnum-lsh
+ &+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ shortcircuit-apply
+ shortcircuit-apply-1
+ shortcircuit-apply-2
+ shortcircuit-apply-3
+ shortcircuit-apply-4
+ shortcircuit-apply-5
+ shortcircuit-apply-6
+ shortcircuit-apply-7
+ shortcircuit-apply-8
+ stack-and-interrupt-check
+ invoke-primitive
+ vector-cons
+ string-allocate
+ floating-vector-cons
+ flonum-sin
+ flonum-cos
+ flonum-tan
+ flonum-asin
+ flonum-acos
+ flonum-atan
+ flonum-exp
+ flonum-log
+ flonum-truncate
+ flonum-ceiling
+ flonum-floor
+ flonum-atan2
+ compiled-code-bkpt
+ compiled-closure-bkpt
+ copy-closure-pattern
+ copy-multiclosure-pattern
+ closure-entry-bkpt-hook
+ interrupt-procedure/new
+ interrupt-continuation/new
+ interrupt-closure/new
+ quotient
+ remainder
+ interpreter-call))
+\f
+;; There is a NOP here because otherwise the return address would have
+;; to be adjusted by the hook code. This gives more flexibility to the
+;; compiler since it may be able to eliminate the NOP by moving an
+;; instruction preceding the BLE to the delay slot.
+
+(define (invoke-hook hook)
+ (LAP (BLE () (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble))
+ (NOP ())))
+
+;; This is used when not returning. It uses BLE instead of BE as a debugging
+;; aid. The hook gets a return address pointing to the caller, even
+;; though the code will not return.
+
+(define (invoke-hook/no-return hook)
+ (LAP (BLE (N) (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble))))
+
+(define (require-registers! . regs)
+ (let ((code (apply clean-registers! regs)))
+ (need-registers! regs)
+ code))
+
+(define (load-interface-args! first second third fourth)
+ (let ((clear-regs
+ (apply clear-registers!
+ (append (if first (list regnum:first-arg) '())
+ (if second (list regnum:second-arg) '())
+ (if third (list regnum:third-arg) '())
+ (if fourth (list regnum:fourth-arg) '()))))
+ (load-reg
+ (lambda (arg reg)
+ (if arg (load-machine-register! arg reg) (LAP)))))
+ (let ((load-regs
+ (LAP ,@(load-reg first regnum:first-arg)
+ ,@(load-reg second regnum:second-arg)
+ ,@(load-reg third regnum:third-arg)
+ ,@(load-reg fourth regnum:fourth-arg))))
+ (LAP ,@clear-regs
+ ,@load-regs
+ ,@(clear-map!)))))
+
+(define (%load-interface-args! first second third fourth)
+ (let* ((load-reg
+ (lambda (arg reg)
+ (if arg
+ (load-machine-register! arg reg)
+ (clean-registers! reg))))
+ (load-one (load-reg first regnum:first-arg))
+ (load-two (load-reg second regnum:second-arg))
+ (load-three (load-reg third regnum:third-arg))
+ (load-four (load-reg fourth regnum:fourth-arg)))
+ (LAP ,@load-one
+ ,@load-two
+ ,@load-three
+ ,@load-four)))
+
+(define (->machine-register source machine-reg)
+ (let ((code (load-machine-register! source machine-reg)))
+ ;; Prevent it from being allocated again.
+ (need-register! machine-reg)
+ code))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lapopt.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1991-1994 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. |#
+
+;;;; LAP Optimizer for HP Precision Archtecture.
+;; package: (compiler lap-optimizer)
+
+(declare (usual-integrations))
+\f
+;;;; An instruction classifier and decomposer
+
+(define-integrable (float-reg reg)
+ (+ 32 reg))
+
+(define (classify-instruction instr)
+ ;; (values type writes reads offset)
+ ;; The types are ALU, MEMORY, FALU (floating ALU), CONTROL
+ (let ((opcode (car instr)))
+ (case opcode
+ ((ANDCM AND OR XOR UXOR SUB DS SUBT
+ SUBB ADD SH1ADD SH2ADD SH3ADD ADDC
+ COMCLR UADDCM UADDCMT ADDL SH1ADDL
+ SH2ADDL SH3ADDL SUBO SUBTO SUBBO
+ ADDO SH1ADDO SH2ADDO SH3ADDO ADDCO
+ VSHD SHD)
+ ;; operator conditions source source ... target
+ (values 'ALU
+ ;; not (list-ref instr 4)
+ (list (car (last-pair instr))) ; Skip the "..."
+ (list (list-ref instr 2) (list-ref instr 3))
+ false))
+ ((ADDI ADDIO ADDIT ADDITO SUBI SUBIO COMICLR)
+ ;; operator conditions immed source target
+ (values 'ALU
+ (list (list-ref instr 4))
+ (list (list-ref instr 3))
+ false))
+ ((COPY)
+ ;; operator conditions source target
+ (values 'ALU
+ (list (list-ref instr 3))
+ (list (list-ref instr 2))
+ false))
+
+ ((LDW LDB LDO LDH)
+ ;; operator completer (offset bytes space source) target
+ ;; the completer isn't actually used!
+ (let ((offset (list-ref instr 2)))
+ (values (if (eq? opcode 'LDO)
+ 'ALU
+ 'MEMORY)
+ (list (list-ref instr 3))
+ (list (cadddr offset))
+ (cadr offset))))
+ ((LDWM)
+ ;; operator completer (offset bytes space target/source) target
+ ;; Notice that this writes BOTH registers: one from memory
+ ;; contents, the other by adding the offset to the register
+ (let* ((offset (list-ref instr 2))
+ (base (cadddr offset)))
+ (values 'MEMORY
+ (list base (list-ref instr 3))
+ (list base)
+ (cadr offset))))
+ ((LDWS LDHS LDBS LDWAS LDCWS)
+ ;; operator completer (offset bytes space target/source) target
+ (let* ((completer (cadr instr))
+ (offset (list-ref instr 2))
+ (base (cadddr offset)))
+ (values 'MEMORY
+ (cons (list-ref instr 3)
+ (if (or (memq 'MA completer)
+ (memq 'MB completer))
+ (list base)
+ '()))
+ (list base)
+ (cadr offset))))
+\f
+ ((LDWX LDHX LDBX LDWAX LDCWX)
+ ;; operator completer (INDEX source1 m source2/target) target
+ (let* ((completer (cadr instr))
+ (index (list-ref instr 2))
+ (base (cadddr index)))
+ (values 'MEMORY
+ (cons (list-ref instr 3)
+ (if (or (memq 'M completer)
+ (memq 'SM completer))
+ (list base)
+ '()))
+ (list (cadr index) base)
+ false)))
+ ((STW STB STH)
+ ;; operator completer source1 (offset bytes space source2)
+ (let ((offset (list-ref instr 3)))
+ (values 'MEMORY
+ '()
+ (list (list-ref instr 2) (cadddr offset))
+ (cadr offset))))
+ ((STWM)
+ ;; operator completer source1 (offset n m target/source)
+ (let* ((offset (list-ref instr 3))
+ (base (cadddr offset)))
+ (values 'MEMORY
+ (list base)
+ (list (list-ref instr 2) base)
+ (cadr offset))))
+ ((STWS STHS STBS STWAS)
+ ;; operator completer source1 (offset n m target/source)
+ (let* ((offset (list-ref instr 3))
+ (base (cadddr offset)))
+ (values 'MEMORY
+ (if (or (memq 'MA (cadr instr))
+ (memq 'MB (cadr instr)))
+ (list base)
+ '())
+ (list base (list-ref instr 2))
+ (cadr offset))))
+ ((LDI LDIL)
+ ;; immed target
+ (values 'ALU
+ (list (list-ref instr 3))
+ '()
+ (list-ref instr 2)))
+ ((ADDIL)
+ ;; immed source
+ (values 'ALU
+ (list regnum:addil-result)
+ (list (list-ref instr 3))
+ (list-ref instr 2)))
+ ((NOP SKIP)
+ (values 'ALU '() '() false))
+ ((VDEPI DEPI)
+ (values 'ALU
+ (list (car (last-pair instr)))
+ (list (car (last-pair instr)))
+ false))
+ ((ZVDEPI ZDEPI)
+ (values 'ALU
+ (list (car (last-pair instr)))
+ '()
+ false))
+ ((EXTRU EXTRS ZDEP)
+ (values 'ALU
+ (list (list-ref instr 5))
+ (list (list-ref instr 2))
+ false))
+\f
+ ((DEP)
+ (values 'ALU
+ (list (list-ref instr 5))
+ (list (list-ref instr 5) (list-ref instr 2))
+ false))
+ ((VEXTRU VEXTRS VDEP ZVDEP)
+ (values 'ALU
+ (list (list-ref instr 4))
+ (list (list-ref instr 2))
+ false))
+ ((FCPY FABS FSQRT FRND)
+ ;; source target
+ (values 'FALU
+ (list (float-reg (list-ref instr 3)))
+ (list (float-reg (list-ref instr 2)))
+ false))
+ ((FADD FSUB FMPY FDIV FREM)
+ ;; source1 source2 target
+ (values 'FALU
+ (list (float-reg (list-ref instr 4)))
+ (list (float-reg (list-ref instr 2))
+ (float-reg (list-ref instr 3)))
+ false))
+ ((FSTDS)
+ ;; source (offset n m base)
+ (let* ((offset (list-ref instr 3))
+ (base (cadddr offset)))
+ (values 'MEMORY
+ (if (or (memq 'MA (cadr instr))
+ (memq 'MB (cadr instr)))
+ (list base)
+ '())
+ (list base
+ (float-reg (list-ref instr 2)))
+ (cadr offset))))
+ ((COMBT COMBF COMB COMBN)
+ ;; source1 source2
+ (values 'CONTROL
+ '()
+ (list (list-ref instr 2) (list-ref instr 3))
+ false))
+ ((COMIBT COMIBF COMIB COMIBTN COMIBFN)
+ ;; immediate source
+ (values 'CONTROL
+ '()
+ (list (list-ref instr 3))
+ false))
+ ((BL)
+ ;; target
+ (values 'CONTROL
+ (list (list-ref instr 2))
+ '()
+ false))
+ ((B)
+ ;; target
+ (values 'CONTROL
+ '()
+ '()
+ false))
+ ((BV)
+ ;; source-1 source-2
+ (values 'CONTROL
+ '()
+ (list (list-ref instr 2) (list-ref instr 3))
+ false))
+\f
+ ((BLR)
+ ;; source target
+ (values 'CONTROL
+ (list (list-ref instr 3))
+ (list (list-ref instr 2))
+ false))
+ ((BLE)
+ (let ((offset-expr (list-ref instr 2)))
+ (values 'CONTROL
+ (list 31)
+ (list (list-ref offset-expr 3))
+ (list-ref offset-expr 1))))
+ ((BE)
+ (let ((offset-expr (list-ref instr 2)))
+ (values 'CONTROL
+ '()
+ (list (list-ref offset-expr 3))
+ (list-ref offset-expr 1))))
+ #|
+ ((ADDBT ADDBF ADDB)
+ ;; source1 source2/target
+ (let ((target (list-ref instr 3)))
+ (values 'CONTROL
+ (list target)
+ (list (list-ref instr 2) target)
+ false)))
+ ((ADDIBT ADDIBF ADDIB)
+ ;; immediate source/target
+ (let ((target (list-ref instr 3)))
+ (values 'CONTROL
+ (list target)
+ (list target)
+ false)))
+ ((GATE)
+ <>)
+ ((MOVB ...)
+ <>)
+ ((PCR-HOOK)
+ <>)
+ ((LABEL EQUATE ENTRY-POINT
+ EXTERNAL-LABEL BLOCK-OFFSET
+ SCHEME-OBJECT SCHEME-EVALUATION PADDING)
+ (values 'DIRECTIVE '() '() false))
+ |#
+ (else
+ (values 'UNKNOWN '() '() false)))))
+
+(define (offset-fits? offset opcode)
+ (and (number? offset)
+ (memq opcode '(LDW LDB LDO LDI LDH STW STB STH STWM LDWM
+ STWS LDWS FLDWS FLDDS FSTWS FSTDS))
+ (<= -8192 offset 8191)))
+\f
+;;;; Utilities
+
+;; A trivial pattern matcher
+
+(define (match pattern instance)
+ (let ((dict '(("empty" . empty))))
+
+ (define (match-internal pattern instance)
+ (cond ((not (pair? pattern))
+ (eqv? pattern instance))
+ ((eq? (car pattern) '?)
+ (let ((var (cadr pattern))
+ (val instance))
+ (cond ((eq? var '?) ; quoting ?
+ (eq? val '?))
+ ((assq var dict)
+ => (lambda (place)
+ (equal? (cdr place) val)))
+ (else
+ (set! dict (cons (cons var val) dict))
+ true))))
+ (else
+ (and (pair? instance)
+ (match-internal (car pattern) (car instance))
+ (match-internal (cdr pattern) (cdr instance))))))
+
+ (and (match-internal pattern instance)
+ dict)))
+
+(define (directive? instr)
+ (memq (car instr)
+ '(COMMENT
+ LABEL EQUATE ENTRY-POINT
+ EXTERNAL-LABEL BLOCK-OFFSET
+ SCHEME-OBJECT SCHEME-EVALUATION PADDING)))
+
+(define (find-or-label instrs)
+ (and (not (null? instrs))
+ (if (memq (caar instrs)
+ '(COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE))
+ (find-or-label (cdr instrs))
+ instrs)))
+
+(define (find-non-label instrs)
+ (and (not (null? instrs))
+ (if (memq (caar instrs)
+ '(LABEL COMMENT SCHEME-OBJECT SCHEME-EVALUATION EQUATE))
+ (find-non-label (cdr instrs))
+ instrs)))
+
+(define (list-difference whole suffix)
+ (if (eq? whole suffix)
+ '()
+ (cons (car whole)
+ (list-difference (cdr whole) suffix))))
+\f
+(define (fix-complex-return ret frame junk instr avoid)
+ (let ((syll `(OFFSET ,frame 0 ,regnum:stack-pointer)))
+ (if (and (eq? (car instr) 'STW)
+ (equal? (cadddr instr) syll))
+ ;; About to store return address. Forego store completely
+ ;; FORMAT: (STW () ret (OFFSET frame 0 regnum:stack-pointer))
+ (let ((ret (caddr instr)))
+ `(,@(reverse junk)
+ ,@(entry->address ret)
+ (BV () 0 ,ret)
+ (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
+ ,regnum:stack-pointer)))
+ (let ((ret (list-search-positive
+ (list ret regnum:first-arg regnum:second-arg
+ regnum:third-arg regnum:fourth-arg)
+ (lambda (reg)
+ (not (memq reg avoid))))))
+ `(,@(reverse junk)
+ (LDW () ,syll ,ret)
+ ,instr
+ ,@(entry->address ret)
+ (BV () 0 ,ret)
+ (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
+ ,regnum:stack-pointer))))))
+
+(define (fix-simple-return ret frame junk)
+ ;; JSM: Why can't the LDO be in the delay slot of the BV?
+ `(,@(reverse junk)
+ (LDW () (OFFSET ,frame 0 ,regnum:stack-pointer) ,ret)
+ (LDO () (OFFSET ,(+ frame 4) 0 ,regnum:stack-pointer)
+ ,regnum:stack-pointer)
+ ,@(entry->address ret)
+ (BV (N) 0 ,ret)))
+
+(define (fix-a-return dict1 junk dict2 rest)
+ (let* ((next (find-or-label rest))
+ (next* (and next (find-non-label next)))
+ (frame (cdr (assq 'frame dict2)))
+ (ret (cdr (assq 'ret dict1))))
+ (cond ((or (not next)
+ (instr-pc-sensitive? (car next))
+ (memq (caar next)
+ '(ENTRY-POINT EXTERNAL-LABEL BLOCK-OFFSET PCR-HOOK))
+ (and (eq? (caar next) 'LABEL)
+ (or (not next*)
+ (not (instr-skips? (car next*))))))
+ (values (fix-simple-return ret frame junk)
+ rest))
+ ((or (eq? (caar next) 'LABEL)
+ (instr-skips? (car next)))
+ (values '() false))
+ (else
+ (call-with-values
+ (lambda () (classify-instruction (car next)))
+ (lambda (type writes reads offset)
+ offset ; ignored
+ (if (or (not (memq type '(ALU MEMORY FALU)))
+ (equal? writes (list regnum:stack-pointer)))
+ (values (fix-simple-return ret frame junk)
+ rest)
+ (values
+ (fix-complex-return ret frame
+ (append junk
+ (list-difference rest next))
+ (car next)
+ (append writes reads))
+ (cdr next)))))))))
+\f
+(define (fix-sequences instrs tail)
+ (define-integrable (single instr)
+ (fix-sequences (cdr instrs)
+ (cons instr tail)))
+
+ (define-integrable (fail)
+ (single (car instrs)))
+
+ (if (null? instrs)
+ tail
+ (let* ((instr (car instrs))
+ (opcode (car instr)))
+
+ (define (try-skip)
+ (let ((label (let ((address (list-ref instr 4)))
+ (and (eq? (car address) '@PCR)
+ (cadr address)))))
+ (if (not label)
+ (fail)
+ (let* ((next (find-non-label tail))
+ (instr* (and next
+ (not (directive? (car next)))
+ (car next)))
+ (next* (and instr* (find-or-label (cdr next))))
+ (instr** (and next* (car next*))))
+ (if (or (not instr**)
+ (not (eq? (car instr**) 'LABEL))
+ (not (eq? (cadr instr**) label))
+ (instr-expands? instr*))
+ (fail)
+ (case opcode
+ ((COMB COMBT COMBN)
+ (single
+ `(COMCLR ,(delq 'N (cadr instr))
+ ,(caddr instr)
+ ,(cadddr instr)
+ 0)))
+ ((COMIB COMIBT COMIBTN)
+ (single
+ `(COMICLR ,(delq 'N (cadr instr))
+ ,(caddr instr)
+ ,(cadddr instr)
+ 0)))
+ ((COMBF)
+ (single
+ `(COMCLR ,(map invert-condition
+ (delq 'N (cadr instr)))
+ ,(caddr instr)
+ ,(cadddr instr)
+ 0)))
+ ((COMIBF COMIBFN)
+ (single
+ `(COMICLR ,(map invert-condition
+ (delq 'N (cadr instr)))
+ ,(caddr instr)
+ ,(cadddr instr)
+ 0)))
+ (else "LAPOPT: try-skip bad case" instr)))))))
+
+ (define (fix-unconditional-branch)
+ (if (not (equal? (cadr instr) '(N)))
+ (fail)
+ (call-with-values
+ (lambda ()
+ (find-movable-instr/delay instr (cdr instrs)))
+ (lambda (movable junk rest)
+ (if (not movable)
+ (fail)
+ (fix-sequences
+ rest
+ `(,@(reverse junk)
+ (,opcode () ,@(cddr instr))
+ ,movable
+ ,@tail)))))))
+
+ (define (drop-instr)
+ (fix-sequences (cdr instrs)
+ (cons '(COMMENT (branch removed))
+ tail)))
+
+ (define (generate-skip)
+ (let* ((default (lambda () (single `(SKIP (TR)))))
+ (previous (find-or-label (cdr instrs)))
+ (skipify
+ (lambda (instr*)
+ (fix-sequences
+ (cdr previous)
+ (cons instr*
+ (append
+ (reverse (list-difference (cdr instrs) previous))
+ tail)))))
+ (instr (and previous (car previous)))
+ (previous* (and previous (find-non-label (cdr previous)))))
+ (if (or (not instr)
+ (not (null? (cadr instr)))
+ (directive? instr)
+ (and previous*
+ (instr-skips? (car previous*))))
+ (default)
+ (call-with-values
+ (lambda ()
+ (classify-instruction instr))
+ (lambda (type writes reads offset)
+ (cond ((or (not (eq? type 'ALU))
+ (memq (car instr) '(LDIL ADDIL)))
+ (default))
+ ((not (memq (car instr) '(LDO LDI)))
+ (skipify
+ `(,(car instr) (TR) ,@(cddr instr))))
+ ((not (fits-in-11-bits-signed? offset))
+ (default))
+ (else
+ (skipify
+ `(ADDI (TR)
+ ,offset
+ ,(if (null? reads)
+ 0
+ (car reads))
+ ,(car writes))))))))))
+\f
+ (case opcode
+ ((BV)
+ (let ((dict1 (match (cdr return-pattern) instrs)))
+ (if (not dict1)
+ (fix-unconditional-branch)
+ (let* ((tail* (cddr instrs))
+ (next (find-or-label tail*))
+ (fail*
+ (lambda ()
+ (fix-sequences
+ tail*
+ (append (reverse (list-head instrs 2))
+ tail))))
+ (dict2
+ (and next
+ (match (car return-pattern) (car next)))))
+
+ (if (not dict2)
+ (fail*)
+ (call-with-values
+ (lambda ()
+ (fix-a-return dict1
+ (list-difference tail* next)
+ dict2
+ (cdr next)))
+ (lambda (frobbed untouched)
+ (if (null? frobbed)
+ (fail*)
+ (fix-sequences untouched
+ (append frobbed tail))))))))))
+
+ ((B)
+ (let ((address (caddr instr)))
+ (if (not (eq? (car address) '@PCR))
+ (fix-unconditional-branch)
+ (let ((label (cadr address)))
+ (if (equal? (cadr instr) '(N))
+ ;; Branch with nullification
+ (let* ((next (find-or-label tail))
+ (instr* (and next (car next))))
+ (cond ((not instr*)
+ (fix-unconditional-branch))
+ ((eq? (car instr*) 'LABEL)
+ (if (not (eq? (cadr instr*) label))
+ (fix-unconditional-branch)
+ (drop-instr)))
+ ((eq? (car instr*) 'EXTERNAL-LABEL)
+ (let ((address* (list-ref instr* 3)))
+ (if (or (not (eq? (car address*) '@PCR))
+ (not (eq? label (cadr address*))))
+ (fix-unconditional-branch)
+ (generate-skip))))
+ (else
+ (fix-unconditional-branch))))
+ ;; Branch with no nullification
+ (let* ((next (find-non-label tail))
+ (instr* (and next (car next)))
+ (next* (and next (find-or-label (cdr next))))
+ (instr** (and next* (car next*))))
+ (cond ((not instr**)
+ (fix-unconditional-branch))
+ ((and (eq? (car instr**) 'LABEL)
+ (eq? (cadr instr**) label)
+ (not (instr-expands? instr*)))
+ (drop-instr))
+ (else
+ (fix-unconditional-branch)))))))))
+\f
+ ((BE BLE)
+ (fix-unconditional-branch))
+ ((NOP)
+ (let ((dict (match hook-pattern instrs)))
+ (if (not dict)
+ (fail)
+ (call-with-values
+ (lambda ()
+ (find-movable-instr/delay (cadr instrs) ; The BLE
+ (cddr instrs)))
+ (lambda (movable junk rest)
+ (if (not movable)
+ (fail)
+ (fix-sequences
+ rest
+ `(,@(reverse junk)
+ ,(cadr instrs)
+ ,movable
+ ,@tail))))))))
+ ((LDW LDB LDH)
+ #|
+ ;; yyy
+ ;; LD[WB] ... Rx
+ ;; use Rx
+ ;; =>
+ ;; LD[WB] ... Rx
+ ;; yyy
+ ;; use Rx
+ |#
+ (let* ((writes (fourth instr))
+ (next (find-non-label tail)))
+ (if (or (not next)
+ (not (instr-uses? (car next) writes)))
+ (fail)
+ (call-with-values
+ (lambda ()
+ (find-movable-instr/load (cdr instrs)
+ (list (fourth (third instr)))
+ (list writes)
+ (car next)))
+ (lambda (movable junk rest)
+ (if (not movable)
+ (fix-sequences
+ (cdr instrs)
+ (cons* instr '(COMMENT *load-stall*) tail))
+ (fix-sequences
+ rest
+ `(,@(reverse junk)
+ (COMMENT (moved for load scheduling))
+ ,instr
+ ,movable
+ ,@tail))))))))
+\f
+ #|
+ (else
+ (cond (;; Load scheduling
+ ;; xxx
+ ;; LD[WB] ... Rx
+ ;; use Rx
+ ;; =>
+ ;; LD[WB] ... Rx
+ ;; xxx
+ ;; use Rx
+ (and (pair? (cdr instrs))
+ ;; `use Rx' is not, say, a comment
+ (not (directive? instr))
+ (eq? instrs (find-or-label instrs))
+ (memq (caar (find-or-label (cdr instrs))) '(LDW LDB))
+ (instr-uses?
+ instr
+ (fourth (car (find-or-label (cdr instrs))))))
+ (call-with-values
+ (lambda ()
+ (find-movable-instr-for-load-slot
+ (cdr (find-or-label (cdr instrs)))))
+ (lambda (movable junk rest)
+ (if (or (not movable)
+ (memq (car movable) '(LDWM STWM)))
+ ;; This annotates them, otherwise eqv to (fail):
+ (fix-sequences (cdr instrs)
+ (cons* '(COMMENT *load-stall*)
+ (car instrs) tail))
+ (fix-sequences
+ rest
+ `(,@(reverse junk)
+ ,(car (find-or-label (cdr instrs)))
+ (COMMENT (moved for load scheduling))
+ ,movable
+ ,(car instrs)
+ ,@tail))))))
+ (else
+ (fail))))
+ |#
+ ((COMB COMBT COMBF COMIB COMIBT COMIBF)
+ (if (not (memq 'N (cadr instr)))
+ (fail)
+ (try-skip)))
+ ((COMBN COMIBTN COMIBFN)
+ (try-skip))
+ (else
+ (fail))))))
+
+(define (fits-in-11-bits-signed? value)
+ (and (< value 1024)
+ (>= value -1024)))
+\f
+(define (instr-skips? instr)
+ ;; Not really true, for example
+ ;; (COMBT (<) ...)
+ (or (and (pair? (cadr instr))
+ (not (memq (car instr)
+ '(B BL BV BLR BLE BE
+ LDWS LDHS LDBS LDCWS
+ STWS STHS STBS STBYS
+ FLDWS FLDDS FSTWS FSTDS
+ COMBN COMIBTN COMIBFN)))
+ ;; or SGL, or QUAD, but not used now.
+ (not (memq 'DBL (cadr instr))))
+
+ ;; A jump with a non-nullified delay slot
+ (and (memq (car instr) '(B BL BV BLR BLE BE))
+ (null? (cadr instr)))))
+
+(define (instr-uses? instr reg)
+ ;; Might INSTR have a data dependency on REG?
+ (call-with-values
+ (lambda () (classify-instruction instr))
+ (lambda (type writes reads offset)
+ writes offset ; ignored
+ (or (eq? type 'UNKNOWN)
+ (eq? type 'DIRECTIVE)
+ (memq reg reads)))))
+
+(define (instr-expands? instr)
+ (call-with-values
+ (lambda () (classify-instruction instr))
+ (lambda (type writes reads offset)
+ writes reads ; ignored
+ (or (eq? type 'UNKNOWN)
+ (eq? type 'DIRECTIVE)
+ (cond (offset
+ (not (offset-fits? offset (car instr))))
+ ((eq? type 'CONTROL)
+ (instr-pc-sensitive? instr))
+ (else
+ false))))))
+
+(define (instr-pc-sensitive? instr)
+ (let walk ((instr instr))
+ (or (memq instr '(*PC* @PCR))
+ (and (pair? instr)
+ (or (walk (car instr))
+ (walk (cdr instr)))))))
+\f
+(define (find-movable-instr/delay instr instrs)
+ (let* ((next (find-or-label instrs))
+ (instr* (and next (car next)))
+ (next* (and next (find-non-label (cdr next)))))
+ (if (and instr*
+ (call-with-values
+ (lambda () (classify-instruction instr*))
+ (lambda (type writes reads offset)
+ (and (memq type '(ALU MEMORY FALU))
+ (or (not offset)
+ (offset-fits? offset (car instr*)))
+ (call-with-values
+ (lambda () (classify-instruction instr))
+ (lambda (type* writes* reads* offset*)
+ type* offset* ; ignored
+ ;;(pp `((,instr* writes ,writes reads ,reads)
+ ;; (,instr writes* ,writes* reads* ,reads*)))
+ (and (null? (eq-set-intersection writes reads*))
+ (null? (eq-set-intersection reads writes*))))))))
+ (not (instr-skips? instr*))
+ (not (instr-pc-sensitive? instr*))
+ (or (not next*)
+ (not (instr-skips? (car next*)))))
+ (values instr*
+ (list-difference instrs next)
+ (cdr next))
+ (values false false false))))
+\f
+;; Certainly dont try (equal? instr recache-memtop) in above as it causes the
+;; branch for which we are seeking an instruction to fill its delay slot to
+;; be put in the delay slot of the COMB instruction.
+
+#|
+(define (find-movable-instr-for-load-slot instrs)
+ ;; This needs to be taught about dependencies between instructiions.
+ ;; Currently it will only reschedule the recaching of memtop as that has no
+ ;; dependencies at all.
+ (let* ((next (find-or-label instrs))
+ (instr (and next (car next))))
+ (if (or (equal? instr recache-memtop)
+ #F)
+ (values instr
+ (list-difference instrs next)
+ (cdr next))
+ (values false false false))))
+|#
+
+(define (find-movable-instr/load instrs reads writes next**)
+ (let* ((next (find-or-label instrs))
+ (instr (and next (car next)))
+ (next* (and next (find-non-label (cdr next)))))
+ (if (and instr
+ (not (instr-skips? instr))
+ (call-with-values
+ (lambda () (classify-instruction instr))
+ (lambda (type writes* reads* offset)
+ offset ; ignored
+ (and (memq type '(ALU MEMORY FALU))
+ (null? (eq-set-intersection writes* reads))
+ (null? (eq-set-intersection writes reads*))
+ (or (null? writes*)
+ (not (there-exists? writes*
+ (lambda (tgt)
+ (instr-uses? next** tgt))))))))
+ (or (not (memq (car instr)
+ '(STW STB STH STWM STWS STHS STBS STWAS)))
+ ;; Don't move a memory store instruction past
+ ;; a load. There are cases where this is OK,
+ ;; but we're not going to handle them now. -- JSM
+ (begin
+ ;;(write-line (list 'FIND-MOVABLE-INSTR/LOAD instr))
+ #F))
+ (or (not next*)
+ (not (instr-skips? (car next*)))
+ (equal? instr recache-memtop)))
+ (values instr
+ (list-difference instrs next)
+ (cdr next))
+ (values false false false))))
+
+(define return-pattern ; reversed
+ (cons
+ `(LDO () (OFFSET (? frame) 0 ,regnum:stack-pointer) ,regnum:stack-pointer)
+ `((BV (N) 0 (? ret))
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) (? ret))
+ . (? more-insts))))
+\f
+(define hook-pattern
+ `((NOP ())
+ (BLE () (OFFSET (? hook) 4 ,regnum:scheme-to-interface-ble))
+ . (? more-insts)))
+
+(define recache-memtop '(LDW () (OFFSET 0 0 4) #x14))
+
+(define (old-optimize-linear-lap instructions)
+ (fix-sequences (reverse! instructions) '()))
+
+#|
+** I believe that I have fixed this - there are cdd..drs and list
+ indexes in the code that assume that the return pattern has a
+ certain length.
+
+;; At the moment the code removes the assignment to r2 in the following:
+
+((entry-point fixmul-5)
+ (scheme-object CONSTANT-0 debugging-info)
+ (scheme-object CONSTANT-1 environment)
+ (comment (rtl (procedure-header fixmul-0 3 3)))
+ (equate fixmul-5 fixmul-0)
+ (label label-4)
+ (ble () (offset 0 4 3))
+ (ldi () 26 28)
+ (external-label () 771 (@pcr fixmul-0))
+ (label fixmul-0)
+ (comb (>=) 21 20 (@pcr label-4))
+ (ldw () (offset 0 0 4) 20)
+ (comment
+ (rtl (assign (register 65) (offset (register 22) (machine-constant 0)))))
+ (ldw () (offset 0 0 22) 6)
+ (comment
+ (rtl (assign (register 66) (offset (register 22) (machine-constant 1)))))
+ (ldw () (offset 4 0 22) 7)
+ (comment
+ (rtl
+ (assign
+ (register 2)
+ (fixnum-2-args multiply-fixnum (register 65) (register 66) #f))))
+ (copy () 6 26)
+ (copy () 7 25)
+ (ble () (offset 116 4 3))
+ (nop ())
+ (comment
+ (rtl
+ (assign
+ (register 22)
+ (offset-address (register 22) (machine-constant 2)))))
+ (ldo () (offset 8 0 22) 22)
+ (comment (rtl (pop-return)))
+ (copy () 26 2)
+ (ldwm () (offset 4 0 22) 6)
+ (bv (n) 0 6))
+
+** But there is still a bug:
+
+gc.scm when optimized SEGVs in flush-purification-queue for no apparent reason
+
+
+|#
+(define (optimize-linear-lap instructions)
+ (old-optimize-linear-lap instructions))
+\f
+;;;; This works in conjuction with try-skip in fix-sequences.
+
+(define (lap:mark-preferred-branch! pblock cn an)
+ ;; This can leave pblock unchanged
+ (define (single-instruction bblock other)
+ (and (sblock? bblock)
+ (let ((next (snode-next bblock)))
+ (or (not next)
+ (eq? next other)))
+ (let find-first ((instrs (bblock-instructions bblock)))
+ (and (not (null? instrs))
+ (let ((instr (car instrs)))
+ (if (eq? 'COMMENT (car instr))
+ (find-first (cdr instrs))
+ (and (let find-next ((instrs (cdr instrs)))
+ (or (null? instrs)
+ (and (eq? 'COMMENT (car (car instrs)))
+ (find-next (cdr instrs)))))
+ instr)))))))
+
+ (define (try branch bblock other)
+ (let ((instr (single-instruction bblock other)))
+ (and instr
+ (not (instr-expands? instr))
+ (pnode/prefer-branch! pblock branch)
+ true)))
+
+ (let ((branch-instr
+ (car (last-pair ((pblock-consequent-lap-generator pblock) 'FOO)))))
+ (and (memq (car branch-instr)
+ '(COMB COMBT COMBF COMIB COMIBT COMIBF COMBN COMIBTN COMIBFN))
+ (or (try 'CONSEQUENT cn an)
+ (try 'ALTERNATIVE an cn)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: machin.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;; Machine Model for Spectrum
+;;; package: (compiler)
+
+;;! Changes for split fixnum tags makeed with ;;!
+
+(declare (usual-integrations))
+\f
+;;;; Architecture Parameters
+
+(define stack-use-pre/post-increment? true)
+(define heap-use-pre/post-increment? true)
+(define continuation-in-stack? false)
+(define closure-in-stack? false)
+
+(define-integrable endianness 'BIG)
+(define-integrable addressing-granularity 8)
+(define-integrable scheme-object-width 32)
+(define-integrable scheme-type-width 6) ;or 8
+
+;; NOTE: expt is not being constant-folded now.
+;; For the time being, some of the parameters below are
+;; pre-computed and marked with ***
+;; There are similar parameters in lapgen.scm
+;; Change them if any of the parameters above do.
+
+(define-integrable scheme-datum-width
+ (- scheme-object-width scheme-type-width))
+
+(define-integrable type-scale-factor
+ ;; (expt 2 (- 8 scheme-type-width)) ***
+ 4)
+
+(define-integrable float-width 64)
+(define-integrable float-alignment 64)
+
+(define-integrable address-units-per-float
+ (quotient float-width addressing-granularity))
+
+;;; It is currently required that both packed characters and objects
+;;; be integrable numbers of address units. Furthermore, the number
+;;; of address units per object must be an integral multiple of the
+;;; number of address units per character. This will cause problems
+;;; on a machine that is word addressed: we will have to rethink the
+;;; character addressing strategy.
+
+(define-integrable address-units-per-object
+ (quotient scheme-object-width addressing-granularity))
+
+(define-integrable address-units-per-packed-char 1)
+
+(define-integrable max-type-code
+ ;; (-1+ (expt 2 scheme-type-width)) ***
+ 63)
+
+(define #|-integrable|# untagged-fixnums?
+ ;; true when fixnums have tags 000000... and 111111...
+ (and (= 0 (ucode-type positive-fixnum))
+ (= max-type-code (ucode-type negative-fixnum))))
+
+(if (and (not untagged-fixnums?)
+ (not (= (ucode-type positive-fixnum) (ucode-type negative-fixnum))))
+ (error "machin.scm: split fixnum type-codes must be 000... and 111..."))
+
+(define #|-integrable|# signed-fixnum/upper-limit
+ (if untagged-fixnums?
+ ;; (expt 2 scheme-datum-width) ***
+ 67108864
+ ;; (expt 2 (-1+ scheme-datum-width)) ***
+ 33554432))
+
+(define-integrable signed-fixnum/lower-limit
+ (- signed-fixnum/upper-limit))
+
+(define #|-integrable|# unsigned-fixnum/upper-limit
+ (if untagged-fixnums?
+ signed-fixnum/upper-limit
+ (* 2 signed-fixnum/upper-limit)))
+
+(define #|-integrable|# quad-mask-value
+ (cond ((= scheme-type-width 5) #b01000)
+ ((= scheme-type-width 6) #b010000)
+ ((= scheme-type-width 8) #b01000000)
+ (else (error "machin.scm: weird type width:" scheme-type-width))))
+
+(define #|-integrable|# untagged-entries?
+ ;; This is true if the value we have chosen for the compiled-entry
+ ;; type-code is equal to the bits in the type-code field of an
+ ;; address.
+ (= quad-mask-value (ucode-type compiled-entry)))
+
+(define-integrable (stack->memory-offset offset) offset)
+(define-integrable ic-block-first-parameter-offset 2)
+(define-integrable execute-cache-size 3) ; Long words per UUO link slot
+\f
+;;;; Closures and multi-closures
+
+;; On the 68k, to save space, entries can be at 2 mod 4 addresses,
+;; which makes it impossible to use an arbitrary closure entry-point
+;; to reference closed-over variables since the compiler only uses
+;; long-word offsets. Instead, all closure entry points are bumped
+;; back to the first entry point, which is always long-word aligned.
+
+;; On the HP-PA, and all other RISCs, all the entry points are
+;; long-word aligned, so there is no need to bump back to the first
+;; entry point.
+
+(define-integrable closure-entry-size
+ #|
+ Long words in a single closure entry:
+ GC offset word
+ LDIL L'target,26
+ BLE R'target(5,26)
+ ADDI -12,31,31
+ |#
+ 4)
+
+;; Given: the number of entry points in a closure, and a particular
+;; entry point number, compute the distance from that entry point to
+;; the first variable slot in the closure object (in long words).
+
+(define (closure-first-offset nentries entry)
+ (if (zero? nentries)
+ 1 ; Strange boundary case
+ (- (* closure-entry-size (- nentries entry)) 1)))
+
+;; Like the above, but from the start of the complete closure object,
+;; viewed as a vector, and including the header word.
+
+(define (closure-object-first-offset nentries)
+ (case nentries
+ ((0)
+ ;; Vector header only
+ 1)
+ ((1)
+ ;; Manifest closure header followed by single entry point
+ (+ 1 closure-entry-size))
+ (else
+ ;; Manifest closure header, number of entries, then entries.
+ (+ 1 1 (* closure-entry-size nentries)))))
+
+;; Bump distance in bytes from one entry point to another.
+;; Used for invocation purposes.
+
+(define (closure-entry-distance nentries entry entry*)
+ nentries ; ignored
+ (* (* closure-entry-size 4) (- entry* entry)))
+
+;; Bump distance in bytes from one entry point to the entry point used
+;; for variable-reference purposes.
+;; On a RISC, this is the entry point itself.
+
+(define (closure-environment-adjustment nentries entry)
+ nentries entry ; ignored
+ 0)
+\f
+;;;; Machine Registers
+
+(define-integrable g0 0)
+(define-integrable g1 1)
+(define-integrable g2 2)
+(define-integrable g3 3)
+(define-integrable g4 4)
+(define-integrable g5 5)
+(define-integrable g6 6)
+(define-integrable g7 7)
+(define-integrable g8 8)
+(define-integrable g9 9)
+(define-integrable g10 10)
+(define-integrable g11 11)
+(define-integrable g12 12)
+(define-integrable g13 13)
+(define-integrable g14 14)
+(define-integrable g15 15)
+(define-integrable g16 16)
+(define-integrable g17 17)
+(define-integrable g18 18)
+(define-integrable g19 19)
+(define-integrable g20 20)
+(define-integrable g21 21)
+(define-integrable g22 22)
+(define-integrable g23 23)
+(define-integrable g24 24)
+(define-integrable g25 25)
+(define-integrable g26 26)
+(define-integrable g27 27)
+(define-integrable g28 28)
+(define-integrable g29 29)
+(define-integrable g30 30)
+(define-integrable g31 31)
+
+;; fp0 - fp3 are status registers. The rest are real registers
+(define-integrable fp0 32)
+(define-integrable fp1 33)
+(define-integrable fp2 34)
+(define-integrable fp3 35)
+(define-integrable fp4 36)
+(define-integrable fp5 37)
+(define-integrable fp6 38)
+(define-integrable fp7 39)
+(define-integrable fp8 40)
+(define-integrable fp9 41)
+(define-integrable fp10 42)
+(define-integrable fp11 43)
+(define-integrable fp12 44)
+(define-integrable fp13 45)
+(define-integrable fp14 46)
+(define-integrable fp15 47)
+
+;; The following registers are available only on the newer processors
+(define-integrable fp16 48)
+(define-integrable fp17 49)
+(define-integrable fp18 50)
+(define-integrable fp19 51)
+(define-integrable fp20 52)
+(define-integrable fp21 53)
+(define-integrable fp22 54)
+(define-integrable fp23 55)
+(define-integrable fp24 56)
+(define-integrable fp25 57)
+(define-integrable fp26 58)
+(define-integrable fp27 59)
+(define-integrable fp28 60)
+(define-integrable fp29 61)
+(define-integrable fp30 62)
+(define-integrable fp31 63)
+
+(define-integrable number-of-machine-registers 64)
+(define-integrable number-of-temporary-registers 256)
+\f
+;;; Fixed-use registers for Scheme compiled code.
+(define-integrable regnum:return-value g2)
+(define-integrable regnum:scheme-to-interface-ble g3)
+(define-integrable regnum:regs-pointer g4)
+(define-integrable regnum:quad-bitmask g5)
+(define-integrable regnum:false-value g5) ; Yes: same as quad-bitmask
+(define-integrable regnum:empty-list g18)
+(define-integrable regnum:continuation g19)
+(define-integrable regnum:memtop-pointer g20)
+(define-integrable regnum:free-pointer g21)
+(define-integrable regnum:stack-pointer g22)
+(define-integrable regnum:closure g25)
+
+;;; Fixed-use registers due to architecture or OS calling conventions.
+(define-integrable regnum:zero g0)
+(define-integrable regnum:addil-result g1)
+(define-integrable regnum:C-global-pointer g27)
+(define-integrable regnum:C-return-value g28)
+(define-integrable regnum:C-stack-pointer g30)
+(define-integrable regnum:ble-return g31)
+(define-integrable regnum:fourth-arg g23)
+(define-integrable regnum:third-arg g24)
+(define-integrable regnum:second-arg g25)
+(define-integrable regnum:first-arg g26)
+
+(define (machine-register-value-class register)
+ (cond ((or (= register 0)
+ (= register 26)
+ (= register 29)
+ (= register regnum:ble-return))
+ value-class=word)
+ ((or (= register regnum:addil-result)
+ (= register regnum:scheme-to-interface-ble))
+ value-class=unboxed)
+ ((or (= register regnum:continuation)
+ (= register regnum:closure))
+ (if untagged-entries?
+ value-class=object ; because it is untagged
+ value-class=address))
+ (;; argument registers
+ (or (= register 2)
+ (<= 6 register 17)
+ (<= 23 register 24))
+ value-class=object)
+ ((or (= register regnum:false-value)
+ (= register regnum:empty-list))
+ value-class=object)
+ ((or (= register regnum:regs-pointer)
+ (= register regnum:memtop-pointer)
+ (= register regnum:free-pointer)
+ (= register regnum:stack-pointer)
+ (= register 27)
+ (= register 30))
+ value-class=address)
+ ((= register 28)
+ value-class=object)
+ ((<= 32 register 63)
+ value-class=float)
+ (else
+ (error "illegal machine register" register))))
+
+;;(define *rtlgen/argument-registers*
+;; ;; arbitrary small number for debugging stack arguments
+;; '#(2 6 7))
+
+(define *rtlgen/argument-registers*
+ ;; Leave 28, 29, and 31 as temporaries
+ ;; For now, 25 and 26 cannot be used because closure patterns
+ ;; use them to jump.
+ '#(#| 0 1 |#
+ 2 #| 3 4 5 |#
+ 6 7 8 9 10 11 12 13 14 15 16 17 #| 18 19 20 21 22 |#
+ 23 24 #| 25 26 27 28 29 30 31 |#
+ ))
+
+(define-integrable (machine-register-known-value register)
+ register ;ignore
+ false)
+
+(define (machine-register-known-type register)
+ (cond ((and (machine-register? register)
+ (value-class=address? (machine-register-value-class register)))
+ quad-mask-value)
+ (else
+ #F)))
+\f
+;;;; Interpreter Registers
+
+(define-integrable (interpreter-free-pointer)
+ (rtl:make-machine-register regnum:free-pointer))
+
+(define (interpreter-free-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:free-pointer)))
+
+(define-integrable (interpreter-regs-pointer)
+ (rtl:make-machine-register regnum:regs-pointer))
+
+(define (interpreter-regs-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:regs-pointer)))
+
+(define-integrable (interpreter-value-register)
+ (rtl:make-machine-register regnum:return-value))
+
+(define (interpreter-value-register? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:return-value)))
+
+(define-integrable (interpreter-stack-pointer)
+ (rtl:make-machine-register regnum:stack-pointer))
+
+(define (interpreter-stack-pointer? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:stack-pointer)))
+
+(define-integrable (interpreter-dynamic-link)
+ (rtl:make-machine-register regnum:dynamic-link))
+
+(define (interpreter-dynamic-link? expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression) regnum:dynamic-link)))
+
+(define-integrable (interpreter-int-mask-register)
+ (rtl:make-offset (interpreter-regs-pointer)
+ (rtl:make-machine-constant 1)))
+
+(define-integrable (interpreter-environment-register)
+ (rtl:make-offset (interpreter-regs-pointer)
+ (rtl:make-machine-constant 3)))
+
+(define (interpreter-environment-register? expression)
+ (and (rtl:offset? expression)
+ (interpreter-regs-pointer? (rtl:offset-base expression))
+ (let ((offset (rtl:offset-offset expression)))
+ (and (rtl:machine-constant? offset)
+ (= 3 (rtl:machine-constant-value offset))))))
+
+(define-integrable (interpreter-register:access)
+ (rtl:make-machine-register g28))
+
+(define-integrable (interpreter-register:cache-reference)
+ (rtl:make-machine-register g28))
+
+(define-integrable (interpreter-register:cache-unassigned?)
+ (rtl:make-machine-register g28))
+
+(define-integrable (interpreter-register:lookup)
+ (rtl:make-machine-register g28))
+
+(define-integrable (interpreter-register:unassigned?)
+ (rtl:make-machine-register g28))
+
+(define-integrable (interpreter-register:unbound?)
+ (rtl:make-machine-register g28))
+
+
+(define-integrable (interpreter-continuation-register)
+ ;; defined only if not continuation-in-stack?
+ ;; Needs to be a param in machin.scm
+ ;; ***IMPORTANT: cannot be 31 because BLE clobbers
+ ;; it when going to the interface***
+ ;; It should be 2, like for C, but we can't do this
+ ;; until the calling interface is changed.
+ (rtl:make-machine-register regnum:continuation))
+
+(define-integrable (interpreter-closure-register)
+ ;; defined only if not closure-in-stack?
+ (rtl:make-machine-register regnum:closure))
+
+(define-integrable (interpreter-memtop-register)
+ (rtl:make-machine-register regnum:memtop-pointer))
+\f
+;;;; Parameters moved from RTLGEN
+
+(define (rtlgen/interpreter-call/argument-home index)
+ (case index
+ ((1) `(REGISTER 25))
+ ((2) `(REGISTER 24))
+ (else
+ (internal-error "Unexpected interpreter-call argument index" index))))
+
+(define (machine/indexed-loads? type)
+ type ; for all types
+ #T)
+
+(define (machine/indexed-stores? type)
+ (eq? type 'FLOAT))
+
+(define (machine/cont-adjustment)
+ ;; Distance in bytes between a raw continuation
+ ;; (as left behind by JSR) and the real continuation
+ ;; (after descriptor)
+ 0)
+
+\f
+;;;; RTL Registers, Constants, and Primitives
+
+(define (rtl:machine-register? rtl-register)
+ (case rtl-register
+ ((STACK-POINTER)
+ (interpreter-stack-pointer))
+ ;((DYNAMIC-LINK)
+ ; (interpreter-dynamic-link))
+ ((VALUE)
+ (interpreter-value-register))
+ ((FREE)
+ (interpreter-free-pointer))
+ ((MEMORY-TOP)
+ (rtl:make-machine-register regnum:memtop-pointer))
+ ((INTERPRETER-CALL-RESULT:ACCESS)
+ (interpreter-register:access))
+ ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE)
+ (interpreter-register:cache-reference))
+ ((INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?)
+ (interpreter-register:cache-unassigned?))
+ ((INTERPRETER-CALL-RESULT:LOOKUP)
+ (interpreter-register:lookup))
+ ((INTERPRETER-CALL-RESULT:UNASSIGNED?)
+ (interpreter-register:unassigned?))
+ ((INTERPRETER-CALL-RESULT:UNBOUND?)
+ (interpreter-register:unbound?))
+ (else false)))
+
+(define (rtl:interpreter-register? rtl-register)
+ (case rtl-register
+ ((INT-MASK) 1)
+ ((ENVIRONMENT) 3)
+ ((TEMPORARY) 4)
+ (else false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+
+(define (rtl:constant-cost expression)
+ ;; Magic numbers.
+ ;; 0, #F and '() all live in registers.
+ ;; Is there any reason that all these costs were originally >0 ?
+ ;; Making 0 #F and '() all 0 cost prevents any spurious rtl cse.
+ ;; *** THIS IS A BAD IDEA - it makes substitutions even though there might
+ ;; not be rules to handle it!
+ (let ((if-integer
+ (lambda (value)
+ (cond ((zero? value) 1)
+ ((fits-in-5-bits-signed? value) 2)
+ (else 3)))))
+ (let ((if-synthesized-constant
+ (lambda (type datum)
+ (if-integer (make-non-pointer-literal type datum)))))
+ (case (rtl:expression-type expression)
+ ((CONSTANT)
+ (let ((value (rtl:constant-value expression)))
+ (cond ((eq? value #F) 1)
+ ((eq? value '()) 1)
+ ((non-pointer-object? value)
+ (if-synthesized-constant (object-type value)
+ (object-datum value)))
+ (else 3))))
+ ((MACHINE-CONSTANT)
+ (if-integer (rtl:machine-constant-value expression)))
+ ((ENTRY:PROCEDURE
+ ENTRY:CONTINUATION
+ ASSIGNMENT-CACHE
+ VARIABLE-CACHE
+ OFFSET-ADDRESS
+ BYTE-OFFSET-ADDRESS
+ FLOAT-OFFSET-ADDRESS)
+ 3)
+ ((CONS-POINTER)
+ (and (rtl:machine-constant? (rtl:cons-pointer-type expression))
+ (rtl:machine-constant? (rtl:cons-pointer-datum expression))
+ (if-synthesized-constant
+ (rtl:machine-constant-value (rtl:cons-pointer-type expression))
+ (rtl:machine-constant-value
+ (rtl:cons-pointer-datum expression)))))
+ ;; This case causes OBJECT->FIXNUM to be combined with
+ ;; FIXNUM-PRED-1-ARGs and FIXNUM-PRED-2-ARGS:
+ ;((OBJECT->FIXNUM)
+ ; (if (rtl:register? (rtl:object->fixnum-expression expression))
+ ; 0
+ ; (rtl:expression-cost (rtl:object->fixnum-expression expression))))
+ ;;((OBJECT->UNSIGNED-FIXNUM)
+ ;; (- (rtl:expression-cost
+ ;; (rtl:object->unsigned-fixnum-expression expression))
+ ;; 1))
+ ;;((FIXNUM->OBJECT)
+ ;; (+ (rtl:expression-cost (rtl:fixnum->object-expression expression))
+ ;; 1))
+ (else false)))))
+
+(define compiler:open-code-floating-point-arithmetic?
+ true)
+
+(define compiler:primitives-with-no-open-coding
+ '(DIVIDE-FIXNUM GCD-FIXNUM &/ FLONUM-ROUND->EXACT
+ FLONUM-TRUNCATE->EXACT FLONUM-FLOOR->EXACT
+ FLONUM-CEILING->EXACT FLONUM-NORMALIZE
+ FLONUM-DENORMALIZE FLONUM-EXPT))
+
+(define (generic->inline-data generic-op)
+ (define (generic-additive-test constant)
+ (and (exact-integer? constant)
+ (< (abs constant) (/ unsigned-fixnum/upper-limit 2))))
+ (define (fixnum? x)
+ (fix:fixnum? x))
+ (define (make-rtl-fixnum-1-arg-coder name)
+ (lambda (operand)
+ (rtl:make-fixnum-1-arg
+ name (rtl:make-object->fixnum operand) true)))
+ (define (make-rtl-fixnum-pred-1-arg-coder name)
+ (lambda (operand)
+ (rtl:make-fixnum-pred-1-arg name (rtl:make-object->fixnum operand))))
+ (define (make-rtl-fixnum-2-arg-coder name)
+ (lambda (operand1 operand2)
+ (rtl:make-fixnum-2-args name
+ (rtl:make-object->fixnum operand1)
+ (rtl:make-object->fixnum operand2)
+ true)))
+ (define (make-rtl-fixnum-pred-2-arg-coder name)
+ (lambda (operand1 operand2)
+ (if (eq? name 'EQUAL-FIXNUM?)
+ ;; This produces better code.
+ (rtl:make-eq-test operand1 operand2)
+ (rtl:make-fixnum-pred-2-args name
+ (rtl:make-object->fixnum operand1)
+ (rtl:make-object->fixnum operand2)))))
+ (case generic-op
+ ;; Returns #<pre-test-code-name compile-test-code in-line-coder>
+ ((integer-add &+)
+ (values 'GENERIC-ADDITIVE-TEST generic-additive-test
+ (make-rtl-fixnum-2-arg-coder 'PLUS-FIXNUM)))
+ ((integer-subtract &-)
+ (values 'GENERIC-ADDITIVE-TEST generic-additive-test
+ (make-rtl-fixnum-2-arg-coder 'MINUS-FIXNUM)))
+ ((integer-multiply &*)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-2-arg-coder 'MULTIPLY-FIXNUM)))
+ ((integer-quotient quotient)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-2-arg-coder 'FIXNUM-QUOTIENT)))
+ ((integer-remainder remainder)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-2-arg-coder 'FIXNUM-REMAINDER)))
+ ((integer-add-1 1+)
+ (values 'GENERIC-ADDITIVE-TEST generic-additive-test
+ (make-rtl-fixnum-1-arg-coder 'ONE-PLUS-FIXNUM)))
+ ((integer-subtract-1 -1+)
+ (values 'GENERIC-ADDITIVE-TEST generic-additive-test
+ (make-rtl-fixnum-1-arg-coder 'MINUS-ONE-PLUS-FIXNUM)))
+ ((integer-negate)
+ (values 'GENERIC-ADDITIVE-TEST generic-additive-test
+ (make-rtl-fixnum-1-arg-coder 'FIXNUM-NEGATE)))
+ ((integer-less? &<)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-pred-2-arg-coder 'LESS-THAN-FIXNUM?)))
+ ((integer-greater? &>)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-pred-2-arg-coder 'GREATER-THAN-FIXNUM?)))
+ ((integer-equal? &=)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-pred-2-arg-coder 'EQUAL-FIXNUM?)))
+ ((integer-zero? zero?)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-pred-1-arg-coder 'ZERO-FIXNUM?)))
+ ((integer-positive? positive?)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-pred-1-arg-coder 'POSITIVE-FIXNUM?)))
+ ((integer-negative? negative?)
+ (values 'FIXNUM? fixnum?
+ (make-rtl-fixnum-pred-1-arg-coder 'NEGATIVE-FIXNUM?)))
+ (else (error "Can't find corresponding fixnum op:" generic-op))))
+
+;(define (target-object-type object)
+; ;; This should be fixed for cross-compilation
+; (if (and (fix:fixnum? object)
+; (negative? object))
+; #x3F
+; (object-type object)))
+
+(define (target-object-type object)
+ (object-type object))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: make.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1993 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: System Construction
+
+(declare (usual-integrations))
+
+(let ((old-purify purify))
+ ;; This temporary monkey-business stops uncompiled code from being
+ ;; purified so that TRACE & BREAK dont take so long
+ (fluid-let
+ ((purify (lambda (thing)
+ (if (not (comment? thing))
+ (old-purify thing)))))
+
+ ;; Original expression
+ (let ((value ((load "base/make")
+ (lambda ()
+ (string-append
+ "HP PA untagged fixnums and entries, "
+ (number->string
+ ((access rtlgen/number-of-argument-registers
+ (->environment '(compiler midend)))))
+ " arg regs")))))
+ (set! (access compiler:compress-top-level? (->environment '(compiler)))
+ true)
+ value)))
+
+
+
+(load "midend/load" #F)
+
+
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rgspcm.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1987-1993 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. |#
+
+;;;; RTL Generation: Special primitive combinations. Spectrum version.
+
+(declare (usual-integrations))
+\f
+(define (define-special-primitive-handler name handler)
+ (let ((primitive (make-primitive-procedure name true)))
+ (let ((entry (assq primitive special-primitive-handlers)))
+ (if entry
+ (set-cdr! entry handler)
+ (set! special-primitive-handlers
+ (cons (cons primitive handler)
+ special-primitive-handlers)))))
+ name)
+
+(define (special-primitive-handler primitive)
+ (let ((entry (assq primitive special-primitive-handlers)))
+ (and entry
+ ((cdr entry)))))
+
+(define special-primitive-handlers
+ '())
+
+(define (define-special-primitive/standard primitive)
+ (define-special-primitive-handler primitive
+ (lambda ()
+ rtl:make-invocation:special-primitive)))
+
+(define (define-special-primitive/if-open-coding primitive)
+ (define-special-primitive-handler primitive
+ (lambda ()
+ (and compiler:open-code-primitives?
+ rtl:make-invocation:special-primitive))))
+
+(define-special-primitive/standard '&+)
+(define-special-primitive/standard '&-)
+(define-special-primitive/standard '&*)
+(define-special-primitive/standard '&/)
+(define-special-primitive/standard '&=)
+(define-special-primitive/standard '&<)
+(define-special-primitive/standard '&>)
+(define-special-primitive/standard '1+)
+(define-special-primitive/standard '-1+)
+(define-special-primitive/standard 'zero?)
+(define-special-primitive/standard 'positive?)
+(define-special-primitive/standard 'negative?)
+(define-special-primitive/standard 'quotient)
+(define-special-primitive/standard 'remainder)
+(define-special-primitive/if-open-coding 'vector-cons)
+(define-special-primitive/if-open-coding 'string-allocate)
+(define-special-primitive/if-open-coding 'floating-vector-cons)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules1.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1989-1994 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. |#
+
+;;;; LAP Generation Rules: Data Transfers
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Simple Operations
+
+;;; All assignments to pseudo registers are required to delete the
+;;; dead registers BEFORE performing the assignment. However, it is
+;;; necessary to derive the effective address of the source
+;;; expression(s) before deleting the dead registers. Otherwise any
+;;; source expression containing dead registers might refer to aliases
+;;; which have been reused.
+
+;;(define-rule statement
+;; (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+;; (standard-move-to-target! source target)
+;; (LAP))
+
+(define-rule statement
+ ;; tag the contents of a register
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
+ (let* ((type (standard-source! type))
+ (target (standard-move-to-target! datum target)))
+ (LAP (DEP () ,type ,(-1+ scheme-type-width) ,scheme-type-width ,target))))
+
+(define-rule statement
+ ;; tag the contents of a register
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? source))))
+ ;; (QUALIFIER (fits-in-5-bits-signed? type))
+ ;; This qualifier does not work because the qualifiers are not
+ ;; tested in the rtl compressor. The qualifier is combined with
+ ;; the rule body into a single procedure, and the rtl compressor
+ ;; cannot invoke it since it is not in the context of the lap
+ ;; generator. Thus the qualifier is not checked, the RTL instruction
+ ;; is compressed, and then the lap generator fails when the qualifier
+ ;; fails.
+ (if (= 0 type)
+ (standard-unary-conversion source target object->datum)
+ (adjust-type (if (value-class=address? (register-value-class source))
+ quad-mask-value
+ #F)
+ type
+ (standard-move-to-target! source target))))
+
+(define-rule statement
+ ;; Tag the contents of a register. This rule is here just to fix the
+ ;; poor targeting of the value register when returning an open coded
+ ;; allocator. Usually target=r2 and base=free.
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset)))))
+ (let ((base (standard-source! base))
+ (target (standard-target! target)))
+ (LAP ,@(load-offset (* 4 offset) base target)
+ ,@(adjust-type (if (value-class=address? (register-value-class base))
+ quad-mask-value
+ #F)
+ type
+ target))))
+
+(define-rule statement
+ ;; extract the type part of a register's contents
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (standard-unary-conversion source target object->type))
+
+(define-rule statement
+ ;; extract the datum part of a register's contents
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
+ (standard-unary-conversion source target object->datum))
+
+
+;(define-rule statement
+; ;; extract the value of a scheme fixnum as an unsigned machine value
+; (ASSIGN (REGISTER (? target)) (OBJECT->UNSIGNED-FIXNUM (REGISTER (? source))))
+; (standard-move-to-target! source target)
+; (LAP))
+
+(define-rule statement
+ ;; convert the contents of a register to an address
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (object->address (standard-move-to-target! source target)))
+
+(define-rule statement
+ ;; pop an object off the stack
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER (? reg)) 1))
+ (QUALIFIER (= reg regnum:stack-pointer))
+ (LAP
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,(standard-target! target))))
+
+(define-rule statement
+ ;; pop an address off the stack: usually the dynamic link
+ (ASSIGN (REGISTER (? target))
+ (OBJECT->ADDRESS (POST-INCREMENT (REGISTER (? reg)) 1)))
+ (QUALIFIER (= reg regnum:stack-pointer))
+ (let ((tgt (standard-target! target)))
+ (LAP
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,tgt)
+ ,@(object->address tgt))))
+\f
+;;;; Indexed modes
+
+(define-rule statement
+ ;; read an object from memory
+ (ASSIGN (REGISTER (? target))
+ (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
+ (standard-unary-conversion base target
+ (lambda (base target)
+ (load-word (* 4 offset) base target))))
+
+(define-rule statement
+ ;; read an object from memory
+ (ASSIGN (REGISTER (? target))
+ (OFFSET (REGISTER (? base)) (REGISTER (? offset))))
+ (let ((base (standard-source! base))
+ (offset (standard-source! offset)))
+ (let ((target (standard-target! target)))
+ (LAP (LDWX (S) (INDEX ,offset 0 ,base) ,target)))))
+\f
+;;;; Address manipulation
+
+(define-rule statement
+ ;; add a constant offset (in long words) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (standard-unary-conversion base target
+ (lambda (base target)
+ (load-offset (* 4 offset) base target))))
+
+(define-rule statement
+ ;; add a constant offset (in bytes) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (standard-unary-conversion base target
+ (lambda (base target)
+ (load-offset offset base target))))
+
+(define-rule statement
+ ;; add a constant offset (in bytes) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (standard-unary-conversion base target
+ (lambda (base target)
+ (load-offset (* 8 offset) base target))))
+
+(define-rule statement
+ ;; add a computed offset (in long words) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? offset))))
+ (indexed-load-address target base offset 4))
+
+(define-rule statement
+ ;; add a computed offset (in long words) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? offset))))
+ (indexed-load-address target base offset 1))
+
+(define-rule statement
+ ;; add a computed offset (in long words) to a register's contents
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET-ADDRESS (REGISTER (? base))
+ (REGISTER (? offset))))
+ (indexed-load-address target base offset 8))
+
+;;; Optimized address operations
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))))
+; (indexed-object->address target base index 4))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (BYTE-OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))))
+; (indexed-object->address target base index 1))
+\f
+;; These have to be here because the instruction combiner
+;; operates by combining one piece at a time, and the intermediate
+;; pieces can be generated.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+ (REGISTER (? index))))
+ (indexed-object->address target base index 4))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+ (REGISTER (? index))))
+ (indexed-object->address target base index 1))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (OFFSET-ADDRESS (REGISTER (? base))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))))
+; (indexed-object->datum target base index 4))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (BYTE-OFFSET-ADDRESS (REGISTER (? base))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))))
+; (indexed-object->datum target base index 1))
+
+(define (indexed-load-address target base index scale)
+ (let ((base (standard-source! base))
+ (index (standard-source! index)))
+ (%indexed-load-address (standard-target! target) base index scale)))
+
+;(define (indexed-object->datum target base index scale)
+; (let ((base (standard-source! base))
+; (index (standard-source! index))
+; (temp (standard-temporary!)))
+; (let ((target (standard-target! target)))
+; ;;(LAP ,@(object->datum index temp)
+; ;; ,@(%indexed-load-address target base temp scale))
+; (LAP ,@(%indexed-load-address target base index scale)))))
+
+(define (indexed-object->address target base index scale)
+ (let ((base (standard-source! base))
+ (index (standard-source! index)))
+ (let ((target (standard-target! target)))
+ (LAP ,@(%indexed-load-address target base index scale)
+ ,@(object->address target)))))
+
+(define (%indexed-load-address target base index scale)
+ (case scale
+ ((4)
+ (LAP (SH2ADDL () ,index ,base ,target)))
+ ((8)
+ (LAP (SH3ADDL () ,index ,base ,target)))
+ ((1)
+ (LAP (ADDL () ,index ,base ,target)))
+ ((2)
+ (LAP (SH1ADDL () ,index ,base ,target)))
+ (else
+ (error "%indexed-load-address: Unknown scale"))))
+\f
+;;;; Loading of Constants
+
+(define-rule statement
+ ;; load a machine constant
+ (ASSIGN (REGISTER (? target)) (MACHINE-CONSTANT (? source)))
+ (load-immediate source (standard-target! target)))
+
+(define-rule statement
+ ;; load a Scheme constant
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
+ (load-constant source (standard-target! target)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (? source register-expression))
+ (standard-move-to-target! source target)
+ (LAP))
+
+(define-rule statement
+ ;; load the type part of a Scheme constant
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (CONSTANT (? constant))))
+ (load-non-pointer 0 (object-type constant) (standard-target! target)))
+
+(define-rule statement
+ ;; load the datum part of a Scheme constant
+ (ASSIGN (REGISTER (? target)) (OBJECT->DATUM (CONSTANT (? constant))))
+ (QUALIFIER (non-pointer-object? constant))
+ (load-non-pointer 0
+ (careful-object-datum constant)
+ (standard-target! target)))
+
+(define-rule statement
+ ;; load a synthesized constant
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (load-non-pointer type datum (standard-target! target)))
+
+(define-rule statement
+ ;; load the address of a variable reference cache
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (load-pc-relative (free-reference-label name)
+ (standard-target! target)
+ 'CONSTANT))
+
+(define-rule statement
+ ;; load the address of an assignment cache
+ (ASSIGN (REGISTER (? target)) (ASSIGNMENT-CACHE (? name)))
+ (load-pc-relative (free-assignment-label name)
+ (standard-target! target)
+ 'CONSTANT))
+
+(define-rule statement
+ ;; load the address of a procedure's entry point
+ (ASSIGN (REGISTER (? target)) (ENTRY:PROCEDURE (? label)))
+ (load-pc-relative-address label (standard-target! target) 'CODE))
+
+(define-rule statement
+ ;; load the address of a continuation
+ (ASSIGN (REGISTER (? target)) (ENTRY:CONTINUATION (? label)))
+ (load-pc-relative-address label (standard-target! target) 'CODE))
+
+;;; Spectrum optimizations
+
+(define (load-entry label target)
+ (let ((target (standard-target! target)))
+ (LAP ,@(load-pc-relative-address label target 'CODE)
+ ,@(address->entry target))))
+
+(define-rule statement
+ ;; load a procedure object
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:PROCEDURE (? label))))
+ (QUALIFIER (= type (ucode-type compiled-entry)))
+ (load-entry label target))
+
+(define-rule statement
+ ;; load a return address object
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (ENTRY:CONTINUATION (? label))))
+ (QUALIFIER (= type (ucode-type compiled-entry)))
+ (load-entry label target))
+\f
+;;;; Transfers to Memory
+
+(define-rule statement
+ ;; store an object in memory
+ (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+ (? source register-expression))
+ (QUALIFIER (word-register? source))
+ (store-word (standard-source! source)
+ (* 4 offset)
+ (standard-source! base)))
+
+(define-rule statement
+ ;; Push an object register on the heap
+ ;; *** IMPORTANT: This uses a STWS instruction with the cache hint set.
+ ;; The cache hint prevents newer HP PA processors from loading a cache
+ ;; line from memory when it is about to be overwritten.
+ ;; In theory this could cause a problem at the very end (64 bytes) of the
+ ;; heap, since the last cache line may overlap the next area (the stack).
+ ;; ***
+ (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (? source register-expression))
+ (QUALIFIER (and (= reg regnum:free-pointer)
+ (word-register? source)))
+ (LAP
+ (STWS (MA C) ,(standard-source! source) (OFFSET 4 0 ,regnum:free-pointer))))
+
+(define-rule statement
+ ;; Push an object register on the stack
+ (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (? source register-expression))
+ (QUALIFIER (and (word-register? source)
+ (= reg regnum:stack-pointer)))
+ (LAP
+ (STWM () ,(standard-source! source) (OFFSET -4 0 ,regnum:stack-pointer))))
+
+;; Cheaper, common patterns.
+
+;(define-rule statement
+; (ASSIGN (OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+; (MACHINE-CONSTANT 0))
+; (store-word 0
+; (* 4 offset)
+; (standard-source! base)))
+;
+;(define-rule statement
+; (ASSIGN (POST-INCREMENT (REGISTER (? reg)) 1) (MACHINE-CONSTANT 0))
+; (QUALIFIER (= reg regnum:free-pointer))
+; (LAP (STWS (MA C) 0 (OFFSET 4 0 ,regnum:free-pointer))))
+;
+;(define-rule statement
+; (ASSIGN (PRE-INCREMENT (REGISTER (? reg)) -1) (MACHINE-CONSTANT 0))
+; (QUALIFIER (= reg regnum:stack-pointer))
+; (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer))))
+\f
+;;;; CHAR->ASCII/BYTE-OFFSET
+
+(define-rule statement
+ ;; load char object from memory and convert to ASCII byte
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (OFFSET (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset)))))
+ (standard-unary-conversion base target
+ (lambda (base target)
+ (load-byte (+ 3 (* 4 offset)) base target))))
+
+(define-rule statement
+ ;; load ASCII byte from memory
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (standard-unary-conversion base target
+ (lambda (base target)
+ (load-byte offset base target))))
+
+(define-rule statement
+ ;; load ASCII byte from memory
+ (ASSIGN (REGISTER (? target))
+ (BYTE-OFFSET (REGISTER (? base))
+ (REGISTER (? offset))))
+ (let ((base (standard-source! base))
+ (offset (standard-source! offset)))
+ (let ((target (standard-target! target)))
+ (LAP (LDBX () (INDEX ,offset 0 ,base) ,target)))))
+
+(define-rule statement
+ ;; convert char object to ASCII byte
+ ;; Missing optimization: If source is home and this is the last
+ ;; reference (it is dead afterwards), an LDB could be done instead
+ ;; of an LDW followed by an object->datum. This is unlikely since
+ ;; the value will be home only if we've spilled it, which happens
+ ;; rarely.
+ (ASSIGN (REGISTER (? target))
+ (CHAR->ASCII (REGISTER (? source))))
+ (standard-unary-conversion source target
+ (lambda (source target)
+ (LAP (EXTRU () ,source 31 8 ,target)))))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (CHAR->ASCII (CONS-POINTER (? anything) (REGISTER (? source)))))
+; anything ; ignore
+; (standard-unary-conversion source target
+; (lambda (source target)
+; (LAP (EXTRU () ,source 31 8 ,target)))))
+
+(define-rule statement
+ ;; store ASCII byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+ (REGISTER (? source)))
+ (store-byte (standard-source! source) offset (standard-source! base)))
+
+(define-rule statement
+ ;; convert char object to ASCII byte and store it in memory
+ ;; register + byte offset <- contents of register (clear top bits)
+ (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+ (CHAR->ASCII (REGISTER (? source))))
+ (store-byte (standard-source! source) offset (standard-source! base)))
+
+(define-rule statement
+ ;; store null byte in memory
+ (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+ (CHAR->ASCII (CONSTANT #\NUL)))
+ (store-byte 0 offset (standard-source! base)))
+
+;(define-rule statement
+; ;; store a character without bothering to put a typecode on it
+; (ASSIGN (BYTE-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+; (CHAR->ASCII (CONS-POINTER (? anything)
+; (REGISTER (? source)))))
+; anything ; ignore
+; (store-byte (standard-source! source) offset (standard-source! base)))
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules2.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; LAP Generation Rules: Predicates
+
+(declare (usual-integrations))
+\f
+;(define-rule predicate
+; ;; test for two registers EQ?
+; (EQ-TEST (REGISTER (? source1)) (REGISTER (? source2)))
+; (compare '= (standard-source! source1) (standard-source! source2)))
+;
+;(define-rule predicate
+; (EQ-TEST (MACHINE-CONSTANT 0) (REGISTER (? register)))
+; (compare-immediate '= 0 (standard-source! register)))
+;
+;(define-rule predicate
+; (EQ-TEST (REGISTER (? register)) (MACHINE-CONSTANT 0))
+; (compare-immediate '= 0 (standard-source! register)))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
+ (eq-test/constant*register constant register))
+
+(define-rule predicate
+ ;; test for register EQ? to constant
+ (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
+ (eq-test/constant*register constant register))
+
+(define (eq-test/constant*register constant source)
+ (let ((source (standard-source! source)))
+ (if (non-pointer-object? constant)
+ (compare-immediate '= (non-pointer->literal constant) source)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-constant constant temp)
+ ,@(compare '= temp source))))))
+
+(define-rule predicate
+ ;; test for register EQ? to synthesized constant
+ (EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum)))
+ (REGISTER (? register)))
+ (eq-test/synthesized-constant*register type datum register))
+
+(define-rule predicate
+ ;; test for register EQ? to synthesized constant
+ (EQ-TEST (REGISTER (? register))
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (MACHINE-CONSTANT (? datum))))
+ (eq-test/synthesized-constant*register type datum register))
+
+(define (eq-test/synthesized-constant*register type datum source)
+ (compare-immediate '=
+ (make-non-pointer-literal type datum)
+ (standard-source! source)))
+
+(define-rule predicate
+ ;; test for two registers, or values EQ?
+ (EQ-TEST (? source1 register-expression) (? source2 register-expression))
+ (compare '= (standard-source! source1) (standard-source! source2)))
+
+(define-rule predicate
+ (PRED-1-ARG FALSE? (REGISTER (? source)))
+ (if compiler:generate-trap-on-null-valued-conditional?
+ (let ((source (standard-source! source)))
+ (set-current-branches!
+ (lambda (label)
+ (LAP (COMBN (=) ,regnum:false-value ,source (@PCR ,label))
+ (COMCLR (<>) ,regnum:empty-list ,source 0)
+ (BREAK () 0 0)))
+ (lambda (label)
+ (let ((local-label (generate-uninterned-symbol 'quasi-bogon-)))
+ (LAP (COMBN (=) ,regnum:false-value ,source (@PCR ,local-label))
+ (COMBN (<>) ,regnum:empty-list ,source (@PCR ,label))
+ (BREAK () 0 0)
+ (LABEL ,local-label)))))
+ (LAP))
+ (compare '= regnum:false-value (standard-source! source))))
+
+(define-rule predicate
+ (PRED-1-ARG NULL? (REGISTER (? source)))
+ (compare '= regnum:empty-list (standard-source! source)))
+
+(define-rule predicate
+ ;; Branch if virtual register contains the specified type number
+ (TYPE-TEST (REGISTER (? register)) (? type))
+ (QUALIFIER (exact-integer? type))
+ (compare-immediate '= type (standard-source! register)))
+
+(define-rule predicate
+ ;; Branch if virtual register contains the specified type number
+ (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) 0)
+ (let ((src (standard-source! register)))
+ (set-current-branches!
+ (lambda (if-true)
+ (LAP (EXTRU (<>) ,src ,(-1+ scheme-type-width) ,scheme-type-width 0)
+ (B (N) (@PCR ,if-true))))
+ (lambda (if-false)
+ (LAP (EXTRU (=) ,src ,(-1+ scheme-type-width) ,scheme-type-width 0)
+ (B (N) (@PCR ,if-false)))))
+ (LAP)))
+
+(define-rule predicate
+ (PRED-2-ARGS SMALL-FIXNUM?
+ (REGISTER (? source))
+ (MACHINE-CONSTANT (? nbits)))
+ (let* ((src (standard-source! source))
+ (temp (standard-temporary!)))
+ (LAP (EXTRS () ,src 31 ,(- (+ scheme-datum-width 1) nbits) ,temp)
+ ,@(COMPARE '= src temp))))
+
+(define-rule predicate
+ (PRED-1-ARG GENERIC-ADDITIVE-TEST (REGISTER (? source)))
+ (let ((temp (standard-temporary!))
+ (src (standard-source! source)))
+ (LAP (EXTRS () ,src 31 ,scheme-datum-width ,temp)
+ ,@(compare '= src temp))))
+
+(define-rule predicate
+ (PRED-1-ARG FIXNUM? (REGISTER (? source)))
+ (let ((temp (standard-temporary!))
+ (src (standard-source! source)))
+ (LAP (EXTRS () ,src 31 ,(1+ scheme-datum-width) ,temp)
+ ,@(compare '= src temp))))
+
+#|
+;; Taken care of by rewrite
+(define-rule predicate
+ (PRED-1-ARG INDEX-FIXNUM? (REGISTER (? source)))
+ (let ((temp (standard-temporary!))
+ (src (standard-source! source)))
+ (LAP (blah blah blah))))
+|#
+
+(define-rule predicate
+ (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED?
+ (REGISTER (? smaller))
+ (REGISTER (? larger)))
+ (compare '<< (standard-source! smaller) (standard-source! larger)))
+
+(define-rule predicate
+ (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED?
+ (CONSTANT (? smaller))
+ (REGISTER (? larger)))
+ (compare-immediate '<< smaller (standard-source! larger)))
+
+(define-rule predicate
+ (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED?
+ (REGISTER (? smaller))
+ (CONSTANT (? larger)))
+ (compare-immediate '>> (standard-source! smaller) larger))
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules3.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; LAP Generation Rules: Invocations and Entries
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Invocations
+
+(define-rule statement
+ (POP-RETURN)
+ (pop-return))
+
+(define (pop-return)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(clear-map!)
+ ;; This assumes that the return address is always longword aligned
+ ;; (it better be, since instructions should be longword aligned).
+ ;; Thus the bottom two bits of temp are 0, representing the
+ ;; highest privilege level, and the privilege level will
+ ;; not be changed by the BV instruction.
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,temp)
+ ;; Originally was ,@(object->address temp)
+ ,@(entry->address temp)
+ (BV (N) 0 ,temp))))
+
+(define (%invocation:apply frame-size)
+ (case frame-size
+ ((1) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-1 4
+ ,regnum:scheme-to-interface-ble))))
+ ((2) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-2 4
+ ,regnum:scheme-to-interface-ble))))
+ ((3) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-3 4
+ ,regnum:scheme-to-interface-ble))))
+ ((4) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-4 4
+ ,regnum:scheme-to-interface-ble))))
+ ((5) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-5 4
+ ,regnum:scheme-to-interface-ble))))
+ ((6) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-6 4
+ ,regnum:scheme-to-interface-ble))))
+ ((7) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-7 4
+ ,regnum:scheme-to-interface-ble))))
+ ((8) (LAP (BLE () (OFFSET ,hook:compiler-shortcircuit-apply-8 4
+ ,regnum:scheme-to-interface-ble))))
+ (else
+ (LAP ,@(load-immediate frame-size regnum:second-arg)
+ (BLE () (OFFSET ,hook:compiler-shortcircuit-apply 4
+ ,regnum:scheme-to-interface-ble))))))
+
+(define-rule statement
+ (INVOCATION:APPLY (? frame-size) (? continuation))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ ,@(%invocation:apply frame-size)
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,regnum:first-arg)))
+
+(define-rule statement
+ (INVOCATION:JUMP (? frame-size) (? continuation) (? label))
+ frame-size continuation ;ignore
+ (LAP ,@(clear-map!)
+ (B (N) (@PCR ,label))))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-JUMP (? frame-size) (? continuation))
+ frame-size continuation ;ignore
+ ;; It expects the procedure at the top of the stack
+ (pop-return))
+
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ ,@(load-immediate number-pushed regnum:second-arg)
+ ,@(load-pc-relative-address label regnum:first-arg 'CODE)
+ ,@(invoke-interface code:compiler-lexpr-apply)))
+
+(define-rule statement
+ (INVOCATION:COMPUTED-LEXPR (? number-pushed) (? continuation))
+ continuation ;ignore
+ ;; Destination address is at TOS; pop it into first-arg
+ (LAP ,@(clear-map!)
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,regnum:first-arg)
+ ,@(load-immediate number-pushed regnum:second-arg)
+ ,@(object->address regnum:first-arg)
+ ,@(invoke-interface code:compiler-lexpr-apply)))
+\f
+#|
+ (define-rule statement
+ (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+ continuation ;ignore
+ (LAP ,@(clear-map!)
+ (B (N) (@PCR ,(free-uuo-link-label name frame-size)))))
+|#
+(define-rule statement
+ (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name))
+ (invocation:some-uuo-link frame-size continuation name free-uuo-link-label))
+
+(define-rule statement
+ (INVOCATION:GLOBAL-LINK (? frame-size) (? continuation) (? name))
+ (invocation:some-uuo-link frame-size continuation name
+ global-uuo-link-label))
+
+(define (invocation:some-uuo-link frame-size continuation name label-generator)
+ (if continuation
+ (if compiler:compile-by-procedures? ; i.e. small offsets
+ ;; Perhaps a better idea than this would be to generate the general
+ ;; code and peephole optimise
+ ;; (BL () r (@pco 0))
+ ;; (LDO/LDW () (offset d 0 r) t)
+ ;; (B (N) (@pcr label))
+ ;; to
+ ;; (BL () t (@pcr label)
+ ;; (LDO/LDW () (offset d 0 t) t)
+ ;; where d'
+
+ (let ((here (generate-label)))
+ (let ((value `(+ ,here ,(+ 8 *privilege-level*))))
+ (LAP ,@(clear-map!)
+ (LABEL ,here)
+ (BL () 19 (@PCR ,(label-generator name frame-size)))
+ (LDO () (OFFSET (- ,continuation ,value) 0 19) 19))))
+ (LAP ,@(clear-map!)
+ ,@(load-pc-relative-address continuation 19 'CODE)
+ (B (N) (@PCR ,(label-generator name frame-size)))))
+ (LAP ,@(clear-map!)
+ (B (N) (@PCR ,(label-generator name frame-size))))))
+
+
+(define-rule statement
+ (INVOCATION:CACHE-REFERENCE (? frame-size)
+ (? continuation)
+ (? extension register-expression))
+ continuation ;ignore
+ (LAP ,@(load-interface-args! extension false false false)
+ ,@(load-immediate frame-size regnum:third-arg)
+ ,@(load-pc-relative-address *block-label* regnum:second-arg 'CODE)
+ ,@(invoke-interface code:compiler-cache-reference-apply)))
+
+(define-rule statement
+ (INVOCATION:LOOKUP (? frame-size)
+ (? continuation)
+ (? environment register-expression)
+ (? name))
+ continuation ;ignore
+ (LAP ,@(load-interface-args! environment false false false)
+ ,(load-constant name regnum:second-arg)
+ ,(load-immediate frame-size regnum:third-arg)
+ ,@(invoke-interface code:compiler-lookup-apply)))
+
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
+ continuation ;ignore
+ (if (eq? primitive compiled-error-procedure)
+ (LAP ,@(clear-map!)
+ ,@(load-immediate frame-size regnum:first-arg)
+ ,@(invoke-interface code:compiler-error))
+ (let ((arity (primitive-procedure-arity primitive)))
+ (if (not (negative? arity))
+ (invoke-primitive primitive
+ hook:compiler-invoke-primitive)
+ (LAP ,@(clear-map!)
+ ,@(load-pc-relative (constant->label primitive)
+ regnum:first-arg
+ 'CONSTANT)
+ ,@(cond ((= arity -1)
+ (LAP ,@(load-immediate (-1+ frame-size) 1)
+ (STW () 1 ,reg:lexpr-primitive-arity)
+ ,@(invoke-interface
+ code:compiler-primitive-lexpr-apply)))
+ #|
+ ((not (negative? arity))
+ (invoke-interface code:compiler-primitive-apply))
+ |#
+ (else
+ ;; Unknown primitive arity. Go through apply.
+ (LAP ,@(load-immediate frame-size regnum:second-arg)
+ ,@(invoke-interface code:compiler-apply)))))))))
+
+(define (invoke-primitive primitive hook)
+ ;; Only for known, fixed-arity primitives
+ (LAP ,@(clear-map!)
+ ,@(invoke-hook hook)
+ (WORD () (- ,(constant->label primitive) *PC*))))
+\f
+(let-syntax
+ ((define-old-optimized-primitive-invocation
+ (macro (name)
+ `(define-rule statement
+ (INVOCATION:SPECIAL-PRIMITIVE
+ (? frame-size)
+ (? continuation)
+ ,(make-primitive-procedure name true))
+ frame-size
+ (old-optimized-primitive-invocation
+ ,(symbol-append 'HOOK:COMPILER- name)
+ continuation))))
+
+ (define-optimized-primitive-invocation
+ (macro (name)
+ `(define-rule statement
+ (INVOCATION:SPECIAL-PRIMITIVE
+ (? frame-size)
+ (? continuation)
+ ,(make-primitive-procedure name true))
+ frame-size
+ (optimized-primitive-invocation
+ ,(symbol-append 'HOOK:COMPILER- name)
+ continuation))))
+
+ (define-allocation-primitive
+ (macro (name)
+ (let ((prim (make-primitive-procedure name true)))
+ `(define-rule statement
+ (INVOCATION:SPECIAL-PRIMITIVE
+ (? frame-size)
+ (? continuation)
+ ,prim)
+ (open-code-block-allocation ',name ',prim
+ ,(symbol-append 'HOOK:COMPILER- name)
+ frame-size continuation))))))
+
+ (define-optimized-primitive-invocation &+)
+ (define-optimized-primitive-invocation &-)
+ (define-optimized-primitive-invocation &*)
+ (define-optimized-primitive-invocation &/)
+ (define-optimized-primitive-invocation &=)
+ (define-optimized-primitive-invocation &<)
+ (define-optimized-primitive-invocation &>)
+ (define-old-optimized-primitive-invocation 1+)
+ (define-old-optimized-primitive-invocation -1+)
+ (define-old-optimized-primitive-invocation zero?)
+ (define-old-optimized-primitive-invocation positive?)
+ (define-old-optimized-primitive-invocation negative?)
+ (define-optimized-primitive-invocation quotient)
+ (define-optimized-primitive-invocation remainder)
+ (define-allocation-primitive vector-cons)
+ (define-allocation-primitive string-allocate)
+ (define-allocation-primitive floating-vector-cons))
+\f
+(define (preserving-regs clobbered-regs gen-suffix)
+ ;; THIS IS ***NOT*** GENERAL PURPOSE CODE.
+ ;; It assumes a bunch of things, like "the pseudo-registers
+ ;; currently assigned to the clobbered registers aren't going to be
+ ;; referenced before their contents are restored."
+ ;; It is intended only for preserving registers around in-line calls
+ ;; that may need to back in to the interpreter in rare cases.
+ (define *comments* '())
+ (define (delete-clobbered-aliases-for-recomputable-pseudo-registers preserved)
+ (let* ((how (cadr preserved))
+ (reg (car preserved)))
+ (if (eq? how 'RECOMPUTE)
+ (let ((entry (map-entries:find-home *register-map* reg)))
+ (if entry
+ (let* ((aliases (map-entry-aliases entry))
+ (new-entry
+ (make-map-entry
+ (map-entry-home entry)
+ false ; Not in home anymore
+ (list-transform-negative aliases
+ (lambda (alias) (memq alias clobbered-regs)))
+ ; No clobbered regs. for aliases
+ (map-entry-label entry))))
+ (set! *comments*
+ (append
+ *comments*
+ `((COMMENT CLOBBERDATA: (,reg ,how ,entry ,new-entry)))))
+ (set! *register-map*
+ (make-register-map
+ (map-entries:replace *register-map* entry new-entry)
+ (map-registers *register-map*)))))))))
+ (for-each delete-clobbered-aliases-for-recomputable-pseudo-registers
+ *preserved-registers*)
+ (let ((clean (apply require-registers! clobbered-regs)))
+ (LAP ,@clean
+ ,@*comments*
+ ,@(call-with-values
+ clear-map!/preserving
+ (lambda (machine-regs pseudo-regs)
+ (cond ((and (null? machine-regs) (null? pseudo-regs))
+ (gen-suffix false))
+ ((null? pseudo-regs)
+ (gen-suffix (->mask machine-regs false false)))
+ (else
+ (call-with-values
+ (lambda () (->bytes pseudo-regs))
+ (lambda (gen-int-regs gen-float-regs)
+ (gen-suffix (->mask machine-regs
+ gen-int-regs
+ gen-float-regs)))))))))))
+
+(define (->bytes pseudo-regs)
+ ;; (values gen-int-regs gen-float-regs)
+ (define (do-regs regs)
+ (LAP (COMMENT (PSEUDO-REGISTERS . ,regs))
+ ,@(bytes->uwords
+ (let* ((l (length regs))
+ (bytes (reverse (cons l
+ (map register-renumber regs)))))
+ (append (let ((r (remainder (+ l 1) 4)))
+ (if (zero? r)
+ '()
+ (make-list (- 4 r) 0)))
+ bytes)))))
+
+ (call-with-values
+ (lambda ()
+ (list-split pseudo-regs
+ (lambda (reg)
+ (value-class=float? (pseudo-register-value-class reg)))))
+ (lambda (float-regs int-regs)
+ (values (and (not (null? int-regs))
+ (lambda () (do-regs int-regs)))
+ (and (not (null? float-regs))
+ (lambda () (do-regs float-regs)))))))
+
+(define (->mask machine-regs gen-int-regs gen-float-regs)
+ (let ((int-mask (make-bit-string 32 false))
+ (flo-mask (make-bit-string 32 false)))
+ (if gen-int-regs
+ (bit-string-set! int-mask (- 31 0)))
+ (if gen-float-regs
+ (bit-string-set! int-mask (- 31 1)))
+ (let loop ((regs machine-regs))
+ (cond ((not (null? regs))
+ (let ((reg (car regs)))
+ (if (< reg 32)
+ (bit-string-set! int-mask (- 31 reg))
+ (bit-string-set! flo-mask (- 31 (- reg 32))))
+ (loop (cdr regs))))
+ ((bit-string-zero? flo-mask)
+ (lambda ()
+ (LAP ,@(if gen-float-regs (gen-float-regs) (LAP))
+ ,@(if gen-int-regs (gen-int-regs) (LAP))
+ (COMMENT (MACHINE-REGS . ,machine-regs))
+ (UWORD () ,(bit-string->unsigned-integer int-mask)))))
+ (else
+ (bit-string-set! int-mask (- 31 31))
+ (lambda ()
+ (LAP ,@(if gen-float-regs (gen-float-regs) (LAP))
+ (COMMENT (MACHINE-REGS . ,machine-regs))
+ (UWORD () ,(bit-string->unsigned-integer flo-mask))
+ ,@(if gen-int-regs (gen-int-regs) (LAP))
+ (COMMENT (MACHINE-REGS . ,machine-regs))
+ (UWORD () ,(bit-string->unsigned-integer int-mask)))))))))
+\f
+;; *** optimized-primitive-invocation and open-code-block-allocation
+;; skip the first instruction of the hook as a way of signalling
+;; that there are registers to preserve. Eventually the convention
+;; can be changed, but this one is backwards compatible. ***
+
+(define *optimized-clobbered-regs*
+ (list g31 g2 g26 g25 g28 g29 fp4 fp5))
+
+(define (optimized-primitive-invocation hook cont-label)
+ (preserving-regs
+ *optimized-clobbered-regs*
+ (lambda (gen-preservation-info)
+ (let ((load-continuation
+ (if cont-label
+ (load-pc-relative-address cont-label 19 'CODE)
+ '())))
+ (if (not gen-preservation-info)
+ (LAP ,@load-continuation
+ ,@(invoke-hook/no-return hook))
+ (let ((label1 (generate-label))
+ (label2 (generate-label)))
+ (LAP ,@load-continuation
+ (BLE () (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble))
+ (LDO () (OFFSET (- (- ,label2 ,label1) ,*privilege-level*)
+ 0 31)
+ 31)
+ (LABEL ,label1)
+ ,@(gen-preservation-info)
+ (LABEL ,label2))))))))
+
+(define (old-optimized-primitive-invocation hook cont-label)
+ (let ((load-continuation
+ (if cont-label
+ (load-pc-relative-address cont-label 19 'CODE)
+ '())))
+ (LAP ,@(clear-map!)
+ ,@load-continuation
+ ,@(invoke-hook/no-return hook))))
+
+(define *allocation-clobbered-regs*
+ (list g31 g2 g26 g25 g28 g29))
+
+(define (open-code-block-allocation name prim hook frame-size cont-label)
+ name frame-size cont-label ; ignored
+ (preserving-regs
+ *allocation-clobbered-regs*
+ (lambda (gen-preservation-info)
+ (let ((load-continuation
+ (if cont-label
+ (load-pc-relative-address cont-label 19 'CODE)
+ '())))
+ (if (not gen-preservation-info)
+ (LAP ,@(clear-map!)
+ ,@load-continuation
+ ,@(invoke-hook hook)
+ (WORD () (- ,(constant->label prim) *PC*)))
+ (let ((label1 (generate-label))
+ (label2 (generate-label)))
+ (LAP ,@load-continuation
+ (BLE () (OFFSET ,hook 4 ,regnum:scheme-to-interface-ble))
+ (ADDI () (- (- ,label2 ,label1) ,*privilege-level*) 31 31)
+ (LABEL ,label1)
+ ,@(gen-preservation-info)
+ (LABEL ,label2)
+ (WORD () (- ,(constant->label prim) *PC*)))))))))
+\f
+#|
+(define (open-code-block-allocation name prim hook frame-size cont-label)
+ ;; One argument (length in units) on top of the stack.
+ ;; Note: The length checked is not necessarily the complete length
+ ;; of the object, but is off by a constant number of words, which
+ ;; is OK, since we can cons a finite number of words without
+ ;; checking.
+ (define (default)
+ (LAP ,@(clear-map!)
+ ,@(load-pc-relative (constant->label prim)
+ regnum:first-arg
+ 'CONSTANT)
+ ,@(invoke-interface code:compiler-primitive-apply)))
+
+ hook ; ignored
+ (cond ((not (= frame-size 2))
+ (error "open-code-allocate-block: Wrong number of arguments"
+ prim frame-size))
+ ((not compiler:open-code-primitives?)
+ (default))
+ (else
+ (let ((label (generate-label))
+ (rsp regnum:stack-pointer)
+ (rfp regnum:free-pointer)
+ (rmp regnum:memtop-pointer)
+ (ra1 regnum:first-arg)
+ (ra2 regnum:second-arg)
+ (ra3 regnum:third-arg)
+ (rrv regnum:return-value))
+
+ (define (end tag rl)
+ (LAP ,@(deposit-type (ucode-type manifest-nm-vector) rl)
+ (STW () ,rl (OFFSET 0 0 ,rrv))
+ ,@(deposit-type tag rrv)
+ (LDO () (OFFSET ,(* 4 frame-size) 0 ,rsp) ,rsp)
+ (B (N) (@PCR ,cont-label))
+ (LABEL ,label)
+ ,@(default)))
+
+ (case name
+ ((STRING-ALLOCATE)
+ (LAP (LDW () (OFFSET 0 0 ,rsp) ,ra1)
+ (COPY () ,rfp ,rrv)
+ ,@(object->datum ra1 ra1)
+ (ADD () ,ra1 ,rfp ,ra2)
+ (COMB (>= N) ,ra2 ,rmp (@PCR ,label))
+ (STB () 0 (OFFSET 8 0 ,ra2))
+ (SHD () 0 ,ra1 2 ,ra3)
+ (LDO () (OFFSET 2 0 ,ra3) ,ra3)
+ (STWS (MB) ,ra1 (OFFSET 4 0 ,rfp))
+ (SH2ADD () ,ra3 ,rfp ,rfp)
+ ,@(end (ucode-type string) ra3)))
+ ((FLOATING-VECTOR-CONS)
+ (LAP (LDW () (OFFSET 0 0 ,rsp) ,ra1)
+ ;; (STW () 0 (OFFSET 0 0 ,rfp))
+ (DEPI () #b100 31 3 ,rfp) ; 8-byte alignment for elements
+ (COPY () ,rfp ,rrv)
+ ,@(object->datum ra1 ra1)
+ (SH3ADD () ,ra1 ,rfp ,ra2)
+ (COMB (>= N) ,ra2 ,rmp (@PCR ,label))
+ (SHD () ,ra1 0 31 ,ra1)
+ (LDO () (OFFSET 4 0 ,ra2) ,rfp)
+ ,@(end (ucode-type flonum) ra1)))
+ (else
+ (error "open-code-block-allocation: Unknown primitive"
+ name)))))))
+|#
+\f
+;;;; Invocation Prefixes
+
+;;; MOVE-FRAME-UP size address
+;;;
+;;; Moves up the last <size> words of the stack so that the first of
+;;; these words is at location <address>, and resets the stack pointer
+;;; to the last of these words. That is, it pops off all the words
+;;; between <address> and TOS+/-<size>.
+
+(define-rule statement
+ ;; Move up 0 words back to top of stack : a No-Op
+ (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER (? reg)))
+ (QUALIFIER (= reg regnum:stack-pointer))
+ (LAP))
+
+#|
+(define-rule statement
+ ;; Move <frame-size> words back to dynamic link marker
+ (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) (REGISTER (? reg)))
+ (QUALIFIER (= reg regnum:dynamic-link))
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (LAP (COPY () ,regnum:dynamic-link ,reg)))))
+|#
+
+(define-rule statement
+ ;; Move <frame-size> words back to SP+offset
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size)
+ (OFFSET-ADDRESS (REGISTER (? reg))
+ (MACHINE-CONSTANT (? offset))))
+ (QUALIFIER (= reg regnum:stack-pointer))
+ (let ((how-far (* 4 (- offset frame-size))))
+ (cond ((zero? how-far)
+ (LAP))
+ ((negative? how-far)
+ (error "invocation-prefix:move-frame-up: bad specs"
+ frame-size offset))
+ ((zero? frame-size)
+ (load-offset how-far regnum:stack-pointer regnum:stack-pointer))
+ ((= frame-size 1)
+ (let ((temp (standard-temporary!)))
+ (LAP (LDWM () (OFFSET ,how-far 0 ,regnum:stack-pointer) ,temp)
+ (STW () ,temp (OFFSET 0 0 ,regnum:stack-pointer)))))
+ ((= frame-size 2)
+ (let ((temp1 (standard-temporary!))
+ (temp2 (standard-temporary!)))
+ (LAP (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) ,temp1)
+ (LDWM () (OFFSET ,(- how-far 4) 0 ,regnum:stack-pointer)
+ ,temp2)
+ (STW () ,temp1 (OFFSET 0 0 ,regnum:stack-pointer))
+ (STW () ,temp2 (OFFSET 4 0 ,regnum:stack-pointer)))))
+ (else
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (load-offset (* 4 offset) regnum:stack-pointer reg)))))))
+
+(define-rule statement
+ ;; Move <frame-size> words back to base virtual register + offset
+ (INVOCATION-PREFIX:MOVE-FRAME-UP
+ (? frame-size)
+ (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset))))
+ (generate/move-frame-up frame-size
+ (lambda (reg)
+ (load-offset (* 4 offset) (standard-source! base) reg))))
+\f
+;;; DYNAMIC-LINK instructions have a <frame-size>, <new frame end>,
+;;; and <current dynamic link> as arguments. They pop the stack by
+;;; removing the lesser of the amount needed to move the stack pointer
+;;; back to the <new frame end> or <current dynamic link>. The last
+;;; <frame-size> words on the stack (the stack frame for the procedure
+;;; about to be called) are then put back onto the newly adjusted
+;;; stack.
+
+#|
+(define-rule statement
+ (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size)
+ (REGISTER (? source))
+ (REGISTER (? reg)))
+ (QUALIFIER (= reg regnum:dynamic-link))
+ (if (and (zero? frame-size)
+ (= source regnum:stack-pointer))
+ (LAP)
+ (let ((env-reg (standard-move-to-temporary! source)))
+ (LAP
+ ;; skip if env LS dyn link
+ (SUB (<<=) ,env-reg ,regnum:dynamic-link 0)
+ ;; env <- dyn link
+ (COPY () ,regnum:dynamic-link ,env-reg)
+ ,@(generate/move-frame-up* frame-size env-reg)))))
+|#
+
+(define (generate/move-frame-up frame-size destination-generator)
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(destination-generator temp)
+ ,@(generate/move-frame-up* frame-size temp))))
+
+(define (generate/move-frame-up* frame-size destination)
+ ;; Destination is guaranteed to be a machine register number; that
+ ;; register has the destination base address for the frame. The stack
+ ;; pointer is reset to the top end of the copied area.
+ (LAP ,@(case frame-size
+ ((0)
+ (LAP))
+ ((1)
+ (let ((temp (standard-temporary!)))
+ (LAP (LDW () (OFFSET 0 0 ,regnum:stack-pointer) ,temp)
+ (STWM () ,temp (OFFSET -4 0 ,destination)))))
+ (else
+ (generate/move-frame-up** frame-size destination)))
+ (COPY () ,destination ,regnum:stack-pointer)))
+
+(define (generate/move-frame-up** frame-size dest)
+ (let ((from (standard-temporary!))
+ (temp1 (standard-temporary!))
+ (temp2 (standard-temporary!)))
+ (LAP ,@(load-offset (* 4 frame-size) regnum:stack-pointer from)
+ ,@(if (<= frame-size 3)
+ ;; This code can handle any number > 1 (handled above),
+ ;; but we restrict it to 3 for space reasons.
+ (let loop ((n frame-size))
+ (case n
+ ((0)
+ (LAP))
+ ((3)
+ (let ((temp3 (standard-temporary!)))
+ (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1)
+ (LDWM () (OFFSET -4 0 ,from) ,temp2)
+ (LDWM () (OFFSET -4 0 ,from) ,temp3)
+ (STWM () ,temp1 (OFFSET -4 0 ,dest))
+ (STWM () ,temp2 (OFFSET -4 0 ,dest))
+ (STWM () ,temp3 (OFFSET -4 0 ,dest)))))
+ (else
+ (LAP (LDWM () (OFFSET -4 0 ,from) ,temp1)
+ (LDWM () (OFFSET -4 0 ,from) ,temp2)
+ (STWM () ,temp1 (OFFSET -4 0 ,dest))
+ (STWM () ,temp2 (OFFSET -4 0 ,dest))
+ ,@(loop (- n 2))))))
+ (LAP ,@(load-immediate frame-size temp2)
+ (LDWM () (OFFSET -4 0 ,from) ,temp1)
+ (ADDIBF (=) -1 ,temp2 (@PCO -12))
+ (STWM () ,temp1 (OFFSET -4 0 ,dest)))))))
+\f
+;;;; External Labels
+
+(define (make-external-label code label)
+ (set! *external-labels* (cons label *external-labels*))
+ (LAP (EXTERNAL-LABEL () ,code (@PCR ,label))
+ (LABEL ,label)))
+
+;;; Entry point types
+
+(define-integrable (make-code-word min max)
+ (+ (* #x100 min) max))
+
+(define (make-procedure-code-word min max)
+ ;; The "min" byte must be less than #x80; the "max" byte may not
+ ;; equal #x80 but can take on any other value.
+ (if (or (negative? min) (>= min #x80))
+ (error "MAKE-PROCEDURE-CODE-WORD: minimum out of range" min))
+ (if (>= (abs max) #x80)
+ (error "MAKE-PROCEDURE-CODE-WORD: maximum out of range" max))
+ (make-code-word min (if (negative? max) (+ #x100 max) max)))
+
+(define expression-code-word
+ (make-code-word #xff #xff))
+
+(define internal-entry-code-word
+ (make-code-word #xff #xfe))
+
+(define internal-continuation-code-word
+ (make-code-word #xff #xfc))
+
+;; #xff #xfb taken up by return-to-interpreter and reflect-to-interface
+
+(define internal-closure-code-word
+ (make-code-word #xff #xfa))
+
+(define (continuation-code-word label)
+ (frame-size->code-word
+ (if label
+ (rtl-continuation/next-continuation-offset (label->object label))
+ 0)
+ internal-continuation-code-word))
+
+(define (internal-procedure-code-word rtl-proc)
+ ;; represented as return addresses so the debugger will
+ ;; not barf when it sees them (on the stack if interrupted).
+ (frame-size->code-word
+ (rtl-procedure/next-continuation-offset rtl-proc)
+ internal-entry-code-word))
+
+(define (frame-size->code-word offset default)
+ (cond ((not offset)
+ default)
+ ((< offset #x2000)
+ ;; This uses up through (#xff #xdf).
+ (let ((qr (integer-divide offset #x80)))
+ (make-code-word (+ #x80 (integer-divide-remainder qr))
+ (+ #x80 (integer-divide-quotient qr)))))
+ (else
+ (error "Unable to encode continuation offset" offset))))
+\f
+;;;; Procedure headers
+
+;;; The following calls MUST appear as the first thing at the entry
+;;; point of a procedure. They assume that the register map is clear
+;;; and that no register contains anything of value.
+;;;
+;;; The only reason that this is true is that no register is live
+;;; across calls. If that were not true, then we would have to save
+;;; any such registers on the stack so that they would be GC'ed
+;;; appropriately.
+;;;
+;;; The only exception is the dynamic link register, handled
+;;; specially. Procedures that require a dynamic link use a different
+;;; interrupt handler that saves and restores the dynamic link
+;;; register.
+
+#|
+(define (simple-procedure-header code-word label code)
+ (let ((gc-label (generate-label)))
+ (LAP (LABEL ,gc-label)
+ ,@(invoke-interface-ble code)
+ ,@(make-external-label code-word label)
+ ,@(interrupt-check label gc-label))))
+|#
+
+#|
+(define (dlink-procedure-header code-word label)
+ (let ((gc-label (generate-label)))
+ (LAP (LABEL ,gc-label)
+ (COPY () ,regnum:dynamic-link ,regnum:second-arg)
+ ,@(invoke-interface-ble code:compiler-interrupt-dlink)
+ ,@(make-external-label code-word label)
+ ,@(interrupt-check label gc-label))))
+|#
+
+#|
+(define (interrupt-check label gc-label)
+ (case (let ((object (label->object label)))
+ (and (rtl-procedure? object)
+ (not (rtl-procedure/stack-leaf? object))
+ compiler:generate-stack-checks?))
+ ((#F)
+ (LAP (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer
+ (@PCR ,gc-label))
+ (LDW () ,reg:memtop ,regnum:memtop-pointer)))
+ ((OUT-OF-LINE)
+ (let ((label (generate-label)))
+ (LAP (BLE ()
+ (OFFSET ,hook:compiler-stack-and-interrupt-check
+ 4
+ ,regnum:scheme-to-interface-ble))
+ ;; Assumes that (<= #x-2000 (- ,gc-label ,label) #x1fff)
+ ;; otherwise this assembles to two instructions, and it
+ ;; won't fit in the branch-delay slot.
+ (LDI () (- ,gc-label ,label) ,regnum:first-arg)
+ (LABEL ,label))))
+ (else
+ (LAP (LDW () ,reg:stack-guard ,regnum:first-arg)
+ (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer
+ (@PCR ,gc-label))
+ (COMB (<=) ,regnum:stack-pointer ,regnum:first-arg (@PCR ,gc-label))
+ (LDW () ,reg:memtop ,regnum:memtop-pointer)))))
+|#
+\f
+(define-rule statement
+ (CONTINUATION-ENTRY (? internal-label))
+ (make-external-label (continuation-code-word internal-label)
+ internal-label))
+
+(define-rule statement
+ (CONTINUATION-HEADER (? internal-label))
+ (simple-procedure-header (continuation-code-word internal-label)
+ internal-label
+ code:compiler-interrupt-continuation))
+
+(define-rule statement
+ (IC-PROCEDURE-HEADER (? internal-label))
+ (let ((procedure (label->object internal-label)))
+ (let ((external-label (rtl-procedure/external-label procedure)))
+ (LAP (ENTRY-POINT ,external-label)
+ (EQUATE ,external-label ,internal-label)
+ ,@(simple-procedure-header expression-code-word
+ internal-label
+ code:compiler-interrupt-ic-procedure)))))
+
+(define-rule statement
+ (OPEN-PROCEDURE-HEADER (? internal-label))
+ (let ((rtl-proc (label->object internal-label)))
+ (LAP (EQUATE ,(rtl-procedure/external-label rtl-proc) ,internal-label)
+ ,@((if (rtl-procedure/dynamic-link? rtl-proc)
+ dlink-procedure-header
+ (lambda (code-word label)
+ (simple-procedure-header code-word label
+ code:compiler-interrupt-procedure)))
+ (internal-procedure-code-word rtl-proc)
+ internal-label))))
+
+(define-rule statement
+ (PROCEDURE-HEADER (? internal-label) (? min) (? max))
+ (LAP (EQUATE ,(rtl-procedure/external-label (label->object internal-label))
+ ,internal-label)
+ ,@(simple-procedure-header (make-procedure-code-word min max)
+ internal-label
+ code:compiler-interrupt-procedure)))
+\f
+;;;; Closures. These two statements are intertwined:
+
+(define-rule statement
+ ;; This depends on the following facts:
+ ;; 1- TC_COMPILED_ENTRY is a multiple of two.
+ ;; 2- all the top 6 bits in a data address are 0 except the quad bit
+ ;; 3- type codes are 6 bits long.
+ (CLOSURE-HEADER (? internal-label) (? nentries) (? entry))
+ entry ; Used only if entries may not be word-aligned.
+ (if (zero? nentries)
+ (error "Closure header for closure with no entries!"
+ internal-label))
+
+ ;; Closures used to use (internal-procedure-code-word rtl-proc)
+ ;; instead of internal-closure-code-word.
+ ;; This confused the bkpt utilties and was unnecessary because
+ ;; these entry points cannot properly be used as return addresses.
+
+ (let* ((rtl-proc (label->object internal-label))
+ (external-label (rtl-procedure/external-label rtl-proc)))
+ (let ((suffix
+ (lambda (gc-label)
+ (LAP ,@(make-external-label internal-closure-code-word
+ external-label)
+ ,@(address->entry g25)
+ (STWM () ,g25 (OFFSET -4 0 ,regnum:stack-pointer))
+ (LABEL ,internal-label)
+ ,@(interrupt-check internal-label gc-label)))))
+ (share-instruction-sequence!
+ 'CLOSURE-GC-STUB
+ suffix
+ (lambda (gc-label)
+ (LAP (LABEL ,gc-label)
+ ,@(invoke-interface code:compiler-interrupt-closure)
+ ,@(suffix gc-label)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-CLOSURE (ENTRY:PROCEDURE (? procedure-label))
+ (? min) (? max) (? size)))
+ (cons-closure target procedure-label min max size))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-MULTICLOSURE (? nentries) (? size) (? entries)))
+ ;; entries is a vector of all the entry points
+ (case nentries
+ ((0)
+ (let ((dest (standard-target! target)))
+ (LAP ,@(load-non-pointer (ucode-type manifest-vector)
+ size
+ dest)
+ (STW () ,dest (OFFSET 0 0 ,regnum:free-pointer))
+ (COPY () ,regnum:free-pointer ,dest)
+ ,@(load-offset (* 4 (1+ size))
+ regnum:free-pointer
+ regnum:free-pointer))))
+ ((1)
+ (let ((entry (vector-ref entries 0)))
+ (cons-closure
+ target (car entry) (cadr entry) (caddr entry) size)))
+ (else
+ (cons-multiclosure target nentries size (vector->list entries)))))
+\f
+#|
+;;; Old style closure consing -- Out of line.
+
+(define (%cons-closure target total-size size core)
+ (let* ((flush-reg (require-registers! regnum:first-arg
+ #| regnum:addil-result |#
+ regnum:ble-return))
+ (target (standard-target! target)))
+ (LAP ,@flush-reg
+ ;; Vector header
+ ,@(load-non-pointer (ucode-type manifest-closure)
+ total-size
+ regnum:first-arg)
+ (STWS (MA C) ,regnum:first-arg (OFFSET 4 0 ,regnum:free-pointer))
+ ;; Make entries and store result
+ ,@(core target)
+ ;; Allocate space for closed-over variables
+ ,@(load-offset (* 4 size)
+ regnum:free-pointer
+ regnum:free-pointer))))
+
+(define (cons-closure target entry min max size)
+ (%cons-closure
+ target
+ (+ size closure-entry-size)
+ size
+ (lambda (target)
+ (LAP ;; Entry point is result.
+ ,@(load-offset 4 regnum:free-pointer target)
+ ,@(cons-closure-entry entry min max 8)))))
+
+(define (cons-multiclosure target nentries size entries)
+ (define (generate-entries offset entries)
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (LAP ,@(cons-closure-entry (car entry) (cadr entry) (caddr entry)
+ offset)
+ ,@(generate-entries (+ offset (* 4 closure-entry-size))
+ (cdr entries))))))
+
+ (%cons-closure
+ target
+ (+ 1 (* closure-entry-size nentries) size)
+ size
+ (lambda (target)
+ (LAP ;; Number of closure entries
+ ,@(load-entry-format nentries 0 target)
+ (STWS (MA C) ,target (OFFSET 4 0 ,regnum:free-pointer))
+ ;; First entry point is result.
+ ,@(load-offset 4 regnum:free-pointer target)
+ ,@(generate-entries 12 entries)))))
+\f
+;; Utilities for old-style closure consing.
+
+(define (load-entry-format code-word gc-offset dest)
+ (load-immediate (+ (* code-word #x10000)
+ (quotient gc-offset 2))
+ dest))
+
+(define (cons-closure-entry entry min max offset)
+ ;; Call an out-of-line hook to do this.
+ ;; Making the instructions is a lot of work!
+ ;; Perhaps there should be a closure hook invoked and the real
+ ;; entry point could follow. It would also be easier on the GC.
+ (let ((entry-label (rtl-procedure/external-label (label->object entry))))
+ (LAP ,@(load-entry-format (make-procedure-code-word min max)
+ offset
+ regnum:first-arg)
+ #|
+ ;; This does not work!!! The LDO may overflow.
+ ;; A new pseudo-op has been introduced for this purpose.
+ (BLE ()
+ (OFFSET ,hook:compiler-store-closure-entry
+ 4
+ ,regnum:scheme-to-interface-ble))
+ (LDO ()
+ (OFFSET (- ,entry-label (+ *PC* 4))
+ 0
+ ,regnum:ble-return)
+ ,regnum:addil-result)
+ |#
+ (PCR-HOOK ()
+ ,regnum:addil-result
+ (OFFSET ,hook:compiler-store-closure-entry
+ 4
+ ,regnum:scheme-to-interface-ble)
+ (@PCR ,entry-label)))))
+|#
+
+;; Magic for compiled entries.
+
+(define-integrable (address->entry register)
+ (adjust-type quad-mask-value (ucode-type compiled-entry) register))
+
+(define-integrable (entry->address register)
+ (adjust-type (ucode-type compiled-entry) quad-mask-value register))
+\f
+;;; New style closure consing using compiler-prepared and
+;;; linker-maintained patterns
+
+;; Compiled code blocks are aligned like floating-point numbers and vectors.
+;; That is, the address of their header word is congruent 4 mod 8
+
+(define *initial-dword-offset* 4)
+(define *closure-padding-bitstring* (make-bit-string 32 false))
+
+;; This agrees with hppa_extract_absolute_address in microcode/cmpintmd/hppa.h
+
+(define *ldil/ble-split*
+ ;; (expt 2 13) ***
+ 8192)
+
+(define *ldil-factor*
+ ;; (/ *ldil/ble-split* ldil-scale)
+ 4)
+
+(define (declare-closure-pattern! pattern)
+ (add-extra-code!
+ (or (find-extra-code-block 'CLOSURE-PATTERNS)
+ (let ((section-label (generate-label))
+ (ev-label (generate-label)))
+ (let ((block (declare-extra-code-block!
+ 'CLOSURE-PATTERNS
+ 'LAST
+ `(((/ (- ,ev-label ,section-label) 4)
+ . ,ev-label)))))
+ (add-extra-code! block
+ (LAP (LABEL ,section-label)))
+ block)))
+ (LAP (PADDING ,(- 4 *initial-dword-offset*) 8 ,*closure-padding-bitstring*)
+ ,@pattern)))
+
+(define (generate-closure-entry offset pattern label min max)
+ (let ((entry-label (rtl-procedure/external-label (label->object label))))
+ (LAP (USHORT ()
+ ,(make-procedure-code-word min max)
+ ,(quotient offset 2))
+ ;; This contains an offset -- the linker turns it to an abs. addr.
+ (LDIL () (* (QUOTIENT (- (+ ,pattern ,offset) ,entry-label)
+ ,*ldil/ble-split*)
+ ,*ldil-factor*)
+ 26)
+ (BLE () (OFFSET (REMAINDER (- (+ ,pattern ,offset) ,entry-label)
+ ,*ldil/ble-split*)
+ 5 26))
+ (ADDI () -15 31 25))))
+
+(define (cons-closure target entry-label min max size)
+ (let ((offset 8)
+ (total-size (+ size closure-entry-size))
+ (pattern (generate-label)))
+
+ (declare-closure-pattern!
+ (LAP ,@(lap:comment `(CLOSURE-PATTERN ,entry-label))
+ (LABEL ,pattern)
+ (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure)
+ total-size))
+ ,@(generate-closure-entry offset pattern entry-label min max)))
+ #|
+ ;; This version uses ordinary integer instructions
+
+ (let* ((offset* (* 4 (1+ closure-entry-size)))
+ (target (standard-target! target))
+ (temp1 (standard-temporary!))
+ (temp2 (standard-temporary!))
+ (temp3 (standard-temporary!)))
+
+ (LAP ,@(load-pc-relative-address pattern target 'CODE)
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp2)
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp3)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp3 (OFFSET 4 0 ,regnum:free-pointer))
+\f
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,target) ,temp2)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (LDO () (OFFSET ,(- offset offset*) 0 ,regnum:free-pointer) ,target)
+ (FDC () (INDEX 0 0 ,target))
+ (FDC () (INDEX 0 0 ,regnum:free-pointer))
+ (SYNC ())
+ (FIC () (INDEX 0 5 ,target))
+ (SYNC ())
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer)))
+ |#
+
+ #|
+ ;; This version is faster by using floating-point (doubleword) moves
+
+ (let* ((offset* (* 4 (1+ closure-entry-size)))
+ (target (standard-target! target))
+ (dwtemp1 (flonum-temporary!))
+ (dwtemp2 (flonum-temporary!))
+ (swtemp (standard-temporary!)))
+
+ (LAP ,@(load-pc-relative-address pattern target 'CODE)
+ (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align
+ (LDWS (MA) (OFFSET 4 0 ,target) ,swtemp)
+ (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp1)
+ (STWS (MA) ,swtemp (OFFSET 4 0 ,regnum:free-pointer))
+ (FLDDS (MA) (OFFSET 8 0 ,target) ,dwtemp2)
+ (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer))
+ (LDO () (OFFSET ,(- offset (- offset* 8)) 0 ,regnum:free-pointer)
+ ,target)
+ (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer))
+ (FDC () (INDEX 0 0 ,target))
+ (FDC () (INDEX 0 0 ,regnum:free-pointer))
+ (SYNC ())
+ (FIC () (INDEX 0 5 ,target))
+ (SYNC ())
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer)))
+ |#
+
+ ;; This version does the copy out of line, using fp instructions.
+
+ (let* ((hook-label (generate-label))
+ (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10
+ #| regnum:addil-result |#
+ regnum:ble-return)))
+ (delete-register! target)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target g25)
+ (LAP ,@flush-reg
+ ,@(invoke-hook hook:compiler-copy-closure-pattern)
+ (LABEL ,hook-label)
+ (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*))
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer)))))
+\f
+(define (cons-multiclosure target nentries size entries)
+ ;; nentries > 1
+ (let ((offset 12)
+ (total-size (+ (+ 1 (* closure-entry-size nentries)) size))
+ (pattern (generate-label)))
+
+ (declare-closure-pattern!
+ (LAP ,@(lap:comment `(CLOSURE-PATTERN ,(caar entries)))
+ (LABEL ,pattern)
+ (UWORD () ,(make-non-pointer-literal (ucode-type manifest-closure)
+ total-size))
+ (USHORT () ,nentries 0)
+ ,@(let make-entries ((entries entries)
+ (offset offset))
+ (if (null? entries)
+ (LAP)
+ (let ((entry (car entries)))
+ (LAP ,@(generate-closure-entry offset
+ pattern
+ (car entry)
+ (cadr entry)
+ (caddr entry))
+ ,@(make-entries (cdr entries)
+ (+ offset
+ (* 4 closure-entry-size)))))))))
+ #|
+ ;; This version uses ordinary integer instructions
+
+ (let ((target (standard-target! target)))
+ (let ((temp1 (standard-temporary!))
+ (temp2 (standard-temporary!))
+ (ctr (standard-temporary!))
+ (srcptr (standard-temporary!))
+ (index (standard-temporary!))
+ (loop-label (generate-label)))
+
+ (LAP ,@(load-pc-relative-address pattern srcptr 'CODE)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (LDO () (OFFSET 4 0 ,regnum:free-pointer) ,target)
+ (LDI () -16 ,index)
+ (LDI () ,nentries ,ctr)
+ ;; The loop copies 16 bytes, and the architecture specifies
+ ;; that a cache line must be a multiple of this value.
+ ;; Therefore we only need to flush once per loop,
+ ;; and once more (D only) to take care of phase.
+ (LABEL ,loop-label)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp1)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp2)
+ (STWS (MA C) ,temp1 (OFFSET 4 0 ,regnum:free-pointer))
+ (STWS (MA C) ,temp2 (OFFSET 4 0 ,regnum:free-pointer))
+ (FDC () (INDEX ,index 0 ,regnum:free-pointer))
+ (SYNC ())
+ (ADDIB (>) -1 ,ctr ,ctr (@PCR ,loop-label))
+ (FIC () (INDEX ,index 5 ,regnum:free-pointer))
+ (FDC () (INDEX 0 0 ,regnum:free-pointer))
+ (SYNC ())
+ (FIC () (INDEX 0 5 ,regnum:free-pointer))
+ (SYNC ())
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer))))
+ |#
+\f
+ #|
+ ;; This version is faster by using floating-point (doubleword) moves
+
+ (let ((target (standard-target! target)))
+ (let ((dwtemp1 (flonum-temporary!))
+ (dwtemp2 (flonum-temporary!))
+ (temp (standard-temporary!))
+ (ctr (standard-temporary!))
+ (srcptr (standard-temporary!))
+ (index (standard-temporary!))
+ (loop-label (generate-label)))
+
+ (LAP ,@(load-pc-relative-address pattern srcptr 'CODE)
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp)
+ (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align
+ (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer))
+ (LDO () (OFFSET 8 0 ,regnum:free-pointer) ,target)
+ (LDI () -16 ,index)
+ (LDI () ,nentries ,ctr)
+
+ ;; The loop copies 16 bytes, and the architecture specifies
+ ;; that a cache line must be a multiple of this value.
+ ;; Therefore we only need to flush (D) once per loop,
+ ;; and once more to take care of phase.
+ ;; We only need to flush the I cache once because it is
+ ;; newly allocated memory.
+
+ (LABEL ,loop-label)
+ (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp1)
+ (FLDDS (MA) (OFFSET 8 0 ,srcptr) ,dwtemp2)
+ (FSTDS (MA) ,dwtemp1 (OFFSET 8 0 ,regnum:free-pointer))
+ (FSTDS (MA) ,dwtemp2 (OFFSET 8 0 ,regnum:free-pointer))
+ (ADDIB (>) -1 ,ctr (@PCR ,loop-label))
+ (FDC () (INDEX ,index 0 ,regnum:free-pointer))
+
+ (LDWS (MA) (OFFSET 4 0 ,srcptr) ,temp)
+ (LDI () ,(* -4 (1+ size)) ,index)
+ (STWM () ,temp (OFFSET ,(* 4 (1+ size)) 0 ,regnum:free-pointer))
+ (FDC () (INDEX ,index 0 ,regnum:free-pointer))
+ (SYNC ())
+ (FIC () (INDEX 0 5 ,target))
+ (SYNC ()))))
+ |#
+
+ ;; This version does the copy out of line, using fp instructions.
+
+ (let* ((hook-label (generate-label))
+ (flush-reg (require-registers! g29 g28 g26 g25 fp11 fp10
+ #| regnum:addil-result |#
+ regnum:ble-return)))
+ (delete-register! target)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target g25)
+ (LAP ,@flush-reg
+ (LDI () ,nentries 1)
+ ,@(invoke-hook hook:compiler-copy-multiclosure-pattern)
+ (LABEL ,hook-label)
+ (UWORD () (- (- ,pattern ,hook-label) ,*privilege-level*))
+ (LDO () (OFFSET ,(* 4 size) 0 ,regnum:free-pointer)
+ ,regnum:free-pointer)))))
+\f
+;;;; Entry Header
+;;; This is invoked by the top level of the LAP generator.
+
+(define (generate/quotation-header environment-label free-ref-label n-sections)
+ ;; Calls the linker
+ (in-assembler-environment
+ (empty-register-map)
+ (list 2 19
+ regnum:first-arg regnum:second-arg
+ regnum:third-arg regnum:fourth-arg)
+ (lambda ()
+ (let* ((segment (load-pc-relative-address environment-label 1 'CONSTANT)))
+ (LAP (STWM () 2 (OFFSET -4 0 ,regnum:stack-pointer)) ; Push Env
+ (STWM () 19 (OFFSET -4 0 ,regnum:stack-pointer)) ; Push continuation
+ ,@segment
+ (STW () 2 (OFFSET 0 0 1))
+ ,@(load-pc-relative-address *block-label* regnum:second-arg 'CODE)
+ ,@(load-pc-relative-address free-ref-label regnum:third-arg
+ 'CONSTANT)
+ ,@(load-immediate n-sections regnum:fourth-arg)
+ ,@(invoke-interface-ble code:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))
+ ;; 19 popped by call to code:compiler-link
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) 2) ; Env
+ )))))
+
+
+(define (generate/remote-link code-block-label
+ environment-offset
+ free-ref-offset
+ n-sections)
+ ;; Link all of the top level procedures within the file
+ (in-assembler-environment
+ (empty-register-map)
+ (list 2 19
+ regnum:first-arg regnum:second-arg
+ regnum:third-arg regnum:fourth-arg)
+ (lambda ()
+ (let* ((segment (load-pc-relative code-block-label regnum:second-arg
+ 'CONSTANT)))
+ (LAP (STWM () 2 (OFFSET -4 0 ,regnum:stack-pointer)) ; Push Env
+ (STWM () 19 (OFFSET -4 0 ,regnum:stack-pointer)) ; Push continuation
+ ,@segment
+ ,@(object->address regnum:second-arg)
+ ,@(load-offset environment-offset regnum:second-arg 1)
+ (STW () 2 (OFFSET 0 0 1))
+ ,@(load-offset free-ref-offset regnum:second-arg regnum:third-arg)
+ ,@(load-immediate n-sections regnum:fourth-arg)
+ ,@(invoke-interface-ble code:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))
+ ;; 19 popped by call to code:compiler-link
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) 2) ; Env
+ )))))
+
+(define (in-assembler-environment map needed-registers thunk)
+ (fluid-let ((*register-map* map)
+ (*prefix-instructions* (LAP))
+ (*suffix-instructions* (LAP))
+ (*needed-registers* needed-registers))
+ (let ((instructions (thunk)))
+ (LAP ,@*prefix-instructions*
+ ,@instructions
+ ,@*suffix-instructions*))))
+\f
+(define (generate/remote-links n-code-blocks code-blocks-label n-sections)
+ (if (= n-code-blocks 0)
+ (LAP)
+ (let ((loop (generate-label))
+ (bytes (generate-label))
+ (after-bytes (generate-label)))
+ (LAP (STWM () 0 (OFFSET -4 0 ,regnum:stack-pointer))
+ (COPY () 0 ,regnum:first-arg)
+ (LABEL ,loop)
+ (LDO () (OFFSET 1 0 ,regnum:first-arg) ,regnum:second-arg)
+ (STW () ,regnum:second-arg (OFFSET 0 0 ,regnum:stack-pointer))
+ (BL () ,regnum:third-arg (@PCR ,after-bytes))
+ (DEP () 0 31 2 ,regnum:third-arg)
+ (LABEL ,bytes)
+ ,@(sections->bytes n-code-blocks n-sections)
+ (LABEL ,after-bytes)
+ (LDBX () (INDEX ,regnum:first-arg 0 ,regnum:third-arg)
+ ,regnum:fourth-arg)
+ (LDW () (OFFSET (- ,code-blocks-label ,bytes) 0 ,regnum:third-arg)
+ ,regnum:third-arg)
+ ,@(object->address regnum:third-arg)
+ (LDWX (S) (INDEX ,regnum:second-arg 0 ,regnum:third-arg)
+ ,regnum:second-arg)
+ ,@(object->address regnum:second-arg)
+ (LDW () (OFFSET 4 0 ,regnum:second-arg) ,regnum:third-arg)
+ (LDW () (OFFSET 0 0 ,regnum:second-arg) ,regnum:first-arg)
+ ,@(object->datum regnum:third-arg regnum:third-arg)
+ ,@(object->datum regnum:first-arg regnum:first-arg)
+ (SH2ADD () ,regnum:third-arg ,regnum:second-arg ,regnum:third-arg)
+ (SH2ADD () ,regnum:first-arg ,regnum:second-arg
+ ,regnum:first-arg)
+ (LDO () (OFFSET 8 0 ,regnum:third-arg) ,regnum:third-arg)
+ (STW () 2 (OFFSET 0 0 ,regnum:first-arg))
+ (STWM () 2 (OFFSET -4 0 ,regnum:stack-pointer)) ;Push Env
+ (STWM () 19 (OFFSET -4 0 ,regnum:stack-pointer)) ;Push continuation
+ ,@(invoke-interface-ble code:compiler-link)
+ ,@(make-external-label (continuation-code-word false)
+ (generate-label))
+ ;; 19 popped by call to code:compiler-link
+ (LDWM () (OFFSET 4 0 ,regnum:stack-pointer) 2) ; Env
+ (LDW () (OFFSET 0 0 ,regnum:stack-pointer) ,regnum:first-arg)
+ ,@(cond ((fits-in-5-bits-signed? n-code-blocks)
+ (LAP (COMIBF (<=) ,n-code-blocks ,regnum:first-arg
+ (@PCR ,loop))
+ (NOP ())))
+ ((fits-in-11-bits-signed? n-code-blocks)
+ (LAP (COMICLR (<=) ,n-code-blocks ,regnum:first-arg 0)
+ (B (N) (@PCR ,loop))))
+ (else
+ (LAP (LDI () ,n-code-blocks ,regnum:second-arg)
+ (COMBF (<=) ,regnum:second-arg ,regnum:first-arg
+ (@PCR ,loop))
+ (NOP ()))))
+ (LDO () (OFFSET 4 0 ,regnum:stack-pointer)
+ ,regnum:stack-pointer)))))
+
+(define (sections->bytes n-code-blocks n-sections)
+ (bytes->uwords (append (vector->list n-sections)
+ (let ((left (remainder n-code-blocks 4)))
+ (if (zero? left)
+ '()
+ (make-list (- 4 left) 0))))))
+\f
+(define (bytes->uwords bytes)
+ ;; There must be a multiple of 4 bytes
+ (let walk ((bytes bytes))
+ (if (null? bytes)
+ (LAP)
+ (let ((hi (car bytes))
+ (midhi (cadr bytes))
+ (midlo (caddr bytes))
+ (lo (cadddr bytes)))
+ (LAP (UWORD ()
+ ,(+ lo (* 256 (+ midlo (* 256 (+ midhi (* 256 hi)))))))
+ ,@(walk (cddddr bytes)))))))
+
+(define (generate/constants-block constants references assignments
+ uuo-links global-links static-vars)
+ (let ((constant-info
+ ;; Note: generate/remote-links depends on all the linkage sections
+ ;; (references & uuos) being first!
+ (declare-constants 0 (transmogrifly uuo-links)
+ (declare-constants 1 references
+ (declare-constants 2 assignments
+ (declare-constants 3 (transmogrifly global-links)
+ (declare-closure-patterns
+ (declare-constants false (map (lambda (pair)
+ (cons false (cdr pair)))
+ static-vars)
+ (declare-constants false constants
+ (cons false (LAP)))))))))))
+ (let ((free-ref-label (car constant-info))
+ (constants-code (cdr constant-info))
+ (debugging-information-label (allocate-constant-label))
+ (environment-label (allocate-constant-label))
+ (n-sections
+ (+ (if (null? uuo-links) 0 1)
+ (if (null? references) 0 1)
+ (if (null? assignments) 0 1)
+ (if (null? global-links) 0 1)
+ (if (not (find-extra-code-block 'CLOSURE-PATTERNS)) 0 1))))
+ (values
+ (LAP ,@constants-code
+ ;; Place holder for the debugging info filename
+ (SCHEME-OBJECT ,debugging-information-label DEBUGGING-INFO)
+ ;; Place holder for the load time environment if needed
+ (SCHEME-OBJECT ,environment-label
+ ,(if (null? free-ref-label) 0 'ENVIRONMENT)))
+ environment-label
+ free-ref-label
+ n-sections))))
+\f
+(define (declare-constants/tagged tag header constants info)
+ (define-integrable (wrap tag label value)
+ (LAP (,tag ,label ,value)))
+
+ (define (inner constants)
+ (if (null? constants)
+ (cdr info)
+ (let ((entry (car constants)))
+ (LAP ,@(wrap tag (cdr entry) (car entry))
+ ,@(inner (cdr constants))))))
+
+ (if (and header (not (null? constants)))
+ (let ((label (allocate-constant-label)))
+ (cons label
+ (LAP (SCHEME-OBJECT
+ ,label
+ ,(let ((datum (length constants)))
+ (if (> datum #xffff)
+ (error "datum too large" datum))
+ (+ (* header #x10000) datum)))
+ ,@(inner constants))))
+ (cons (car info) (inner constants))))
+
+(define (declare-constants header constants info)
+ (declare-constants/tagged 'SCHEME-OBJECT header constants info))
+
+(define (declare-closure-patterns info)
+ (let ((block (find-extra-code-block 'CLOSURE-PATTERNS)))
+ (if (not block)
+ info
+ (declare-constants/tagged 'SCHEME-EVALUATION
+ 4
+ (extra-code-block/xtra block)
+ info))))
+
+(define (declare-evaluations header evals info)
+ (declare-constants/tagged 'SCHEME-EVALUATION header evals info))
+
+(define (transmogrifly uuos)
+ (define (inner name assoc)
+ (if (null? assoc)
+ (transmogrifly (cdr uuos))
+ `((,name . ,(cdar assoc)) ; uuo-label LDIL
+ (0 . ,(allocate-constant-label)) ; spare BLE
+ (,(caar assoc) . ; frame-size
+ ,(allocate-constant-label))
+ ,@(inner name (cdr assoc)))))
+ (if (null? uuos)
+ '()
+ (inner (caar uuos) (cdar uuos))))
+\f
+;;;; New RTL
+
+(define-rule statement
+ (INVOCATION:REGISTER 0 #F (REGISTER (? reg))
+ #F (MACHINE-CONSTANT (? nregs)))
+ nregs ; ignored
+ (let ((addr (standard-source! reg)))
+ (LAP ,@(clear-map!)
+ (BV (N) 0 ,addr))))
+
+(define-rule statement
+ (INVOCATION:PROCEDURE 0 (? continuation) (? destination)
+ (MACHINE-CONSTANT (? nregs)))
+ nregs ; ignored
+ (LAP ,@(clear-map!)
+ ,@(if (not continuation)
+ (LAP (B (N) (@PCR ,destination)))
+ (LAP (BL () 19 (@PCR ,destination))
+ (LDO () (OFFSET ,(- 4 *privilege-level*) 0 19) 19)))))
+
+(define-rule statement
+ (INVOCATION:NEW-APPLY (? frame-size) (? continuation)
+ (REGISTER (? dest)) (MACHINE-CONSTANT (? nregs)))
+ ;; *** For now, ignore nregs and use frame-size ***
+ nregs
+ (let* ((obj (register-alias dest (register-type dest)))
+ (prefix (if obj
+ (LAP)
+ (%load-machine-register! dest regnum:first-arg
+ delete-dead-registers!)))
+ (obj* (or obj regnum:first-arg)))
+ (need-register! obj*)
+ (let ((addr (if untagged-entries? obj* (standard-temporary!)))
+ (temp (standard-temporary!))
+ (label (generate-label))
+ (load-continuation
+ (if continuation
+ (load-pc-relative-address continuation 19 'CODE)
+ '())))
+ (LAP ,@prefix
+ ,@(clear-map!)
+ ,@load-continuation
+ ,@(object->type obj* temp)
+ ,@(let ((tag (ucode-type compiled-entry)))
+ (if (fits-in-5-bits-signed? tag)
+ (LAP (COMIBN (<>) ,tag ,temp (@PCR ,label)))
+ (LAP (COMICLR (=) ,tag ,temp 0)
+ (B (N) (@PCR ,label)))))
+ ,@(if untagged-entries?
+ (LAP)
+ (LAP (COPY () ,obj* ,addr)
+ ,@(adjust-type (ucode-type compiled-entry)
+ quad-mask-value
+ addr)))
+ (LDB () (OFFSET -3 0 ,addr) ,temp)
+ (COMICLR (<>) ,frame-size ,temp 0)
+ (BV (N) 0 ,addr)
+ (LABEL ,label)
+ ,@(copy obj* regnum:first-arg)
+ ,@(%invocation:apply frame-size)
+ (NOP ())))))
+\f
+(define-rule statement
+ (RETURN-ADDRESS (? label)
+ (MACHINE-CONSTANT (? frame-size))
+ (MACHINE-CONSTANT (? nregs)))
+ nregs ; ignored
+ (begin
+ (restore-registers!)
+ (make-external-label
+ (frame-size->code-word frame-size internal-continuation-code-word)
+ label)))
+
+(define-rule statement
+ (PROCEDURE (? label) (MACHINE-CONSTANT (? frame-size)))
+ (make-external-label (frame-size->code-word frame-size
+ internal-continuation-code-word)
+ label))
+
+(define-rule statement
+ (TRIVIAL-CLOSURE (? label)
+ (MACHINE-CONSTANT (? min))
+ (MACHINE-CONSTANT (? max)))
+ (make-external-label (make-procedure-code-word min max)
+ label))
+
+(define-rule statement
+ (CLOSURE (? label) (MACHINE-CONSTANT (? frame-size)))
+ frame-size ; ignored
+ (LAP ,@(make-external-label internal-closure-code-word label)))
+
+(define-rule statement
+ (EXPRESSION (? label))
+ #|
+ ;; Prefix takes care of this
+ (LAP ,@(make-external-label expression-code-word label))
+ |#
+ label ; ignored
+ (LAP))
+\f
+(define-rule statement
+ (INTERRUPT-CHECK:PROCEDURE (? intrpt) (? heap) (? stack) (? label)
+ (MACHINE-CONSTANT (? frame-size)))
+ (generate-interrupt-check/new
+ intrpt heap stack
+ (lambda (interrupt-label)
+ (let ((ret-add-label (generate-label)))
+ (LAP (LABEL ,interrupt-label)
+ (LDI () ,(- frame-size 1) 1)
+ ,@(invoke-hook hook:compiler-interrupt-procedure/new)
+ (LABEL ,ret-add-label)
+ (WORD () (- (- ,label ,ret-add-label) ,*privilege-level*)))))))
+
+(define-rule statement
+ (INTERRUPT-CHECK:CONTINUATION (? intrpt) (? heap) (? stack) (? label)
+ (MACHINE-CONSTANT (? frame-size)))
+ ;; Generated both for continuations and in some weird case of
+ ;; top-level expressions.
+ (generate-interrupt-check/new
+ intrpt heap
+ (and (= frame-size 1) stack) ; expressions only
+ (lambda (interrupt-label)
+ (let ((ret-add-label (generate-label)))
+ (LAP (LABEL ,interrupt-label)
+ (LDI () ,(- frame-size 1) 1)
+ #| (LDI ()
+ ,(if (= nregs 0) ; **** probably wrong
+ code:compiler-interrupt-procedure
+ code:compiler-interrupt-continuation)
+ 28) |#
+ ,@(invoke-hook hook:compiler-interrupt-continuation/new)
+ (LABEL ,ret-add-label)
+ (WORD () (- (- ,label ,ret-add-label) ,*privilege-level*)))))))
+
+(define-rule statement
+ (INTERRUPT-CHECK:CLOSURE (? intrpt) (? heap) (? stack)
+ (MACHINE-CONSTANT (? frame-size)))
+ (generate-interrupt-check/new
+ intrpt heap stack
+ (lambda (interrupt-label)
+ (LAP (LABEL ,interrupt-label)
+ (LDI () ,(- frame-size 2) 1) ; Continuation and self
+ ; register are saved by other
+ ; means.
+ ,@(invoke-hook hook:compiler-interrupt-closure/new)))))
+
+(define-rule statement
+ (INTERRUPT-CHECK:SIMPLE-LOOP (? intrpt) (? heap) (? stack)
+ (? loop-label) (? header-label)
+ (MACHINE-CONSTANT (? frame-size)))
+ ;; Nothing generates this now -- JSM
+ loop-label ; ignored
+ (generate-interrupt-check/new
+ intrpt heap stack
+ (lambda (interrupt-label)
+ (let ((ret-add-label (generate-label)))
+ (LAP (LABEL ,interrupt-label)
+ (LDI () ,(- frame-size 1) 1)
+ ,@(invoke-hook hook:compiler-interrupt-procedure/new)
+ (LABEL ,ret-add-label)
+ (WORD () (- (- ,header-label ,ret-add-label)
+ ,*privilege-level*)))))))
+\f
+(define (generate-interrupt-check/new intrpt heap stack generate-stub)
+ ;; This does not check the heap because it is assumed that there is
+ ;; a large buffer at the end of the heap. As long as the code can't
+ ;; loop without checking, which is what intrpt guarantees, there
+ ;; is no need to check.
+ heap ; ignored
+ (let* ((interrupt-label (generate-label))
+ (heap-check? intrpt)
+ (stack-check? (and stack compiler:generate-stack-checks?))
+ (need-interrupt-code (lambda ()
+ (add-end-of-block-code!
+ (lambda ()
+ (generate-stub interrupt-label))))))
+ (cond ((and heap-check? stack-check?)
+ (need-interrupt-code)
+ (LAP (LDW () ,reg:stack-guard 1)
+ (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer
+ (@PCR ,interrupt-label))
+ (COMB (<=) ,regnum:stack-pointer 1 (@PCR ,interrupt-label))
+ (LDW () ,reg:memtop ,regnum:memtop-pointer)))
+ (heap-check?
+ (need-interrupt-code)
+ (LAP (COMB (>=) ,regnum:free-pointer ,regnum:memtop-pointer
+ (@PCR ,interrupt-label))
+ (LDW () ,reg:memtop ,regnum:memtop-pointer)))
+ (stack-check?
+ (need-interrupt-code)
+ (LAP (LDW () ,reg:stack-guard 1)
+ (COMBN (<=) ,regnum:stack-pointer 1 (@PCR ,interrupt-label))))
+ (else
+ (LAP)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? dst)) (ALIGN-FLOAT (REGISTER (? src))))
+ (let ((dst (standard-move-to-target! src dst)))
+ (LAP
+ ;; The STW instruction would make the heap parsable forwards
+ ;; (STW () 0 (OFFSET 0 0 ,dst))
+ (DEPI () #b100 31 3 ,dst))))
+
+;; *** For now ***
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (STATIC-CELL (? name)))
+ (***unimplemented-rtl***
+ `(ASSIGN (REGISTER ,target) (STATIC-CELL ,name))))
+
+(define (***unimplemented-rtl*** inst)
+ (error "Unimplemented RTL statement" inst))
+
+;;; Local Variables: ***
+;;; eval: (put 'declare-constants 'scheme-indent-hook 2) ***
+;;; End: ***
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rules4.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; LAP Generation Rules: Interpreter Calls
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Variable cache trap handling.
+
+(define *interpreter-call-clobbered-regs*
+ ;; g26 g25 g24 g23 used for argument passing, already cleared
+ ;; SRA - dont think so?
+ (list g31 g2 g28 g29 g26 g25 g24 g23))
+
+(define (interpreter-call code extension extra)
+ (let ((start (%load-interface-args! false extension extra false)))
+ (LAP (COMMENT >> %interface-load-args)
+ ,@start
+ (COMMENT << %interface-load-args)
+ ,@(preserving-regs
+ *interpreter-call-clobbered-regs*
+ (lambda (gen-preservation-info)
+ (if (not gen-preservation-info)
+ (invoke-interface-ble code)
+ (let ((label1 (generate-label))
+ (label2 (generate-label)))
+ (LAP (LDI () ,code ,g28)
+ (BLE () (OFFSET ,hook:compiler-interpreter-call 4
+ ,regnum:scheme-to-interface-ble))
+ (LDO ()
+ (OFFSET (- (- ,label2 ,label1)
+ ,*privilege-level*)
+ 0 31)
+ 31)
+ (LABEL ,label1)
+ ,@(gen-preservation-info)
+ (LABEL ,label2)))))))))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-REFERENCE (? cont)
+ (REGISTER (? extension))
+ (? safe?))
+ cont ; ignored
+ (interpreter-call (if safe?
+ code:compiler-safe-reference-trap
+ code:compiler-reference-trap)
+ extension false))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont)
+ (REGISTER (? extension))
+ (? value register-expression))
+ cont ; ignored
+ (interpreter-call code:compiler-assignment-trap extension value))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont)
+ (REGISTER (? extension)))
+ cont ; ignored
+ (interpreter-call code:compiler-unassigned?-trap extension false))
+\f
+;;;; Interpreter Calls
+
+;;; All the code that follows is obsolete. It hasn't been used in a while.
+;;; It is provided in case the relevant switches are turned off, but there
+;;; is no real reason to do this. Perhaps the switches should be removed.
+
+(define-rule statement
+ (INTERPRETER-CALL:ACCESS (? cont)
+ (? environment register-expression)
+ (? name))
+ cont ; ignored
+ (lookup-call code:compiler-access environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? cont)
+ (? environment register-expression)
+ (? name)
+ (? safe?))
+ cont ; ignored
+ (lookup-call (if safe? code:compiler-safe-lookup code:compiler-lookup)
+ environment
+ name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? cont)
+ (? environment register-expression)
+ (? name))
+ cont ; ignored
+ (lookup-call code:compiler-unassigned? environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (? cont)
+ (? environment register-expression)
+ (? name))
+ cont ; ignored
+ (lookup-call code:compiler-unbound? environment name))
+
+(define (lookup-call code environment name)
+ (LAP ,@(load-interface-args! false environment false false)
+ ,@(load-constant name regnum:third-arg)
+ ,@(invoke-interface-ble code)))
+
+(define-rule statement
+ (INTERPRETER-CALL:DEFINE (? cont)
+ (? environment register-expression)
+ (? name)
+ (? value register-expression))
+ cont ; ignored
+ (assignment-call code:compiler-define environment name value))
+
+(define-rule statement
+ (INTERPRETER-CALL:SET! (? cont)
+ (? environment register-expression)
+ (? name)
+ (? value register-expression))
+ cont ; ignored
+ (assignment-call code:compiler-set! environment name value))
+
+(define (assignment-call code environment name value)
+ (LAP ,@(load-interface-args! false environment false value)
+ ,@(load-constant name regnum:third-arg)
+ ,@(invoke-interface-ble code)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulfix.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1989-1994 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. |#
+
+;;;; LAP Generation Rules: Fixnum Rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Conversions
+
+;;; NOTE: The **only** part of the compiler that currently (12/28/93)
+;;; generates (OBJECT->FIXNUM ...) is opncod.scm and it guarantees
+;;; that these are either preceded by a type check for fixnum or the
+;;; user has open-coded a fixnum operation indicating that type
+;;; checking isn't necessary. So we don't bother to clear type bits
+;;; if untagged-fixnums? is #T.
+
+;;; NOTE(2): rulrew.scm removes all the occurences of
+;;; OBJECT->FIXNUM, FIXNUM->OBJECT and OBJECT->UNSIGNED-FIXNUM
+;;; as these are no-ops when using untagged fixnums
+
+;;; NOMENCLATURE:
+;;; OBJECT means an object represented in standard Scheme form
+;;; ADDRESS means a hardware pointer to an address; on the PA this
+;;; means it has the quad bits set correctly
+;;; FIXNUM means a value without type code, in a form suitable for
+;;; machine arithmetic. If UNTAGGED-FIXNUMS? is #T (i.e.
+;;; POSITIVE-FIXNUM is type code 0, NEGATIVE-FIXNUM is type
+;;; code -1), then we simply use the standard hardware
+;;; representation of integers. Otherwise, we shift the
+;;; integer so that the Scheme fixnum sign bit is stored in the
+;;; hardware sign bit: i.e. left shifted by typecode-width (6)
+;;; bits.
+
+;(define (copy-instead-of-object->fixnum source target)
+; (standard-move-to-target! source target)
+; (LAP))
+
+;(define (copy-instead-of-fixnum->object source target)
+; (standard-move-to-target! source target)
+; (LAP))
+
+;(define-rule statement
+; ;; convert a fixnum object to a "fixnum integer"
+; (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (REGISTER (? source))))
+; (if untagged-fixnums?
+; (copy-instead-of-object->fixnum source target)
+; (standard-unary-conversion source target object->fixnum)))
+
+;(define-rule statement
+; ;; load a fixnum constant as a "fixnum integer"
+; (ASSIGN (REGISTER (? target)) (OBJECT->FIXNUM (CONSTANT (? constant))))
+; (load-fixnum-constant constant (standard-target! target)))
+
+(define-rule statement
+ ;; convert a memory address to a "fixnum integer"
+ (ASSIGN (REGISTER (? target)) (ADDRESS->FIXNUM (REGISTER (? source))))
+ (standard-unary-conversion source target address->fixnum))
+
+(define-rule statement
+ ;; convert an object's address to a "fixnum integer"
+ (ASSIGN (REGISTER (? target))
+ (ADDRESS->FIXNUM (OBJECT->ADDRESS (REGISTER (? source)))))
+ (if untagged-fixnums?
+ (standard-unary-conversion source target object->datum)
+ ;;(standard-unary-conversion source target object->fixnum)
+ ))
+
+;(define-rule statement
+; ;; convert a "fixnum integer" to a fixnum object
+; (ASSIGN (REGISTER (? target)) (FIXNUM->OBJECT (REGISTER (? source))))
+; (standard-move-to-target! source target)
+; (LAP (COMMENT (elided (object->fixnum (register ,source))))))
+; ;; (standard-unary-conversion source target fixnum->object)
+
+(define-rule statement
+ ;; convert a "fixnum integer" to a memory address
+ (ASSIGN (REGISTER (? target)) (FIXNUM->ADDRESS (REGISTER (? source))))
+ (standard-unary-conversion source target fixnum->address))
+
+(let ((make-scaled-object->fixnum
+ (lambda (factor)
+ (let ((shift (integer-log-base-2? factor)))
+ (cond ((not shift)
+ (error "make-scaled-object->fixnum: Not a power of 2"
+ factor))
+ ((> shift scheme-datum-width)
+ (error "make-scaled-object->fixnum: shift too large" shift))
+ (else
+ (lambda (src tgt)
+ (if untagged-fixnums?
+ (LAP (SHD () ,src 0 ,(- 32 shift) ,tgt))
+ (LAP (SHD () ,src 0 ,(- scheme-datum-width shift)
+ ,tgt))))))))))
+
+ (define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (CONSTANT (? value))
+ (REGISTER (? source))
+ #F))
+ (QUALIFIER (integer-log-base-2? value))
+ (standard-unary-conversion source target
+ (make-scaled-object->fixnum value)))
+
+ (define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS MULTIPLY-FIXNUM
+ (REGISTER (? source))
+ (CONSTANT (? value))
+ #F))
+ (QUALIFIER (integer-log-base-2? value))
+ (standard-unary-conversion source target
+ (make-scaled-object->fixnum value))))
+\f
+(define-integrable (fixnum->index-fixnum src tgt)
+ ;; Takes a register containing a FIXNUM representing an index in
+ ;; units of Scheme object units and generates the
+ ;; corresponding FIXNUM for the byte offset: it multiplies by 4.
+ ;;! (if untagged-fixnums? 'nothing-different)
+ (LAP (SHD () ,src 0 30 ,tgt)))
+
+;(define-integrable (object->fixnum src tgt)
+; ;; With untagged-fixnums this is called *only* when we are not
+; ;; treating the src as containing a signed fixnum -- i.e. when we
+; ;; have a pointer and want to do integer arithmetic on it. In this
+; ;; case it is OK to generate positive numbers in all cases. Notice
+; ;; that we *also* choose, in this case, to have "fixnums" be
+; ;; unshifted, while with tagged-fixnums we shift to put the Scheme
+; ;; sign bit in the hardware sign bit, and unshift later.
+; (if untagged-fixnums?
+; (begin
+; (warn "object->fixum: " src tgt)
+; ;; This is wrong!
+; ;;(deposit-type 0 (standard-move-to-target! src tgt))
+; (LAP ,@(copy src tgt)
+; ,@(deposit-type 0 tgt)))
+; (LAP (SHD () ,src 0 ,scheme-datum-width ,tgt))))
+
+(define-integrable (address->fixnum src tgt)
+ ;; This happens to be the same as object->fixnum
+ ;; With untagged-fixnums we need to clear the quad bits, With single tag
+ ;; fixnums shift the sign into the machine sign, shifting out the
+ ;; quad bits.
+ (if untagged-fixnums?
+ (deposit-type 0 (standard-move-to-target! src tgt))
+ (LAP (SHD () ,src 0 ,scheme-datum-width ,tgt))))
+
+;(define-integrable (fixnum->object src tgt)
+; (if untagged-fixnums?
+; ;;B?(copy-instead-of-fixnum->object src tgt)
+; (untagged-fixnum-sign-extend src tgt)
+; (LAP ,@(load-immediate (ucode-type positive-fixnum) regnum:addil-result)
+; (SHD () ,regnum:addil-result ,src ,scheme-type-width ,tgt))))
+
+(define (fixnum->address src tgt)
+ (if untagged-fixnums?
+ (LAP (DEP () ,regnum:quad-bitmask ,(-1+ scheme-type-width)
+ ,scheme-type-width ,tgt))
+ (LAP (SHD () ,regnum:quad-bitmask ,src ,scheme-type-width ,tgt))))
+
+(define (fixnum->datum src tgt)
+ (if untagged-fixnums?
+ (deposit-type 0 (standard-move-to-target! src tgt))
+ (LAP (SHD () 0 ,src ,scheme-type-width ,tgt))))
+
+(define (load-fixnum-constant constant target)
+ (load-immediate (* constant fixnum-1) target))
+
+(define #|-integrable|# fixnum-1
+ ;; (expt 2 scheme-type-width) ***
+ (if untagged-fixnums? 1 64))
+\f
+;;;; Arithmetic Operations
+
+(define-rule statement
+ ;; execute a unary fixnum operation
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-1-ARG (? operation)
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER (fixnum-1-arg/operator? operation))
+ (standard-unary-conversion
+ source
+ target
+ (lambda (source target)
+ ((fixnum-1-arg/operator operation) target source overflow?))))
+
+(define-integrable (fixnum-1-arg/operator operation)
+ (lookup-arithmetic-method operation fixnum-methods/1-arg))
+
+(define-integrable (fixnum-1-arg/operator? operation)
+ (arithmetic-method? operation fixnum-methods/1-arg))
+
+(define fixnum-methods/1-arg
+ (list 'FIXNUM-METHODS/1-ARG))
+
+;(define-rule statement
+; ;; execute a binary fixnum operation
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM->OBJECT
+; (FIXNUM-2-ARGS (? operation)
+; (OBJECT->FIXNUM (REGISTER (? source1)))
+; (OBJECT->FIXNUM (REGISTER (? source2)))
+; (? overflow?))))
+; (QUALIFIER (fixnum-2-args/operator? operation))
+; (standard-binary-conversion source1 source2 target
+; (lambda (source1 source2 target)
+; ((fixnum-2-args/operator operation)
+; target source1 source2 overflow?))))
+
+(define-rule statement
+ ;; execute a binary fixnum operation
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (QUALIFIER (fixnum-2-args/operator? operation))
+ (standard-binary-conversion source1 source2 target
+ (lambda (source1 source2 target)
+ ((fixnum-2-args/operator operation)
+ target source1 source2 overflow?))))
+
+(define-integrable (fixnum-2-args/operator operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args))
+
+(define-integrable (fixnum-2-args/operator? operation)
+ (arithmetic-method? operation fixnum-methods/2-args))
+
+(define fixnum-methods/2-args
+ (list 'FIXNUM-METHODS/2-ARGS))
+
+;; Some operations are too long to do in-line.
+;; Use out-of-line utilities.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (QUALIFIER (fixnum-2-args/special-operator? operation))
+ (special-binary-operation
+ operation
+ (fixnum-2-args/special-operator operation)
+ target source1 source2 overflow?))
+
+(define-integrable (fixnum-2-args/special-operator operation)
+ (lookup-arithmetic-method operation fixnum-methods/2-args/special))
+
+(define-integrable (fixnum-2-args/special-operator? operation)
+ (arithmetic-method? operation fixnum-methods/2-args/special))
+
+(define fixnum-methods/2-args/special
+ (list 'FIXNUM-METHODS/2-ARGS/SPECIAL))
+\f
+;; Note: Bit-wise operations never overflow, therefore they always
+;; skip the branch (cond = TR). Perhaps they should error?
+
+;; Note: The commas in the macros do not follow normal QUASIQUOTE patterns.
+;; This is due to a bad interaction between QUASIQUOTE and LAP!
+
+(let-syntax
+ ((unary-fixnum
+ (macro (name instr nsv fixed-operand)
+ `(define-arithmetic-method ',name fixnum-methods/1-arg
+ (lambda (tgt src overflow?)
+ (if untagged-fixnums?
+ (begin
+ (if overflow? (no-overflow-branches!))
+ (LAP (,instr () ,fixed-operand ,',src ,',tgt)))
+ (if overflow?
+ (LAP (,instr (,nsv) ,fixed-operand ,',src ,',tgt))
+ (LAP (,instr () ,fixed-operand ,',src ,',tgt))))))))
+
+ (binary-fixnum
+ (macro (name instr nsv)
+ `(define-arithmetic-method ',name fixnum-methods/2-args
+ (lambda (tgt src1 src2 overflow?)
+ (if untagged-fixnums?
+ (begin
+ (if overflow? (no-overflow-branches!))
+ (LAP (,instr () ,',src1 ,',src2 ,',tgt)))
+ (if overflow?
+ (LAP (,instr (,nsv) ,',src1 ,',src2 ,',tgt))
+ (LAP (,instr () ,',src1 ,',src2 ,',tgt))))))))
+
+ (binary-out-of-line
+ (macro (name . regs)
+ `(define-arithmetic-method ',name fixnum-methods/2-args/special
+ (cons ,(symbol-append 'HOOK:COMPILER- name)
+ (lambda ()
+ ,(if (null? regs)
+ `(LAP)
+ `(require-registers! ,@regs))))))))
+
+ (unary-fixnum ONE-PLUS-FIXNUM ADDI NSV ,fixnum-1)
+ (unary-fixnum MINUS-ONE-PLUS-FIXNUM ADDI NSV ,(- fixnum-1))
+ (unary-fixnum FIXNUM-NOT SUBI TR ,(- fixnum-1));;?? XOR?
+
+ (binary-fixnum PLUS-FIXNUM ADD NSV)
+ (binary-fixnum MINUS-FIXNUM SUB NSV)
+ (binary-fixnum FIXNUM-AND AND TR)
+ (binary-fixnum FIXNUM-ANDC ANDCM TR)
+ (binary-fixnum FIXNUM-OR OR TR)
+ (binary-fixnum FIXNUM-XOR XOR TR)
+
+ (binary-out-of-line MULTIPLY-FIXNUM fp4 fp5)
+ (binary-out-of-line FIXNUM-QUOTIENT fp4 fp5)
+ (binary-out-of-line FIXNUM-REMAINDER fp4 fp5 regnum:addil-result)
+ (binary-out-of-line FIXNUM-LSH))
+\f
+;;; Out of line calls.
+
+;; Arguments are passed in regnum:first-arg and regnum:second-arg.
+;; Result is returned in regnum:first-arg, and a boolean is returned
+;; in regnum:second-arg indicating wheter there was overflow.
+#|
+(define (special-binary-operation operation hook target source1 source2 ovflw?)
+ (if (not (pair? hook))
+ (error "special-binary-operation: Unknown operation" operation))
+
+ (let* ((extra ((cdr hook)))
+ (load-1 (->machine-register source1 regnum:first-arg))
+ (load-2 (->machine-register source2 regnum:second-arg)))
+ ;; Make regnum:first-arg the only alias for target
+ (delete-register! target)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target regnum:first-arg)
+ (if (and untagged-fixnums? ovflw?)
+ (overflow-branch-if-not-nullified!))
+ (LAP ,@extra
+ ,@load-1
+ ,@load-2
+ ,@(invoke-hook (car hook))
+ ,@(if (not ovflw?)
+ (LAP)
+ (LAP (COMICLR (=) 0 ,regnum:second-arg 0))))))
+|#
+
+;; This version fixes the problem with the previous that a reduction merge
+;; like (if ... (fix:remainder x y) 0) would never assign target (=r2)
+
+(define (special-binary-operation operation hook target source1 source2 ovflw?)
+ (if (not (pair? hook))
+ (error "special-binary-operation: Unknown operation" operation))
+
+ (let* ((extra ((cdr hook)))
+ (load-1 (->machine-register source1 regnum:first-arg))
+ (load-2 (->machine-register source2 regnum:second-arg)))
+ (let ((core
+ (lambda (extra-2)
+ (if (and untagged-fixnums? ovflw?)
+ (overflow-branch-if-not-nullified!))
+ (LAP ,@extra
+ ,@load-1
+ ,@load-2
+ ,@(invoke-hook (car hook))
+ ,@extra-2
+ ,@(if (not ovflw?)
+ (LAP)
+ (LAP (COMICLR (=) 0 ,regnum:second-arg 0)))))))
+ (if (machine-register? target)
+ (begin
+ (delete-dead-registers!)
+ (core (copy regnum:first-arg target)))
+ (begin
+ (delete-register! target)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target regnum:first-arg)
+ (core (LAP)))))))
+
+;;; Binary operations with one argument constant.
+
+(define-rule statement
+ ;; execute binary fixnum operation with constant second arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? source))
+ (CONSTANT (? constant))
+ (? overflow?)))
+ (QUALIFIER
+ (fixnum-2-args/operator/register*constant? operation constant overflow?))
+ (standard-unary-conversion
+ source target
+ (lambda (source target)
+ ((fixnum-2-args/operator/register*constant operation)
+ target source constant overflow?))))
+
+(define-rule statement
+ ;; execute binary fixnum operation with constant first arg
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS (? operation)
+ (CONSTANT (? constant))
+ (REGISTER (? source))
+ (? overflow?)))
+ (QUALIFIER
+ (fixnum-2-args/operator/constant*register? operation constant overflow?))
+ (standard-unary-conversion
+ source target
+ (lambda (source target)
+ (if (fixnum-2-args/commutative? operation)
+ ((fixnum-2-args/operator/register*constant operation)
+ target source constant overflow?)
+ ((fixnum-2-args/operator/constant*register operation)
+ target constant source overflow?)))))
+\f
+(define (define-arithconst-method name table qualifier code-gen)
+ (define-arithmetic-method name table
+ (cons code-gen qualifier)))
+
+(define (fixnum-2-args/commutative? operator)
+ (memq operator '(PLUS-FIXNUM
+ MULTIPLY-FIXNUM
+ FIXNUM-AND
+ FIXNUM-OR
+ FIXNUM-XOR)))
+
+(define-integrable (fixnum-2-args/operator/register*constant operation)
+ (car (lookup-arithmetic-method operation
+ fixnum-methods/2-args/register*constant)))
+
+(define (fixnum-2-args/operator/register*constant? operation constant ovflw?)
+ (let ((handler (arithmetic-method? operation
+ fixnum-methods/2-args/register*constant)))
+ (and handler
+ ((cddr handler) constant ovflw?))))
+
+(define fixnum-methods/2-args/register*constant
+ (list 'FIXNUM-METHODS/2-ARGS/REGISTER*CONSTANT))
+
+(define-integrable (fixnum-2-args/operator/constant*register operation)
+ (car (lookup-arithmetic-method operation
+ fixnum-methods/2-args/constant*register)))
+
+(define (fixnum-2-args/operator/constant*register? operation constant ovflw?)
+ (let ((handler (arithmetic-method? operation
+ fixnum-methods/2-args/constant*register)))
+ (or (and handler
+ ((cddr handler) constant ovflw?))
+ (and (fixnum-2-args/commutative? operation)
+ (fixnum-2-args/operator/register*constant? operation
+ constant ovflw?)))))
+
+(define fixnum-methods/2-args/constant*register
+ (list 'FIXNUM-METHODS/2-ARGS/CONSTANT*REGISTER))
+
+(define (guarantee-signed-fixnum n)
+ (if (not (signed-fixnum? n)) (error "Not a signed fixnum" n))
+ n)
+
+(define (signed-fixnum? n)
+ (and (exact-integer? n)
+ (>= n signed-fixnum/lower-limit)
+ (< n signed-fixnum/upper-limit)))
+\f
+;;;; The following are for special case handling where one argument is
+;;;; a compile-time constant. Each has a predicate to see if the
+;;;; constant is of the form required for the open coding to work.
+
+(define-integrable (divisible? m n)
+ (zero? (remainder m n)))
+
+(define (integer-log-base-2? n)
+ (let loop ((power 1) (exponent 0))
+ (cond ((< n power) false)
+ ((= n power) exponent)
+ (else
+ (loop (* 2 power) (1+ exponent))))))
+\f
+(if untagged-fixnums?
+
+ (define-arithconst-method 'PLUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw?
+ ;; ignored because success of generic arithmetic pretest
+ ;; guarantees it won't overflow
+ (fits-in-14-bits-signed? (* constant fixnum-1)))
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (if overflow? (no-overflow-branches!))
+ (let ((value (* constant fixnum-1)))
+ (load-offset value src tgt))))
+
+ (define-arithconst-method 'PLUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (fits-in-11-bits-signed? (* constant fixnum-1)))
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (let ((value (* constant fixnum-1)))
+ (if overflow?
+ (cond ((zero? constant)
+ (LAP (ADD (TR) ,src 0 ,tgt)))
+ ((fits-in-11-bits-signed? value)
+ (LAP (ADDI (NSV) ,value ,src ,tgt)))
+ (else
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-fixnum-constant constant temp)
+ (ADD (NSV) ,src ,temp ,tgt)))))
+ (load-offset value src tgt)))))
+ )
+\f
+(if untagged-fixnums?
+
+ (define-arithconst-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw?
+ ;; ignored because success of generic arithmetic pretest
+ ;; guarantees it won't overflow
+ (fits-in-14-bits-signed? (- (* constant fixnum-1))))
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (if overflow? (no-overflow-branches!))
+ (let ((value (- (* constant fixnum-1))))
+ (load-offset value src tgt))))
+
+ (define-arithconst-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (fits-in-11-bits-signed? (- (* constant fixnum-1))))
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (let ((value (- (* constant fixnum-1))))
+ (if overflow?
+ (cond ((zero? constant)
+ (LAP (ADD (TR) ,src 0 ,tgt)))
+ ((fits-in-11-bits-signed? value)
+ (LAP (ADDI (NSV) ,value ,src ,tgt)))
+ (else
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-fixnum-constant constant temp)
+ (ADD (NSV) ,src ,temp ,tgt)))))
+ (load-offset value src tgt)))))
+ )
+
+(if untagged-fixnums?
+ (define-arithconst-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/constant*register
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (fits-in-11-bits-signed? (* constant fixnum-1)))
+ (lambda (tgt constant src overflow?)
+ (guarantee-signed-fixnum constant)
+ (if overflow? (no-overflow-branches!))
+ (let ((value (* constant fixnum-1)))
+ (if (fits-in-11-bits-signed? value)
+ (LAP (SUBI () ,value ,src ,tgt))
+ (error "MINUS-FIXNUM <c>*<r> with bad constant" value)))))
+
+ (define-arithconst-method 'MINUS-FIXNUM
+ fixnum-methods/2-args/constant*register
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (fits-in-11-bits-signed? (* constant fixnum-1)))
+ (lambda (tgt constant src overflow?)
+ (guarantee-signed-fixnum constant)
+ (let ((value (* constant fixnum-1)))
+ (if (fits-in-11-bits-signed? value)
+ (if overflow?
+ (LAP (SUBI (NSV) ,value ,src ,tgt))
+ (LAP (SUBI () ,value ,src ,tgt)))
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-fixnum-constant constant temp)
+ ,@(if overflow?
+ (LAP (SUB (NSV) ,temp ,src ,tgt))
+ (LAP (SUB () ,temp ,src ,tgt)))))))))
+ )
+
+
+(if untagged-fixnums?
+ (define-arithconst-method 'FIXNUM-AND
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw?
+ ;; ignored because can never happen
+ (integer-log-base-2? (+ constant 1)))
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (if overflow? (no-overflow-branches!))
+ (let ((bits (integer-log-base-2? (+ constant 1))))
+ (LAP (EXTRU () ,src 31 ,bits ,tgt))))))
+\f
+(if untagged-fixnums?
+ (define-arithconst-method 'FIXNUM-LSH
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ (if ovflw? (error "RULFIX: FIXNUM-LSH with overflow check requested"))
+ constant ; ignored
+ true)
+ ;; OVERFLOW? should never be set, because there is no generic
+ ;; LSH operation and only generics cause overflow detection
+ (lambda (tgt src shift overflow?)
+ (if overflow?
+ (error "RULFIX: FIXNUM-LSH with overflow check requested"))
+ (guarantee-signed-fixnum shift)
+ (cond ((zero? shift)
+ (copy src tgt))
+ ((negative? shift)
+ ;; Right shift
+ (let ((shift (- shift)))
+ (if (>= shift scheme-datum-width)
+ (copy 0 tgt)
+ (LAP (SHD () 0 ,src ,shift ,tgt)))))
+ (else
+ ;; Left shift
+ (if (>= shift scheme-datum-width)
+ (copy 0 tgt)
+ (LAP (SHD () ,src 0 ,(- 32 shift) ,tgt)))))))
+
+ (define-arithconst-method 'FIXNUM-LSH
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ constant ovflw? ; ignored
+ true)
+ (lambda (tgt src shift overflow?)
+ ;; What does overflow mean for a logical shift?
+ ;; The code commented out below corresponds to arithmetic shift
+ ;; overflow conditions.
+ (guarantee-signed-fixnum shift)
+ (cond ((zero? shift)
+ (cond ((not overflow?)
+ (copy src tgt))
+ ((= src tgt)
+ (LAP (SKIP (TR))))
+ (else
+ (LAP (COPY (TR) ,src ,tgt)))))
+ ((negative? shift)
+ ;; Right shift
+ (let ((shift (- shift)))
+ (cond ((< shift scheme-datum-width)
+ (LAP (SHD () 0 ,src ,shift ,tgt)
+ ;; clear shifted bits
+ (DEP (,(if overflow? 'TR 'NV))
+ 0 31 ,scheme-type-width ,tgt)))
+ ((not overflow?)
+ (copy 0 tgt))
+ (else
+ (LAP (COPY (TR) 0 ,tgt))))))
+ (else
+ ;; Left shift
+ (if (>= shift scheme-datum-width)
+ (if (not overflow?)
+ (copy 0 tgt)
+ #| (LAP (COMICLR (=) 0 ,src ,tgt)) |#
+ (LAP (COMICLR (TR) 0 ,src ,tgt)))
+ (let ((nbits (- 32 shift)))
+ (if overflow?
+ #|
+ ;; Arithmetic overflow condition accomplished
+ ;; by skipping all over the place.
+ ;; Another possibility is to use the shift-and-add
+ ;; instructions, which compute correct signed overflow
+ ;; conditions.
+ (let ((nkept (- 32 shift))
+ (temp (standard-temporary!)))
+ (LAP (ZDEP () ,src ,(- nkept 1) ,nkept ,tgt)
+ (EXTRS (=) ,src ,(- shift 1) ,shift ,temp)
+ (COMICLR (<>) -1 ,temp 0)
+ (SKIP (TR))))
+ |#
+ (LAP (ZDEP (TR) ,src ,(- nbits 1) ,nbits ,tgt))
+ (LAP (ZDEP () ,src ,(- nbits 1) ,nbits ,tgt)))))))))
+ )
+\f
+(define (no-overflow-branches!)
+ (set-current-branches!
+ (lambda (if-overflow)
+ if-overflow
+ (LAP))
+ (lambda (if-no-overflow)
+ (LAP (B (N) (@PCR ,if-no-overflow))
+ (NOP ())))))
+
+(define (untagged-fixnum-sign-extend source target)
+ (let ((len (+ 1 scheme-datum-width)))
+ (LAP (EXTRS () ,source 31 ,len ,target))))
+
+(define (fix:fixnum?-overflow-branches! register)
+ (let ((temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP ,@(untagged-fixnum-sign-extend register temp)
+ (COMBN (<>) ,register ,temp (@PCR ,if-overflow))))
+ (lambda (if-no-overflow)
+ (LAP ,@(untagged-fixnum-sign-extend register temp)
+ (COMBN (=) ,register ,temp (@PCR ,if-no-overflow)))))))
+
+(define (overflow-branch-if-not-nullified!)
+ (set-current-branches!
+ (lambda (if-overflow)
+ (LAP (B (N) (@PCR ,if-overflow))))
+ (lambda (if-no-overflow)
+ (LAP (SKIP (TR))
+ (B (N) (@PCR ,if-no-overflow))))))
+\f
+(define (expand-factor tgt src factor skipping? condition skip)
+ (define (sh3add condition src1 src2 tgt)
+ (LAP (SH3ADD ,condition ,src1 ,src2 ,tgt)))
+
+ (define (sh2add condition src1 src2 tgt)
+ (LAP (SH2ADD ,condition ,src1 ,src2 ,tgt)))
+
+ (define (sh1add condition src1 src2 tgt)
+ (LAP (SH1ADD ,condition ,src1 ,src2 ,tgt)))
+
+ (define (handle factor fixed)
+ (define (wrap instr next value)
+ (let ((code? (car next))
+ (result-reg (cadr next))
+ (temp-reg (caddr next))
+ (code (cadddr next)))
+ (list true
+ tgt
+ temp-reg
+ (LAP ,@code
+ ,@(if code?
+ (skip)
+ (LAP))
+ ,@(instr condition result-reg value tgt)))))
+
+ (cond ((zero? factor) (list false 0 fixed (LAP)))
+ ((= factor 1) (list false fixed fixed (LAP)))
+ ((divisible? factor 8)
+ (wrap sh3add (handle (/ factor 8) fixed) 0))
+ ((divisible? factor 4)
+ (wrap sh2add (handle (/ factor 4) fixed) 0))
+ ((divisible? factor 2)
+ (wrap sh1add (handle (/ factor 2) fixed) 0))
+ (else
+ (let* ((f1 (-1+ factor))
+ (fixed (if (or (not (= fixed src))
+ (not (= src tgt))
+ (and (integer-log-base-2? f1)
+ (< f1 16)))
+ fixed
+ (standard-temporary!))))
+ (cond ((divisible? f1 8)
+ (wrap sh3add (handle (/ f1 8) fixed) fixed))
+ ((divisible? f1 4)
+ (wrap sh2add (handle (/ f1 4) fixed) fixed))
+ (else
+ (wrap sh1add (handle (/ f1 2) fixed) fixed)))))))
+
+ (let ((result (handle factor src)))
+ (let ((result-reg (cadr result))
+ (temp-reg (caddr result))
+ (code (cadddr result)))
+
+ (LAP ,@(cond ((= temp-reg src)
+ (LAP))
+ ((not skipping?)
+ (LAP (COPY () ,src ,temp-reg)))
+ (else
+ (LAP (COPY (TR) ,src ,temp-reg)
+ ,@(skip))))
+ ,@code
+ ,@(cond ((= result-reg tgt)
+ (LAP))
+ ((or (null? condition)
+ (memq 'NV condition))
+ (LAP (COPY () ,result-reg ,tgt)))
+ (else
+ (LAP (COPY (TR) ,result-reg ,tgt)
+ ,@(skip))))))))
+ ; end of EXPAND-FACTOR
+\f
+(if untagged-fixnums?
+ (define-arithconst-method 'MULTIPLY-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ (let ((factor (abs constant)))
+ (or (not ovflw?)
+ (< factor 64) ; Can't overflow out of 32-bit word
+ (and
+ (< (abs factor) (expt 2 (-1+ scheme-datum-width)))
+ (integer-log-base-2? factor)))))
+
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (let* ((factor (abs constant))
+ (xpt (integer-log-base-2? factor)))
+ (case constant
+ ((0) (if overflow? (no-overflow-branches!))
+ (LAP (COPY () 0 ,tgt)))
+ ((1) (if overflow? (no-overflow-branches!))
+ (copy src tgt))
+ ((-1) (if overflow? (fix:fixnum?-overflow-branches! tgt))
+ (LAP (SUB () 0 ,src ,tgt)))
+ ((and overflow? xpt (> xpt 6))
+ (let ((true-src (if (negative? constant) tgt src))
+ (temp (standard-temporary!)))
+ (set-current-branches!
+ (lambda (if-oflow)
+ (LAP (COMBN (<>) ,true-src ,temp ,if-oflow)
+ (SHD ,true-src 0 ,(- 32 xpt) ,tgt)))
+ (lambda (if-no-oflow)
+ (LAP (COMB (=) ,true-src ,temp ,if-no-oflow)
+ (SHD ,true-src 0 ,(- 32 xpt) ,tgt))))
+ (LAP ,@(if (negative? constant)
+ (LAP (SUB () 0 ,src ,true-src))
+ (LAP))
+ (EXTRS () ,true-src 31
+ ,(- 31 (+ xpt scheme-type-width))
+ ,temp))))
+ (else
+ ;; No overflow, or small constant
+ (if overflow? (fix:fixnum?-overflow-branches! tgt))
+ (let ((src+ (if (negative? constant) tgt src)))
+ (LAP ,@(if (negative? constant)
+ (LAP (SUB () 0 ,src ,tgt))
+ (LAP))
+ ,@(if xpt
+ (LAP (SHD () ,src+ 0 ,(- 32 xpt) ,tgt))
+ (expand-factor tgt src+ factor false '()
+ (lambda () (LAP)))))))))))
+\f
+ (define-arithconst-method 'MULTIPLY-FIXNUM
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ (let ((factor (abs constant)))
+ #|
+ (or (integer-log-base-2? factor)
+ (and (<= factor 64)
+ (or (not ovflw?)
+ (<= factor (expt 2 scheme-type-width)))))
+ |#
+ (or (not ovflw?)
+ (<= factor 64)
+ (integer-log-base-2? factor))))
+
+ (lambda (tgt src constant overflow?)
+ (guarantee-signed-fixnum constant)
+ (let ((skip (if overflow? 'NSV 'NV)))
+ (case constant
+ ((0)
+ (if overflow?
+ (LAP (COPY (TR) 0 ,tgt))
+ (LAP (COPY () 0 ,tgt))))
+ ((1)
+ (if overflow?
+ (LAP (COPY (TR) ,src ,tgt))
+ (copy src tgt)))
+ ((-1)
+ (LAP (SUB (,skip) 0 ,src ,tgt)))
+ (else
+ (let* ((factor (abs constant))
+ (src+ (if (negative? constant) tgt src))
+ (xpt (integer-log-base-2? factor)))
+ (cond ((not overflow?)
+ (LAP ,@(if (negative? constant)
+ (LAP (SUB () 0 ,src ,tgt))
+ (LAP))
+ ,@(if xpt
+ (LAP (SHD () ,src+ 0 ,(- 32 xpt) ,tgt))
+ (expand-factor tgt src+ factor false '()
+ (lambda ()
+ (LAP))))))
+ ((and xpt (> xpt 6))
+ (let* ((high (standard-temporary!))
+ (low (if (or (= src tgt) (negative? constant))
+ (standard-temporary!)
+ src))
+ (nbits (- 32 xpt))
+ (core
+ (LAP (SHD () ,low 0 ,nbits ,tgt)
+ (SHD (=) ,high ,low ,(-1+ nbits) ,high)
+ (COMICLR (<>) -1 ,high 0)
+ (SKIP (TR)))))
+ (if (negative? constant)
+ (LAP (EXTRS () ,src 0 1 ,high)
+ (SUB () 0 ,src ,low)
+ (SUBB () 0 ,high ,high)
+ ,@core)
+ (LAP ,@(if (not (= src low))
+ (LAP (COPY () ,src ,low))
+ (LAP))
+ (EXTRS () ,low 0 1 ,high)
+ ,@core))))
+ (else
+ (LAP ,@(if (negative? constant)
+ (LAP (SUB (SV) 0 ,src ,tgt))
+ (LAP))
+ ,@(expand-factor tgt src+ factor
+ (negative? constant)
+ '(NSV)
+ (lambda ()
+ (LAP (SKIP (TR))))))))))))))
+ )
+\f
+;;;; Division
+
+(if untagged-fixnums?
+ (define-arithconst-method 'FIXNUM-QUOTIENT
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (integer-log-base-2? (abs constant)))
+ (lambda (tgt src constant ovflw?)
+ (guarantee-signed-fixnum constant)
+ (case constant
+ ((1) (if ovflw? (no-overflow-branches!))
+ (copy src tgt))
+ ((-1)
+ (if ovflw? (fix:fixnum?-overflow-branches!))
+ (LAP (SUB () 0 ,src ,tgt)))
+ (else
+ (let* ((factor (abs constant))
+ (xpt (integer-log-base-2? factor)))
+ (cond ((not xpt)
+ (error "fixnum-quotient: Inconsistency" constant))
+ ((>= xpt scheme-datum-width)
+ (if ovflw? (no-overflow-branches!))
+ (copy 0 tgt))
+ (else
+ ;; Note: The following cannot overflow because we are
+ ;; dividing by a constant whose absolute value is
+ ;; strictly greater than 1.
+ (if ovflw? (no-overflow-branches!))
+ (let* ((posn (- 32 xpt))
+ (delta (* (-1+ factor) fixnum-1))
+ (fits? (fits-in-11-bits-signed? delta))
+ (temp (and (not fits?) (standard-temporary!))))
+ (LAP ,@(if fits?
+ (LAP)
+ (load-immediate delta temp))
+ (ADD (>=) 0 ,src ,tgt) ; Copy to tgt & test
+ ; negative dividend
+ ,@(if fits? ; For negative dividend ONLY
+ (LAP (ADDI () ,delta ,tgt ,tgt))
+ (LAP (ADD () ,temp ,tgt ,tgt)))
+ (EXTRS () ,tgt ,(-1+ posn) ,posn ,tgt)
+ ,@(if (negative? constant)
+ (LAP (SUB () 0 ,tgt ,tgt))
+ (LAP)))))))))))
+
+ (define-arithconst-method 'FIXNUM-QUOTIENT
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (integer-log-base-2? (abs constant)))
+ (lambda (tgt src constant ovflw?)
+ (guarantee-signed-fixnum constant)
+ (case constant
+ ((1)
+ (if ovflw?
+ (LAP (COPY (TR) ,src ,tgt))
+ (copy src tgt)))
+ ((-1)
+ (let ((skip (if ovflw? 'NSV 'NV)))
+ (LAP (SUB (,skip) 0 ,src ,tgt))))
+ (else
+ (let* ((factor (abs constant))
+ (xpt (integer-log-base-2? factor)))
+ (cond ((not xpt)
+ (error "fixnum-quotient: Inconsistency" constant))
+ ((>= xpt scheme-datum-width)
+ (if ovflw?
+ (LAP (COPY (TR) 0 ,tgt))
+ (copy 0 tgt)))
+ (else
+ ;; Note: The following cannot overflow because we are
+ ;; dividing by a constant whose absolute value is
+ ;; strictly greater than 1. However, we need to
+ ;; negate after shifting, not before, because negating
+ ;; the input can overflow (if it is -0).
+ ;; This unfortunately implies an extra instruction in the
+ ;; case of negative constants because if this weren't the
+ ;; case, we could substitute the first ADD instruction for
+ ;; a SUB for negative constants, and eliminate the SUB later.
+ (let* ((posn (- 32 xpt))
+ (delta (* (-1+ factor) fixnum-1))
+ (fits? (fits-in-11-bits-signed? delta))
+ (temp (and (not fits?) (standard-temporary!))))
+
+ (LAP ,@(if fits?
+ (LAP)
+ (load-immediate delta temp))
+ (ADD (>=) 0 ,src ,tgt)
+ ,@(if fits?
+ (LAP (ADDI () ,delta ,tgt ,tgt))
+ (LAP (ADD () ,temp ,tgt ,tgt)))
+ (EXTRS () ,tgt ,(-1+ posn) ,posn ,tgt)
+ ,@(let ((skip (if ovflw? 'TR 'NV)))
+ (if (negative? constant)
+ (LAP (DEP () 0 31 ,scheme-type-width ,tgt)
+ (SUB (,skip) 0 ,tgt ,tgt))
+ (LAP
+ (DEP (,skip) 0 31 ,scheme-type-width
+ ,tgt)))))))))))))
+ )
+
+(if untagged-fixnums?
+ (define-arithconst-method 'FIXNUM-REMAINDER
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (integer-log-base-2? (abs constant)))
+ (lambda (tgt src constant ovflw?)
+ (guarantee-signed-fixnum constant)
+ (if ovflw? (no-overflow-branches!))
+ (case constant
+ ((1 -1)
+ (LAP (COPY () 0 ,tgt)))
+ (else
+ (let ((sign (standard-temporary!))
+ (len (integer-log-base-2? (abs constant))))
+ (let ((sgn-len (- 32 len)))
+ (LAP (EXTRS () ,src 0 1 ,sign)
+ (EXTRU (=) ,src 31 ,len ,tgt)
+ (DEP () ,sign ,(- sgn-len 1) ,sgn-len ,tgt))))))))
+
+ (define-arithconst-method 'FIXNUM-REMAINDER
+ fixnum-methods/2-args/register*constant
+ (lambda (constant ovflw?)
+ ovflw? ; ignored
+ (integer-log-base-2? (abs constant)))
+ (lambda (tgt src constant ovflw?)
+ (guarantee-signed-fixnum constant)
+ (case constant
+ ((1 -1)
+ (if ovflw?
+ (LAP (COPY (TR) 0 ,tgt))
+ (LAP (COPY () 0 ,tgt))))
+ (else
+ (let ((sign (standard-temporary!))
+ (len (let ((xpt (integer-log-base-2? (abs constant))))
+ (and xpt (+ xpt scheme-type-width)))))
+ (let ((sgn-len (- 32 len)))
+ (if (not len)
+ (error "fixnum-remainder: Inconsistency" constant ovflw?))
+ (LAP (EXTRS () ,src 0 1 ,sign)
+ (EXTRU (=) ,src 31 ,len ,tgt)
+ (DEP () ,sign ,(- sgn-len 1) ,sgn-len ,tgt)
+ ,@(if ovflw?
+ (LAP (SKIP (TR)))
+ (LAP)))))))))
+ )
+\f
+;;;; Predicates
+
+;; This is a kludge. It assumes that the last instruction of the
+;; arithmetic operation that may cause an overflow condition will skip
+;; the following instruction if there was no overflow, ie., the last
+;; instruction will nullify using NSV (or TR if overflow is
+;; impossible). The code for the alternative is a real kludge because
+;; we can't force the arithmetic instruction that precedes this code
+;; to use the inverted condition. Hopefully a peep-hole optimizer
+;; will fix this. The linearizer attempts to use the "good" branch.
+
+(define-rule predicate
+ (OVERFLOW-TEST)
+ ;; Overflow test handling for untagged-fixnums is embedded in the
+ ;; code for the operator.
+ (if (not untagged-fixnums?)
+ (overflow-branch-if-not-nullified!))
+ (LAP))
+
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ (QUALIFIER (memq predicate '(ZERO-FIXNUM? EQUAL-FIXNUM?
+ NEGATIVE-FIXNUM? LESS-THAN-FIXNUM?
+ POSITIVE-FIXNUM? GREATER-THAN-FIXNUM?)))
+ (compare (fixnum-pred->cc predicate)
+ (standard-source! source)
+ 0))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (compare (fixnum-pred->cc predicate)
+ (standard-source! source1)
+ (standard-source! source2)))
+
+;(define-rule predicate
+; (FIXNUM-PRED-2-ARGS (? predicate)
+; (OBJECT->FIXNUM (REGISTER (? source1)))
+; (OBJECT->FIXNUM (REGISTER (? source2))))
+; (compare (fixnum-pred->cc predicate)
+; (standard-source! source1)
+; (standard-source! source2)))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source))
+ (CONSTANT (? constant)))
+ (compare-fixnum/constant*register (invert-condition-noncommutative
+ (fixnum-pred->cc predicate))
+ constant
+ (standard-source! source)))
+
+(define-rule predicate
+ (FIXNUM-PRED-2-ARGS (? predicate)
+ (CONSTANT (? constant))
+ (REGISTER (? source)))
+ (compare-fixnum/constant*register (fixnum-pred->cc predicate)
+ constant
+ (standard-source! source)))
+
+(define-integrable (compare-fixnum/constant*register cc n r)
+ (guarantee-signed-fixnum n)
+ (compare-immediate cc (* n fixnum-1) r))
+
+(define (fixnum-pred->cc predicate)
+ (case predicate
+ ((ZERO-FIXNUM? EQUAL-FIXNUM?) '=)
+ ((NEGATIVE-FIXNUM? LESS-THAN-FIXNUM?) '<)
+ ((POSITIVE-FIXNUM? GREATER-THAN-FIXNUM?) '>)
+ (else
+ (error "fixnum-pred->cc: unknown predicate" predicate))))
+\f
+;;;; New "optimizations"
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (OBJECT->DATUM (FIXNUM->OBJECT (REGISTER (? source)))))
+; (standard-unary-conversion source target fixnum->datum))
+
+(define (constant->additive-operand operation constant)
+ (case operation
+ ((PLUS-FIXNUM ONE-PLUS-FIXNUM) constant)
+ ((MINUS-FIXNUM MINUS-ONE-PLUS-FIXNUM) (- constant))
+ (else
+ (error "constant->additive-operand: Unknown operation"
+ operation))))
+
+(define (guarantee-fixnum-result target)
+ (if untagged-fixnums?
+ (if compiler:assume-safe-fixnums?
+ (LAP)
+ (untagged-fixnum-sign-extend target target))
+ (let ((default
+ (lambda ()
+ (deposit-immediate (ucode-type positive-fixnum)
+ (-1+ scheme-type-width)
+ scheme-type-width
+ target))))
+ #|
+ ;; Unsafe at sign crossings until the tags are changed.
+ (if compiler:assume-safe-fixnums?
+ (LAP)
+ (default))
+ |#
+ (default))))
+
+;(define (obj->fix-of-reg*obj->fix-of-const operation target source constant)
+; (let* ((source (standard-source! source))
+; (temp (standard-temporary!))
+; (target (standard-target! target)))
+; (pp (list 'obj->fix-of-reg*obj->fix-of-const operation target source constant))
+; (LAP ,@(load-offset (constant->additive-operand operation constant)
+; source temp)
+; ,@(if untagged-fixnums?
+; ;;B? (copy-instead-of-object->fixnum temp target)
+; (object->fixnum temp target)
+; (object->fixnum temp target)))))
+;
+;(define (obj->fix-of-reg*obj->fix-of-const operation target source constant)
+; (let* ((source (standard-source! source))
+; (target (standard-target! target)))
+; (LAP ,@(load-offset (constant->additive-operand operation constant)
+; source target)
+; ,@(guarantee-fixnum-result target))))
+
+
+;(define (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target
+; source constant)
+; (let* ((source (standard-source! source))
+; (target (standard-target! target)))
+; (LAP ,@(load-offset (constant->additive-operand operation constant)
+; source target)
+; ,@(guarantee-fixnum-result target))))
+;
+;(define (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const
+; operation target source constant)
+; (let* ((source (standard-source! source))
+; (temp (standard-temporary!))
+; (target (standard-target! target)))
+; (LAP ,@(load-offset (constant->additive-operand operation constant)
+; source temp)
+; ,@(object->datum temp target))))
+;
+;(define (fix->obj-of-reg*obj->fix-of-const operation target source constant)
+; (let* ((source (standard-source! source))
+; (temp (standard-temporary!))
+; (target (standard-target! target)))
+; (LAP ,@(load-offset
+; (constant->additive-operand operation (* constant fixnum-1))
+; source temp)
+; ,@(fixnum->object temp target))))
+;
+;(define (obj->dat-of-fix->obj-of-reg*obj->fix-of-const
+; operation target source constant)
+; (let* ((source (standard-source! source))
+; (temp (standard-temporary!))
+; (target (standard-target! target)))
+; (LAP ,@(load-offset
+; (constant->additive-operand operation (* constant fixnum-1))
+; source temp)
+; ,@(fixnum->datum temp target))))
+\f
+;(define (incr-or-decr? operation)
+; (and (memq operation '(ONE-PLUS-FIXNUM MINUS-ONE-PLUS-FIXNUM))
+; operation))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM-1-ARG (? operation incr-or-decr?)
+; (OBJECT->FIXNUM (REGISTER (? source)))
+; #F))
+; (obj->fix-of-reg*obj->fix-of-const operation target source 1))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM-1-ARG (? operation incr-or-decr?)
+; (OBJECT->FIXNUM (REGISTER (? source)))
+; #F))
+; (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target source 1))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (OBJECT->DATUM
+; (FIXNUM->OBJECT
+; (FIXNUM-1-ARG (? operation incr-or-decr?)
+; (OBJECT->FIXNUM (REGISTER (? source)))
+; #F))))
+; (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const
+; operation target source 1))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM-1-ARG (? operation incr-or-decr?)
+; (REGISTER (? source))
+; #F))
+; (fix->obj-of-reg*obj->fix-of-const operation target source 1))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (OBJECT->DATUM
+; (FIXNUM->OBJECT
+; (FIXNUM-1-ARG (? operation incr-or-decr?)
+; (REGISTER (? source))
+; #F))))
+; (obj->dat-of-fix->obj-of-reg*obj->fix-of-const
+; operation target source 1))
+\f
+(define (plus-or-minus? operation)
+ (and (memq operation '(PLUS-FIXNUM MINUS-FIXNUM))
+ operation))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (OBJECT->FIXNUM (REGISTER (? source)))
+; (OBJECT->FIXNUM (CONSTANT (? constant)))
+; #F))
+; (obj->fix-of-reg*obj->fix-of-const operation target source constant))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM->OBJECT
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (OBJECT->FIXNUM (REGISTER (? source)))
+; (OBJECT->FIXNUM (CONSTANT (? constant)))
+; #F)))
+; (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)))
+; (fix->obj-of-obj->fix-of-reg*obj->fix-of-const operation target
+; source constant))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (OBJECT->DATUM
+; (FIXNUM->OBJECT
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (OBJECT->FIXNUM (REGISTER (? source)))
+; (OBJECT->FIXNUM (CONSTANT (? constant)))
+; #F))))
+; (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)))
+; (obj->dat-of-fix->obj-of-obj->fix-of-reg*obj->fix-of-const
+; operation target source constant))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM->OBJECT
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (REGISTER (? source))
+; (OBJECT->FIXNUM (CONSTANT (? constant)))
+; #F)))
+; (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)))
+; (fix->obj-of-reg*obj->fix-of-const operation target source constant))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (OBJECT->DATUM
+; (FIXNUM->OBJECT
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (REGISTER (? source))
+; (OBJECT->FIXNUM (CONSTANT (? constant)))
+; #F))))
+; (QUALIFIER (memq operation '(PLUS-FIXNUM MINUS-FIXNUM)))
+; (obj->dat-of-fix->obj-of-reg*obj->fix-of-const
+; operation target source constant))
+\f
+;(define (additive-operate operation target source-1 source-2)
+; (case operation
+; ((PLUS-FIXNUM)
+; (LAP (ADD () ,source-1 ,source-2 ,target)))
+; ((MINUS-FIXNUM)
+; (LAP (SUB () ,source-1 ,source-2 ,target)))
+; (else
+; (error "constant->additive-operand: Unknown operation"
+; operation))))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (REGISTER (? source-1))
+; (REGISTER (? source-2))
+; #F))
+; (let* ((source-1 (standard-source! source-1))
+; (source-2 (standard-source! source-2))
+; (target (standard-target! target)))
+; (LAP ,@(additive-operate operation target source-1 source-2))))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (REGISTER (? source-1))
+; (REGISTER (? source-2))
+; #F))
+; (let* ((source-1 (standard-source! source-1))
+; (source-2 (standard-source! source-2))
+; (target (standard-target! target)))
+; (LAP ,@(additive-operate operation target source-1 source-2))))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (REGISTER (? source-1))
+; (REGISTER (? source-2))
+; #F))
+; (let* ((source-1 (standard-source! source-1))
+; (source-2 (standard-source! source-2))
+; (target (standard-target! target)))
+; (LAP ,@(additive-operate operation target source-1 source-2))))
+;
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FIXNUM-2-ARGS (? operation plus-or-minus?)
+; (REGISTER (? source-1))
+; (REGISTER (? source-2))
+; #F))
+; (let* ((source-1 (standard-source! source-1))
+; (source-2 (standard-source! source-2))
+; (target (standard-target! target)))
+; (LAP ,@(additive-operate operation target source-1 source-2)
+; ,@(guarantee-fixnum-result target))))
+
+\f
+;; This recognises the pattern for flo:vector-length:
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (MACHINE-CONSTANT 0)
+ (FIXNUM-2-ARGS FIXNUM-LSH
+ (OBJECT->DATUM (REGISTER (? source)))
+ (CONSTANT (? constant))
+ #F)))
+ (QUALIFIER (and (integer? constant)
+ (<= (- 1 scheme-datum-width) constant -1)))
+ (let* ((source (standard-source! source))
+ (target (standard-target! target)))
+ (LAP (EXTRU () ,source ,(+ 31 constant) ,(+ scheme-datum-width constant)
+ ,target))))
+
+;; Intermediate patterns of above:
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FIXNUM-2-ARGS FIXNUM-LSH
+ (OBJECT->DATUM (REGISTER (? source)))
+ (CONSTANT (? constant))
+ #F))
+ (QUALIFIER (and (integer? constant)
+ (<= (- 1 scheme-datum-width) constant -1)))
+ (let* ((source (standard-source! source))
+ (target (standard-target! target)))
+ (LAP (EXTRU () ,source ,(+ 31 constant) ,(+ scheme-datum-width constant)
+ ,target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-NON-POINTER (MACHINE-CONSTANT 0)
+ (FIXNUM-2-ARGS FIXNUM-LSH
+ (REGISTER (? source))
+ (CONSTANT (? constant))
+ #F)))
+ (QUALIFIER (and (integer? constant)
+ (<= (- 1 scheme-datum-width) constant -1)))
+ (let* ((source (standard-source! source))
+ (target (standard-target! target)))
+ (LAP ;; Without OBJECT->DATUM the high order bits could be anything and
+ ;; some could creep into the result.
+ (EXTRU () ,source ,(+ 31 constant) ,(+ 32 constant) ,target)
+ (DEPI () 0 ,(- scheme-type-width 1) ,scheme-type-width ,target))))
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulflo.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1989-1994 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. |#
+
+;;;; LAP Generation Rules: Flonum rules
+;; Package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+(define (flonum-source! register)
+ (float-register->fpr (load-alias-register! register 'FLOAT)))
+
+(define (flonum-target! pseudo-register)
+ (delete-dead-registers!)
+ (float-register->fpr (allocate-alias-register! pseudo-register 'FLOAT)))
+
+(define (flonum-temporary!)
+ (float-register->fpr (allocate-temporary-register! 'FLOAT)))
+
+(define-rule statement
+ ;; convert a floating-point number to a flonum object
+ (ASSIGN (REGISTER (? target))
+ (FLOAT->OBJECT (REGISTER (? source))))
+ (let ((source (flonum-source! source))
+ (temp (standard-temporary!)))
+ (let ((target (standard-target! target)))
+ (LAP
+ ;; make heap parsable forwards
+ ;; (STW () 0 (OFFSET 0 0 ,regnum:free-pointer))
+ (DEPI () #b100 31 3 ,regnum:free-pointer) ; quad align
+ (COPY () ,regnum:free-pointer ,target)
+ ,@(deposit-type (ucode-type flonum) target)
+ ,@(load-non-pointer (ucode-type manifest-nm-vector) 2 temp)
+ (STWS (MA C) ,temp (OFFSET 4 0 ,regnum:free-pointer))
+ (FSTDS (MA) ,source (OFFSET 8 0 ,regnum:free-pointer))))))
+
+(define-rule statement
+ ;; convert a flonum object to a floating-point number
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (REGISTER (? source))))
+ (let ((source (standard-move-to-temporary! source)))
+ (LAP ,@(object->address source)
+ (FLDDS () (OFFSET 4 0 ,source) ,(flonum-target! target)))))
+
+;; This is endianness dependent!
+
+(define (flonum-value->data-decl value)
+ (let ((high (make-bit-string 32 false))
+ (low (make-bit-string 32 false)))
+ (read-bits! value 32 high)
+ (read-bits! value 64 low)
+ (LAP ,@(lap:comment `(FLOAT ,value))
+ (UWORD () ,(bit-string->unsigned-integer high))
+ (UWORD () ,(bit-string->unsigned-integer low)))))
+
+(define (flonum->label value)
+ (let* ((block
+ (or (find-extra-code-block 'FLOATING-CONSTANTS)
+ (let ((block (declare-extra-code-block! 'FLOATING-CONSTANTS
+ 'ANYWHERE
+ '())))
+ (add-extra-code!
+ block
+ (LAP (PADDING ,(- 0 *initial-dword-offset*) 8)))
+ block)))
+ (pairs (extra-code-block/xtra block))
+ (place (assoc value pairs)))
+ (if place
+ (cdr place)
+ (let ((label (generate-label)))
+ (set-extra-code-block/xtra!
+ block
+ (cons (cons value label) pairs))
+ (add-extra-code! block
+ (LAP (LABEL ,label)
+ ,@(flonum-value->data-decl value)))
+ label))))
+\f
+#|
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT 0.)))
+ (LAP (FCPY (DBL) 0 ,(flonum-target! target))))
+|#
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value))))
+ (cond ((not (flo:flonum? fp-value))
+ (error "OBJECT->FLOAT: Not a floating-point value" fp-value))
+ (compiler:cross-compiling?
+ (let ((temp (standard-temporary!)))
+ (LAP ,@(load-constant fp-value temp)
+ ,@(object->address temp)
+ (FLDDS () (OFFSET 4 0 ,temp) ,(flonum-target! target)))))
+ ((flo:= fp-value 0.0)
+ (LAP (FCPY (DBL) 0 ,(flonum-target! target))))
+ (else
+ (let* ((temp (standard-temporary!))
+ (target (flonum-target! target)))
+ (LAP ,@(load-pc-relative-address (flonum->label fp-value)
+ temp
+ 'CONSTANT)
+ (FLDDS () (OFFSET 0 0 ,temp) ,target))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset))))
+ (float-load/offset target base (* 8 offset)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? w-offset)))
+ (MACHINE-CONSTANT (? f-offset))))
+ (float-load/offset target base (+ (* 4 w-offset) (* 8 f-offset))))
+
+(define-rule statement
+ (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (MACHINE-CONSTANT (? offset)))
+ (REGISTER (? source)))
+ (float-store/offset base (* 8 offset) source))
+
+(define-rule statement
+ (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? w-offset)))
+ (MACHINE-CONSTANT (? f-offset)))
+ (REGISTER (? source)))
+ (float-store/offset base (+ (* 4 w-offset) (* 8 f-offset)) source))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index))))
+ (let* ((base (standard-source! base))
+ (index (standard-source! index))
+ (target (flonum-target! target)))
+ (LAP (FLDDX (S) (INDEX ,index 0 ,base) ,target))))
+
+(define-rule statement
+ (ASSIGN (FLOAT-OFFSET (REGISTER (? base)) (REGISTER (? index)))
+ (REGISTER (? source)))
+ (let ((source (flonum-source! source))
+ (base (standard-source! base))
+ (index (standard-source! index)))
+ (LAP (FSTDX (S) ,source (INDEX ,index 0 ,base)))))
+
+(define (float-load/offset target base offset)
+ (let ((base (standard-source! base)))
+ (%float-load/offset (flonum-target! target)
+ base
+ offset)))
+
+(define (float-store/offset base offset source)
+ (%float-store/offset (standard-source! base)
+ offset
+ (flonum-source! source)))
+
+(define (%float-load/offset target base offset)
+ (if (<= -16 offset 15)
+ (LAP (FLDDS () (OFFSET ,offset 0 ,base) ,target))
+ (let ((base* (standard-temporary!)))
+ (LAP (LDO () (OFFSET ,offset 0 ,base) ,base*)
+ (FLDDS () (OFFSET 0 0 ,base*) ,target)))))
+
+(define (%float-store/offset base offset source)
+ (if (<= -16 offset 15)
+ (LAP (FSTDS () ,source (OFFSET ,offset 0 ,base)))
+ (let ((base* (standard-temporary!)))
+ (LAP (LDO () (OFFSET ,offset 0 ,base) ,base*)
+ (FSTDS () ,source (OFFSET 0 0 ,base*))))))
+\f
+;;;; Optimized floating-point references
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+ (MACHINE-CONSTANT (? w-offset)))
+ (MACHINE-CONSTANT (? f-offset))))
+ (let ((b-offset (+ (* 4 w-offset) (* 8 f-offset))))
+ (reuse-pseudo-register-alias!
+ base 'GENERAL
+ (lambda (base)
+ (let ((target (flonum-target! target)))
+ (LAP ,@(object->address base)
+ ,@(%float-load/offset target base b-offset))))
+ (lambda ()
+ (let* ((base (standard-source! base))
+ (base* (standard-temporary!))
+ (target (flonum-target! target)))
+ (LAP (LDO () (OFFSET ,b-offset 0 ,base) ,base*)
+ ,@(object->address base*)
+ (FLDDS () (OFFSET 0 0 ,base*) ,target)))))))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+; (MACHINE-CONSTANT (? offset)))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))))
+; (let ((base (standard-source! base))
+; (index (standard-source! index))
+; (temp (standard-temporary!)))
+; (let ((target (flonum-target! target)))
+; (LAP (SH3ADDL () ,index ,base ,temp)
+; ,@(object->address temp)
+; ,@(%float-load/offset target temp (* 4 offset))))))
+
+;(define-rule statement
+; (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+; (MACHINE-CONSTANT (? offset)))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))
+; (REGISTER (? source)))
+; (let ((source (flonum-source! source))
+; (base (standard-source! base))
+; (index (standard-source! index))
+; (temp (standard-temporary!)))
+; (LAP (SH3ADDL () ,index ,base ,temp)
+; ,@(object->address temp)
+; ,@(%float-store/offset temp (* 4 offset) source))))
+\f
+;;;; Intermediate rules needed to generate the above.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+ (MACHINE-CONSTANT (? offset))))
+ (let* ((base (standard-source! base))
+ (target (standard-target! target)))
+ (LAP (LDO () (OFFSET ,(* 4 offset) 0 ,base) ,target)
+ ,@(object->address target))))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
+; (MACHINE-CONSTANT (? offset)))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))))
+; (let ((base (standard-source! base))
+; (index (standard-source! index))
+; (temp (standard-temporary!)))
+; (let ((target (flonum-target! target)))
+; (LAP ;; ,@(object->datum index temp)
+; ;; (SH3ADDL () ,temp ,base ,temp)
+; (SH3ADDL () ,index ,base ,temp)
+; ,@(%float-load/offset target temp (* 4 offset))))))
+
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FLOAT-OFFSET (REGISTER (? base))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))))
+; (let ((base (standard-source! base))
+; (index (standard-source! index))
+; (temp (standard-temporary!)))
+; (let ((target (flonum-target! target)))
+; (LAP ,@(object->datum index temp)
+; (FLDDX (S) (INDEX ,temp 0 ,base) ,target)))))
+
+;(define-rule statement
+; (ASSIGN (REGISTER (? target))
+; (FLOAT-OFFSET (REGISTER (? base))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index)))))
+; (let ((base (standard-source! base))
+; (index (standard-source! index)))
+; (let ((target (flonum-target! target)))
+; (LAP (FLDDX (S) (INDEX ,index 0 ,base) ,target)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset)))
+ (REGISTER (? index))))
+ (let ((base (standard-source! base))
+ (index (standard-source! index))
+ (temp (standard-temporary!)))
+ (let ((target (flonum-target! target)))
+ (LAP (SH3ADDL () ,index ,base ,temp)
+ ,@(%float-load/offset target temp (* 4 offset))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+ (MACHINE-CONSTANT (? offset)))
+ (REGISTER (? index))))
+ (let ((base (standard-source! base))
+ (index (standard-source! index))
+ (temp (standard-temporary!)))
+ (let ((target (flonum-target! target)))
+ (LAP (SH3ADDL () ,index ,base ,temp)
+ ,@(object->address temp)
+ ,@(%float-load/offset target temp (* 4 offset))))))
+\f
+;(define-rule statement
+; (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
+; (MACHINE-CONSTANT (? offset)))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))
+; (REGISTER (? source)))
+; (let ((base (standard-source! base))
+; (index (standard-source! index))
+; (temp (standard-temporary!))
+; (source (flonum-source! source)))
+; (LAP ;; ,@(object->datum index temp)
+; ;; (SH3ADDL () ,temp ,base ,temp)
+; (SH3ADDL () ,index ,base ,temp)
+; ,@(%float-store/offset temp (* 4 offset) source))))
+
+;(define-rule statement
+; (ASSIGN (FLOAT-OFFSET (REGISTER (? base))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))
+; (REGISTER (? source)))
+; (let ((base (standard-source! base))
+; (index (standard-source! index))
+; (temp (standard-temporary!))
+; (source (flonum-source! source)))
+; (LAP ,@(object->datum index temp)
+; (FSTDX (S) ,source (INDEX ,temp 0 ,base)))))
+
+;(define-rule statement
+; (ASSIGN (FLOAT-OFFSET (REGISTER (? base))
+; (OBJECT->UNSIGNED-FIXNUM (REGISTER (? index))))
+; (REGISTER (? source)))
+; (let ((base (standard-source! base))
+; (index (standard-source! index))
+; (source (flonum-source! source)))
+; (LAP (FSTDX (S) ,source (INDEX ,index 0 ,base)))))
+
+(define-rule statement
+ (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (REGISTER (? base))
+ (MACHINE-CONSTANT (? offset)))
+ (REGISTER (? index)))
+ (REGISTER (? source)))
+ (let ((base (standard-source! base))
+ (index (standard-source! index))
+ (temp (standard-temporary!))
+ (source (flonum-source! source)))
+ (LAP (SH3ADDL () ,index ,base ,temp)
+ ,@(%float-store/offset temp (* 4 offset) source))))
+
+(define-rule statement
+ (ASSIGN (FLOAT-OFFSET (OFFSET-ADDRESS (OBJECT->ADDRESS (REGISTER (? base)))
+ (MACHINE-CONSTANT (? offset)))
+ (REGISTER (? index)))
+ (REGISTER (? source)))
+ (let ((base (standard-source! base))
+ (index (standard-source! index))
+ (temp (standard-temporary!))
+ (source (flonum-source! source)))
+ (LAP (SH3ADDL () ,index ,base ,temp)
+ ,@(object->address temp)
+ ,@(%float-store/offset temp (* 4 offset) source))))
+\f
+;;;; Flonum Arithmetic
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
+ (QUALIFIER (arithmetic-method? operation flonum-methods/1-arg))
+ overflow? ;ignore
+ (let ((source (flonum-source! source)))
+ ((flonum-1-arg/operator operation) (flonum-target! target) source)))
+
+(define (flonum-1-arg/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/1-arg))
+
+(define flonum-methods/1-arg
+ (list 'FLONUM-METHODS/1-ARG))
+
+;;; Notice the weird ,', syntax here.
+;;; If LAP changes, this may also have to change.
+
+(let-syntax
+ ((define-flonum-operation
+ (macro (primitive-name opcode)
+ `(define-arithmetic-method ',primitive-name flonum-methods/1-arg
+ (lambda (target source)
+ (LAP (,opcode (DBL) ,',source ,',target)))))))
+ (define-flonum-operation FLONUM-ABS FABS)
+ (define-flonum-operation FLONUM-SQRT FSQRT)
+ (define-flonum-operation FLONUM-ROUND FRND))
+
+(define-arithmetic-method 'FLONUM-NEGATE flonum-methods/1-arg
+ (lambda (target source)
+ ;; The status register (fr0) reads as 0 for non-store instructions.
+ (LAP (FSUB (DBL) 0 ,source ,target))))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
+ (QUALIFIER (arithmetic-method? operation flonum-methods/1-arg/special))
+ overflow? ;ignore
+ (flonum/1-arg/special
+ (lookup-arithmetic-method operation flonum-methods/1-arg/special)
+ target source))
+
+(define flonum-methods/1-arg/special
+ (list 'FLONUM-METHODS/1-ARG/SPECIAL))
+
+(let-syntax ((define-out-of-line
+ (macro (name)
+ `(define-arithmetic-method ',name flonum-methods/1-arg/special
+ ,(symbol-append 'HOOK:COMPILER- name)))))
+ (define-out-of-line FLONUM-SIN)
+ (define-out-of-line FLONUM-COS)
+ (define-out-of-line FLONUM-TAN)
+ (define-out-of-line FLONUM-ASIN)
+ (define-out-of-line FLONUM-ACOS)
+ (define-out-of-line FLONUM-ATAN)
+ (define-out-of-line FLONUM-EXP)
+ (define-out-of-line FLONUM-LOG)
+ (define-out-of-line FLONUM-TRUNCATE)
+ (define-out-of-line FLONUM-CEILING)
+ (define-out-of-line FLONUM-FLOOR))
+
+(define caller-saves-registers
+ (list
+ ;; g1 g19 g20 g21 g22 ; Not available for allocation
+ g23 g24 g25 g26 g28 g29 g31
+ ;; fp0 fp1 fp2 fp3 ; Not real registers
+ fp4 fp5 fp6 fp7 fp8 fp9 fp10 fp11))
+
+(define registers-to-preserve-around-special-calls
+ (append (list g14 g15 g16 g17)
+ caller-saves-registers))
+
+(define (flonum/1-arg/special hook target source)
+ (let ((load-arg (->machine-register source fp5)))
+ (delete-register! target)
+ (delete-dead-registers!)
+ (let ((clear-regs
+ (apply clean-registers!
+ registers-to-preserve-around-special-calls)))
+ (add-pseudo-register-alias! target fp4)
+ (LAP ,@load-arg
+ ,@clear-regs
+ ,@(invoke-hook hook)))))
+
+;; Missing operations
+
+#|
+;; Return integers
+(define-out-of-line FLONUM-ROUND->EXACT)
+(define-out-of-line FLONUM-TRUNCATE->EXACT)
+(define-out-of-line FLONUM-FLOOR->EXACT)
+(define-out-of-line FLONUM-CEILING->EXACT)
+
+;; Returns a pair
+(define-out-of-line FLONUM-NORMALIZE)
+
+;; Two arguments
+(define-out-of-line FLONUM-DENORMALIZE) ; flo*int
+|#
+\f
+;;;; Two arg operations
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS FLONUM-SUBTRACT
+ (OBJECT->FLOAT (CONSTANT 0.))
+ (REGISTER (? source))
+ (? overflow?)))
+ overflow? ; ignore
+ (let ((source (flonum-source! source)))
+ (LAP (FSUB (DBL) 0 ,source ,(flonum-target! target)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS (? operation)
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ (QUALIFIER (arithmetic-method? operation flonum-methods/2-args))
+ overflow? ;ignore
+ (let ((source1 (flonum-source! source1))
+ (source2 (flonum-source! source2)))
+ ((flonum-2-args/operator operation) (flonum-target! target)
+ source1
+ source2)))
+
+(define (flonum-2-args/operator operation)
+ (lookup-arithmetic-method operation flonum-methods/2-args))
+
+(define flonum-methods/2-args
+ (list 'FLONUM-METHODS/2-ARGS))
+
+(let-syntax
+ ((define-flonum-operation
+ (macro (primitive-name opcode)
+ `(define-arithmetic-method ',primitive-name flonum-methods/2-args
+ (lambda (target source1 source2)
+ (LAP (,opcode (DBL) ,',source1 ,',source2 ,',target)))))))
+ (define-flonum-operation flonum-add fadd)
+ (define-flonum-operation flonum-subtract fsub)
+ (define-flonum-operation flonum-multiply fmpy)
+ (define-flonum-operation flonum-divide fdiv)
+ (define-flonum-operation flonum-remainder frem))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (FLONUM-2-ARGS FLONUM-ATAN2
+ (REGISTER (? source1))
+ (REGISTER (? source2))
+ (? overflow?)))
+ overflow? ;ignore
+ (let* ((load-arg-1 (->machine-register source1 fp5))
+ (load-arg-2 (->machine-register source2 fp7)))
+ (delete-register! target)
+ (delete-dead-registers!)
+ (let ((clear-regs
+ (apply clean-registers!
+ registers-to-preserve-around-special-calls)))
+ (add-pseudo-register-alias! target fp4)
+ (LAP ,@load-arg-1
+ ,@load-arg-2
+ ,@clear-regs
+ ,@(invoke-hook hook:compiler-flonum-atan2)))))
+\f
+;;;; Flonum Predicates
+
+(define-rule predicate
+ (FLONUM-PRED-1-ARG (? predicate) (REGISTER (? source)))
+ #|
+ ;; No immediate zeros, easy to generate by subtracting from itself
+ (let ((temp (flonum-temporary!)))
+ (LAP (FSUB (DBL) ,temp ,temp ,temp)
+ ,@(flonum-compare
+ (case predicate
+ ((FLONUM-ZERO?) '=)
+ ((FLONUM-NEGATIVE?) '<)
+ ((FLONUM-POSITIVE?) '>)
+ (else (error "unknown flonum predicate" predicate)))
+ (flonum-source! source)
+ temp)))
+ |#
+ ;; The status register (fr0) reads as 0 for non-store instructions.
+ (flonum-compare (case predicate
+ ((FLONUM-ZERO?) '=)
+ ((FLONUM-NEGATIVE?) '<)
+ ((FLONUM-POSITIVE?) '>)
+ (else (error "unknown flonum predicate" predicate)))
+ (flonum-source! source)
+ 0))
+
+(define-rule predicate
+ (FLONUM-PRED-2-ARGS (? predicate)
+ (REGISTER (? source1))
+ (REGISTER (? source2)))
+ (flonum-compare (case predicate
+ ((FLONUM-EQUAL?) '=)
+ ((FLONUM-LESS?) '<)
+ ((FLONUM-GREATER?) '>)
+ (else (error "unknown flonum predicate" predicate)))
+ (flonum-source! source1)
+ (flonum-source! source2)))
+
+(define (flonum-compare cc r1 r2)
+ (set-current-branches!
+ (lambda (true-label)
+ (LAP (FCMP (,(invert-float-condition cc) DBL) ,r1 ,r2)
+ (FTEST ())
+ (B (N) (@PCR ,true-label))))
+ (lambda (false-label)
+ (LAP (FCMP (,cc DBL) ,r1 ,r2)
+ (FTEST ())
+ (B (N) (@PCR ,false-label)))))
+ (LAP))
+
+;; invert-float-condition makes sure that NaNs are taken care of
+;; correctly.
+
+(define (invert-float-condition cc)
+ (let ((place (assq cc float-inversion-table)))
+ (if (not place)
+ (error "invert-float-condition: Unknown condition"
+ cc)
+ (cadr place))))
+
+(define float-inversion-table
+ ;; There are many others, but only these are used here.
+ '((> !>)
+ (< !<)
+ (= !=)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rulrew.scm,v 1.1 1994/11/19 02:08:04 adams Exp $
+
+Copyright (c) 1990-1993 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. |#
+
+;;;; RTL Rewrite Rules
+;;; package: (compiler lap-syntaxer)
+
+(declare (usual-integrations))
+\f
+;;;; Synthesized Data
+
+(define-rule rewriting
+ (CONS-NON-POINTER (? type) (? datum))
+ ;; Since we use DEP instructions to insert type codes, there's no
+ ;; difference between the way that pointers and non-pointers are
+ ;; constructed.
+ (rtl:make-cons-pointer type datum))
+
+
+(define-rule add-pre-cse-rewriting-rule!
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (? datum))
+ (QUALIFIER
+ (and (rtl:machine-constant? type)
+ (let ((value (rtl:machine-constant-value type))
+ (class (rtl:expression-value-class datum)))
+ ;; Typecode values that we can use for DEPI instruction, even
+ ;; though the type cant be specified in 6 bits (01xxxx/10xxxx)
+ ;; If the quad mask bits are 0xxxx0 then we can do (0xxxxx/xxxxx0)
+ ;; In a single DEPI.
+ ;; Forcing them to be constants prevents any cse on the values.
+ (and (value-class=address? class)
+ (fix:fixnum? value)
+ (or (even? (fix:or quad-mask-value value))
+ (fix:<= (fix:or quad-mask-value value) #b11111))))))
+ (rtl:make-cons-pointer type datum))
+
+
+;(define-rule add-pre-cse-rewriting-rule!
+; (CONS-POINTER (REGISTER (? type register-known-value))
+; (? datum))
+; (QUALIFIER
+; (and (rtl:machine-constant? type)
+; (let ((value (rtl:machine-constant-value type))
+; (class (rtl:expression-value-class datum)))
+; ;; Elide a (CONS-POINTER address-bits address-register)
+; (and (eq? class value-class=address)
+; (fix:fixnum? value)
+; (fix:= value quad-mask-value value)))))
+; datum)
+
+(define-rule add-pre-cse-rewriting-rule!
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (? datum))
+ (QUALIFIER
+ (and (rtl:machine-constant? type)
+ (let ((value (rtl:machine-constant-value type)))
+ ;; Typecode values that we can use for DEPI instructions.
+ ;; Forcing them to be constants prevents any cse on the values.
+ (or (fits-in-5-bits-signed? value)
+ (fits-in-5-bits-signed? (- value (1+ max-type-code)))
+ (= value quad-mask-value) ; for which we use r5
+ ))))
+ (rtl:make-cons-pointer type datum))
+
+(define-rule add-pre-cse-rewriting-rule!
+ (CONS-NON-POINTER (REGISTER (? type register-known-value))
+ (? datum))
+ (QUALIFIER
+ (and (rtl:machine-constant? type)
+ (let ((value (rtl:machine-constant-value type)))
+ ;; Typecode values that we can use for DEPI instructions.
+ ;; Forcing them to be constants prevents any cse on the values.
+ (or (fits-in-5-bits-signed? value)
+ (fits-in-5-bits-signed? (- value (1+ max-type-code)))
+ (= value quad-mask-value) ; for which we use
+ ))))
+ (rtl:make-cons-pointer type datum))
+
+\f
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum register-known-value)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (rtl:machine-constant? datum)))
+ (rtl:make-cons-pointer type datum))
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value)) (? datum))
+ (QUALIFIER
+ (and (rtl:object->type? type)
+ (rtl:constant? (rtl:object->type-expression type))))
+ (rtl:make-cons-pointer
+ (rtl:make-machine-constant
+ (target-object-type
+ (rtl:constant-value (rtl:object->type-expression datum))))
+ datum))
+
+(define-rule rewriting
+ (CONS-POINTER (? type) (REGISTER (? datum register-known-value)))
+ (QUALIFIER (and (rtl:object->datum? datum)
+ (not (rtl:constant-non-pointer?
+ (rtl:object->datum-expression datum)))))
+ ;; Since we use DEP/DEPI, there is no need to clear the old bits
+ (rtl:make-cons-pointer type (rtl:object->datum-expression datum)))
+
+(define-rule rewriting
+ (OBJECT->TYPE (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant? source))
+ (rtl:make-machine-constant (target-object-type (rtl:constant-value source))))
+
+(define-rule rewriting
+ (OBJECT->DATUM (REGISTER (? source register-known-value)))
+ (QUALIFIER (rtl:constant-non-pointer? source))
+ (rtl:make-machine-constant
+ (careful-object-datum (rtl:constant-value source))))
+
+(define (rtl:constant-non-pointer? expression)
+ (and (rtl:constant? expression)
+ (non-pointer-object? (rtl:constant-value expression))))
+
+\f
+;;; These rules are losers because there's no abstract way to cons a
+;;; statement or a predicate without also getting some CFG structure.
+
+(define-rule rewriting
+ ;; Use register 0, always 0.
+ (ASSIGN (? target) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'ASSIGN target (rtl:make-machine-constant 0)))
+
+(define-rule rewriting
+ ;; Compare to register 0, always 0.
+ (EQ-TEST (? source) (REGISTER (? comparand register-known-value)))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-constant 0)))
+
+(define-rule rewriting
+ ;; Compare to register 0, always 0.
+ (EQ-TEST (REGISTER (? comparand register-known-value)) (? source))
+ (QUALIFIER (rtl:immediate-zero-constant? comparand))
+ (list 'EQ-TEST source (rtl:make-machine-constant 0)))
+
+(define (rtl:immediate-zero-constant? expression)
+ (cond ((rtl:constant? expression)
+ (let ((value (rtl:constant-value expression)))
+ (and (non-pointer-object? value)
+ (zero? (target-object-type value))
+ (zero? (careful-object-datum value)))))
+ ((rtl:cons-pointer? expression)
+ (and (let ((expression (rtl:cons-pointer-type expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))
+ (let ((expression (rtl:cons-pointer-datum expression)))
+ (and (rtl:machine-constant? expression)
+ (zero? (rtl:machine-constant-value expression))))))
+ (else false)))
+\f
+;;;; Fixnums
+;;;
+;; Some constants should always be folded into the operation because either
+;; they are encodable as an immediate value in the instruction at no cost
+;; or they are open coded specially in a way that does not put the value in
+;; a register. We detect these cases by inspecting the arithconst predicates
+;; in fulfix.scm.
+;; This is done pre-cse so that cse doesnt decide to hide the constant in a
+;; register in expressions like (cons (fix:quotient x 8) (fix:remainder x 8)))
+
+(define-rule add-pre-cse-rewriting-rule!
+ (FIXNUM-2-ARGS (? operation)
+ (REGISTER (? operand-1 register-known-fixnum-constant))
+ (? operand-2)
+ (? overflow?))
+ (QUALIFIER
+ (and (rtl:register? operand-2)
+ (fixnum-2-args/operator/constant*register?
+ operation
+ (known-fixnum-constant/fixnum-value operand-1)
+ overflow?)))
+ (rtl:make-fixnum-2-args operation operand-1 operand-2 overflow?))
+
+(define-rule add-pre-cse-rewriting-rule!
+ (FIXNUM-2-ARGS (? operation)
+ (? operand-1)
+ (REGISTER (? operand-2 register-known-fixnum-constant))
+ (? overflow?))
+ (QUALIFIER
+ (and (rtl:register? operand-1)
+ (fixnum-2-args/operator/register*constant?
+ operation
+ (known-fixnum-constant/fixnum-value operand-2)
+ overflow?)))
+ (rtl:make-fixnum-2-args operation operand-1 operand-2 overflow?))
+
+
+(define (register-known-fixnum-constant regnum)
+ ;; returns the rtl of a constant that is a fixnum, i.e (CONSTANT 1000)
+ ;; recognizes (CONSTANT x)
+ ;; (OBJECT->FIXNUM (CONSTANT x))
+ ;; (OBJECT->FIXNUM (REGISTER y)) where y also satisfies this pred
+ (let ((expr (register-known-value regnum)))
+ (and expr
+ (cond ((and (rtl:constant? expr)
+ (fix:fixnum? (rtl:constant-value expr)))
+ expr)
+ ((and (rtl:object->fixnum? expr)
+ (rtl:constant? (rtl:object->fixnum-expression expr))
+ (fix:fixnum? (rtl:constant-value
+ (rtl:object->fixnum-expression expr))))
+ (rtl:object->fixnum-expression expr))
+ ((and (rtl:object->fixnum? expr)
+ (rtl:register? (rtl:object->fixnum-expression expr)))
+ (register-known-fixnum-constant
+ (rtl:register-number (rtl:object->fixnum-expression expr))))
+ (else #F)))))
+
+(define (known-fixnum-constant/fixnum-value constant)
+ (rtl:constant-value constant))
+\f
+(define-rule add-pre-cse-rewriting-rule!
+ (PRED-1-ARG INDEX-FIXNUM? (? source))
+
+ ;; This is a predicate so we can't use rtl:make-type-test
+
+ (list 'TYPE-TEST (rtl:make-object->type source) (ucode-type positive-fixnum)))
+
+\f
+;;;; Closures and other optimizations.
+
+;; These rules are Spectrum specific
+
+(define-rule rewriting
+ (CONS-POINTER (REGISTER (? type register-known-value))
+ (REGISTER (? datum register-known-value)))
+ (QUALIFIER (and (rtl:machine-constant? type)
+ (= (rtl:machine-constant-value type)
+ (ucode-type compiled-entry))
+ (or (rtl:entry:continuation? datum)
+ (rtl:entry:procedure? datum)
+ (rtl:cons-closure? datum))))
+ (rtl:make-cons-pointer type datum))
+
+
+(define-rule rewriting
+ (FLOAT-OFFSET (REGISTER (? base register-known-value))
+ (MACHINE-CONSTANT 0))
+ (QUALIFIER (rtl:simple-float-offset-address? base))
+ (rtl:make-float-offset (rtl:float-offset-address-base base)
+ (rtl:float-offset-address-offset base)))
+
+;; This is here to avoid generating things like
+;;
+;; (float-offset (offset-address (object->address (constant #(foo bar baz gack)))
+;; (machine-constant 1))
+;; (register 84))
+;;
+;; since the offset-address subexpression is constant, and therefore
+;; known!
+
+(define (rtl:simple-float-offset-address? expr)
+ (and (rtl:float-offset-address? expr)
+ (let ((offset (rtl:float-offset-address-offset expr)))
+ (or (rtl:machine-constant? offset)
+ (rtl:register? offset)
+ (and (rtl:object->datum? offset)
+ (rtl:register? (rtl:object->datum-expression offset)))))
+ (let ((base (rtl:float-offset-address-base expr)))
+ (or (rtl:register? base)
+ (and (rtl:offset-address? base)
+ (let ((base* (rtl:offset-address-base base))
+ (offset* (rtl:offset-address-offset base)))
+ (and (rtl:machine-constant? offset*)
+ (or (rtl:register? base*)
+ (and (rtl:object->address? base*)
+ (rtl:register?
+ (rtl:object->address-expression
+ base*)))))))))))
+
+
+;;
+;; (CONS-NON-POINTER (MACHINE-CONSTANT 0)
+;; (? thing-with-known-type-already=0)) => thing
+;;
+
+(define-rule add-pre-cse-rewriting-rule!
+ (CONS-NON-POINTER (REGISTER (? type register-known-value))
+ (? datum))
+ (QUALIFIER
+ (and (rtl:machine-constant? type)
+ (= 0 (rtl:machine-constant-value type))
+ (rtl:has-type-zero? datum)))
+ datum)
+
+(define (rtl:has-type-zero? expr)
+ (or (value-class=ascii? (rtl:expression-value-class expr))
+ (value-class=datum? (rtl:expression-value-class expr))
+ #F))
+
+
+;; Remove all object->fixnum and fixnum->object and object->unsigned-fixnum
+
+(define-rule add-pre-cse-rewriting-rule!
+ (OBJECT->FIXNUM (? frob))
+ frob)
+
+(define-rule add-pre-cse-rewriting-rule!
+ (OBJECT->UNSIGNED-FIXNUM (? frob))
+ frob)
+
+(define-rule add-pre-cse-rewriting-rule!
+ (FIXNUM->OBJECT (? frob))
+ frob)
+
+(define-rule add-pre-cse-rewriting-rule!
+ (COERCE-VALUE-CLASS (? frob) (? class))
+ class ; ignored
+ (error "Unknown expression for " frob)
+ frob)
+
+(define-rule add-pre-cse-rewriting-rule!
+ (COERCE-VALUE-CLASS (REGISTER (? frob register-known-expression)) (? class))
+ class ; ignored
+ frob)
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+(define (alphaconv/top-level program)
+ (alphaconv/expr (alphaconv/state/make alphaconv/remember)
+ '()
+ program))
+
+(define-macro (define-alphaconv keyword bindings . body)
+ (let ((proc-name (symbol-append 'ALPHACONV/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cddr bindings) '(handler state env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons* (car bindings) (cadr bindings) names) ,@body)))
+ (named-lambda (,proc-name state env form)
+ ,code)))))))
+
+(define-alphaconv LOOKUP (state env name)
+ env ; ignored
+ `(LOOKUP ,(alphaconv/env/lookup name env)))
+
+(define-alphaconv LAMBDA (state env lambda-list body)
+ (let* ((names (lambda-list->names lambda-list))
+ (new-names (alphaconv/renamings env names))
+ (env* (alphaconv/env/extend env names new-names)))
+ `(LAMBDA ,(alphaconv/rename-lambda-list lambda-list new-names)
+ ,(alphaconv/expr state env* body))))
+
+(define (alphaconv/rename-lambda-list lambda-list new-names)
+ (let loop ((ll lambda-list) (nn new-names) (result '()))
+ (cond ((null? ll) (reverse! result))
+ ((memq (car ll) '(#!AUX #!OPTIONAL #!REST))
+ (loop (cdr ll) nn (cons (car ll) result)))
+ (else
+ (loop (cdr ll) (cdr nn) (cons (car nn) result))))))
+
+(define-alphaconv CALL (state env rator cont #!rest rands)
+ `(CALL ,(alphaconv/expr state env rator)
+ ,(alphaconv/expr state env cont)
+ ,@(alphaconv/expr* state env rands)))
+
+(define-alphaconv LET (state env bindings body)
+ (alphaconv/let-like 'LET state env bindings body))
+
+(define-alphaconv LETREC (state env bindings body)
+ (alphaconv/let-like 'LETREC state env bindings body))
+
+(define (alphaconv/let-like keyword state env bindings body)
+ (let* ((names (lmap car bindings))
+ (new-names (alphaconv/renamings env names))
+ (inner-env (alphaconv/env/extend env names new-names))
+ (expr-env (if (eq? keyword 'LETREC) inner-env env))
+ (bindings* (map (lambda (new-name binding)
+ (list new-name
+ (alphaconv/expr state expr-env (second binding))))
+ new-names
+ bindings)))
+ `(,keyword ,bindings* ,(alphaconv/expr state inner-env body))))
+
+(define-alphaconv QUOTE (state env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-alphaconv DECLARE (state env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+(define-alphaconv BEGIN (state env #!rest actions)
+ `(BEGIN ,@(alphaconv/expr* state env actions)))
+
+(define-alphaconv IF (state env pred conseq alt)
+ `(IF ,(alphaconv/expr state env pred)
+ ,(alphaconv/expr state env conseq)
+ ,(alphaconv/expr state env alt)))
+
+(define-alphaconv SET! (state env name value)
+ `(SET! ,(alphaconv/env/lookup name env) ,(alphaconv/expr state env value)))
+
+(define-alphaconv UNASSIGNED? (state env name)
+ env ; ignored
+ `(UNASSIGNED? ,(alphaconv/env/lookup name env)))
+
+(define-alphaconv OR (state env pred alt)
+ `(OR ,(alphaconv/expr state env pred)
+ ,(alphaconv/expr state env alt)))
+
+(define-alphaconv DELAY (state env expr)
+ `(DELAY ,(alphaconv/expr state env expr)))
+\f
+(define (alphaconv/expr state env expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (let ((new-expr
+ (case (car expr)
+ ((QUOTE)
+ (alphaconv/quote state env expr))
+ ((LOOKUP)
+ (alphaconv/lookup state env expr))
+ ((LAMBDA)
+ (alphaconv/lambda state env expr))
+ ((LET)
+ (alphaconv/let state env expr))
+ ((DECLARE)
+ (alphaconv/declare state env expr))
+ ((CALL)
+ (alphaconv/call state env expr))
+ ((BEGIN)
+ (alphaconv/begin state env expr))
+ ((IF)
+ (alphaconv/if state env expr))
+ ((LETREC)
+ (alphaconv/letrec state env expr))
+ ((SET!)
+ (alphaconv/set! state env expr))
+ ((UNASSIGNED?)
+ (alphaconv/unassigned? state env expr))
+ ((OR)
+ (alphaconv/or state env expr))
+ ((DELAY)
+ (alphaconv/delay state env expr))
+ ((ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr)))))
+ ((alphaconv/state/remember state) new-expr expr)))
+
+(define (alphaconv/expr* state env exprs)
+ (lmap (lambda (expr)
+ (alphaconv/expr state env expr))
+ exprs))
+
+(define-integrable (alphaconv/remember new old)
+ old ; ignored for now and forever
+ new)
+
+(define-structure
+ (alphaconv/state
+ (conc-name alphaconv/state/)
+ (constructor alphaconv/state/make))
+ remember)
+
+
+\f
+(define-structure
+ (alphaconv/binding
+ (conc-name alphaconv/binding/)
+ (constructor alphaconv/binding/make (name renaming))
+ (print-procedure
+ (standard-unparser-method 'ALPHACONV/BINDING
+ (lambda (binding port)
+ (write-char #\space port)
+ (write-string (symbol-name (alphaconv/binding/name binding)) port)))))
+
+ (name false read-only true)
+ (renaming false read-only true))
+
+(define alphaconv/env/lookup
+ (let ((finder (association-procedure eq? alphaconv/binding/name)))
+ (lambda (name env)
+ (cond ((finder name env)
+ => (lambda (binding)
+ (alphaconv/binding/renaming binding)))
+ (else
+ name)))))
+
+(define (alphaconv/env/extend env names new-names)
+ (map* env
+ alphaconv/binding/make
+ names
+ new-names))
+
+(define (alphaconv/renamings env names)
+ env ; ignored
+ (map (lambda (name)
+ (variable/rename name))
+ names))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: applicat.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Use special pseudo primitives to call funky stuff
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (applicat/top-level program)
+ (applicat/expr '() program))
+
+(define-macro (define-applicator keyword bindings . body)
+ (let ((proc-name (symbol-append 'APPLICAT/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name env form)
+ (applicat/remember ,code
+ form))))))))
+
+(define-applicator LOOKUP (env name)
+ env ; ignored
+ `(LOOKUP ,name))
+
+(define-applicator LAMBDA (env lambda-list body)
+ `(LAMBDA ,lambda-list
+ ,(applicat/expr (append (lmap (lambda (name)
+ (list name false))
+ (lambda-list->names lambda-list))
+ env)
+ body)))
+
+(define-applicator QUOTE (env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-applicator DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+(define-applicator BEGIN (env #!rest actions)
+ `(BEGIN ,@(applicat/expr* env actions)))
+
+(define-applicator IF (env pred conseq alt)
+ `(IF ,(applicat/expr env pred)
+ ,(applicat/expr env conseq)
+ ,(applicat/expr env alt)))
+\f
+(define-applicator CALL (env rator cont #!rest rands)
+ (define (default)
+ `(CALL (QUOTE ,%internal-apply)
+ ,(applicat/expr env cont)
+ (QUOTE ,(length rands))
+ ,(applicat/expr env rator)
+ ,@(applicat/expr* env rands)))
+ (cond ((QUOTE/? rator)
+ (cond ((and (known-operator? (cadr rator))
+ (not (and (primitive-procedure? (cadr rator))
+ (memq (primitive-procedure-name (cadr rator))
+ compiler:primitives-with-no-open-coding))))
+ `(CALL ,(applicat/expr env rator)
+ ,(applicat/expr env cont)
+ ,@(applicat/expr* env rands)))
+ ((primitive-procedure? (cadr rator))
+ `(CALL (QUOTE ,%primitive-apply)
+ ,(applicat/expr env cont)
+ (QUOTE ,(length rands))
+ ,(applicat/expr env rator)
+ ,@(applicat/expr* env rands)))
+ (else
+ (default))))
+ ((LOOKUP/? rator)
+ (let ((place (assq (cadr rator) env)))
+ (if (or (not place) (not (cadr place)))
+ (default)
+ `(CALL ,(applicat/expr env rator)
+ ,(applicat/expr env cont)
+ ,@(applicat/expr* env rands)))))
+ ((LAMBDA/? rator)
+ (let* ((lambda-list (cadr rator))
+ (rator* `(LAMBDA ,lambda-list
+ ,(applicat/expr
+ (append
+ (map (lambda (name rand)
+ (list name
+ (and (pair? rand)
+ (eq? (car rand) 'LAMBDA))))
+ lambda-list
+ rands)
+ env)
+ (caddr rator)))))
+ `(CALL ,(applicat/remember rator* rator)
+ ,(applicat/expr env cont)
+ ,@(applicat/expr* env rands))))
+ (else
+ (default))))
+
+(define-applicator LET (env bindings body)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (applicat/expr env (cadr binding))))
+ bindings)
+ ,(applicat/expr
+ (append (lmap (lambda (binding)
+ (list (car binding)
+ (let ((value (cadr binding)))
+ (and (pair? value)
+ (eq? (car value) 'LAMBDA)))))
+ bindings)
+ env)
+ body)))
+\f
+(define-applicator LETREC (env bindings body)
+ (let ((env*
+ (append (lmap (lambda (binding)
+ (list (car binding)
+ (let ((value (cadr binding)))
+ (and (pair? value)
+ (eq? (car value) 'LAMBDA)))))
+ bindings)
+ env)))
+ `(LETREC ,(lmap (lambda (binding)
+ (list (car binding)
+ (applicat/expr env* (cadr binding))))
+ bindings)
+ ,(applicat/expr env* body))))
+
+(define (applicat/expr env expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (applicat/quote env expr))
+ ((LOOKUP)
+ (applicat/lookup env expr))
+ ((LAMBDA)
+ (applicat/lambda env expr))
+ ((LET)
+ (applicat/let env expr))
+ ((DECLARE)
+ (applicat/declare env expr))
+ ((CALL)
+ (applicat/call env expr))
+ ((BEGIN)
+ (applicat/begin env expr))
+ ((IF)
+ (applicat/if env expr))
+ ((LETREC)
+ (applicat/letrec env expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (applicat/expr* env exprs)
+ (lmap (lambda (expr)
+ (applicat/expr env expr))
+ exprs))
+
+(define (applicat/remember new old)
+ (code-rewrite/remember new old))
+
+(define (applicat/new-name prefix)
+ (new-variable prefix))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: assconv.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Assignment Converter
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (assconv/top-level program)
+ (assconv/expr '() program))
+
+(define-macro (define-assignment-converter keyword bindings . body)
+ (let ((proc-name (symbol-append 'ASSCONV/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name env form)
+ (assconv/remember ,code form))))))))
+
+;;;; Variable manipulation forms
+
+(define-assignment-converter LAMBDA (env lambda-list body)
+ (call-with-values
+ (lambda ()
+ (assconv/binding-body env
+ (lambda-list->names lambda-list)
+ body))
+ (lambda (shadowed body*)
+ `(LAMBDA ,(if (null? shadowed)
+ lambda-list
+ (lmap (lambda (name)
+ (if (memq name shadowed)
+ (assconv/new-name 'IGNORED)
+ name))
+ lambda-list))
+ ,body*))))
+
+(define-assignment-converter LET (env bindings body)
+ (call-with-values
+ (lambda ()
+ (assconv/binding-body env (lmap car bindings) body))
+ (lambda (shadowed body*)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (assconv/expr env (cadr binding))))
+ (if (null? shadowed)
+ bindings
+ (list-transform-negative bindings
+ (lambda (binding)
+ (memq (car binding) shadowed)))))
+ ,body*))))
+
+(define-assignment-converter LOOKUP (env name)
+ (let ((binding (assconv/env-lookup env name)))
+ (if (not binding)
+ (free-var-error name)
+ (let ((result `(LOOKUP ,name)))
+ (set-assconv/binding/references!
+ binding
+ (cons result (assconv/binding/references binding)))
+ result))))
+
+(define-assignment-converter SET! (env name value)
+ (let ((binding (assconv/env-lookup env name)))
+ (if (not binding)
+ (free-var-error name)
+ (let ((result `(SET! ,name ,(assconv/expr env value))))
+ (set-assconv/binding/assignments!
+ binding
+ (cons result (assconv/binding/assignments binding)))
+ result))))
+\f
+;;;; Trivial forms
+
+(define-assignment-converter QUOTE (env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-assignment-converter DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+(define-assignment-converter CALL (env rator cont #!rest rands)
+ `(CALL ,(assconv/expr env rator)
+ ,(assconv/expr env cont)
+ ,@(assconv/expr* env rands)))
+
+(define-assignment-converter BEGIN (env #!rest actions)
+ `(BEGIN ,@(assconv/expr* env actions)))
+
+(define-assignment-converter IF (env pred conseq alt)
+ `(IF ,(assconv/expr env pred)
+ ,(assconv/expr env conseq)
+ ,(assconv/expr env alt)))
+
+;;; Dispatcher
+
+(define (assconv/expr env expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (assconv/quote env expr))
+ ((LOOKUP)
+ (assconv/lookup env expr))
+ ((LAMBDA)
+ (assconv/lambda env expr))
+ ((LET)
+ (assconv/let env expr))
+ ((DECLARE)
+ (assconv/declare env expr))
+ ((CALL)
+ (assconv/call env expr))
+ ((BEGIN)
+ (assconv/begin env expr))
+ ((IF)
+ (assconv/if env expr))
+ ((SET!)
+ (assconv/set! env expr))
+ ((LETREC)
+ (not-yet-legal expr))
+ ((UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (assconv/expr* env exprs)
+ (lmap (lambda (expr)
+ (assconv/expr env expr))
+ exprs))
+
+(define (assconv/remember new old)
+ (code-rewrite/remember new old)
+ new)
+
+(define (assconv/new-name prefix)
+ (new-variable prefix))
+
+(define (assconv/new-cell-name prefix)
+ (new-variable (string-append (symbol-name prefix) "-cell")))
+\f
+;;;; Utilities for variable manipulation forms
+
+(define-structure (assconv/binding
+ (conc-name assconv/binding/)
+ (constructor assconv/binding/make (name)))
+ (name false read-only true)
+ (cell-name false read-only false)
+ (references '() read-only false)
+ (assignments '() read-only false))
+
+(define (assconv/binding-body env names body)
+ ;; (values shadowed-names body*)
+ (let* ((frame (lmap assconv/binding/make names))
+ (env* (cons frame env))
+ (body* (assconv/expr env* body))
+ (assigned
+ (list-transform-positive frame
+ (lambda (binding)
+ (not (null? (assconv/binding/assignments binding))))))
+ (ssa-candidates
+ (list-transform-positive assigned
+ (lambda (binding)
+ (let ((assignments (assconv/binding/assignments binding)))
+ (and (null? (cdr assignments))
+ (assconv/single-assignment/trivial?
+ (car assignments))))))))
+ (if (null? ssa-candidates)
+ (assconv/bind-cells '() assigned body*)
+ (call-with-values
+ (lambda ()
+ (assconv/single-analyze ssa-candidates body*))
+ (lambda (let-like letrec-like)
+ (assconv/bind-cells
+ (lmap assconv/binding/name (append let-like letrec-like))
+ (list-transform-negative assigned
+ (lambda (binding)
+ (or (memq binding let-like)
+ (memq binding letrec-like))))
+ (assconv/letify 'LET
+ let-like
+ (assconv/letify 'LETREC
+ letrec-like
+ body*))))))))
+
+(define (assconv/first-assignment body)
+ (let loop ((actions (list body)))
+ (and (not (null? actions))
+ (pair? (car actions))
+ (case (car (car actions))
+ ((BEGIN)
+ (loop (append (cdr (car actions)) (cdr actions))))
+ ((DECLARE)
+ (loop (cdr actions)))
+ ((SET!)
+ (and (not (null? (cdr actions)))
+ (car actions)))
+ (else
+ false)))))
+\f
+(define (assconv/bind-cells shadowed-names bindings body)
+ ;; (values shadowed-names body*)
+ ;; Last chance to undo an assignment
+ (define (finish shadowed-names bindings body)
+ (if (null? bindings)
+ (values shadowed-names body)
+ (begin
+ (for-each assconv/cellify! bindings)
+ (values
+ shadowed-names
+ `(LET ,(lmap (lambda (binding)
+ (let ((name (assconv/binding/name binding)))
+ `(,(assconv/binding/cell-name binding)
+ (CALL (QUOTE ,%make-cell)
+ (QUOTE #F)
+ (LOOKUP ,name)
+ (QUOTE ,name)))))
+ bindings)
+ ,body)))))
+
+ (define (default)
+ (finish shadowed-names bindings body))
+
+ (cond ((null? bindings)
+ (default))
+ ((assconv/first-assignment body)
+ => (lambda (ass)
+ (let* ((name (cadr ass))
+ (binding
+ (list-search-positive bindings
+ (lambda (binding)
+ (eq? (assconv/binding/name binding)
+ name))))
+ (value (caddr ass)))
+ (if (or (not binding)
+ (not (null? (cdr (assconv/binding/assignments
+ binding))))
+ (memq name (form/free-vars value))) ; JSM
+ (default)
+ (begin
+ (form/rewrite! ass `(QUOTE ,%unspecific))
+ (finish (cons name shadowed-names)
+ (delq binding bindings)
+ (bind name value body)))))))
+ (else (default))))
+\f
+(define (assconv/letify keyword bindings body)
+ `(,keyword
+ ,(lmap (lambda (binding)
+ (let* ((ass (car (assconv/binding/assignments binding)))
+ (value (caddr ass)))
+ (form/rewrite! ass `(QUOTE ,%unassigned))
+ `(,(assconv/binding/name binding) ,value)))
+ bindings)
+ ,body))
+
+(define (assconv/cell-reference binding)
+ `(CALL (QUOTE ,%cell-ref)
+ (QUOTE #F)
+ (LOOKUP ,(assconv/binding/cell-name binding))
+ (QUOTE ,(assconv/binding/name binding))))
+
+(define (assconv/cell-assignment binding value)
+ (let ((cell-name (assconv/binding/cell-name binding))
+ (value-name (assconv/binding/name binding)))
+ #|
+ ;; This returns the new value
+ (bind value-name value
+ `(BEGIN
+ (CALL (QUOTE ,%cell-set!)
+ (QUOTE #F)
+ (LOOKUP ,cell-name)
+ (LOOKUP ,value-name)
+ (QUOTE ,value-name))
+ (LOOKUP ,value-name)))
+ |#
+ ;; This returns the old value
+ (bind value-name
+ `(CALL (QUOTE ,%cell-ref)
+ (QUOTE #F)
+ (LOOKUP ,cell-name)
+ (QUOTE ,value-name))
+ `(BEGIN
+ (CALL (QUOTE ,%cell-set!)
+ (QUOTE #F)
+ (LOOKUP ,cell-name)
+ ,value
+ (QUOTE ,value-name))
+ (LOOKUP ,value-name)))))
+
+(define (assconv/cellify! binding)
+ (let ((cell-name (assconv/new-cell-name (assconv/binding/name binding))))
+ (set-assconv/binding/cell-name! binding cell-name)
+ (for-each (lambda (ref)
+ (form/rewrite!
+ ref
+ (assconv/cell-reference binding)))
+ (assconv/binding/references binding))
+ (for-each (lambda (ass)
+ (form/rewrite!
+ ass
+ (assconv/cell-assignment binding (caddr ass))))
+ (assconv/binding/assignments binding))))
+\f
+(define (assconv/env-lookup env name)
+ (let spine-loop ((env env))
+ (and (not (null? env))
+ (let rib-loop ((rib (car env)))
+ (cond ((null? rib)
+ (spine-loop (cdr env)))
+ ((eq? name (assconv/binding/name (car rib)))
+ (car rib))
+ (else
+ (rib-loop (cdr rib))))))))
+
+(define (assconv/single-assignment/trivial? assignment-form)
+ (let ((name (second assignment-form))
+ (value (third assignment-form)))
+ (and (pair? value)
+ (or (eq? (car value) 'QUOTE)
+ (and (eq? (car value) 'LAMBDA)
+ #| (not (memq name (form/free-vars value))) |#
+ )))))
+
+(define (assconv/single-analyze ssa-candidates body)
+ ;; (values let-like letrec-like)
+ ;; This only recognizes very simple patterns.
+ ;; It can be improved in the future.
+ (if (not (pair? body))
+ (values '() '())
+ (let ((single-assignments
+ (lmap (lambda (binding)
+ (cons (car (assconv/binding/assignments binding))
+ binding))
+ ssa-candidates))
+ (finish
+ (lambda (bindings)
+ (values
+ (reverse
+ (list-transform-positive bindings
+ (lambda (binding)
+ (eq? (car (caddr (car (assconv/binding/assignments
+ binding))))
+ 'QUOTE))))
+ (reverse
+ (list-transform-positive bindings
+ (lambda (binding)
+ (eq? (car (caddr (car (assconv/binding/assignments
+ binding))))
+ 'LAMBDA))))))))
+
+ (let loop ((bindings '())
+ (actions (if (eq? (car body) 'BEGIN)
+ (cdr body)
+ (list body))))
+ (cond ((null? actions)
+ (finish bindings))
+ ((assq (car actions) single-assignments)
+ => (lambda (single-assignment)
+ (loop (cons (cdr single-assignment) bindings)
+ (cdr actions))))
+ ((not (pair? (car actions)))
+ (finish bindings))
+ (else
+ (case (caar actions)
+ ((DECLARE)
+ (loop bindings (cdr actions)))
+ ((SET!)
+ (if (assconv/single-assignment/trivial? (car actions))
+ (loop bindings (cdr actions))
+ (finish bindings)))
+ (else
+ (finish bindings)))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: cleanup.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Rename to avoid conflict, substitute parameters, etc.
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (cleanup/top-level program)
+ (cleanup/expr '() program))
+
+(define-macro (define-cleanup-handler keyword bindings . body)
+ (let ((proc-name (symbol-append 'CLEANUP/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(DEFINE ,proc-name
+ (LET ((HANDLER (LAMBDA ,(cons (car bindings) names) ,@body)))
+ (NAMED-LAMBDA (,proc-name ENV FORM)
+ (CLEANUP/REMEMBER ,code FORM))))))))
+
+(define-cleanup-handler LOOKUP (env name)
+ (let ((place (assq name env)))
+ (if (not place)
+ (free-var-error name)
+ (form/copy (cadr place)))))
+
+(define-cleanup-handler LAMBDA (env lambda-list body)
+ (let ((renames (cleanup/renamings env (lambda-list->names lambda-list))))
+ `(LAMBDA ,(lmap (lambda (token)
+ (cleanup/rename renames token))
+ lambda-list)
+ ,(cleanup/expr (append renames env) body))))
+
+(define-cleanup-handler LETREC (env bindings body)
+ (do-letrec-cleanup env bindings body))
+
+(define (do-letrec-cleanup env bindings body)
+ (let* ((renames (cleanup/renamings env (lmap car bindings)))
+ (env* (append renames env))
+ (body* (cleanup/expr env* body)))
+ (if (null? bindings)
+ body*
+ `(LETREC ,(lmap (lambda (binding)
+ (list (cleanup/rename renames (car binding))
+ (cleanup/expr env* (cadr binding))))
+ bindings)
+ ,body*))))
+
+(define-cleanup-handler QUOTE (env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-cleanup-handler DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+\f
+(define-cleanup-handler IF (env pred conseq alt)
+ (let* ((pred* (cleanup/expr env pred))
+ (default (lambda ()
+ `(IF ,pred*
+ ,(cleanup/expr env conseq)
+ ,(cleanup/expr env alt)))))
+ (cond ((QUOTE/? pred*)
+ (case (boolean/discriminate (quote/text pred*))
+ ((FALSE)
+ (cleanup/expr env alt))
+ ((TRUE)
+ (cleanup/expr env conseq))
+ (else
+ (default))))
+ ((CALL/? pred*)
+ ;; (if (not p) c a) => (if p a c)
+ (let ((pred-rator (call/operator pred*)))
+ (if (and (QUOTE/? pred-rator)
+ (eq? (quote/text pred-rator) not)
+ (equal? (call/continuation pred*) `(QUOTE #F)))
+ `(IF ,(first (call/operands pred*))
+ ,(cleanup/expr env alt)
+ ,(cleanup/expr env conseq))
+ (default))))
+ (else
+ (default)))))
+\f
+(define-cleanup-handler BEGIN (env #!rest actions)
+ (beginnify (cleanup/expr* env actions)))
+
+(define-cleanup-handler LET (env bindings body)
+ (cleanup/let* cleanup/letify env bindings body))
+
+(define-cleanup-handler CALL (env rator cont #!rest rands)
+ (define (default)
+ `(CALL ,(cleanup/expr env rator)
+ ,(cleanup/expr env cont)
+ ,@(cleanup/expr* env rands)))
+ (cond ((LAMBDA/? rator)
+ (let ((lambda-list (lambda/formals rator))
+ (lambda-body (lambda/body rator)))
+ (define (generate env let-names let-values)
+ (cleanup/let*
+ (lambda (bindings* body*)
+ (cleanup/pseudo-letify rator bindings* body*))
+ env
+ (cleanup/bindify let-names let-values)
+ lambda-body))
+ #|(define (build-call-lambda/try1 new-cont-var body closure)
+ `(CALL (LAMBDA (,new-cont-var) ,body) ,closure))
+ |#
+ (define (build-call-lambda/try2 new-cont-var body closure)
+ ;; We can further reduce one special case: when the body is an
+ ;; invoke-continuation and the stack closure is a real
+ ;; continuation (not just a push)
+ (if (and (CALL/%invoke-continuation? body)
+ (LOOKUP/? (CALL/%invoke-continuation/cont body))
+ (eq? new-cont-var
+ (LOOKUP/name (CALL/%invoke-continuation/cont body)))
+ (CALL/%make-stack-closure? closure)
+ (LAMBDA/?
+ (CALL/%make-stack-closure/lambda-expression closure)))
+ `(CALL (QUOTE ,%invoke-continuation)
+ ,closure
+ ,@(CALL/%invoke-continuation/values body))
+ `(CALL (LAMBDA (,new-cont-var) ,body) ,closure)))
+ (if (call/%make-stack-closure? cont)
+ ;; Cannot substitute a make-stack-closure because both pushing
+ ;; and poping have to be kept in the right order.
+ (let* ((old-cont-var (car lambda-list))
+ (new-cont-var (variable/rename old-cont-var))
+ (new-env `((,old-cont-var (LOOKUP ,new-cont-var))
+ ,@env)))
+ (build-call-lambda/try2
+ new-cont-var
+ (generate new-env (cdr lambda-list) rands)
+ (cleanup/expr env cont)))
+ (generate env lambda-list (cons cont rands)))))
+ ((not *flush-closure-calls?*)
+ (default))
+ (else
+ (let ((call* (default)))
+ (cond ((form/match cleanup/call-closure-pattern call*)
+ => (lambda (result)
+ (cleanup/call/maybe-flush-closure call*
+ env
+ result)))
+ ((form/match cleanup/call-trivial-pattern call*)
+ => (lambda (result)
+ (let ((lam-expr
+ (cadr (assq cleanup/?lam-expr result)))
+ (rands
+ (cadr (assq cleanup/?rands result)))
+ (cont
+ (cadr (assq cleanup/?cont result))))
+ (cleanup/expr env
+ `(CALL ,lam-expr ,cont ,@rands)))))
+ (else
+ call*))))))
+
+(define (cleanup/call/maybe-flush-closure call* env match-result)
+ (let ((lambda-expr (cadr (assq cleanup/?lam-expr match-result)))
+ (cont (cadr (assq cleanup/?cont match-result)))
+ (closure-elts (cadr (assq cleanup/?closure-elts match-result)))
+ (closure-vector (cadr (assq cleanup/?closure-vector match-result)))
+ (rands (cadr (assq cleanup/?rands match-result))))
+ (let* ((lambda-list (cadr lambda-expr))
+ (lambda-body (caddr lambda-expr))
+ (closure-name (cadr lambda-list)))
+ (call-with-values
+ (lambda () (cleanup/closure-refs lambda-body closure-name))
+ (lambda (self-refs ordinary-refs)
+ (if (not (null? self-refs))
+ call*
+ (let ((bindings (map list
+ (vector->list closure-vector)
+ closure-elts)))
+ (for-each (lambda (ref)
+ (let ((name (cadr (sixth ref))))
+ (form/rewrite! ref `(LOOKUP ,name))))
+ ordinary-refs)
+ (let ((cont-name (car lambda-list)))
+ (cleanup/expr
+ env
+ (bind* (cons cont-name (lmap car bindings))
+ (cons cont (lmap cadr bindings))
+ `(CALL (LAMBDA ,(cons (car lambda-list)
+ (cddr lambda-list))
+ ,lambda-body)
+ ,(if (equal? cont `(QUOTE #F))
+ `(QUOTE #F)
+ `(LOOKUP ,cont-name))
+ ,@rands)))))))))))
+\f
+(define cleanup/?closure-elts (->pattern-variable 'CLOSURE-ELTS))
+(define cleanup/?closure-vector (->pattern-variable 'CLOSURE-VECTOR))
+(define cleanup/?cont (->pattern-variable 'CONT))
+(define cleanup/?nrands (->pattern-variable 'NRANDS))
+(define cleanup/?rands (->pattern-variable 'RANDS))
+(define cleanup/?lam-expr (->pattern-variable 'LAM-EXPR))
+(define cleanup/?rest (->pattern-variable 'REST))
+
+(define cleanup/call-closure-pattern
+ `(CALL (QUOTE ,%internal-apply)
+ ,cleanup/?cont
+ (QUOTE ,cleanup/?nrands)
+ (CALL (QUOTE ,%make-heap-closure)
+ (QUOTE #F)
+ ,cleanup/?lam-expr
+ (QUOTE ,cleanup/?closure-vector)
+ ,@cleanup/?closure-elts)
+ ,@cleanup/?rands))
+
+(define cleanup/call-trivial-pattern
+ `(CALL (QUOTE ,%internal-apply)
+ ,cleanup/?cont
+ (QUOTE ,cleanup/?nrands)
+ (CALL (QUOTE ,%make-trivial-closure)
+ (QUOTE #F)
+ ,cleanup/?lam-expr)
+ ,@cleanup/?rands))
+
+#|
+(define cleanup/continuation-call-pattern
+ `(CALL (QUOTE ,%make-stack-closure) . ,cleanup/?rest))
+|#
+
+(define (cleanup/closure-refs form var-name)
+ ;; (values self-refs ordinary-refs)
+ ;; var-name is assumed to be unique, so there is
+ ;; no need to worry about shadowing.
+ (list-split
+ (let walk ((form form))
+ (and (pair? form)
+ (case (car form)
+ ((QUOTE DECLARE) '())
+ ((LOOKUP)
+ (if (eq? (lookup/name form) var-name)
+ (list form)
+ '()))
+ ((LAMBDA)
+ (walk (lambda/body form)))
+ ((LET LETREC)
+ (append-map* (walk (caddr form))
+ (lambda (binding)
+ (walk (cadr binding)))
+ (cadr form)))
+ ((BEGIN IF)
+ (append-map walk (cdr form)))
+ ((CALL)
+ (if (call/%heap-closure-ref? form)
+ (if (eq? (lookup/name (call/%heap-closure-ref/closure form))
+ var-name)
+ (list form)
+ '())
+ (append-map walk (cdr form))))
+ (else
+ (no-longer-legal form)))))
+ LOOKUP/?))
+\f
+(define (cleanup/let* letify env bindings body)
+ ;; Some bindings bind names to trivial expressions (e.g. constant) and
+ ;; easy expression (e.g. closure references). We substitute the
+ ;; expressions for these names in BODY, but first we look at the
+ ;; names in these expressions and rename to avoid name capture.
+ (let ((bindings* (lmap (lambda (binding)
+ (list (car binding)
+ (cleanup/expr env (cadr binding))))
+ bindings)))
+ (call-with-values
+ (lambda ()
+ (list-split bindings*
+ (lambda (binding*)
+ (let ((form (cadr binding*)))
+ (and (pair? form)
+ (eq? (car form) 'QUOTE))))))
+ (lambda (trivial non-trivial)
+ (call-with-values
+ (lambda ()
+ (list-split non-trivial
+ (lambda (binding*)
+ (cleanup/easy? (cadr binding*)))))
+ (lambda (easy non-easy)
+ (let* ((possibly-captured
+ (lmap (lambda (binding)
+ (cleanup/easy/name (cadr binding)))
+ easy))
+ (complex-triplets
+ ;; (original-name renamed-version value-expression)
+ (lmap (lambda (binding)
+ (let ((name (car binding)))
+ (list name
+ (if (memq name possibly-captured)
+ (variable/rename name)
+ name)
+ (cadr binding))))
+ non-easy))
+ (body*
+ (cleanup/expr
+ (append trivial
+ easy
+ (lmap (lambda (triplet)
+ (list (car triplet)
+ `(LOOKUP ,(cadr triplet))))
+ complex-triplets)
+ env)
+ body)))
+ (if (null? complex-triplets)
+ body*
+ (letify (lmap cdr complex-triplets)
+ body*)))))))))
+\f
+(define (cleanup/easy? form)
+ (and (pair? form)
+ (case (car form)
+ ((LOOKUP) true)
+ ((CALL)
+ (let ((rator (cadr form)))
+ (and (pair? rator)
+ (eq? (car rator) 'QUOTE)
+ (memq (cadr rator) cleanup/easy/ops)
+ (let ((cont&rands (cddr form)))
+ (and (for-all? cont&rands cleanup/trivial?)
+ (let ((all-lookups
+ (list-transform-positive cont&rands
+ (lambda (rand)
+ (and (pair? rand)
+ (eq? (car rand) 'LOOKUP))))))
+ (or (null? all-lookups)
+ (null? (cdr all-lookups)))))))))
+ (else
+ false))))
+
+(define (cleanup/trivial? form)
+ (and (pair? form)
+ (or (memq (car form) '(QUOTE LOOKUP))
+ (and (eq? (car form) 'CALL)
+ (pair? (cadr form))
+ (eq? 'QUOTE (car (cadr form)))
+ (memq (cadr (cadr form)) cleanup/trivial/ops)
+ (for-all? (cddr form)
+ (lambda (rand)
+ (and (pair? rand)
+ (eq? 'QUOTE (car rand)))))))))
+
+(define (cleanup/easy/name form)
+ ;; form must satisfy cleanup/easy?
+ (case (car form)
+ ((LOOKUP) (cadr form))
+ ((CALL)
+ (let ((lookup-rand (list-search-positive (cddr form)
+ (lambda (rand)
+ (eq? (car rand) 'LOOKUP)))))
+ (and lookup-rand
+ (cadr lookup-rand))))
+ (else
+ (internal-error "Unrecognized easy form" form))))
+
+(define cleanup/trivial/ops
+ (list %vector-index))
+
+(define cleanup/easy/ops
+ (append cleanup/trivial/ops
+ (list %stack-closure-ref %heap-closure-ref)))
+\f
+(define (cleanup/letify bindings body)
+ `(LET ,bindings ,body))
+
+(define (cleanup/bindify lambda-list operands)
+ (map (lambda (name operand) (list name operand))
+ (lambda-list->names lambda-list)
+ (lambda-list/applicate lambda-list operands)))
+
+(define (cleanup/pseudo-letify rator bindings body)
+ (define (default)
+ (pseudo-letify rator bindings body cleanup/remember))
+ (define (trivial last bindings)
+ (beginnify (map* (list last) cadr bindings)))
+ (cond ((memq *order-of-argument-evaluation* '(ANY LEFT-TO-RIGHT))
+ (default))
+ ((LOOKUP/? body)
+ (let* ((name (lookup/name body))
+ (place (assq name bindings)))
+ (if (not place)
+ (trivial body bindings)
+ (trivial
+ (cadr place)
+ (delq place bindings)))))
+ ((QUOTE/? body)
+ (trivial body bindings))
+ (else
+ (default))))
+
+(define (cleanup/rename renames token)
+ (let ((place (assq token renames)))
+ (if (not place)
+ token
+ (cadr (cadr place)))))
+
+(define (cleanup/renamings env names)
+ (lmap (lambda (name)
+ (let ((place (assq name env)))
+ ;; Do not rename if the shadowed binding is disappearing
+ (if (or (not place)
+ (QUOTE/? (cadr place)))
+ `(,name (LOOKUP ,name))
+ `(,name (LOOKUP ,(variable/rename name))))))
+ names))
+\f
+(define (cleanup/expr env expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (cleanup/quote env expr))
+ ((LOOKUP)
+ (cleanup/lookup env expr))
+ ((LAMBDA)
+ (cleanup/lambda env expr))
+ ((LET)
+ (cleanup/let env expr))
+ ((DECLARE)
+ (cleanup/declare env expr))
+ ((CALL)
+ (cleanup/call env expr))
+ ((BEGIN)
+ (cleanup/begin env expr))
+ ((IF)
+ (cleanup/if env expr))
+ ((LETREC)
+ (cleanup/letrec env expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (cleanup/expr* env exprs)
+ (lmap (lambda (expr)
+ (cleanup/expr env expr))
+ exprs))
+
+(define (cleanup/remember new old)
+ (code-rewrite/remember new old))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: closconv.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Closure converter
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define *closconv-operator-and-operand-illegal?* true)
+
+(define (closconv/top-level program #!optional after-cps?)
+ (closconv/bind-parameters
+ (and (not (default-object? after-cps?))
+ after-cps?)
+ (lambda ()
+ (let* ((env (closconv/env/%make 'STATIC false))
+ (program* (closconv/expr env (lifter/letrecify program))))
+ (closconv/analyze! env program*)))))
+
+(define-macro (define-closure-converter keyword bindings . body)
+ (let ((proc-name (symbol-append 'CLOSCONV/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name env form)
+ (closconv/remember ,code
+ form))))))))
+
+(define-closure-converter LOOKUP (env name)
+ (closconv/lookup* env name 'ORDINARY))
+
+(define-closure-converter LAMBDA (env lambda-list body)
+ (call-with-values
+ (lambda () (closconv/lambda* 'DYNAMIC env lambda-list body))
+ (lambda (expr* env*)
+ (set-closconv/env/close?! env* true)
+ expr*)))
+
+(define-closure-converter LET (env bindings body)
+ (let* ((env* (closconv/env/make
+ (binding-context-type 'LET
+ (closconv/env/context env)
+ bindings)
+ env
+ (lmap car bindings)))
+ (expr* `(LET ,(closconv/bindings env* env bindings)
+ ,(closconv/expr env* body))))
+ (set-closconv/env/form! env* expr*)
+ expr*))
+
+(define-closure-converter LETREC (env bindings body)
+ (let* ((env* (closconv/env/make
+ (binding-context-type 'LETREC
+ (closconv/env/context env)
+ bindings)
+ env
+ (lmap car bindings)))
+ (expr* `(LETREC ,(closconv/bindings env* env* bindings)
+ ,(closconv/expr env* body))))
+ (set-closconv/env/form! env* expr*)
+ expr*))
+\f
+(define-closure-converter CALL (env rator cont #!rest rands)
+ (let* ((rands (cons cont rands))
+ (default
+ (lambda ()
+ `(CALL ,(closconv/expr env rator)
+ ,@(closconv/expr* env rands)))))
+ (cond ((not (pair? rator))
+ (default))
+ ((eq? (car rator) 'LOOKUP)
+ (let* ((name (cadr rator))
+ (rator* (closconv/remember
+ (closconv/lookup* env name 'OPERATOR)
+ rator)))
+ `(CALL ,rator*
+ ,@(closconv/expr* env rands))))
+ ((eq? (car rator) 'LAMBDA)
+ (let ((ll (cadr rator))
+ (body (caddr rator)))
+ (guarantee-simple-lambda-list ll)
+ (guarantee-argument-list rands (length ll))
+ (let ((bindings (map list ll rands)))
+ (call-with-values
+ (lambda ()
+ (closconv/lambda*
+ (binding-context-type 'CALL
+ (closconv/env/context env)
+ bindings)
+ env ll body))
+ (lambda (rator* env*)
+ (let ((bindings* (closconv/bindings env* env bindings)))
+ `(CALL ,(closconv/remember rator* rator)
+ ,@(lmap cadr bindings*))))))))
+ (else
+ (default)))))
+
+(define-closure-converter QUOTE (env object)
+ env
+ `(QUOTE ,object))
+
+(define-closure-converter DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+(define-closure-converter BEGIN (env #!rest actions)
+ `(BEGIN ,@(closconv/expr* env actions)))
+
+(define-closure-converter IF (env pred conseq alt)
+ `(IF ,(closconv/expr env pred)
+ ,(closconv/expr env conseq)
+ ,(closconv/expr env alt)))
+\f
+(define (closconv/expr env expr)
+ ;; This copies the expression and returns the copy. It
+ ;; simultaneously builds an environment representation (see the data
+ ;; structure closconv/expr, below) by mutating the ENV argument.
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (closconv/quote env expr))
+ ((LOOKUP)
+ (closconv/lookup env expr))
+ ((LAMBDA)
+ (closconv/lambda env expr))
+ ((LET)
+ (closconv/let env expr))
+ ((DECLARE)
+ (closconv/declare env expr))
+ ((CALL)
+ (closconv/call env expr))
+ ((BEGIN)
+ (closconv/begin env expr))
+ ((IF)
+ (closconv/if env expr))
+ ((LETREC)
+ (closconv/letrec env expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (closconv/expr* env exprs)
+ (lmap (lambda (expr)
+ (closconv/expr env expr))
+ exprs))
+
+(define (closconv/remember new old)
+ (code-rewrite/remember new old))
+
+(define (closconv/split new old)
+ ;; The old code is being duplicated in the output, so the debugging
+ ;; information must understand the split.
+ (let ((old* (code-rewrite/original-form old)))
+ (if old*
+ (code-rewrite/remember*
+ new
+ (if (new-dbg-procedure? old*)
+ (new-dbg-procedure/copy old*)
+ old*)))
+ new))
+
+(define (closconv/new-name prefix)
+ (new-variable prefix))
+\f
+;;;; Parameterization for invocation before and after cps conversion
+
+;; Before CPS
+
+(define (closconv/closure/new-name/pre-cps)
+ (new-closure-variable))
+
+(define (closconv/closure/sort-variables/pre-cps variable-refs)
+ (if (there-exists? variable-refs continuation-variable?)
+ (internal-error "Closing over continuation variable before CPS"
+ variable-refs))
+ variable-refs)
+
+(define (closconv/closure/make-handler/pre-cps closure-name params body
+ captured)
+ captured ; ignored
+ `(LAMBDA (,(car params) ,closure-name ,@(cdr params))
+ ,body))
+
+(define (closconv/closure/make-trivial/pre-cps handler)
+ `(CALL (QUOTE ,%make-trivial-closure) (QUOTE #F) ,handler))
+
+(define (closconv/closure/make-set!/pre-cps closure-name index name*)
+ `(CALL (QUOTE ,%heap-closure-set!) (QUOTE #F) (LOOKUP ,closure-name)
+ ,index (LOOKUP ,name*) (QUOTE ,name*)))
+
+;; After CPS
+
+(define (closconv/closure/new-name/post-cps)
+ (let ((name (closconv/new-name 'FRAME)))
+ (declare-variable-property! name '(FRAME-VARIABLE))
+ name))
+
+(define (closconv/closure/sort-variables/post-cps variable-refs)
+ (call-with-values
+ (lambda ()
+ (list-split variable-refs
+ (lambda (free-ref)
+ (continuation-variable?
+ (closconv/binding/name (car free-ref))))))
+ (lambda (cont-refs non-cont-refs)
+ (append cont-refs non-cont-refs))))
+
+(define (closconv/closure/make-handler/post-cps closure-name params body
+ captured)
+ `(LAMBDA ,params
+ (LET ((,closure-name
+ (CALL (QUOTE ,%fetch-stack-closure)
+ (QUOTE #F)
+ (QUOTE ,captured))))
+ ,body)))
+
+(define (closconv/closure/make-trivial/post-cps handler)
+ ;; This gets invoked on lambda expressions that appear in several
+ ;; places (e.g. args to %make-heap-closure, %make-trivial-closure, etc.)
+ handler)
+
+(define (closconv/closure/make-set!/post-cps closure-name index name*)
+ closure-name index ; ignored
+ (internal-error "Assigning closure after CPS conversion?" name*))
+\f
+(define %make-closure %make-heap-closure)
+(define %closure-ref %heap-closure-ref)
+
+(let-syntax ((define-closconv-parameter
+ (macro (name)
+ `(define ,name ,(symbol-append name '/pre-cps)))))
+ (define-closconv-parameter closconv/closure/sort-variables)
+ (define-closconv-parameter closconv/closure/make-handler)
+ (define-closconv-parameter closconv/closure/make-trivial)
+ (define-closconv-parameter closconv/closure/make-set!)
+ (define-closconv-parameter closconv/closure/new-name))
+
+(define (closconv/bind-parameters after-cps? thunk)
+ (let ((bind-parameters
+ (lambda (lift? sort handler trivial
+ constructor refer
+ set new-name)
+ (fluid-let ((*lift-closure-lambdas?* lift?)
+ (closconv/closure/sort-variables sort)
+ (closconv/closure/make-handler handler)
+ (closconv/closure/make-trivial trivial)
+ (%make-closure constructor)
+ (%closure-ref refer)
+ (closconv/closure/make-set! set)
+ (closconv/closure/new-name new-name))
+ (thunk)))))
+ (if after-cps?
+ (bind-parameters false
+ closconv/closure/sort-variables/post-cps
+ closconv/closure/make-handler/post-cps
+ closconv/closure/make-trivial/post-cps
+ %make-stack-closure
+ %stack-closure-ref
+ closconv/closure/make-set!/post-cps
+ closconv/closure/new-name/post-cps)
+ (bind-parameters *lift-closure-lambdas?*
+ closconv/closure/sort-variables/pre-cps
+ closconv/closure/make-handler/pre-cps
+ closconv/closure/make-trivial/pre-cps
+ %make-heap-closure
+ %heap-closure-ref
+ closconv/closure/make-set!/pre-cps
+ closconv/closure/new-name/pre-cps))))
+\f
+(define-structure (closconv/env
+ (conc-name closconv/env/)
+ (constructor closconv/env/%make (context parent)))
+ (context false read-only true) ; Dynamic or static
+ (parent false read-only true)
+ (children '() read-only false)
+ (bound '() read-only false) ; list of closconv/binding structures
+ (free '() read-only false) ; list of (closconv/binding reference)
+ (form false read-only false)
+ (close? false read-only false) ; should be considered for
+ ; having its form closed (i.e.
+ ; converted to a %make-xxx-closure)
+ (closed-over false read-only false) ; slots required in closure
+ ; object: either #F, #T
+ ; (closed, but no slots), or a
+ ; list of (closconv/binding
+ ; reference) elements from free
+ (binding false read-only false)) ; known self-reference binding
+
+(define-structure (closconv/binding
+ (conc-name closconv/binding/)
+ (constructor closconv/binding/make (name env)))
+ (name false read-only true)
+ (env false read-only true)
+ (operator-refs '() read-only false)
+ (ordinary-refs '() read-only false)
+ (value false read-only false))
+
+(define (closconv/env/make context parent bound-names)
+ (let ((env (closconv/env/%make context parent)))
+ (set-closconv/env/bound!
+ env
+ (lmap (lambda (name)
+ (closconv/binding/make name env))
+ bound-names))
+ (set-closconv/env/children! parent
+ (cons env (closconv/env/children parent)))
+ env))
+
+(define (closconv/lookup* env name kind)
+ (let ((ref `(LOOKUP ,name)))
+ (let walk-spine ((env env))
+ (cond ((not env)
+ (free-var-error name))
+ ((closconv/binding/find (closconv/env/bound env) name)
+ => (lambda (binding)
+ (if (eq? kind 'OPERATOR)
+ (set-closconv/binding/operator-refs!
+ binding
+ (cons ref (closconv/binding/operator-refs binding)))
+ (set-closconv/binding/ordinary-refs!
+ binding
+ (cons ref (closconv/binding/ordinary-refs binding))))
+ binding))
+ (else
+ (let* ((binding (walk-spine (closconv/env/parent env)))
+ (free (closconv/env/free env))
+ (place (assq binding free)))
+ (if (not place)
+ (set-closconv/env/free! env
+ (cons (list binding ref) free))
+ (set-cdr! place (cons ref (cdr place))))
+ binding))))
+ ref))
+
+(define (closconv/binding/find bindings name)
+ (let find ((bindings bindings))
+ (and (not (null? bindings))
+ (let ((binding (car bindings)))
+ (if (not (eq? name (closconv/binding/name (car bindings))))
+ (find (cdr bindings))
+ binding)))))
+\f
+(define (closconv/lambda* context env lambda-list body)
+ ;; (values expr* env*)
+ (let* ((env* (closconv/env/make context
+ env
+ (lambda-list->names lambda-list)))
+ (expr* `(lambda ,lambda-list
+ ,(closconv/expr env* body))))
+ (set-closconv/env/form! env* expr*)
+ (values expr* env*)))
+
+(define (closconv/bindings env* env bindings)
+ ;; ENV* is the environment to which the bindings are being added
+ ;; ENV is the environment in which the form part of the binding is
+ ;; to be evaluated (i.e. it will be EQ? to ENV* for LETREC but
+ ;; not for LET)
+ (lmap (lambda (binding)
+ (let ((name (car binding))
+ (value (cadr binding)))
+ (list
+ name
+ (if (or (not (pair? value))
+ (not (eq? (car value) 'LAMBDA)))
+ (closconv/expr env value)
+ (call-with-values
+ (lambda ()
+ (closconv/lambda* 'DYNAMIC ; bindings are dynamic
+ env
+ (cadr value) ; lambda list
+ (caddr value))) ; body
+ (lambda (value* env**)
+ (let ((binding
+ (or (closconv/binding/find (closconv/env/bound env*)
+ name)
+ (internal-error "Missing binding" name))))
+ (set-closconv/env/binding! env** binding)
+ (set-closconv/binding/value! binding env**)
+ value*)))))))
+ bindings))
+\f
+;;;; The Analyzer/Converter Proper
+
+(define (closconv/analyze! env program)
+ (closconv/contaminate! env)
+ (closconv/rewrite! env)
+ program)
+
+(define (closconv/contaminate! env)
+ (cond ((closconv/env/closed-over env)) ; Already figured out
+ ((closconv/env/close? env)
+ (closconv/close! env))
+ ((not (closconv/env/binding env))) ; No known self-binding
+ ((not (null? (closconv/binding/ordinary-refs
+ (closconv/env/binding env))))
+ ;; Self-binding is referenced other than by a call
+ (closconv/close! env)))
+ (for-each closconv/contaminate! (closconv/env/children env)))
+
+(define (closconv/close! env)
+ (let ((closed-over
+ (list-transform-negative (closconv/env/free env)
+ (lambda (free-ref)
+ (closconv/static-binding? (car free-ref))))))
+ (set-closconv/env/closed-over!
+ env
+ (if (or (null? closed-over)
+ ;; Do not close if only free reference is self!
+ (and (null? (cdr closed-over))
+ (closconv/self-reference? env (car (car closed-over)))))
+ true
+ closed-over))
+ (for-each (lambda (free-ref)
+ (let* ((binding (car free-ref))
+ (env* (closconv/binding/value binding)))
+ (if (and env*
+ (not (closconv/env/closed-over env*)))
+ (closconv/close! env*))))
+ closed-over)))
+
+(define (closconv/static-binding? binding)
+ (and (eq? (closconv/env/context (closconv/binding/env binding)) 'STATIC)
+ (not (pseudo-static-variable? (closconv/binding/name binding)))))
+
+(define (closconv/self-reference? env binding)
+ (let ((value (closconv/binding/value binding)))
+ (and value
+ (eq? value env))))
+\f
+(define (closconv/rewrite! env)
+ ;; This must work from the root to the leaves, because a reference
+ ;; may be rewritten multiple times as it is copied from closure
+ ;; to closure.
+ (let ((form (closconv/env/form env))
+ (closed-over (closconv/env/closed-over env)))
+ (cond ((or (not form)
+ (not (pair? form))
+ (eq? (car form) 'LET))
+ (if closed-over
+ (internal-error "Form can't be closed" form))
+ (for-each closconv/rewrite! (closconv/env/children env)))
+ ((eq? (car form) 'LETREC)
+ ;; Handled specially because it must ensure that recursive
+ ;; references work, and the LETREC must remain syntactically
+ ;; acceptable (only lambda bindings allowed).
+ (if closed-over
+ (internal-error "Form can't be closed" form))
+ (let ((closed
+ (list-transform-positive (closconv/env/bound env)
+ (lambda (binding)
+ (let ((value (closconv/binding/value binding)))
+ (and value
+ (closconv/env/closed-over value)))))))
+ (if (null? closed)
+ (closconv/rewrite/letrec/trivial! env)
+ (closconv/rewrite/letrec! env closed))))
+ ((eq? (car form) 'LAMBDA)
+ (cond ((closconv/env/binding env) => closconv/verify-binding))
+ (cond ((pair? closed-over)
+ (closconv/rewrite/lambda! env '()))
+ (closed-over
+ (closconv/rewrite/lambda/trivial! env)))
+ (for-each closconv/rewrite! (closconv/env/children env)))
+ (else
+ (internal-error "Unknown binding form" form)))))
+
+(define (closconv/rewrite/lambda/trivial! env)
+ (closconv/maybe-lift! env
+ (let ((form (closconv/env/form env)))
+ (closconv/split (form/preserve form)
+ form))
+ closconv/closure/make-trivial))
+
+(define (closconv/verify-binding binding)
+ (if (and (not (null? (closconv/binding/operator-refs binding)))
+ (not (null? (closconv/binding/ordinary-refs binding)))
+ *closconv-operator-and-operand-illegal?*)
+ (internal-error "Binding is both operator and operand" binding)))
+\f
+(define (closconv/rewrite/lambda! env circular)
+ ;; Env is a LAMBDA env
+ (let ((closure-name (closconv/closure/new-name))
+ (closed-over*
+ (closconv/closure/sort-variables (closconv/env/closed-over env))))
+ (let* ((closed-over ; Remove self-reference if present
+ (let ((binding (closconv/env/binding env)))
+ (cond ((and binding (assq binding closed-over*))
+ => (lambda (free-ref)
+ (delq free-ref closed-over*)))
+ (else
+ closed-over*))))
+ (closed-over-names
+ (list->vector (lmap (lambda (free-ref)
+ (closconv/binding/name (car free-ref)))
+ closed-over)))
+ (captured
+ (lmap (lambda (free-ref)
+ (let ((binding (car free-ref)))
+ (if (memq binding circular)
+ `(QUOTE ,#f)
+ (form/preserve (cadr free-ref)))))
+ closed-over))
+ (form (closconv/env/form env)))
+ ;; Rewrite references to closed variables
+ (for-each
+ (lambda (free-ref)
+ (let ((name (closconv/binding/name (car free-ref))))
+ (for-each (lambda (ref)
+ (form/rewrite!
+ ref
+ `(CALL (QUOTE ,%closure-ref)
+ (QUOTE #F)
+ (LOOKUP ,closure-name)
+ (CALL (QUOTE ,%vector-index)
+ (QUOTE #F)
+ (QUOTE ,closed-over-names)
+ (QUOTE ,name))
+ (QUOTE ,name))))
+ (cdr free-ref))))
+ closed-over)
+ ;; Rewrite self references
+ (if (not (eq? closed-over closed-over*))
+ (let* ((self-binding (closconv/env/binding env))
+ (free-ref (assq self-binding closed-over*)))
+ (for-each (lambda (ref)
+ (form/rewrite! ref
+ `(LOOKUP ,closure-name)))
+ (cdr free-ref))))
+ ;; Convert to closure and maybe lift to top level
+ (closconv/maybe-lift!
+ env
+ (closconv/split
+ (closconv/closure/make-handler closure-name
+ (cadr form)
+ (caddr form)
+ closed-over-names)
+ form)
+ (lambda (handler)
+ `(CALL (QUOTE ,%make-closure) (QUOTE #F) ,handler
+ (QUOTE ,closed-over-names) ,@captured)))
+ closed-over-names)))
+\f
+(define (closconv/maybe-lift! env handler transform)
+ (form/rewrite! (closconv/env/form env)
+ (if *lift-closure-lambdas?*
+ (let ((handler-name
+ (let ((binding (closconv/env/binding env)))
+ (or (and binding
+ (variable/rename
+ (closconv/binding/name binding)))
+ (closconv/new-name 'LAMBDA)))))
+ (closconv/lift! env handler-name handler)
+ (transform `(LOOKUP ,handler-name)))
+ (transform handler))))
+
+(define (closconv/rewrite/letrec/trivial! env)
+ (for-each closconv/rewrite! (closconv/env/children env)))
+
+(define (closconv/rewrite/letrec! env closed*)
+ ;; Env is a LETREC env
+ (for-each closconv/verify-binding closed*)
+ (call-with-values
+ (lambda ()
+ (list-split closed*
+ (lambda (binding)
+ (let ((value (closconv/binding/value binding)))
+ (pair? (closconv/env/closed-over value))))))
+ (lambda (closed trivial)
+ ;; IMPORTANT: This assumes that make-trivial-closure can be called
+ ;; multiple times for the same lambda expression and returns
+ ;; eq? results!
+ (for-each
+ (lambda (binding)
+ (for-each (lambda (ref)
+ (let ((ref* (form/preserve ref)))
+ (form/rewrite! ref
+ (closconv/closure/make-trivial ref*))))
+ (closconv/binding/ordinary-refs binding)))
+ trivial)
+ (let* ((envs (lmap closconv/binding/value closed))
+ (circular
+ (lmap
+ (lambda (env)
+ (let ((closed-over (closconv/env/closed-over env)))
+ (list-transform-positive closed
+ (lambda (binding)
+ (assq binding closed-over)))))
+ envs)))
+ (let* ((circ-results (map closconv/rewrite/lambda! envs circular))
+ (form (closconv/env/form env)))
+ (form/rewrite!
+ form
+\f
+ (bind* (lmap closconv/binding/name closed)
+ (lmap closconv/env/form envs)
+ (beginnify
+ (append-map*
+ (list
+ (let ((ok (delq* closed (closconv/env/bound env))))
+ (if (null? ok)
+ (caddr form)
+ (let ((ok-names (lmap closconv/binding/name ok)))
+ `(LETREC ,(list-transform-positive (cadr form)
+ (lambda (binding)
+ (memq (car binding) ok-names)))
+ ,(caddr form))))))
+ (lambda (binding captured-names circular)
+ (let ((name (closconv/binding/name binding))
+ (l (vector->list captured-names)))
+ (append-map
+ (lambda (binding)
+ (let ((name* (closconv/binding/name binding)))
+ (if (not (memq name* l))
+ '()
+ (list
+ (closconv/closure/make-set!
+ name
+ `(CALL (QUOTE ,%vector-index)
+ (QUOTE #F)
+ (QUOTE ,captured-names)
+ (QUOTE ,name*))
+ name*)))))
+ circular)))
+ closed circ-results circular)))))
+ (let ((envs (append (lmap closconv/binding/value trivial) envs)))
+ (for-each (lambda (closed-env)
+ (for-each closconv/rewrite!
+ (closconv/env/children closed-env)))
+ envs)
+ (for-each closconv/rewrite!
+ (delq* envs (closconv/env/children env))))))))
+
+(define closconv/lift!
+ (lifter/make (lambda (env)
+ (let loop ((env env))
+ (cond ((not env)
+ (internal-error "No static frame" env))
+ ((eq? (closconv/env/context env) 'STATIC)
+ (closconv/env/form env))
+ (else
+ (loop (closconv/env/parent env))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: compat.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Compatibility package
+;; Decides which parameters are passed on the stack. Primitives get all
+;; their parameters on the stack in an interpreter-like stack-frame.
+;; Procedures get some arguments in registers and the rest on the
+;; stack, with earlier arguments begin deeper to facilitate lexprs.
+;; The number of parameters passed in registers is determined by the
+;; back-end (*rtlgen/arguments-registers*)
+
+
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (compat/top-level program)
+ (let ((result (form/match compat/expression-pattern program)))
+ (if (not result)
+ (internal-error "Expression does not bind continuation" program))
+ (compat/remember
+ (compat/expr '() ; Nothing known about stack yet
+ (let ((continuation-variable
+ (cadr (assq compat/?cont-variable result)))
+ (body (cadr (assq compat/?expr-body result))))
+ (let ((result (form/match compat/needs-environment-pattern body)))
+ (if result
+ `(LAMBDA (,continuation-variable
+ ,(cadr (assq compat/?env-variable result)))
+ ,(cadr (assq compat/?expr-body result)))
+ `(LAMBDA (,continuation-variable
+ ,(new-ignored-variable 'IGNORED-ENVIRONMENT))
+ ,body)))))
+ program)))
+
+(define compat/?cont-variable (->pattern-variable 'CONT-VARIABLE))
+(define compat/?env-variable (->pattern-variable 'ENV-VARIABLE))
+(define compat/?frame-variable (->pattern-variable 'FRAME-VARIABLE))
+(define compat/?frame-vector (->pattern-variable 'FRAME-VECTOR))
+(define compat/?expr-body (->pattern-variable 'EXPR-BODY))
+(define compat/?body (->pattern-variable 'BODY))
+
+(define compat/expression-pattern
+ `(LET ((,compat/?cont-variable
+ (CALL (QUOTE ,%fetch-continuation)
+ (QUOTE #F))))
+ ,compat/?expr-body))
+
+(define compat/needs-environment-pattern
+ `(LET ((,compat/?env-variable
+ (CALL (QUOTE ,%fetch-environment)
+ (QUOTE #F))))
+ ,compat/?expr-body))
+
+(define compat/frame-pattern
+ `(LET ((,compat/?frame-variable
+ (CALL (QUOTE ,%fetch-stack-closure)
+ (QUOTE #F)
+ (QUOTE ,compat/?frame-vector))))
+ ,compat/?body))
+\f
+(define-macro (define-compatibility-rewrite keyword bindings . body)
+ (let ((proc-name (symbol-append 'COMPAT/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name env form)
+ (compat/remember ,code form))))))))
+
+(define-compatibility-rewrite LOOKUP (env name)
+ (let ((place (assq name env)))
+ (if (not place)
+ `(LOOKUP ,name)
+ (cadr place))))
+
+(define-compatibility-rewrite LAMBDA (env lambda-list body)
+ env ; ignored
+ (compat/rewrite-lambda lambda-list body
+ (compat/choose-stack-formals 1 lambda-list)))
+
+
+(define-compatibility-rewrite LET (env bindings body)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (compat/expr env (cadr binding))))
+ bindings)
+ ,(compat/expr env body)))
+
+(define-compatibility-rewrite LETREC (env bindings body)
+ `(LETREC ,(lmap (lambda (binding)
+ (list (car binding)
+ (compat/expr env (cadr binding))))
+ bindings)
+ ,(compat/expr env body)))
+
+(define-compatibility-rewrite QUOTE (env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-compatibility-rewrite BEGIN (env #!rest actions)
+ `(BEGIN ,@(compat/expr* env actions)))
+
+(define-compatibility-rewrite DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+(define-compatibility-rewrite IF (env pred conseq alt)
+ `(IF ,(compat/expr env pred)
+ ,(compat/expr env conseq)
+ ,(compat/expr env alt)))
+\f
+(define-compatibility-rewrite CALL (env rator cont #!rest rands)
+ (compat/rewrite-call env rator cont rands))
+
+(define (compat/rewrite-call env rator cont rands)
+
+ (define (possibly-pass-some-args-on-stack)
+ (compat/standard-call-handler env rator cont rands))
+
+ (define (dont-split-cookie-call)
+ `(CALL ,(compat/expr env rator)
+ ,(compat/expr env cont)
+ ,@(compat/expr* env rands)))
+
+ (cond ((or (not (pair? rator))
+ (not (eq? (car rator) 'QUOTE)))
+ (possibly-pass-some-args-on-stack))
+ ((rewrite-operator/compat? (quote/text rator))
+ => (lambda (handler)
+ (handler env rator cont rands)))
+ #| Hooks into the compiler interface, when they must tail
+ into another computation, are now called with the default
+ (args. in registers) calling convention. This is not a
+ problem because they have fixed arity.
+ ((and (operator/satisfies? (quote/text rator) '(OUT-OF-LINE-HOOK))
+ (not (operator/satisfies? (quote/text rator) '(SPECIAL-INTERFACE)))
+ (not (equal? cont '(QUOTE #F))))
+ (compat/out-of-line env rator cont rands))
+ |#
+ (else (dont-split-cookie-call))))
+
+(define (compat/expr env expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE) (compat/quote env expr))
+ ((LOOKUP) (compat/lookup env expr))
+ ((LAMBDA) (compat/lambda env expr))
+ ((LET) (compat/let env expr))
+ ((DECLARE) (compat/declare env expr))
+ ((CALL) (compat/call env expr))
+ ((BEGIN) (compat/begin env expr))
+ ((IF) (compat/if env expr))
+ ((LETREC) (compat/letrec env expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (compat/expr* env exprs)
+ (lmap (lambda (expr)
+ (compat/expr env expr))
+ exprs))
+
+(define (compat/remember new old)
+ (code-rewrite/remember new old))
+
+(define (compat/new-name prefix)
+ (new-variable prefix))
+\f
+(define (compat/lambda-list->frame lambda-list)
+ (let ((names (lambda-list->names lambda-list)))
+ (let ((first (car names)))
+ (if (not (continuation-variable? first))
+ (internal-error "No continuation variable found" lambda-list))
+ (list->vector (cons first (reverse (cdr names)))))))
+
+
+(define (compat/rewrite-lambda formals body formals-on-stack)
+
+ (define (compat/new-env frame-variable old-frame-vector new-frame-vector)
+ ;; The new environment maps names to %stack-closure-refs and %vector-index
+ ;; vectors to new, extended vectors
+ (let ((alist (lmap (lambda (name)
+ (list name
+ `(CALL (QUOTE ,%stack-closure-ref)
+ (QUOTE #F)
+ (LOOKUP ,frame-variable)
+ (CALL (QUOTE ,%vector-index)
+ (QUOTE #F)
+ (QUOTE ,new-frame-vector)
+ (QUOTE ,name))
+ (QUOTE ,name))))
+ formals-on-stack)))
+ (if old-frame-vector
+ (cons (list old-frame-vector new-frame-vector)
+ alist)
+ alist)))
+
+ (define (make-new-lambda frame-variable old-frame-vector new-frame-vector
+ body)
+ `(LAMBDA ,formals
+ (LET ((,frame-variable
+ (CALL (QUOTE ,%fetch-stack-closure)
+ (QUOTE #F)
+ (QUOTE ,new-frame-vector))))
+ ,(compat/expr (compat/new-env
+ frame-variable old-frame-vector new-frame-vector)
+ body))))
+
+ (cond ((null? formals-on-stack)
+ `(LAMBDA ,formals
+ ,(compat/expr '() body)))
+ ((form/match compat/frame-pattern body)
+ => (lambda (match)
+ (let* ((old-frame-vector (cadr(assq compat/?frame-vector match)))
+ (new-frame-vector
+ (list->vector (append (vector->list old-frame-vector)
+ formals-on-stack))))
+ (make-new-lambda
+ (cadr (assq compat/?frame-variable match))
+ old-frame-vector
+ new-frame-vector
+ (cadr (assq compat/?body match))))))
+ (else
+ (let ((frame (compat/new-name 'FRAME)))
+ (declare-variable-property! frame '(FRAME-VARIABLE))
+ (make-new-lambda frame
+ #F
+ (list->vector formals-on-stack)
+ body)))))
+\f
+(define (compat/choose-stack-formals special-arguments lambda-list)
+ ;; SPECIAL-ARGUMENTS is the number of arguments passed by a special
+ ;; mechanism, usually 1 for the continuation, or 2 for the
+ ;; continuation and heap closure.
+ (with-values
+ (lambda ()
+ (%compat/split-register&stack special-arguments
+ (lambda-list->names lambda-list)))
+ (lambda (register-formals stack-formals)
+ register-formals ; ignored
+ stack-formals)))
+
+
+(define (compat/split-register&stack expressions)
+ (%compat/split-register&stack 0 expressions))
+
+(define (%compat/split-register&stack special-arguments args-or-formals)
+ ;;(values for-regsiters for-stack)
+ (let* ((len (length args-or-formals))
+ (argument-register-count
+ (+ special-arguments
+ (vector-length *rtlgen/argument-registers*))))
+ (if (> len argument-register-count)
+ (values (list-head args-or-formals argument-register-count)
+ (list-tail args-or-formals argument-register-count))
+ (values args-or-formals
+ '()))))
+
+(define (compat/expression->name expr)
+ (cond ((LOOKUP/? expr)
+ (lookup/name expr))
+ ((CALL/%stack-closure-ref? expr)
+ (quote/text (CALL/%stack-closure-ref/name expr)))
+ (else
+ (compat/new-name 'ARG))))
+
+\f
+(define (compat/uniquify-append prefix addends)
+ ;; append addends, ensuring that each is a unique name
+ (define (uniquify names)
+ (if (null? names)
+ '()
+ (let ((unique-tail (uniquify (cdr names))))
+ (cons (if (or (memq (car names) unique-tail)
+ (memq (car names) prefix))
+ (variable/rename (car names))
+ (car names))
+ unique-tail))))
+ (append prefix (uniquify addends)))
+
+
+(define (compat/rewrite-call/split env operator continuation
+ register-operands stack-operands)
+
+ (define (pushed-arg-name form)
+ (compat/expression->name form))
+
+ (define (make-call new-continuation)
+ `(CALL ,(compat/expr env operator)
+ ,(compat/expr env new-continuation)
+ ,@(compat/expr* env register-operands)))
+
+ (define (make-pushing-call continuation old-frame old-pushed-expressions)
+ (make-call
+ `(CALL ',%make-stack-closure
+ '#F
+ ,continuation
+ ',(list->vector
+ (compat/uniquify-append
+ (vector->list old-frame)
+ (map pushed-arg-name stack-operands)))
+ ,@old-pushed-expressions
+ ,@stack-operands)))
+
+ (cond ((null? stack-operands)
+ (make-call continuation))
+ ((call/%make-stack-closure? continuation)
+ ;; extend the stack closure with parameters
+ (make-pushing-call
+ (call/%make-stack-closure/lambda-expression continuation)
+ (quote/text (call/%make-stack-closure/vector continuation))
+ (call/%make-stack-closure/values continuation)))
+ (else
+ ;; introduce a new stack closure for extra parameters
+ (make-pushing-call continuation
+ '#()
+ '()))))
+\f
+(define *compat-rewritten-operators*
+ (make-eq-hash-table))
+
+(define-integrable (rewrite-operator/compat? rator)
+ (hash-table/get *compat-rewritten-operators* rator false))
+
+(define (define-rewrite/compat operator handler)
+ (hash-table/put! *compat-rewritten-operators* operator handler))
+
+(define (compat/standard-call-handler env rator cont rands)
+ (with-values (lambda () (compat/split-register&stack rands))
+ (lambda (reg-rands stack-rands)
+ (compat/rewrite-call/split env rator cont reg-rands stack-rands))))
+
+(let* ((compat/invocation-cookie
+ (lambda (n)
+ (lambda (env rator cont rands)
+ (with-values
+ (lambda () (compat/split-register&stack (list-tail rands n)))
+ (lambda (reg-rands stack-rands)
+ (compat/rewrite-call/split
+ env rator cont
+ (append (list-head rands n) reg-rands)
+ stack-rands))))))
+ (invocation+2-handler (compat/invocation-cookie 2)))
+
+ ;; These are kinds of calls which have extra arguments like arity or cache
+ (define-rewrite/compat %invoke-operator-cache invocation+2-handler)
+ (define-rewrite/compat %invoke-remote-cache invocation+2-handler)
+ (define-rewrite/compat %internal-apply invocation+2-handler)
+ (define-rewrite/compat %invoke-continuation compat/standard-call-handler))
+
+
+(define-rewrite/compat %vector-index
+ (lambda (env rator cont rands)
+ rator cont
+ ;; rands = ('<vector> '<name>)
+ ;; Copy, possibly replacing vector
+ `(CALL (QUOTE ,%vector-index)
+ (QUOTE #F)
+ ,(compat/expr env
+ (let ((vector-arg (first rands)))
+ (if (and (pair? vector-arg)
+ (eq? (car vector-arg) 'QUOTE))
+ (cond ((assq (quote/text vector-arg) env)
+ => (lambda (old.new)
+ `(QUOTE ,(second old.new))))
+ (else vector-arg))
+ (internal-error
+ "Illegal (unquoted) %vector-index arguments"
+ rands))))
+ ,(compat/expr env (second rands)))))
+
+\f
+(define-rewrite/compat %make-heap-closure
+ ;; The lambda expression in a heap closure is special the closure
+ ;; formal is passed by a special mechanism
+ (lambda (env rator cont rands)
+ rator ; ignored
+ (let ((lam-expr (first rands)))
+ (if (not (LAMBDA/? lam-expr))
+ (internal-error "%make-heap-closure is missing a LAMBDA-expression"
+ rands))
+ (let ((lambda-list (lambda/formals lam-expr)))
+ (if (or (< (length lambda-list) 2)
+ (not (closure-variable? (second lambda-list))))
+ (internal-error
+ "%make-heap-closure LAMBDA-expression has bad formals" lam-expr))
+ `(CALL (QUOTE ,%make-heap-closure)
+ ,(compat/expr env cont)
+ ,(compat/rewrite-lambda
+ lambda-list
+ (lambda/body lam-expr)
+ (compat/choose-stack-formals 2 lambda-list))
+ . ,(compat/expr* env (cdr rands)))))))
+
+
+(define-rewrite/compat %variable-cache-ref
+ ;; (CALL ',%variable-cache-ref '#F <read-variable-cache> 'NAME)
+ ;; ------- rator ------- cont -------- rands -----------
+ (lambda (env rator cont rands)
+ rator ; ignored
+ (let ((cont (compat/expr env cont))
+ (cell (compat/expr env (first rands)))
+ (quoted-name (compat/expr env (second rands))))
+ (compat/verify-hook-continuation cont)
+ (compat/verify-cache cell quoted-name)
+ (let* ((%continue
+ (if (not (QUOTE/? cont))
+ (lambda (expr)
+ `(CALL (QUOTE ,%invoke-continuation)
+ ,cont
+ ,expr))
+ (lambda (expr) expr)))
+ (name (quote/text quoted-name))
+ (cell-name
+ (new-variable-cache-variable name `(VARIABLE-CACHE ,name)))
+ (value-name (compat/new-name name)))
+ (if (compat/ignore-reference-traps? name)
+ (%continue `(CALL (QUOTE ,%variable-cell-ref)
+ (QUOTE #F)
+ (CALL (QUOTE ,%variable-read-cache) (QUOTE #F)
+ ,cell ,quoted-name)))
+ `(LET ((,cell-name
+ (CALL (QUOTE ,%variable-read-cache) (QUOTE #F)
+ ,cell ,quoted-name)))
+ (LET ((,value-name (CALL (QUOTE ,%variable-cell-ref)
+ (QUOTE #F)
+ (LOOKUP ,cell-name))))
+ (IF (CALL (QUOTE ,%reference-trap?)
+ (QUOTE #F)
+ (LOOKUP ,value-name))
+ (CALL (QUOTE ,%hook-variable-cell-ref)
+ ,cont
+ (LOOKUP ,cell-name))
+ ,(%continue `(LOOKUP ,value-name))))))))))
+\f
+(define-rewrite/compat %safe-variable-cache-ref
+ (lambda (env rator cont rands)
+ ;; (CALL ',%safe-variable-cache-ref '#F <read-variable-cache> 'NAME)
+ ;; --------- rator --------- cont -------- rands -----------
+ rator ; ignored
+ (let ((cont (compat/expr env cont))
+ (cell (compat/expr env (first rands)))
+ (quoted-name (compat/expr env (second rands))))
+ (compat/verify-hook-continuation cont)
+ (compat/verify-cache cell quoted-name)
+ (let* ((%continue
+ (if (not (QUOTE/? cont))
+ (lambda (expr)
+ `(CALL (QUOTE ,%invoke-continuation)
+ ,cont
+ ,expr))
+ (lambda (expr) expr)))
+ (name (quote/text quoted-name))
+ (cell-name
+ (new-variable-cache-variable name `(VARIABLE-CACHE ,name)))
+ (value-name (compat/new-name name)))
+ `(LET ((,cell-name
+ (CALL (QUOTE ,%variable-read-cache) (QUOTE #F)
+ ,cell ,quoted-name)))
+ (LET ((,value-name (CALL (QUOTE ,%variable-cell-ref)
+ (QUOTE #F)
+ (LOOKUP ,cell-name))))
+ ,(if (compat/ignore-reference-traps? name)
+ (%continue `(LOOKUP ,value-name))
+ `(IF (IF (CALL (QUOTE ,%reference-trap?)
+ (QUOTE #F)
+ (LOOKUP ,value-name))
+ (CALL (QUOTE ,%unassigned?)
+ (QUOTE #F)
+ (LOOKUP ,value-name))
+ (QUOTE #T))
+ ,(%continue `(LOOKUP ,value-name))
+ (CALL (QUOTE ,%hook-safe-variable-cell-ref)
+ ,cont
+ (LOOKUP ,cell-name))))))))))
+
+
+;;; These predicates should determine the right answers from declarations:
+
+(define (compat/ignore-reference-traps? name)
+ name
+ #F)
+
+(define (compat/ignore-assignment-traps? name)
+ name
+ #F)
+\f
+;; NOTE: This is never in value position because envconv expands
+;; all cell sets into begins. In particular, this means that cont
+;; should always be #F!
+;; The expansion in envconv implies that SET! for value is more
+;; expensive than necessary, since it could use the same cell
+;; for the read and the write.
+
+(define-rewrite/compat %variable-cache-set!
+ (lambda (env rator cont rands)
+ ;; (CALL ',%variable-write-cache '#F <write-variable-cache> 'NAME)
+ ;; -------- rator -------- cont -------- rands -----------
+ rator ; ignored
+ (let ((cont (compat/expr env cont))
+ (cell (compat/expr env (first rands)))
+ (value (compat/expr env (second rands)))
+ (quoted-name (compat/expr env (third rands))))
+ ;; (compat/verify-hook-continuation cont)
+ (if (not (equal? cont '(QUOTE #F)))
+ (internal-error "Unexpected continuation to variable cache assignment"
+ cont))
+ (compat/verify-cache cell quoted-name)
+ (let* ((name (quote/text quoted-name))
+ (cell-name
+ (new-variable-cache-variable name `(ASSIGNMENT-CACHE ,name)))
+ (old-value-name (compat/new-name name))
+ (value-name (compat/new-name 'VALUE)))
+ `(LET ((,value-name ,value))
+ (LET ((,cell-name
+ (CALL (QUOTE ,%variable-write-cache) (QUOTE #F)
+ ,cell ,quoted-name)))
+ ,(if (compat/ignore-assignment-traps? name)
+
+ `(CALL (QUOTE ,%variable-cell-set!)
+ ,cont
+ (LOOKUP ,cell-name)
+ (LOOKUP ,value-name))
+
+ `(LET ((,old-value-name (CALL (QUOTE ,%variable-cell-ref)
+ (QUOTE #F)
+ (LOOKUP ,cell-name))))
+ (IF (IF (CALL (QUOTE ,%reference-trap?)
+ (QUOTE #F)
+ (LOOKUP ,old-value-name))
+ (CALL (QUOTE ,%unassigned?)
+ (QUOTE #F)
+ (LOOKUP ,old-value-name))
+ (QUOTE #T))
+ (CALL (QUOTE ,%variable-cell-set!)
+ ,cont
+ (LOOKUP ,cell-name)
+ (LOOKUP ,value-name))
+ (CALL (QUOTE ,%hook-variable-cell-set!)
+ ,cont
+ (LOOKUP ,cell-name)
+ (LOOKUP ,value-name)))))))))))
+
+(define (compat/verify-cache cell name)
+ (if (and (LOOKUP/? cell)
+ (QUOTE/? name))
+ 'ok
+ (internal-error "Unexpected arguments to variable cache operation"
+ cell name)))
+\f
+(define (compat/verify-hook-continuation cont)
+ (if (or (QUOTE/? cont)
+ (LOOKUP/? cont)
+ (CALL/%stack-closure-ref? cont))
+ 'ok
+ (internal-error "Unexpected continuation to out-of-line hook" cont)))
+
+(let ((known-operator->primitive
+ (lambda (env rator cont rands)
+ (compat/->stack-closure
+ env cont (cddr rands)
+ (lambda (cont*)
+ `(CALL ,(compat/remember `(QUOTE ,%primitive-apply/compatible)
+ rator)
+ ,cont*
+ ,(compat/expr env (car rands)) ; Primitive
+ ,(compat/expr env (cadr rands)))))))) ; Arity
+
+ ;; Because these are reflected into the standard C coded primitives,
+ ;; there's no reason to target the machine registers -- they'd wind
+ ;; up on the Scheme stack anyway since that's the only place C can
+ ;; see them!
+ (define-rewrite/compat %primitive-apply known-operator->primitive))
+
+
+(define (compat/->stack-closure env cont rands gen)
+ (define (compat/->stack-names rands)
+ (compat/uniquify-append
+ '()
+ (lmap compat/expression->name
+ rands)))
+
+ (define (compat/->stack-frame names)
+ (list->vector (cons (car names) (reverse (cdr names)))))
+
+ (let* ((cont (compat/expr env cont)))
+ (define (fail)
+ (internal-error "Illegal continuation" cont))
+ (define (default cont-name cont)
+ (let ((names
+ (cons cont-name (compat/->stack-names rands))))
+ `(CALL (QUOTE ,%make-stack-closure)
+ (QUOTE #F)
+ (QUOTE #F) ; magic cookie
+ (QUOTE ,(compat/->stack-frame names))
+ ,cont
+ ,@(compat/expr* env (reverse rands)))))
+ (cond ((LOOKUP/? cont)
+ (gen (default (lookup/name cont) cont)))
+ ((CALL/%make-stack-closure? cont)
+ (let ((cont-var (new-continuation-variable)))
+ `(CALL
+ (LAMBDA (,cont-var)
+ ,(gen (default cont-var `(LOOKUP ,cont-var))))
+ ,cont)))
+ ((CALL/%stack-closure-ref? cont)
+ (gen (default (cadr (list-ref cont 5)) cont)))
+ (else (fail)))))
+\f
+(let ()
+ (define (define-primitive-call rator arity name)
+ (let ((prim (make-primitive-procedure name)))
+ (define-rewrite/compat rator
+ (lambda (env rator cont rands)
+ rator ; ignored
+ (compat/->stack-closure
+ env cont rands
+ (lambda (cont*)
+ `(CALL (QUOTE ,%primitive-apply/compatible)
+ ,cont*
+ (QUOTE ,arity)
+ (QUOTE ,prim))))))))
+
+ (define (define-truncated-call rator arity name)
+ (let ((prim (make-primitive-procedure name)))
+ (define-rewrite/compat rator
+ (lambda (env rator cont rands)
+ rator ; ignored
+ (compat/->stack-closure
+ env cont (list-head rands arity)
+ (lambda (cont*)
+ `(CALL (QUOTE ,%primitive-apply/compatible)
+ ,cont*
+ (QUOTE ,arity)
+ (QUOTE ,prim))))))))
+
+ (define (define-global-call rator arity name)
+ (define-rewrite/compat rator
+ (lambda (env rator cont rands)
+ rator ; ignored
+ (let ((desc (list name arity)))
+ ;; This way ensures it works with very small numbers of
+ ;; argument registers:
+ (compat/rewrite-call env
+ `(QUOTE ,%invoke-remote-cache)
+ cont
+ (cons* `(QUOTE ,desc)
+ `(QUOTE #F)
+ rands))))))
+
+ (define-primitive-call %*define 3 'LOCAL-ASSIGNMENT)
+ (define-primitive-call %execute 2 'SCODE-EVAL)
+
+ (define-global-call %*define* 3 'DEFINE-MULTIPLE)
+ (define-global-call %*make-environment false '*MAKE-ENVIRONMENT)
+ (define-global-call %copy-program 1 'COPY-PROGRAM)
+
+ ;; *** Until the full version is implemented ***
+ ;; The parameters dropped are the expected depth and offset.
+
+ (define-truncated-call %*lookup 2 'LEXICAL-REFERENCE)
+ (define-truncated-call %*set! 3 'LEXICAL-ASSIGNMENT)
+ (define-truncated-call %*unassigned? 2 'LEXICAL-UNASSIGNED?))
+
+\f
+#| Test:
+
+(set! *rtlgen/argument-registers* '#(2 6))
+
+(let ((fv1 '#(save1 save2 save3)))
+ (kmp/pp
+ (compat/expr
+ '()
+ `(call (lookup proc)
+ (call ',%make-stack-closure
+ '#f
+ (lambda (k val1 val2 val3 val4)
+ (let ((frame (call ',%fetch-stack-closure '#f ',fv1)))
+ (call (lookup val4)
+ (call ',%stack-closure-ref
+ '#F
+ (lookup frame)
+ (call ',%vector-index '#F ',fv1 'save2)
+ 'save2)
+ (lookup val2)
+ '1000)))
+ ',fv1
+ 's1
+ 's2
+ 's3)
+ 'arg1
+ 'arg2
+ 'arg3))))
+|#
\ No newline at end of file
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+(define (copier/top-level program remember)
+ (copier/expr remember program))
+
+(define-macro (define-copier-handler keyword bindings . body)
+ (let ((proc-name (symbol-append 'COPIER/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler state) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name state form)
+ (copier/remember ,code
+ form))))))))
+
+(define-copier-handler LOOKUP (state name)
+ state ; ignored
+ `(LOOKUP ,name))
+
+(define-copier-handler LAMBDA (state lambda-list body)
+ `(LAMBDA ,lambda-list
+ ,(copier/expr state body)))
+
+(define-copier-handler CALL (state rator cont #!rest rands)
+ `(CALL ,(copier/expr state rator)
+ ,(copier/expr state cont)
+ ,@(copier/expr* state rands)))
+
+(define-copier-handler LET (state bindings body)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (copier/expr state (cadr binding))))
+ bindings)
+ ,(copier/expr state body)))
+
+(define-copier-handler LETREC (state bindings body)
+ `(LETREC ,(lmap (lambda (binding)
+ (list (car binding)
+ (copier/expr state (cadr binding))))
+ bindings)
+ ,(copier/expr state body)))
+
+(define-copier-handler QUOTE (state object)
+ state ; ignored
+ `(QUOTE ,object))
+
+(define-copier-handler DECLARE (state #!rest anything)
+ state ; ignored
+ `(DECLARE ,@anything))
+
+(define-copier-handler BEGIN (state #!rest actions)
+ `(BEGIN ,@(copier/expr* state actions)))
+
+(define-copier-handler IF (state pred conseq alt)
+ `(IF ,(copier/expr state pred)
+ ,(copier/expr state conseq)
+ ,(copier/expr state alt)))
+
+(define-copier-handler SET! (state name value)
+ `(SET! ,name ,(copier/expr state value)))
+
+(define-copier-handler ACCESS (state name env-expr)
+ `(ACCESS ,name ,(copier/expr state env-expr)))
+
+(define-copier-handler UNASSIGNED? (state name)
+ state ; ignored
+ `(UNASSIGNED? ,name))
+
+(define-copier-handler OR (state pred alt)
+ `(OR ,(copier/expr state pred)
+ ,(copier/expr state alt)))
+
+(define-copier-handler DELAY (state expr)
+ `(DELAY ,(copier/expr state expr)))
+
+(define-copier-handler DEFINE (state name value)
+ `(DEFINE ,name ,(copier/expr state value)))
+
+(define-copier-handler IN-PACKAGE (state envexpr bodyexpr)
+ `(IN-PACKAGE ,(copier/expr state envexpr)
+ ,(copier/expr state bodyexpr)))
+
+(define-copier-handler THE-ENVIRONMENT (state)
+ state ; ignored
+ `(THE-ENVIRONMENT))
+
+\f
+(define (copier/expr state expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (state (case (car expr)
+ ((QUOTE)
+ (copier/quote state expr))
+ ((LOOKUP)
+ (copier/lookup state expr))
+ ((LAMBDA)
+ (copier/lambda state expr))
+ ((LET)
+ (copier/let state expr))
+ ((DECLARE)
+ (copier/declare state expr))
+ ((CALL)
+ (copier/call state expr))
+ ((BEGIN)
+ (copier/begin state expr))
+ ((IF)
+ (copier/if state expr))
+ ((LETREC)
+ (copier/letrec state expr))
+ ((SET!)
+ (copier/set! state expr))
+ ((UNASSIGNED?)
+ (copier/unassigned? state expr))
+ ((OR)
+ (copier/or state expr))
+ ((DELAY)
+ (copier/delay state expr))
+ ((ACCESS)
+ (copier/access state expr))
+ ((DEFINE)
+ (copier/define state expr))
+ ((IN-PACKAGE)
+ (copier/in-package state expr))
+ ((THE-ENVIRONMENT)
+ (copier/the-environment state expr))
+ (else
+ (illegal expr)))
+ expr))
+
+(define (copier/expr* state exprs)
+ (lmap (lambda (expr)
+ (copier/expr state expr))
+ exprs))
+
+(define-integrable (copier/remember new old)
+ old ; ignored for now and forever
+ new)
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: cpsconv.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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-passing style Converter
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (cpsconv/top-level program)
+ (let ((name (new-continuation-variable)))
+ `(LET ((,name (CALL (QUOTE ,%fetch-continuation) (QUOTE #F))))
+ ,(cpsconv/expr (cpsconv/named-continuation name)
+ program))))
+
+(define-macro (define-cps-converter keyword bindings . body)
+ (let ((proc-name (symbol-append 'CPSCONV/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler cont) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name cont form)
+ (cpsconv/remember ,code
+ form))))))))
+
+(define-cps-converter LOOKUP (cont name)
+ (cpsconv/return cont `(LOOKUP ,name)))
+
+(define-cps-converter LAMBDA (cont lambda-list body)
+ (cpsconv/return cont
+ (cpsconv/lambda* lambda-list body)))
+
+#|
+(define-cps-converter LET (cont bindings body)
+ (cpsconv/call** (lmap cpsconv/classify-let-binding bindings)
+ (lambda (names* rands*)
+ `(LET ,(map list names* rands*)
+ ,(cpsconv/expr cont body)))))
+|#
+
+(define (cpsconv/let cont form)
+ (cpsconv/remember
+ (let ((bindings (cadr form))
+ (body (caddr form)))
+ (cpsconv/call** (lmap cpsconv/classify-let-binding bindings)
+ (lambda (names* rands*)
+ `(LET ,(map list names* rands*)
+ ,(cpsconv/expr cont body)))
+ form))
+ form))
+
+(define-cps-converter LETREC (cont bindings body)
+ `(LETREC ,(lmap (lambda (binding)
+ (let ((value (cadr binding)))
+ (list (car binding)
+ (cpsconv/lambda* (cadr value) (caddr value)))))
+ bindings)
+ ,(cpsconv/expr cont body)))
+
+(define (cpsconv/lambda* lambda-list body)
+ `(LAMBDA ,lambda-list
+ ,(cpsconv/expr (cpsconv/named-continuation (car lambda-list))
+ body)))
+\f
+#|
+(define-cps-converter CALL (cont rator orig-cont #!rest rands)
+ (if (not (equal? orig-cont '(QUOTE #F)))
+ (internal-error "Already cps-converted?"
+ `(CALL ,rator ,orig-cont ,@rands)))
+ (cpsconv/call* cont rator rands))
+|#
+
+(define (cpsconv/call cont form)
+ (cpsconv/remember
+ (let ((rator (call/operator form))
+ (orig-cont (call/continuation form))
+ (rands (call/operands form)))
+ (if (not (equal? orig-cont '(QUOTE #F)))
+ (internal-error "Already cps-converted?"
+ `(CALL ,rator ,orig-cont ,@rands)))
+ (cpsconv/call* cont rator rands form))
+ form))
+
+(define (cpsconv/call* cont rator rands form)
+ (let* ((do-call
+ (lambda (elements names call-gen)
+ (cpsconv/call** (map cpsconv/classify-operand elements names)
+ call-gen
+ form)))
+ (default
+ (lambda ()
+ (let ((rator&rands (cons rator rands)))
+ (do-call rator&rands
+ (lmap (lambda (x)
+ x ; ignored
+ false)
+ rator&rands)
+ (lambda (new-names rator*&rands*)
+ new-names ; ignored
+ `(CALL ,(car rator*&rands*)
+ ,(cpsconv/invocation/continuation cont)
+ ,@(cdr rator*&rands*)))))))
+ (simple
+ (lambda (expr*)
+ (cond ((not (simple-operator? (cadr rator)))
+ (cpsconv/hook-return (cadr rator) cont expr*))
+ ((operator/satisfies? (cadr rator) '(UNSPECIFIC-RESULT))
+ `(BEGIN
+ ,expr*
+ ,(cpsconv/return cont `(QUOTE ,%unspecific))))
+ (else
+ (cpsconv/return cont expr*))))))
+ (cond ((LAMBDA/? rator)
+ (if (there-exists? rands
+ (lambda (rand)
+ (or (LOOKUP/? rand)
+ (QUOTE/? rand))))
+ (internal-error "Silly arguments in lambda-combination" rands))
+ (let ((names (lambda/formals rator)))
+ (do-call rands (cdr names)
+ (lambda (names* rands*)
+ `(CALL (LAMBDA ,(cons (cpsconv/new-ignored-continuation)
+ names*)
+ ,(cpsconv/expr cont (caddr rator)))
+ (QUOTE #F)
+ ,@rands*)))))
+ ((not (QUOTE/? rator))
+ (default))
+ ((and (simple-operator? (quote/text rator))
+ (for-all? rands form/simple&side-effect-free?))
+ (simple (cpsconv/simple/copy `(CALL ,rator (QUOTE #F) ,@rands))))
+ ((or (simple-operator? (quote/text rator))
+ (hook-operator? (quote/text rator)))
+ (do-call rands
+ (lmap (lambda (x)
+ x ; ignored
+ false)
+ rands)
+ (lambda (new-names rands*)
+ new-names ; ignored
+ (simple `(CALL ,rator (QUOTE ,#f) ,@rands*)))))
+ (else
+ (default)))))
+\f
+(define (cpsconv/call** classified-operands call-gen form)
+ (define (walk-simple simple)
+ (if (null? simple)
+ (call-gen
+ (lmap (lambda (classified)
+ (vector-fourth classified))
+ classified-operands)
+ (lmap (lambda (classified)
+ (let ((name (vector-second classified)))
+ (if name
+ `(LOOKUP ,name)
+ (cpsconv/simple/copy (vector-first classified)))))
+ classified-operands))
+ `(LET ((,(vector-second (car simple))
+ ,(cpsconv/simple/copy (vector-first (car simple)))))
+ ,(walk-simple (cdr simple)))))
+
+ (define (walk-hard hard)
+ (if (null? hard)
+ (walk-simple (cpsconv/sort/simple
+ (list-transform-positive classified-operands
+ (lambda (operand)
+ (and (vector-second operand)
+ (vector-third operand))))))
+ (let* ((next-name (cpsconv/new-name 'RECEIVER))
+ (ignore (cpsconv/new-ignored-continuation)))
+ `(LET ((,next-name
+ (LAMBDA (,ignore ,(vector-second (car hard)))
+ ,(walk-hard (cdr hard)))))
+ ,(let ((next (vector-first (car hard))))
+ (cpsconv/expr
+ (cpsconv/value-continuation
+ next-name
+ (cpsconv/dbg-continuation/make 'RATOR-OR-RAND form next))
+ next))))))
+
+ (walk-hard (cpsconv/sort/hard
+ (list-transform-negative classified-operands
+ (lambda (operand)
+ (vector-third operand))))))
+
+(define (cpsconv/classify-operand operand name)
+ ;; operand -> #(operand early-name easy? late-name)
+ ;; easy? if does not need a return address
+ (let ((early-name
+ (and (not (cpsconv/trivial? operand))
+ (or name
+ (cpsconv/new-name 'RAND)))))
+ (vector operand early-name
+ (if (eq? *order-of-argument-evaluation* 'ANY)
+ (form/simple&side-effect-free? operand)
+ (form/simple&side-effect-insensitive? operand))
+ (and name
+ (if early-name
+ (cpsconv/new-name 'DUMMY)
+ name)))))
+
+(define (cpsconv/trivial? operand)
+ (or (LOOKUP/? operand)
+ (QUOTE/? operand)
+ (LAMBDA/? operand)))
+
+(define (cpsconv/classify-let-binding binding)
+ (let ((name (car binding))
+ (operand (cadr binding)))
+ (let ((early-name
+ (and (not (cpsconv/trivial? operand))
+ name)))
+ (vector operand early-name true
+ (if early-name
+ (cpsconv/new-name 'DUMMY)
+ name)))))
+\f
+(define (cpsconv/sort/hard operands)
+ (case *order-of-argument-evaluation*
+ ((LEFT-TO-RIGHT) operands)
+ ((RIGHT-TO-LEFT) (reverse operands))
+ (else
+ ;; *** For now ***
+ operands)))
+
+(define (cpsconv/sort/simple operands)
+ ;; Either order is ANY, or they are insensitive
+ ;; *** For now ***
+ operands)
+
+(define (cpsconv/simple/copy form)
+ (let walk ((form form))
+ (cpsconv/remember
+ (case (car form)
+ ((LOOKUP)
+ `(LOOKUP ,(cadr form)))
+ ((QUOTE)
+ `(QUOTE ,(cadr form)))
+ ((LAMBDA)
+ (cpsconv/lambda* (cadr form) (caddr form)))
+ ((IF)
+ `(IF ,(walk (cadr form))
+ ,(walk (caddr form))
+ ,(walk (cadddr form))))
+ ((CALL)
+ (if (not (equal? (call/continuation form) '(QUOTE #F)))
+ (internal-error "Already cps-converted?" form))
+ `(CALL ,(walk (call/operator form))
+ ,@(lmap walk (call/cont-and-operands form))))
+ (else
+ (internal-error "Non simple expression" form)))
+ form)))
+\f
+(define-cps-converter QUOTE (cont object)
+ (cpsconv/return cont `(QUOTE ,object)))
+
+(define-cps-converter DECLARE (cont #!rest anything)
+ (cpsconv/return cont `(DECLARE ,@anything)))
+
+#|
+(define-cps-converter BEGIN (cont #!rest actions)
+ (if (null? actions)
+ (internal-error "Empty begin")
+ (let walk ((next (car actions))
+ (actions (cdr actions)))
+ (if (null? actions)
+ (cpsconv/expr cont next)
+ (let ((next-name (cpsconv/new-name 'NEXT))
+ (ignore (cpsconv/new-ignored-continuation)))
+ `(LET ((,next-name
+ (LAMBDA (,ignore)
+ ,(walk (car actions)
+ (cdr actions)))))
+ ,(cpsconv/expr
+ (cpsconv/begin-continuation
+ next-name
+ (cspconv/dbg-continuation/make 'BEGIN
+ <>
+ next))
+ next)))))))
+
+(define-cps-converter IF (cont pred conseq alt)
+ ;; This does anchor pointing by default?
+ (let ((consname (cpsconv/new-name 'CONS))
+ (altname (cpsconv/new-name 'ALT))
+ (ignore (cpsconv/new-ignored-continuation)))
+ `(LET ((,consname (LAMBDA (,ignore) ,(cpsconv/expr cont conseq)))
+ (,altname (LAMBDA (,ignore) ,(cpsconv/expr cont alt))))
+ ,(cpsconv/expr
+ (cpsconv/predicate-continuation
+ consname altname
+ (cpsconv/dbg-continuation/make 'PREDICATE <> pred))
+ pred))))
+|#
+\f
+(define (cpsconv/begin cont form)
+ (cpsconv/remember
+ (let ((actions (cdr form)))
+ (if (null? actions)
+ (internal-error "Empty begin")
+ (let walk ((next (car actions))
+ (actions (cdr actions)))
+ (if (null? actions)
+ (cpsconv/expr cont next)
+ (let ((next-name (cpsconv/new-name 'NEXT))
+ (ignore (cpsconv/new-ignored-continuation)))
+ `(LET ((,next-name
+ (LAMBDA (,ignore)
+ ,(walk (car actions)
+ (cdr actions)))))
+ ,(cpsconv/expr
+ (cpsconv/begin-continuation
+ next-name
+ (cpsconv/dbg-continuation/make 'BEGIN form next))
+ next)))))))
+ form))
+
+(define (cpsconv/if cont form)
+ (cpsconv/remember
+ (let ((pred (if/predicate form))
+ (conseq (if/consequent form))
+ (alt (if/alternate form)))
+ (let ((consname (cpsconv/new-name 'CONS))
+ (altname (cpsconv/new-name 'ALT))
+ (ignore1 (cpsconv/new-ignored-continuation))
+ (ignore2 (cpsconv/new-ignored-continuation)))
+ `(LET ((,consname (LAMBDA (,ignore1) ,(cpsconv/expr cont conseq)))
+ (,altname (LAMBDA (,ignore2) ,(cpsconv/expr cont alt))))
+ ,(cpsconv/expr (cpsconv/predicate-continuation
+ consname altname
+ (cpsconv/dbg-continuation/make 'PREDICATE form pred))
+ pred))))
+ form))
+\f
+(define (cpsconv/expr cont expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (cpsconv/quote cont expr))
+ ((LOOKUP)
+ (cpsconv/lookup cont expr))
+ ((LAMBDA)
+ (cpsconv/lambda cont expr))
+ ((LET)
+ (cpsconv/let cont expr))
+ ((DECLARE)
+ (cpsconv/declare cont expr))
+ ((CALL)
+ (cpsconv/call cont expr))
+ ((BEGIN)
+ (cpsconv/begin cont expr))
+ ((IF)
+ (cpsconv/if cont expr))
+ ((LETREC)
+ (cpsconv/letrec cont expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (cpsconv/expr* cont exprs)
+ (lmap (lambda (expr)
+ (cpsconv/expr cont expr))
+ exprs))
+
+(define (cpsconv/remember new old)
+ (code-rewrite/remember new old))
+
+(define (cpsconv/remember* new old)
+ (code-rewrite/remember* new old))
+
+(define (cpsconv/new-name prefix)
+ (new-variable prefix))
+
+(define (cpsconv/new-ignored-continuation)
+ (new-ignored-continuation-variable))
+
+(define-structure (cpsconv/cont
+ (conc-name cpsconv/cont/)
+ (constructor cpsconv/cont/make))
+ (kind false read-only true)
+ (field1 false read-only true)
+ (field2 false read-only true)
+ (dbg-cont false read-only true))
+
+(define (cpsconv/named-continuation name)
+ (cpsconv/cont/make 'NAMED name false false))
+
+(define (cpsconv/predicate-continuation conseq alt dbg-cont)
+ (cpsconv/cont/make 'PREDICATE conseq alt dbg-cont))
+
+(define (cpsconv/begin-continuation next dbg-cont)
+ (cpsconv/cont/make 'BEGIN next false dbg-cont))
+
+(define (cpsconv/value-continuation receiver dbg-cont)
+ (cpsconv/cont/make 'VALUE receiver false dbg-cont))
+
+(define (cpsconv/dbg-continuation/make kind outer inner)
+ (new-dbg-continuation/make kind
+ (code-rewrite/original-form/previous outer)
+ (code-rewrite/original-form/previous inner)))
+\f
+(define (cpsconv/return cont expression)
+ (define (default name)
+ `(CALL (LOOKUP ,name)
+ (QUOTE #F)
+ ,expression))
+ (if (and (not (eq? (cpsconv/cont/kind cont) 'BEGIN))
+ (DECLARE/? expression))
+ (internal-error "DECLARE expression in value position"))
+ (case (cpsconv/cont/kind cont)
+ ((VALUE)
+ (default (cpsconv/cont/field1 cont)))
+ ((NAMED)
+ `(CALL (QUOTE ,%invoke-continuation)
+ (LOOKUP ,(cpsconv/cont/field1 cont))
+ ,expression))
+ ((PREDICATE)
+ (let* ((pred-default
+ (lambda (name)
+ `(CALL (LOOKUP ,name)
+ (QUOTE #F))))
+ (full-pred
+ (lambda ()
+ `(IF ,expression
+ ,(pred-default (cpsconv/cont/field1 cont))
+ ,(pred-default (cpsconv/cont/field2 cont))))))
+ (cond ((QUOTE/? expression)
+ (case (boolean/discriminate (cadr expression))
+ ((FALSE)
+ (pred-default (cpsconv/cont/field2 cont)))
+ ((TRUE)
+ (pred-default (cpsconv/cont/field1 cont)))
+ (else
+ (full-pred))))
+ ((LAMBDA/? expression)
+ (pred-default (cpsconv/cont/field1 cont)))
+ (else
+ (full-pred)))))
+ ((BEGIN)
+ (let ((return
+ `(CALL (LOOKUP ,(cpsconv/cont/field1 cont))
+ (QUOTE #F))))
+ (if (form/simple&side-effect-free? expression)
+ return
+ `(LET ((,(cpsconv/new-name 'IGNORE) ,expression))
+ ,return))))
+ (else
+ (internal-error "Unknown continuation kind" cont))))
+\f
+(define (cpsconv/invocation/continuation cont)
+ ;; This eta converts non-named continuations
+ ;; to make the continuations be stack closed,
+ ;; not the receivers, which may be shared.
+ (case (cpsconv/cont/kind cont)
+ ((NAMED)
+ `(LOOKUP ,(cpsconv/cont/field1 cont)))
+ ((VALUE)
+ (let ((value (cpsconv/new-name 'VALUE)))
+ (cpsconv/remember*
+ `(LAMBDA (,(cpsconv/new-ignored-continuation) ,value)
+ (CALL (LOOKUP ,(cpsconv/cont/field1 cont))
+ (QUOTE #F)
+ (LOOKUP ,value)))
+ (cpsconv/cont/dbg-cont cont))))
+ ((PREDICATE)
+ (let ((value (cpsconv/new-name 'VALUE)))
+ (cpsconv/remember*
+ `(LAMBDA (,(cpsconv/new-ignored-continuation) ,value)
+ (IF (LOOKUP ,value)
+ (CALL (LOOKUP ,(cpsconv/cont/field1 cont))
+ (QUOTE #F))
+ (CALL (LOOKUP ,(cpsconv/cont/field2 cont))
+ (QUOTE #F))))
+ (cpsconv/cont/dbg-cont cont))))
+ ((BEGIN)
+ (cpsconv/remember*
+ `(LAMBDA (,(cpsconv/new-ignored-continuation) ,(cpsconv/new-name 'IGNORE))
+ (CALL (LOOKUP ,(cpsconv/cont/field1 cont))
+ (QUOTE #F)))
+ (cpsconv/cont/dbg-cont cont)))
+ (else
+ (internal-error "Unknown continuation kind" cont))))
+
+(define (cpsconv/hook-return rator cont expr*)
+ (define (default)
+ (let ((name (cpsconv/new-name 'VALUE)))
+ `(LET ((,name ,expr*))
+ ,(cpsconv/return cont `(LOOKUP ,name)))))
+ (if (not (operator/satisfies? rator '(OUT-OF-LINE-HOOK)))
+ (default)
+ (case (cpsconv/cont/kind cont)
+ ((PREDICATE)
+ (if (not (operator/satisfies? rator '(OPEN-CODED-PREDICATE)))
+ (default)
+ `(IF ,expr*
+ (CALL (LOOKUP ,(cpsconv/cont/field1 cont))
+ (QUOTE #F))
+ (CALL (LOOKUP ,(cpsconv/cont/field2 cont))
+ (QUOTE #F)))))
+ ((NAMED)
+ `(CALL ,(cadr expr*)
+ (LOOKUP ,(cpsconv/cont/field1 cont))
+ ,@(cdddr expr*)))
+ (else
+ (default)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: dataflow.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; ??
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define *dataflow-report-applied-non-procedures?* #T)
+(define *node-count*)
+
+(define (dataflow/top-level program)
+ (let* ((env (dataflow/make-env))
+ (graph (make-graph program))
+ (result-node (dataflow/expr env graph program)))
+ (fluid-let ((*node-count* (graph/node-count graph)))
+ (if result-node
+ (initial-link-nodes! result-node (graph/escape-node graph)))
+ (dataflow/make-globals-escape! env graph)
+ (if (> (graph/node-count graph) 5000)
+ (pp `(big graph: ,(graph/node-count graph) nodes)))
+ ((if (graph/interesting? graph)
+ show-time
+ (lambda (thunk) (thunk)))
+ (lambda ()
+ (graph/initialize-links! graph)
+ (graph/dataflow! graph)))
+ (graph/substitite-simple-constants graph graph/read-eqv?-preserving-constant?)
+ (if (graph/interesting? graph)
+ (graph/display-statistics! graph))
+ graph)))
+
+(define (graph/interesting? g)
+ #F
+ ;(> (graph/node-count g) 10000)
+)
+
+
+(define-macro (define-dataflow-handler keyword bindings . body)
+ (let ((proc-name (symbol-append 'DATAFLOW/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdddr bindings) '(handler env graph form) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons* (car bindings) (cadr bindings) 'form names)
+ ,@body)))
+ (named-lambda (,proc-name env graph form)
+ (let ((result ,code))
+ (graph/associate! graph form result)
+ result))))))))
+
+;; handler: env x graph! x fields -> node
+
+
+(define-dataflow-handler LOOKUP (env graph form name)
+ (let* ((reference-node (dataflow/name->node env graph name))
+ (result-node (graph/add-expression-node! graph form name)))
+ (if (not reference-node)
+ (internal-error "LOOKUP: Cant find:" name))
+ (initial-link-nodes! reference-node result-node)
+ result-node))
+
+
+(define-dataflow-handler SET! (env graph form name expr)
+ ;; This version models the MIT scheme SET! form which returns the
+ ;; previous value of the binding.
+ (let ((expr-node (dataflow/expr env graph expr))
+ (name-node (dataflow/name->node env graph name))
+ (result-node (graph/add-expression-node! graph form "#[set!-result]")))
+ (initial-link-nodes! expr-node name-node)
+ (initial-link-nodes! name-node result-node)
+ result-node))
+
+
+(define-dataflow-handler DEFINE (env graph form name expr)
+ ;; DEFINE is like SET!, except that the value is unspecified previous
+ ;; value of the binding. The node for the name is in the
+ ;; environment because it is put there by scanning for defines in
+ ;; BEGIN.
+ form ; ignore
+ (let ((expr-node (dataflow/expr env graph expr))
+ (name-node (dataflow/name->node env graph name)))
+ (initial-link-nodes! expr-node name-node)
+ #F))
+
+(define (dataflow/name->node env graph name)
+ ;; Lookup name, possibly creating a global node for the name if it is
+ ;; global and we do not yet know about the name. In this case we
+ ;; ensure that the value escapes (some other program may copy the
+ ;; variable) and the values comming from that variable are unknown
+ ;; (some other program may set the variable).
+ (let* ((binding (dataflow/env/lookup env name))
+ (ref-node (or
+ (and binding (dataflow/binding/value binding))
+ (let ((value (graph/add-location-node! graph
+ 'global-variable
+ name)))
+ (dataflow/env/define-global! env name value)
+ value))))
+ ref-node))
+
+
+;; A distinction is made between before and after CPS conversion. After
+;; CPS conversion procedures do not `return' results, so we need not
+;; create nodes for the procedure results. It is important not to
+;; create these nodes for performance reasons because they all form a
+;; huge equivalence class.
+
+(define-dataflow-handler LAMBDA (env graph form lambda-list body)
+ (let* ((input-names (lambda-list->names lambda-list))
+ (input-nodes (map (lambda (name) (graph/add-location-node! graph form name))
+ input-names))
+ (body-node (dataflow/expr (dataflow/env/push-frame env
+ input-names
+ input-nodes)
+ graph body))
+ (result-node (and body-node
+ (graph/add-expression-node!
+ graph form "#[procedure-result]")))
+ (procedure-node (graph/add-location-node! graph form
+ "#[procedure-value]"))
+ (value (graph/add-procedure!
+ graph form input-nodes result-node)))
+ (if (eq? body-node #F)
+ (if *after-cps-conversion?*
+ 'ok
+ (error "CPS procedure returns result " form))
+ (if *after-cps-conversion?*
+ (error "Pre-CPS procedure returns not result " form)
+ (initial-link-nodes! body-node result-node)))
+ (add! procedure-node value node/initial-values set-node/initial-values!)
+ procedure-node))
+
+
+\f
+(define-dataflow-handler LET (env graph form bindings body)
+ (dataflow/let-like-handler "#[let-result]" #F
+ env graph form bindings body))
+
+(define-dataflow-handler LETREC (env graph form bindings body)
+ (dataflow/let-like-handler "#[letrec-result]" #T
+ env graph form bindings body))
+
+(define (dataflow/let-like-handler result-name recursive?
+ env graph form bindings body)
+ (let* ((binding-names (map (lambda (x) (car x)) bindings))
+ (binding-exprs (map (lambda (x) (second x)) bindings))
+ (binding-nodes (map (lambda (name) (graph/add-location-node! graph form name))
+ binding-names))
+ (inner-env (dataflow/env/push-frame env binding-names binding-nodes))
+ (expr-nodes (dataflow/expr* (if recursive? inner-env env)
+ graph binding-exprs))
+ (body-node (dataflow/expr inner-env graph body))
+ (result-node (and body-node
+ (graph/add-expression-node! graph form result-name))))
+
+ (map initial-link-nodes! expr-nodes binding-nodes)
+ (if result-node
+ (initial-link-nodes! body-node result-node))
+ result-node))
+
+
+(define-dataflow-handler QUOTE (env graph form object)
+ env object ; ignore
+ (graph/add-constant-node! graph form))
+
+
+(define-dataflow-handler DECLARE (env graph form #!rest anything)
+ env graph ; ignored
+ form anything
+ 'declaration-does-not-have-a-node)
+
+
+(define-dataflow-handler BEGIN (env graph form #!rest actions)
+ ;; Only top-level BEGINs contain DEFINEs but this code show work for
+ ;; internal defines too, had they not been converted to #!AUXes and
+ ;; then (a little later) LET[REC]s
+ (dataflow/scan-defines! actions env graph)
+ (let* ((nodes (dataflow/expr* env graph actions))
+ (last-node (car (last-pair nodes)))
+ (result-node (and last-node
+ (graph/add-expression-node! graph form
+ "#[begin-result]"))))
+ (if (node? result-node)
+ (initial-link-nodes! last-node result-node))
+ result-node))
+
+
+(define (dataflow/scan-defines! forms env graph)
+ (define names '())
+ (define defines '())
+ (define (scan forms)
+ (cond ((null? forms)
+ unspecific)
+ ((not (and (pair? forms) (pair? (car forms))))
+ (user-error "scan-defines - not legal KMP scheme: " forms))
+ ((eq? (caar forms) 'BEGIN)
+ (dataflow/scan-defines! (cdr (car forms)) env graph)
+ (scan (cdr forms)))
+ ((eq? (caar forms) 'DEFINE)
+ (set! names (cons (second (car forms)) names))
+ (set! defines (cons (car forms) defines))
+ (scan (cdr forms)))
+ (else
+ (scan (cdr forms)))))
+ (scan forms)
+ (dataflow/env/extend-frame!
+ env
+ names
+ (map (lambda (name defn) (graph/add-location-node! graph defn name))
+ names defines)))
+
+
+(define-dataflow-handler IF (env graph form pred conseq alt)
+ (let ((predicate-node (dataflow/expr env graph pred))
+ (consequent-node (dataflow/expr env graph conseq))
+ (alternative-node (dataflow/expr env graph alt)))
+ (let ((result-node (and consequent-node
+ alternative-node
+ (graph/add-expression-node! graph form
+ "#[if-result]"))))
+ predicate-node ; unused
+ (cond ((node? result-node)
+ (initial-link-nodes! consequent-node result-node)
+ (initial-link-nodes! alternative-node result-node))
+ ((or (node? consequent-node)
+ (node? alternative-node))
+ (internal-error "Mismatch between CPS states of branches"
+ consequent-node alternative-node form)))
+ result-node)))
+
+
+(define-dataflow-handler OR (env graph form pred alt)
+ (let ((predicate-node (dataflow/expr env graph pred))
+ (alternative-node (dataflow/expr env graph alt))
+ (result-node (graph/add-expression-node! graph form
+ "#[or-result]")))
+ ;; No worry about CPS style as OR is removed before CPS conversion
+ (initial-link-nodes! predicate-node result-node)
+ (initial-link-nodes! alternative-node result-node)
+ result-node))
+
+
+(define-dataflow-handler ACCESS (env graph form name env-expr)
+ (let* ((env-node (dataflow/expr env graph env-expr))
+ (result-node (graph/add-expression-node! graph form
+ "#[access-result]")))
+ ;; IF env is system-global-environment and the name is standard (like
+ ;; cons, car, apply, append etc) we should do something better.
+ env-node name
+ (initial-link-nodes! (graph/unknown-input-node graph) result-node)
+ result-node))
+
+
+(define-dataflow-handler CALL (env graph form rator cont #!rest rands)
+ (let* ((special-result
+ (dataflow/handler/special-call env graph form rator cont rands))
+ (result
+ (if (eq? special-result 'ORDINARY)
+ (dataflow/handler/ordinary-call env graph form rator cont rands)
+ special-result)))
+ (if (or (and (node? result) (not (equal? cont '(QUOTE #F))))
+ (and (not (node? result)) (equal? cont '(QUOTE #F))))
+ (internal-error "result/CPS mismatch" result form))
+ result))
+
+(define (dataflow/handler/ordinary-call env graph form rator cont rands)
+ (let* ((operator-node (dataflow/expr env graph rator))
+ (operand-nodes (dataflow/expr* env graph rands))
+ (direct-style? (equal? cont '(QUOTE #F)))
+ (cont-node (if direct-style? #F (dataflow/expr env graph cont)))
+ (result-node (if direct-style?
+ (graph/add-expression-node! graph form
+ "#[call-result]")
+ (graph/add-location-node! graph form
+ "#[call-result]"))))
+ (graph/add-application! graph form
+ operator-node
+ (cons cont-node operand-nodes)
+ result-node)
+ (and direct-style? result-node)))
+
+
+(define (dataflow/handler/special-call env graph form rator cont rands)
+ (if (QUOTE/? rator)
+ (let ((operator (quote/text rator)))
+ (define (use method) (method env graph form rator cont rands))
+ (cond ((eq? operator %make-heap-closure)
+ (use dataflow/handler/%make-heap-closure))
+ ((eq? operator %make-stack-closure)
+ (use dataflow/handler/%make-stack-closure))
+ ((eq? operator %make-trivial-closure)
+ (use dataflow/handler/%make-trivial-closure))
+ ((eq? operator %heap-closure-ref)
+ (use dataflow/handler/%heap-closure-ref))
+ ((eq? operator %stack-closure-ref)
+ (use dataflow/handler/%stack-closure-ref))
+ ((eq? operator %internal-apply)
+ (use dataflow/handler/%internal-apply))
+ ((eq? operator %fetch-stack-closure)
+ (use dataflow/handler/%fetch-stack-closure))
+ ((eq? operator %fetch-continuation)
+ (use dataflow/handler/%fetch-continuation))
+ ((eq? operator %invoke-continuation)
+ (use dataflow/handler/%invoke-continuation))
+ ;;((eq? operator %invoke-operator-cache)
+ ;; (use dataflow/handler/%invoke-operator-cache))
+ (else
+ 'ORDINARY)))
+ 'ORDINARY))
+
+
+(define (dataflow/handler/%make-heap-closure env graph form rator cont rands)
+ ;; (CALL ',%make-heap-closure '#F <lambda-expression> '#(name*) <value>*)
+ ;; -------rator-------- cont ---------------rands---------------
+ ;;
+ rator cont ; ignore
+ (let* ((lambda-expr (first rands))
+ (value-exprs (cddr rands))
+ (closure-name (second (second lambda-expr))) ; (LAMBDA (k <this> ...))
+ (names-vector (second (second rands)))
+
+ (lambda-node (dataflow/expr env graph lambda-expr))
+ (expr-nodes (dataflow/expr* env graph value-exprs))
+ (closed-names (map (lambda (name) (cons closure-name name))
+ (vector->list names-vector)))
+ (closed-nodes (map (lambda (name) (graph/add-location-node!
+ graph form name))
+ closed-names))
+ (procedure (node/the-procedure-value lambda-node))
+ (closure-node (graph/add-expression-node! graph form
+ "#[heap-closure-value]"))
+ (value (graph/add-closure! graph
+ form
+ 'HEAP
+ procedure
+ names-vector
+ (list->vector closed-nodes)
+ closure-node)))
+
+ (map initial-link-nodes! expr-nodes closed-nodes)
+ (add! closure-node value node/initial-values set-node/initial-values!)
+ (graph/add-special-application! graph form
+ %make-heap-closure
+ expr-nodes
+ '() ; no triggers
+ closure-node)
+ closure-node))
+
+
+\f
+(define dataflow/?closure-elts (->pattern-variable 'CLOSURE-ELTS))
+(define dataflow/?closure-vector (->pattern-variable 'CLOSURE-VECTOR))
+(define dataflow/?cont (->pattern-variable 'CONT))
+(define dataflow/?expr1 (->pattern-variable 'EXPR1))
+(define dataflow/?expr2 (->pattern-variable 'EXPR2))
+(define dataflow/?args (->pattern-variable 'ARGS))
+(define dataflow/?frame-var (->pattern-variable 'FRAME-VAR))
+(define dataflow/?nrands (->pattern-variable 'NRANDS))
+(define dataflow/?rands (->pattern-variable 'RANDS))
+(define dataflow/?lam-expr (->pattern-variable 'LAM-EXPR))
+
+(define dataflow/stack-closure-pattern
+ `(CALL (QUOTE ,%make-stack-closure)
+ (QUOTE #F)
+ (LAMBDA (,dataflow/?cont ,@dataflow/?args)
+ (LET ((,dataflow/?frame-var ,dataflow/?expr1))
+ ,dataflow/?expr2))
+ (QUOTE ,dataflow/?closure-vector)
+ . ,dataflow/?closure-elts))
+
+(define dataflow/implicit-stack-frame
+ (generate-uninterned-symbol "*STACK-FRAME*"))
+
+(define (dataflow/handler/%make-stack-closure env graph form rator cont rands)
+ ;; (CALL ',%make-stack-closure '#F <lambda-expression> '#(name*) <value>*)
+ ;; -------rator-------- cont ---------------rands---------------
+ ;; push a frame on the environment for the closed-over variables. The
+ ;; variables are named as pairs (closure . variable)
+ rator cont ; ignore
+ (let* ((lambda-expr (first rands))
+ (parts (form/match dataflow/stack-closure-pattern form))
+ (closure-name (cadr (assq dataflow/?frame-var parts)))
+ (names-vector (cadr (assq dataflow/?closure-vector parts)))
+ (value-exprs (cadr (assq dataflow/?closure-elts parts)))
+ (closed-names (map (lambda (name) (cons closure-name name))
+ (vector->list names-vector)))
+ (closed-nodes (map (lambda (name) (graph/add-location-node!
+ graph form name))
+ closed-names))
+ (closure-node (graph/add-expression-node! graph form
+ "#[stack-closure-value]"))
+ (inner-env (dataflow/env/push-frame env
+ (list dataflow/implicit-stack-frame)
+ (list closure-node)))
+ (lambda-node (dataflow/expr inner-env graph lambda-expr))
+ (procedure (node/the-procedure-value lambda-node))
+ (expr-nodes (dataflow/expr* env graph value-exprs))
+ (value (graph/add-closure! graph
+ form
+ 'STACK
+ procedure
+ names-vector
+ (list->vector closed-nodes)
+ closure-node)))
+
+ (map initial-link-nodes! expr-nodes closed-nodes)
+ (add! closure-node value node/initial-values set-node/initial-values!)
+ (graph/add-special-application! graph form
+ %make-stack-closure
+ expr-nodes
+ '() ; no triggers
+ closure-node)
+ closure-node))
+
+(define (dataflow/handler/%fetch-stack-closure env graph form rator cont rands)
+ ;; (CALL ',%fetch-stack-closure '#F '<names-vector>)
+ ;; --------rator--------- cont ----rands-----
+ ;;
+ rator cont rands ; ignore
+ (let* ((closure-node
+ (dataflow/name->node env graph dataflow/implicit-stack-frame))
+ (result-node
+ (graph/add-expression-node! graph form
+ "#[fetch-stack-closure-result]")))
+ (initial-link-nodes! closure-node result-node)
+ result-node))
+
+
+(define (dataflow/handler/%make-trivial-closure env graph form rator cont rands)
+ ;; (CALL ',%make-trivial-closure '#F <lambda-expression or LOOKUP>)
+ ;; --------rator---------- cont -----------rands------------
+ ;; Initially we add the closure with a NODE for the procedure part.
+ ;; After initial value propagation replace this with the procedure value.
+ rator cont ; ignore
+ (define (finish lambda-node)
+ (let* ((closure-node (graph/add-expression-node! graph form
+ "#[trivial-closure]"))
+ (value (graph/add-closure! graph
+ form
+ 'TRIVIAL
+ lambda-node ;procedure
+ #()
+ #()
+ closure-node)))
+ (add! closure-node value node/initial-values set-node/initial-values!)
+ closure-node))
+
+ (let* ((procedure-expr (first rands)))
+ (cond ((LOOKUP/? procedure-expr)
+ ;; This occurs in a really wierd screw-case, documented elsewhere.
+ ;; The <name> in (LOOKUP <name>) is bound to the lambda, so we
+ ;; can find the lambda node by searching the initial links
+ ;; backwards
+ (finish
+ (dataflow/name->node env graph (lookup/name procedure-expr))))
+ ((LAMBDA/? procedure-expr)
+ (finish (dataflow/expr env graph procedure-expr)))
+ (else
+ (internal-error "Procedure is neither LAMBDA nor LOOKUP" form)))))
+
+
+(define (graph/initialize-closure-procedures! graph)
+ (define (fix-closure-procedure closure)
+ (if (eq? 'TRIVIAL (value/closure/kind closure))
+ (let ((proc-node (value/closure/procedure closure)))
+ (set-value/closure/procedure! closure
+ (node/the-procedure-value proc-node)))))
+ (for-each-item fix-closure-procedure (graph/closures graph)))
+
+
+(define (dataflow/handler/%heap-closure-ref env graph form rator cont rands)
+ ;; (CALL ',%heap-closure-ref '#F <closure> <offset> 'NAME)
+ ;; -------rator------- cont ---------------rands---------------
+ ;; <closure> is always (LOOKUP closure-name)
+ rator cont ; ignore
+ (let* ((closure-node (dataflow/expr env graph (first rands)))
+ (result-node (graph/add-expression-node! graph form
+ (second (third rands)))))
+
+ (graph/add-special-application! graph form
+ %heap-closure-ref
+ (list closure-node)
+ (list closure-node)
+ result-node)
+ result-node))
+
+
+(define (dataflow/handler/%stack-closure-ref env graph form rator cont rands)
+ ;; (CALL ',%stack-closure-ref '#F <closure> <offset> 'NAME)
+ ;; -------rator------- cont ---------------rands---------------
+ ;; <closure> is always (LOOKUP closure-name)
+ rator cont ; ignore
+ (let* ((closure-node (dataflow/expr env graph (first rands)))
+ (result-node (graph/add-expression-node! graph form
+ (second (third rands)))))
+
+ (graph/add-special-application! graph form
+ %stack-closure-ref
+ (list closure-node)
+ (list closure-node)
+ result-node)
+ result-node))
+
+
+(define (dataflow/handler/%internal-apply env graph form rator cont rands)
+ ;; (CALL ',%internal-apply <continuation> 'NARGS <procedure> <value>*)
+ ;; ------rator------ -----cont----- ----------rands------------
+ ;;
+ ;; Treated like a normal call
+ rator ; ignore
+ (let* ((operator-node (dataflow/expr env graph (second rands)))
+ (operand-nodes (dataflow/expr* env graph (cddr rands)))
+ (direct-style? (equal? cont '(QUOTE #F)))
+ (cont-node (if direct-style? #F (dataflow/expr env graph cont)))
+ (result-node (if direct-style?
+ (graph/add-expression-node!
+ graph form "#[internal-apply-result]")
+ (graph/add-location-node!
+ graph form "#[internal-apply-result]"))))
+
+ (graph/add-application! graph form operator-node (cons cont-node operand-nodes) result-node)
+ (and direct-style? result-node)))
+
+(define (dataflow/handler/%fetch-continuation env graph form rator cont rands)
+ ;; (CALL ',%fetch-continuation '#F)
+ ;; --------rator-------- cont --no rands--
+ ;;
+ env rator cont rands ; ignore
+ (let* ((result-node
+ (graph/add-expression-node! graph form
+ "#[fetch-continuation-result]"))
+ (value (value/make-unknown 'top-level-continuation)))
+ (add! result-node value node/initial-values set-node/initial-values!)
+ result-node))
+
+(define (dataflow/handler/%invoke-continuation env graph form rator cont rands)
+ ;; (CALL ',%invoke-continuation <continuation> <value>*)
+ ;; --------rator-------- -----cont----- --rands--
+ ;; The continuation could be anything and invoking it is like an
+ ;; application, but it will ignore its own continuation parameter
+
+ rator ; ignore
+ (let* ((operator-node (dataflow/expr env graph cont))
+ (operand-nodes (dataflow/expr* env graph rands))
+ (bogus-continuation #F) ;(graph/add-constant-node! graph `(QUOTE #F))
+ (result-node #F))
+
+ (graph/add-application! graph form operator-node
+ (cons bogus-continuation operand-nodes)
+ result-node)
+ result-node))
+
+
+;;(define (dataflow/handler/%invoke-operator-cache env graph form rator cont rands)
+;; ;; (CALL ',%invoke-operator-cache <continuation>
+;; ;; '(NAME NARGS) <operator-cache> <value>*)
+;; ;; ---------------rands--------------------
+;; rator
+;; (let* ((cont-node (dataflow/expr env graph cont))
+;; (expr-nodes (dataflow/expr* env graph (cddr rands)))
+;; (result-node (graph/add-node! graph form
+;; "#[invoke-operator-cache-result]"))
+;; (escape-node (graph/escape-node graph)))
+;; (for-each (lambda (node)
+;; (initial-link-nodes! node escape-node))
+;; expr-nodes)
+;; (initial-link-nodes! cont-node escape-node)
+;; (initial-link-nodes! (graph/unknown-input-node graph) result-node)
+;; result-node))
+
+
+\f
+(define (dataflow/expr env graph expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (dataflow/quote env graph expr))
+ ((LOOKUP)
+ (dataflow/lookup env graph expr))
+ ((LAMBDA)
+ (dataflow/lambda env graph expr))
+ ((LET)
+ (dataflow/let env graph expr))
+ ((DECLARE)
+ (dataflow/declare env graph expr))
+ ((CALL)
+ (dataflow/call env graph expr))
+ ((BEGIN)
+ (dataflow/begin env graph expr))
+ ((IF)
+ (dataflow/if env graph expr))
+ ((LETREC)
+ (dataflow/letrec env graph expr))
+ ((OR)
+ (dataflow/or env graph expr))
+ ((SET!)
+ (dataflow/set! env graph expr))
+ ((DEFINE)
+ (dataflow/define env graph expr))
+ ((ACCESS)
+ (dataflow/access env graph expr))
+ ((UNASSIGNED? DELAY
+ IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (dataflow/expr* env graph exprs)
+ (lmap (lambda (expr)
+ (dataflow/expr env graph expr))
+ exprs))
+
+(define (dataflow/remember new old)
+ old ; ignored for now
+ new)
+
+(define (dataflow/new-name prefix)
+ (new-variable prefix))
+
+\f
+(define-structure (dataflow/binding
+ (conc-name dataflow/binding/)
+ (print-procedure
+ (standard-unparser-method 'DATAFLOW/BINDING
+ (lambda (binding port)
+ (write-char #\Space port)
+ (write (dataflow/binding/name binding) port)))))
+ (name false read-only true)
+ (value false read-only false))
+
+(define (dataflow/make-env) (cons '() '()))
+
+(define (dataflow/env/lookup env name)
+ (let spine-loop ((env env))
+ (and (not (null? env))
+ (let rib-loop ((rib (car env)))
+ (cond ((null? rib)
+ (spine-loop (cdr env)))
+ ((name-eq? name (dataflow/binding/name (car rib)))
+ (car rib))
+ (else
+ (rib-loop (cdr rib))))))))
+
+(define-integrable (name-eq? name1 name2)
+ (let ((name1 name1)
+ (name2 name2))
+ (or (eq? name1 name2)
+ (and (pair? name1)
+ (pair? name2)
+ (eq? (car name1) (car name2))
+ (eq? (cdr name1) (cdr name2))))))
+
+(define-integrable dataflow/binding/make make-dataflow/binding)
+
+(define (dataflow/env/push-frame env names values)
+ (cons (map make-dataflow/binding names values)
+ env))
+
+(define (dataflow/env/extend-frame! env names values)
+ (set-car! env (append! (car env)
+ (map make-dataflow/binding names values)))
+ env)
+
+(define (dataflow/env/global-environment env)
+ (let spine-loop ((env env))
+ (if (null? (cdr env))
+ env
+ (spine-loop (cdr env)))))
+
+(define (dataflow/env/define-global! env name value)
+ (let ((env (dataflow/env/global-environment env)))
+ (set-car! env (cons (dataflow/binding/make name value) (car env)))))
+
+(define (dataflow/env/for-each-global-binding procedure env)
+ (map procedure (car (dataflow/env/global-environment env))))
+\f
+;;; Data flow graph
+;;
+;; There are two prinicipal kinds of things: NODEs which represent a
+;; place in te program, and VALUE-SETs which represent the set of
+;; values that may be the value of a particular expression identified
+;; by the node.
+;;
+;; Nodes are either of class LOCATION, being an abstract storage location
+;; (e.g. a formal parameter or closure `slot', or of class
+;; EXPRESSION, for nodes that correspond directly to the source.) It
+;; might be possible to store this value implicitly in terms of the
+;; text an name fields.
+
+(define-structure
+ (node
+ (conc-name node/)
+ (constructor %make-node))
+ number ; each node is numbered
+ text ; source code
+ name ; name with source code
+ initial-values ; list of initial values
+ initial-links-in
+ initial-links-out
+ values ; value-set intermediate & final values
+ links-in ; nodes which sink values to here
+ links-out ; nodes which source values from here
+ connectivity ; data structure for efficient
+ ; predicate for membership in links-in
+ uses/operator ; applications with this node as operator
+ uses/operand ; applications with this node as operand
+ ; or continuation
+ uses/trigger ; graph computations that should be
+ ; reconsidered when the values change
+ class ; LOCATION or EXPRESSION
+ )
+
+;; Note: node/name is either a string or a symbol. Strings are used to
+;; name otherwise unnamed places, like the result of an IF. Symbols
+;; are used for names which occur in the program. LAMBDA-parameters
+;; and LET-bindings have the parameter/binding name as node/name and
+;; the binding form (i.e. the LAMBDA expression or LET expression) as
+;; node/text. Thus we can distinguish the nodes representing:
+;; . The LAMBDA parameter X (name=x, text=(LAMBDA (... X ...) ...))
+;; . The LAMBDA expression (name="#[procedure-expression]", text=(LAMBDA...))
+;; . The value returned by the procedure
+;; (name="#[procedure-result]", text=(LAMBDA...))
+;; . The LET binding X (name=x, text=(LET (... (X ...) ...) ...))
+;; . The LET expresion result (name="...", text=(LET (... (X ...) ...) ...))
+
+(define (%graph/make-node graph text name class)
+ graph
+ (let ((node (%make-node (graph/node-count graph)
+ text
+ name ; name
+ '() ; initial-values
+ '() ; initial-links-in
+ '() ; initial-links-out
+ 'NOT-CACHED ; values
+ (make-empty-node-set) ; links-in
+ (make-empty-node-set) ; links-out
+ #F ; connectivity
+ '() ; uses/operator
+ '() ; uses/operand
+ '() ; uses/trigger
+ class
+ )))
+ (set-graph/node-count! graph (+ (graph/node-count graph) 1))
+ node))
+
+
+(define (initial-link-nodes! from to)
+ (add! to from node/initial-links-in set-node/initial-links-in!)
+ (add! from to node/initial-links-out set-node/initial-links-out!))
+
+(define (node/the-constant-value node)
+ (if (not (and (pair? (node/initial-values node))
+ (null? (cdr (node/initial-values node)))
+ (value/constant? (car (node/initial-values node)))))
+ (internal-error "Constant node does not have unique value" node)
+ (value/constant/value (car (node/initial-values node)))))
+
+(define (node/the-procedure-value node)
+ (define (bad)
+ (internal-error "Node does not have an initial known procedure value" node))
+ (if (null? (node/initial-values node))
+ (let ((values (value-set/new-singletons (node/values node))))
+ (if (and (pair? values)
+ (null? (cdr values))
+ (value/procedure? (car values)))
+ (car values)
+ (bad)))
+ (if (and (pair? (node/initial-values node))
+ (null? (cdr (node/initial-values node)))
+ (value/procedure? (car (node/initial-values node))))
+ (car (node/initial-values node))
+ (bad))))
+
+(define (node/unique-value node)
+ (value-set/unique-value (node/values node)))
+
+(define (node/formal-parameter? node)
+ (and (pair? (node/text node))
+ (eq? (car (node/text node)) 'LAMBDA)
+ (symbol? (node/name node))))
+
+
+(define (expression-node? node)
+ (eq? (node/class node) 'EXPRESSION))
+
+(define (location-node? node)
+ (eq? (node/class node) 'LOCATION))
+
+\f
+;;
+;; Values
+;;
+
+;;(define-structure (value
+;; named
+;; (type vector)
+;; (conc-name value/)
+;; ;(constructor %make-value)
+;; (predicate %value?))
+;; text ; source code resulting in this value
+;; nodes ; nodes which get this value
+;; )
+
+(define value/subtypes '())
+
+(define-macro (define-value structure-description . slots)
+ (let ((name (car structure-description))
+ (structure-options (cdr structure-description)))
+
+ `(BEGIN
+ (DEFINE-STRUCTURE
+ (,name
+ NAMED (TYPE VECTOR)
+ . ,structure-options)
+ TEXT ; source code resulting in this value
+ NODES ; nodes which get this value
+ . ,slots)
+ (SET! VALUE/SUBTYPES (CONS ,name VALUE/SUBTYPES)))))
+
+
+;;(define (value? structure)
+;; (and (vector? structure)
+;; (memq (vector-ref structure 0) value/subtypes)))
+
+(define-integrable (value/text structure) (vector-ref structure 1))
+(define-integrable (value/nodes structure) (vector-ref structure 2))
+
+;;(define-integrable (set-value/text! structure x) (vector-set! structure 1 x))
+(define-integrable (set-value/nodes! structure x) (vector-set! structure 2 x))
+
+;;(define-integrable (value/initialize! value text)
+;; (set-value/text! value text)
+;; (set-value/nodes! value '())
+;; value)
+
+
+(define-value (value/constant
+ (conc-name value/constant/)
+ (constructor %value/make-constant))
+ ;; No extra fields
+ )
+
+(define (value/make-constant text)
+ (%value/make-constant text '() ))
+
+(define (value/constant/value constant)
+ ;; get the quoted thing
+ (second (value/text constant)))
+
+
+(define-value (value/procedure
+ (conc-name value/procedure/)
+ (constructor %value/make-procedure))
+ ;; Nodes for arguments and auxes. We distinguish them by looking at the
+ ;; lambda list of the text slot:
+ input-nodes
+ result-node ; node for result value of procedure
+ )
+
+(define (value/make-procedure text input-nodes result-node)
+ (%value/make-procedure text '()
+ input-nodes result-node))
+
+(define (value/procedure/lambda-list procedure-value)
+ (second (value/text procedure-value)))
+
+\f
+(define-value
+ (value/closure
+ (conc-name value/closure/)
+ (constructor %value/make-closure)
+ (print-procedure
+ (standard-unparser-method 'VALUE/CLOSURE
+ (lambda (value port)
+ (write-char #\space port)
+ (write (value/closure/kind value) port)))))
+
+ kind ; 'HEAP or 'STACK or 'TRIVIAL
+ procedure ; a procedure value (lambda (k self ..))
+ location-names ; vector of symbols
+ location-nodes ; nodes for closed-over values
+ ;; the SELF-NODE has this closure as its initial (and only) value
+ self-node
+ ;; CALL-SITES is a list of applications and symbols. Symbols denote
+ ;; external known call sites, for example, the continuation
+ ;; invocation implicit in &<.
+ call-sites
+ ;; ESCAPES? is #T or #F. To cause the closure to escape, link the node
+ ;; to the escape node (or add the value to the escape node's value
+ ;; set). This will cause the closure to be applied to unknown
+ ;; values. Setting this bit marks the closure as escaped, which
+ ;; might be useful if the closure partially escapes, for example, as
+ ;; a continuation of a known but not inlined primitive.
+ escapes? ; #T or #F
+ )
+
+(define (value/closure/trivial? closure)
+ (eq? (value/closure/kind closure) 'TRIVIAL))
+
+
+(define (value/make-closure text ; e.g. (CALL '#[make-heap-closure] ...)
+ kind
+ procedure
+ location-names ; vector
+ location-nodes ; vector
+ self-node
+ )
+ (%value/make-closure text '()
+ kind procedure location-names
+ location-nodes self-node
+ '()
+ #F))
+
+(define (value/closure/lookup-location-node closure name)
+ (let* ((names (value/closure/location-names closure))
+ (n (vector-length names)))
+ (let loop ((i 0))
+ (cond ((>= i n) (internal-error "Non-closed name" name closure))
+ ((eq? (vector-ref names i) name)
+ (vector-ref (value/closure/location-nodes closure) i))
+ (else (loop (1+ i)))))))
+
+
+(define-value (value/unknown
+ (conc-name value/unknown/)
+ (constructor %value/make-unknown))
+ )
+
+(define (value/make-unknown text)
+ (%value/make-unknown text '()))
+\f
+;; Sets of values
+;;
+;; A value set must collect all the known procedures and closures that
+;; arrive at a node. It may also collect other values in some form.
+;;
+
+(define value-set/print-procedure
+ (standard-unparser-method
+ 'VALUE-SET
+ (lambda (object port)
+ (cond ((value-set/unknown? object)
+ => (lambda (unk)
+ (write-string " " port)
+ (write unk port)))
+ ((value-set/unique-value object)
+ => (lambda (value)
+ (write-string " = " port)
+ (write value port)))
+ ((and (null? (value-set/singletons object))
+ (null? (value-set/new-singletons object)))
+ (write-string " EMPTY" port))
+ (else
+ (write-string " *" port))))))
+
+(define-structure (value-set
+ (conc-name value-set/)
+ (constructor %make-value-set)
+ (print-procedure value-set/print-procedure))
+ unknown? ;; either #F or the offending value/unknown
+ singletons ;; value/procedure & value/constant & value/unknown
+ new-singletons
+ other-values ;; whatever - perhaps some lattice element
+ )
+
+
+(define-integrable (make-value-set)
+ (%make-value-set #F '() '() '()))
+
+(define (value-set/unique-value set)
+ ;; returns the unique value or #F if there is no unique value.
+ ;; This procedure is valid only after dataflow.
+ (if (or (value-set/unknown? set)
+ (null? (value-set/singletons set))
+ (not (null? (cdr (value-set/singletons set)))))
+ #F
+ (car (value-set/singletons set))))
+
+
+(define (value-set/age-value! set)
+ ;; Moves a singleton value from the new values to the old, and returns it.
+ ;; Updates unknown? slot
+ (if (eq-set/empty? (value-set/new-singletons set))
+ #f
+ (let ((elt (car (value-set/new-singletons set))))
+ (begin
+ (set-value-set/singletons! set (cons elt (value-set/singletons set)))
+ (set-value-set/new-singletons! set (cdr (value-set/new-singletons set)))
+ (if (and (value/unknown? elt)
+ (not (value-set/unknown? set)))
+ (set-value-set/unknown?! set elt))
+ elt))))
+
+(define (value-set/union!? set additions)
+ ;; Returns #t if the union operation added new elements, false if the
+ ;; operation turned out to be idempotent
+ (let* ((old-singletons (value-set/singletons set))
+ (new-singletons (value-set/new-singletons set))
+ (updated-singletons
+ (eq-set/union3-difference new-singletons
+ old-singletons
+ (value-set/new-singletons additions)
+ (value-set/singletons additions)))
+ (changed? (not (eq? new-singletons updated-singletons))))
+ (set-value-set/new-singletons! set updated-singletons)
+ ;; 1. An unknown frob, if present, will find its way via the above proc.
+ ;; 2. Do something with other-values
+ changed?))
+
+(define (value-set/union!*? set sets)
+ (let loop ((sets sets) (changed? #F))
+ (if (null? sets)
+ changed?
+ (loop (cdr sets) (or (value-set/union!? set (car sets)) changed?)))))
+
+(define (value-set/add-singleton!? set value)
+ ;; Returns #t if the value was added, false it was already an element.
+ (let* ((old-singletons (value-set/singletons set))
+ (new-singletons (value-set/new-singletons set)))
+ (cond ((memq value old-singletons) #F)
+ ((memq value new-singletons) #F)
+ (else (set-value-set/new-singletons! set (cons value new-singletons))
+ #T))))
+\f
+;; eq-sets
+;;
+
+(define (eq-set/empty) '())
+(define (eq-set/empty? set) (null? set))
+(define (eq-set/union s1 s2)
+ (cond ((null? s1) s2)
+ ((null? s2) s1)
+ ((memq (car s1) s2) (eq-set/union (cdr s1) s2))
+ (else (cons (car s1) (eq-set/union (cdr s1) s2)))))
+
+(define (eq-set/union-difference initial exclude additions)
+ (cond ((null? additions)
+ initial)
+ ((memq (car additions) initial)
+ (eq-set/union-difference initial exclude (cdr additions)))
+ ((memq (car additions) exclude)
+ (eq-set/union-difference initial exclude (cdr additions)))
+ (else
+ (cons (car additions)
+ (eq-set/union-difference initial exclude (cdr additions))))))
+
+(define (eq-set/union3-difference new old new2 old2)
+ ;; This result has the property of being EQ? with new if no elements are
+ ;; added to the set.
+ (eq-set/union-difference (eq-set/union-difference new old old2)
+ old new2))
+\f
+(define-structure (graph
+ (conc-name graph/)
+ (constructor %make-graph))
+ program
+ escape-node ; values that escape collect here
+ unknown-input-node ; values that arrive from unknown
+ ; places (calls in, global vars)
+ nodes ; all nodes in graph
+ procedures ; all procedure values in graph
+ closures ; all closures
+ applications ; all call sites
+ ;;references ; all variable references
+ text->node-table
+ constant->node-table ; cache of constants
+ node-count
+ )
+
+
+(define (make-graph program)
+ (let* ((graph
+ (%make-graph program
+ #f ; escape-node
+ #f ; unknown-input-node
+ '() ; nodes
+ '() ; procedures
+ '() ; closures
+ '() ; applications
+ ;;'() ; references
+ (make-eq-hash-table) ; text->node-table
+ (make-eqv-hash-table) ; constant->node-table
+ 0 ; node-count
+ ))
+ (escape-node
+ (graph/add-location-node! graph 'escape-node #f))
+ (unknown-input-node
+ (graph/add-location-node! graph 'unknown-input-node #f)))
+ (set-graph/escape-node! graph escape-node)
+ (add! escape-node 'ESCAPE-APPLICATION
+ node/uses/trigger set-node/uses/trigger!)
+ (set-graph/unknown-input-node! graph unknown-input-node)
+ ;; I am not sure that this is either necessary or advisable, but it
+ ;; ensures that the escaping nodes are fed back as possible inputs:
+ ;; (initial-link-nodes! escape-node unknown-input-node)
+ (add! unknown-input-node (value/make-unknown 'unknown-input)
+ node/initial-values set-node/initial-values!)
+ graph))
+
+
+(define (graph/associate! graph text node)
+ (hash-table/put! (graph/text->node-table graph) text node))
+
+(define (graph/text->node graph text)
+ (hash-table/get (graph/text->node-table graph) text #F))
+
+
+(define (graph/add-expression-node! graph text name)
+ ;; Nodes corresponding to expressions in the source
+ (let ((node (%graph/make-node graph text name 'EXPRESSION)))
+ (add! graph node graph/nodes set-graph/nodes!)
+ node))
+
+(define (graph/add-location-node! graph text name)
+ ;; Nodes corresponding to hidden locations (formals, bindings, cells,...)
+ (let ((node (%graph/make-node graph text name 'LOCATION)))
+ (add! graph node graph/nodes set-graph/nodes!)
+ node))
+
+(define (graph/for-each-node graph procedure)
+ (for-each procedure (graph/nodes graph)))
+
+;; THIS USED TO BE TRUE BUT NOW WE DONT CACHE THE NODES THEMSELVES
+;; Both constants and nodes are cached in the constant->node-table.
+;; If the node exists the constant is the node's initial value.
+
+(define (graph/add-constant! graph text)
+ ;; Text = (QUOTE constant)
+ (let* ((table (graph/constant->node-table graph))
+ (constant (second text))
+ (cached-node (hash-table/get table constant #F)))
+ (cond ((value/constant? cached-node)
+ cached-node)
+ ((node? cached-node)
+ (car (node/initial-values cached-node)))
+ (else
+ (let* ((value (value/make-constant text)))
+ (hash-table/put! table constant value)
+ value)))))
+
+;;(define (graph/add-constant-node! graph text)
+;; ;; Text = (QUOTE constant)
+;; (let* ((table (graph/constant->node-table graph))
+;; (constant (second text))
+;; (cached-node (hash-table/get table constant #F)))
+;; (if (node? cached-node)
+;; cached-node
+;; (let* ((value (or cached-node (value/make-constant text)))
+;; (node (graph/add-node! graph text "#[constant]")))
+;; (add! node value node/initial-values set-node/initial-values!)
+;; (hash-table/put! table constant node)
+;; node))))
+
+;;(define (graph/add-constant-node! graph text)
+;; ;; Text = (QUOTE constant)
+;; (let* ((value (value/make-constant text))
+;; (node (graph/add-expression-node! graph text "#[constant]")))
+;; (add! node value node/initial-values set-node/initial-values!)
+;; ;;(hash-table/put! table (quote/text text) node)
+;; node))
+
+(define (graph/add-constant-node! graph text)
+ ;; Text = (QUOTE constant)
+ (let* ((value (graph/add-constant! graph text))
+ (node (graph/add-expression-node! graph text "#[constant]")))
+ (add! node value node/initial-values set-node/initial-values!)
+ ;;(hash-table/put! table (quote/text text) node)
+ node))
+
+;;(define (graph/add-reference! graph text variable-node)
+;; (let ((reference (value/make-reference text variable-node)))
+;; (add! graph reference graph/references set-graph/references!)
+;; (add! variable-node reference node/references set-node/references!)
+;; reference))
+
+(define (graph/add-procedure! graph text input-nodes result-node)
+ (let ((procedure (value/make-procedure text input-nodes result-node)))
+ (add! graph procedure graph/procedures set-graph/procedures!)
+ procedure))
+
+
+(define (graph/add-closure! graph text kind procedure location-names location-nodes self-node)
+ (let ((closure (value/make-closure
+ text kind procedure
+ location-names
+ location-nodes
+ self-node)))
+ (add! graph closure graph/closures set-graph/closures!)
+ closure))
+
+(define (graph/initialize-links! graph)
+
+ (define (connect! from to)
+ ;; link nodes transitively
+ (if (not (nodes-linked? from to))
+ (begin
+ (link-nodes! from to)
+ (node-set/for-each (node/links-in from)
+ (lambda (from) (connect! from to)))
+ (node-set/for-each (node/links-out to)
+ (lambda (to) (connect! from to))))))
+
+ (graph/for-each-node graph
+ (lambda (node)
+ (for-each-item (lambda (to)
+ (connect! node to))
+ (node/initial-links-out node))
+ (for-each-item (lambda (from)
+ (connect! from node))
+ (node/initial-links-in node)))))
+\f
+
+(define-structure
+ (application
+ (conc-name application/)
+ (print-procedure
+ (standard-unparser-method 'APPLICATION
+ (lambda (application port)
+ (if (CALL/? (application/text application))
+ (let ((operator (call/operator (application/text application))))
+ (write-char #\Space port)
+ (cond ((QUOTE/? operator)
+ (write operator port))
+ ((LOOKUP/? operator)
+ (write (lookup/name operator) port))
+ ((LAMBDA/? operator)
+ (write-string "(lambda)" port))
+ (else
+ (write-string "<operator>" port)))))))))
+ text
+ operator-node
+ operand-nodes
+ ;; The result node is the expected thing in Direct style. In CPS it
+ ;; holds the value that should be passed to the continuation, which
+ ;; is only really useful when modelling calls to external known
+ ;; operators. For these we create special-applications on the fly
+ ;; that feed the result back to the continuation.
+ result-node
+ )
+
+(define (graph/add-application! graph text
+ operator-node operand-nodes result-node)
+ (let ((application (make-application
+ text operator-node operand-nodes result-node)))
+
+ (add! operator-node application node/uses/trigger set-node/uses/trigger!)
+
+ (add! graph application graph/applications set-graph/applications!)
+ (add! operator-node application node/uses/operator set-node/uses/operator!)
+ (for-each
+ (lambda (node)
+ (if node
+ (add! node application node/uses/operand set-node/uses/operand!)))
+ operand-nodes)
+ application))
+
+
+
+(define-structure
+ (special-application
+ (conc-name special-application/)
+ (print-procedure
+ (standard-unparser-method 'SPECIAL-APPLICATION
+ (lambda (application port)
+ (write-char #\Space port)
+ (write (special-application/operator application) port)))))
+ text
+ operator ; cookie
+ operand-nodes
+ result-node)
+
+(define (graph/add-special-application!
+ graph text
+ operator operand-nodes
+ trigger-nodes
+ result-node)
+ (let ((application (make-special-application
+ text operator operand-nodes result-node)))
+
+ (add! graph application graph/applications set-graph/applications!)
+ (for-each
+ (lambda (node)
+ (add! node application node/uses/operand set-node/uses/operand!))
+ operand-nodes)
+ (for-each
+ (lambda (node)
+ (add! node application node/uses/trigger set-node/uses/trigger!))
+ trigger-nodes)
+ application))
+
+
+\f
+;;
+;; The abstraction that we use for lists of things
+
+(define-integrable (add! structure item accessor setter!)
+ (let ((structure structure))
+ (setter! structure (cons item (accessor structure)))))
+
+(define (empty? frob)
+ (null? frob))
+
+(define-integrable (in? item collection)
+ (memq item collection))
+
+(define-integrable (for-each-item proc things)
+ (for-each proc things))
+\f
+
+
+(define (graph/pp graph)
+ (define (ppp x) (pp x (current-output-port) #T))
+
+ (define (section heading selector pp)
+ (newline) (newline) (display heading)
+ (for-each (lambda (proc)
+ (newline)
+ (pp proc))
+ (selector graph)))
+
+ (pp graph)
+
+ (section "NODES" graph/nodes pp)
+
+ (newline) (newline) (display "TEXT->NODE map") (newline)
+ (for-each ppp (hash-table->alist (graph/text->node-table graph)))
+
+ (section "APPLICATIONS" graph/applications ppp)
+ (section "PROCEDURES" graph/procedures pp)
+ (section "CLOSURES" graph/closures pp)
+)
+
+\f
+;;
+;; Simulated application
+;;
+
+;; Normal procedures: connect up the arguments to the parameters. This
+;; may invalidate other application nodes if an operator flow out
+;;
+;; Primitives: output must be monotonic on each inputs. Need to rerun
+;; any application which has a new value for any of the arguments.
+;;
+;; Values which escape end up in the escape-node.
+
+(define (graph/dataflow! graph)
+ (graph/for-each-node graph
+ (lambda (node) (set-node/values! node 'NOT-CACHED)))
+ (graph/for-each-node graph node/initialize-cache!)
+ ;; Trivial cloaures need to
+ (graph/initialize-closure-procedures! graph)
+ (let ((queue (queue/make)))
+ (queue/enqueue!* queue (graph/applications graph))
+ (queue/enqueue! queue 'ESCAPE-APPLICATION)
+ (queue/drain! queue (simulate-combination graph queue)))
+ ;; This ensures that unknown values get into the flag position in nodes
+ ;; that are not used in an application:
+ (graph/for-each-node graph
+ (lambda (node)
+ (let loop ()
+ (if (value-set/age-value! (node/values node)) (loop)))))
+ ;; Mark all closures that escape. Must be done after the above step.
+ (for-each-item (lambda (value)
+ (if (value/closure? value)
+ (set-value/closure/escapes?! value #T)))
+ (value-set/singletons (node/values (graph/escape-node graph))))
+
+ ;; Invert graph to obtain values->nodes
+ (graph/for-each-node graph
+ (lambda (node)
+ (for-each-item
+ (lambda (value)
+ (add! value node value/nodes set-value/nodes!))
+ (value-set/singletons (node/values node)))))
+
+ )
+
+
+(define ((simulate-combination graph queue) application)
+ (cond ((eq? 'ESCAPE-APPLICATION application)
+ (dataflow/apply-escapees! graph queue))
+ ((application? application)
+ (simulate-application application graph queue))
+ ((special-application? application)
+ (simulate-special-application application graph queue))
+ (else
+ (internal-error "Illegal graph application" application))))
+
+\f
+(define (simulate-application application graph queue)
+
+ (define (connect! from to) (connect-nodes! graph queue from to))
+
+ (let* ((operator-node (application/operator-node application))
+ (operand-nodes (application/operand-nodes application))
+ (result-node (application/result-node application)))
+
+ (define (apply-next-operator)
+ (let ((operator (value-set/age-value! (node/values operator-node))))
+ (cond ((false? operator)
+ 'done)
+
+ ((value/unknown? operator)
+ (for-each
+ (lambda (operand-node)
+ (if operand-node
+ (connect! operand-node (graph/escape-node graph))))
+ operand-nodes)
+ (if result-node
+ (connect! (graph/unknown-input-node graph) result-node))
+ (apply-next-operator))
+
+ ((value/constant? operator)
+ ;; all the magic cookies
+ (dataflow/applicate-constant!
+ graph queue application operator)
+ (apply-next-operator))
+
+ ((value/procedure? operator)
+ (dataflow/applicate! graph
+ queue
+ (value/procedure/lambda-list operator)
+ (value/procedure/input-nodes operator)
+ operand-nodes)
+ (cond ((and result-node (value/procedure/result-node operator))
+ ;; i.e. direct style
+ (connect! (value/procedure/result-node operator)
+ result-node))
+ ;;((or (value/procedure/result-node operator)
+ ;; (first operand-nodes))
+ ;;(internal-error "Direct/CPS mismatch"
+ ;; operator application))
+ )
+ (apply-next-operator))
+
+ ((value/closure? operator)
+ ;; This is slightly more involved as we have to extract the
+ ;; procedure and arrange for the closure to be passed for
+ ;; non-trivial closures
+ (let* ((procedure (value/closure/procedure operator)))
+
+ (add! operator application value/closure/call-sites
+ set-value/closure/call-sites!)
+ (dataflow/applicate!
+ graph
+ queue
+ (value/procedure/lambda-list procedure)
+ (value/procedure/input-nodes procedure)
+ (if (memq (value/closure/kind operator) '(TRIVIAL STACK))
+ operand-nodes
+ (cons* (first operand-nodes)
+ (value/closure/self-node operator)
+ (cdr operand-nodes))))
+ (cond ((and result-node (value/procedure/result-node procedure))
+ ;; i.e. direct style
+ (connect! (value/procedure/result-node procedure)
+ result-node))
+ ;;((or result-node (value/procedure/result-node procedure))
+ ;;(internal-error "Direct/CPS mismatch"
+ ;; operator application))
+ )
+ (apply-next-operator)))
+
+ (else
+ (internal-error "Dont know how to apply"
+ operator application)))))
+
+ (apply-next-operator)))
+
+\f
+(define (simulate-special-application application graph queue)
+
+ (define (connect! from to) (connect-nodes! graph queue from to))
+
+ graph
+
+ (let ((operator (special-application/operator application))
+ (operand-nodes (special-application/operand-nodes application))
+ (result-node (special-application/result-node application)))
+
+ (cond ((eq? operator %make-heap-closure)
+ ;;no action required - closure value precomputed
+ unspecific)
+ ((eq? operator %make-stack-closure)
+ ;;no action required - closure value precomputed
+ unspecific)
+
+ ((or (eq? operator %heap-closure-ref)
+ (eq? operator %stack-closure-ref))
+ ;; (CALL ',%heap-closure-ref '#F <closure> <offset> 'NAME)
+ ;; (CALL ',%stack-closure-ref '#F <closure> <offset> 'NAME)
+ (let* ((text (special-application/text application))
+ (name (second (sixth text)))
+ (ref-kind (second (second text)))
+ (closure-node (first operand-nodes))
+ (closure (value-set/age-value!
+ (node/values closure-node))))
+ (if closure
+ (if (not (node-set/empty? (node/links-in result-node)))
+ (internal-error "Multiple linkings at " application)
+ (begin
+ ;;(pp `(,ref-kind ,closure ,name))
+ (connect! (value/closure/lookup-location-node closure name)
+ result-node)
+ (let ((bad (value-set/age-value!
+ (node/values closure-node))))
+ (if bad
+ (internal-error
+ "Multiple closures at" ref-kind
+ application))))))))
+
+ (else
+ (internal-error
+ "Unknown special-application operator" operator application)))))
+
+\f
+(define (dataflow/apply-escapees! graph queue)
+ ;; Ensure any procedure that escapes is called with unknown arguments and
+ ;; its result escapes too.
+
+ (define (connect! from to) (connect-nodes! graph queue from to))
+
+ (let* ((unknown-input-node (graph/unknown-input-node graph))
+ (escape-node (graph/escape-node graph))
+ (values (node/values escape-node)))
+ (let escape-next-object ()
+ (let ((object (value-set/age-value! values)))
+ (cond ((false? object)
+ unspecific)
+ ((value/procedure? object)
+ ;;(pp (list 'escaped: object))
+ (for-each (lambda (input-node)
+ (connect! unknown-input-node input-node))
+ (value/procedure/input-nodes object))
+ (if (value/procedure/result-node object)
+ (connect! (value/procedure/result-node object)
+ escape-node))
+ (escape-next-object))
+
+ ((value/closure? object)
+ ;; This is slightly more involved as we have to link up a heap
+ ;; closure's procedure with the correct value (node) for the
+ ;; closure argument.
+
+ ;; NOTE: Perhaps this code should also escape the closure
+ ;; locations?
+ ;;(pp (list 'escaped: object))
+ (let* ((procedure (value/closure/procedure object))
+ (input-nodes (value/procedure/input-nodes procedure)))
+ (if (value/procedure/result-node procedure)
+ (connect! (value/procedure/result-node procedure)
+ escape-node))
+ (connect! unknown-input-node (first input-nodes))
+ (if (eq? 'HEAP (value/closure/kind object))
+ (begin
+ (connect! (value/closure/self-node object)
+ (second input-nodes))
+ (for-each
+ (lambda (input-node)
+ (connect! unknown-input-node input-node))
+ (cddr input-nodes)))
+ (begin ; TRIVIAL or STACK
+ (for-each
+ (lambda (input-node)
+ (connect! unknown-input-node input-node))
+ (cdr input-nodes)))))
+
+ (escape-next-object))
+
+ (#F
+ ;; Anything containing locations that are accessible by accessor
+ ;; procedures needs to escape the locations.
+ )
+ (else;; unknown, constants, primitives
+ (escape-next-object)))))))
+
+
+(define (dataflow/make-globals-escape! env graph)
+ (dataflow/env/for-each-global-binding
+ (lambda (binding)
+ (let ((value (dataflow/binding/value binding)))
+ (initial-link-nodes! value (graph/escape-node graph))
+ (initial-link-nodes! (graph/unknown-input-node graph) value)))
+ env))
+\f
+(define (dataflow/applicate-constant! graph
+ queue
+ application
+ operator)
+
+ (let ((operator (value/constant/value operator)))
+ (if (and (not (primitive-procedure? operator))
+ (not (compiled-procedure? operator))
+ (not (known-operator? operator))
+ *dataflow-report-applied-non-procedures?*)
+ (warn "Possibly applied non-procedure object: " operator)))
+
+ ((dataflow/get-method (value/constant/value operator))
+ graph
+ queue
+ application
+ operator))
+
+
+(define dataflow/cookie-methods (make-eq-hash-table))
+
+(define (define-dataflow-method cookie method)
+ (hash-table/put! dataflow/cookie-methods cookie method))
+
+(define (dataflow/get-method cookie)
+ (hash-table/get dataflow/cookie-methods cookie
+ dataflow/method/default-method))
+
+(define (dataflow/method/default-method graph queue application operator)
+ ;; The default method assumes the very worst about the operator: all the
+ ;; arguments escape and the result, if any, is completely unknown
+ (define (connect! from to) (connect-nodes! graph queue from to))
+ operator
+ (if (application/result-node application)
+ (connect! (graph/unknown-input-node graph)
+ (application/result-node application)))
+ (for-each (lambda (node)
+ (if node
+ (connect! node (graph/escape-node graph))))
+ (application/operand-nodes application)))
+
+(define (dataflow/method/simple graph queue application operator)
+ ;; The simple method assumes that none of the arguments escape and the
+ ;; result is completely unknown
+ operator
+ (define (connect! from to) (connect-nodes! graph queue from to))
+ (define result-node (application/result-node application))
+ (connect! (graph/unknown-input-node graph) result-node))
+
+(define (dataflow/method/simple-predicate graph queue application operator)
+ ;; The simple method assumes that none of the arguments escape and the
+ ;; result is either #F or #T
+ operator
+ (define result-node (application/result-node application))
+ (node/add-value! result-node (graph/add-constant! graph `(QUOTE #F)) queue)
+ (node/add-value! result-node (graph/add-constant! graph `(QUOTE #T)) queue))
+
+
+(define (dataflow/external-return graph queue application operator)
+ (let ((result-node (application/result-node application))
+ (cont-node (first (application/operand-nodes application))))
+ (if cont-node
+ (let ((application
+ (graph/add-application! graph
+ `(EXTERNAL-RETURN ,operator)
+ cont-node
+ (list #F result-node)
+ #F)))
+ ;; enqueue it in case the result is already available
+ (queue/enqueue! queue application))
+ ;; In direct style the result is already in place.
+ 'ok)))
+
+
+(define (dataflow/method/external-predicate graph queue application operator)
+ ;; The simple method assumes that none of the arguments escape and the
+ ;; result is either #F or #T
+ operator
+ (define result-node (application/result-node application))
+ (node/add-value! result-node (graph/add-constant! graph `(QUOTE #F)) queue)
+ (node/add-value! result-node (graph/add-constant! graph `(QUOTE #T)) queue)
+ (dataflow/external-return graph queue application operator))
+
+
+
+(define-dataflow-method fix:+ dataflow/method/simple)
+(define-dataflow-method fix:- dataflow/method/simple)
+(define-dataflow-method fix:* dataflow/method/simple)
+
+(define-dataflow-method fix:< dataflow/method/simple-predicate)
+
+(for-each
+ (lambda (name)
+ (define-dataflow-method (make-primitive-procedure name)
+ dataflow/method/external-predicate))
+ '(&< &= &>))
+
+
+
+;;(define (dataflow/method/%make-heap-closure graph queue application operator)
+;; ;; (CALL ,%make-heap-closure '#F (lambda (k closure ..) ..) '#(x y) x y)
+;; (define (connect! from to) (connect-nodes! graph queue from to))
+;;
+;; (let* ((arg-nodes (application/operand-nodes application))
+;; (text (application/text application))
+;; (location-names (second (fifth text)))
+;; (cont-node (first arg-nodes))
+;; (lambda-node (second arg-nodes))
+;; (vector-node (third arg-nodes))
+;; (value-nodes (cdddr arg-nodes))
+;; (procedure (node/the-procedure-value lambda-node))
+;; (self-node (application/result-node application))
+;; (closure (graph/add-closure!
+;; graph
+;; text
+;; 'HEAP
+;; procedure
+;; location-names
+;; self-node)))
+;; (let loop ((i 0) (value-nodes value-nodes))
+;; (if (< i (vector-length location-names))
+;; (let ((node (vector-ref (value/closure/location-nodes closure) i)))
+;; (node/initialize-cache! node)
+;; (connect! (car value-nodes) node)
+;; (loop (+ i 1) (cdr value-nodes)))))
+;; (node/add-value! self-node closure queue)))
+;;
+;;(define-dataflow-method %make-heap-closure dataflow/method/%make-heap-closure)
+;;
+;;
+;;(define (dataflow/method/%heap-closure-ref graph queue application operator)
+;; ;; (CALL ,%heap-closure-ref '#F <closure> <offset> 'NAME)
+;;
+;; (define (connect! from to) (connect-nodes! graph queue from to))
+;;
+;; (let* ((text (application/text application))
+;; (arg-nodes (application/operand-nodes application))
+;; (closure-node (second arg-nodes))
+;; (closure-values (node/values closure-node))
+;; (name (second (fifth text)))
+;; (result-node (application/result-node application)))
+;; ;; This procedure should only ever be called with a single known closure
+;; ;; value. We connect the named slot
+;;
+;; (let loop ((closure (value-set/age-value! closure-values)))
+;; (cond ((false? closure)
+;; unspecific)
+;; ((value/closure? closure)
+;; (if (null? (node/links-in result-node))
+;; (connect! (value/closure/lookup-location-node closure name)
+;; result-node)
+;; (internal-error "%heap-closure-ref again!"
+;; closure application))
+;; (loop (value/set/age-value! closure-values)))
+;; (else
+;; (internal-error "%heap-closure-ref of non-closure"
+;; closure application))))))
+;;
+;;(define-dataflow-method %heap-closure-ref dataflow/method/%heap-closure-ref)
+;;
+
+
+
+(define (dataflow/applicate! graph
+ queue
+ whole-lambda-list
+ whole-formals ; abstract names in lambda list
+ whole-args)
+
+ (define (connect! from to)
+ (connect-nodes! graph queue from to))
+
+ (define (do-normal! name formal arg)
+ name
+ (if arg
+ (connect! arg formal)))
+
+ (define (do-optional! name formal arg)
+ name
+ (if arg
+ (connect! arg formal)
+ (node/add-value!
+ formal
+ (graph/add-constant! graph `(QUOTE ,(make-unassigned-reference-trap)))
+ queue)))
+
+ (define (do-rest! name formal args)
+ name
+ (if (null? args)
+ ;;(connect! (graph/add-constant-node! graph '(QUOTE ())) formal)
+ (node/add-value! formal
+ (graph/add-constant! graph `(QUOTE ()))
+ queue)
+ (connect! (graph/unknown-input-node graph) formal)))
+
+ (define (normal-loop lambda-list formals args)
+ (cond ((null? lambda-list)
+ (if (not (null? args))
+ (warn "Too many args" whole-lambda-list whole-args)))
+ ((eq? (car lambda-list) '#!OPTIONAL)
+ (optional-loop (cdr lambda-list) formals args))
+ ((eq? (car lambda-list) '#!REST)
+ (rest-loop (cdr lambda-list) formals args))
+ ((null? args)
+ (warn "Too few arguments" whole-lambda-list whole-args))
+ (else
+ (do-normal! (car lambda-list) (car formals) (car args))
+ (normal-loop (cdr lambda-list) (cdr formals) (cdr args)))))
+
+ (define (optional-loop lambda-list formals args)
+ (cond ((null? lambda-list)
+ (if (not (null? args))
+ (warn "Too many args" whole-lambda-list whole-args)))
+ ((eq? (car lambda-list) '#!REST)
+ (rest-loop (cdr lambda-list) formals args))
+ ((null? args)
+ (do-optional! (car lambda-list) (car formals) #f)
+ (optional-loop (cdr lambda-list) (cdr formals) '()))
+ (else
+ (do-optional! (car lambda-list) (car formals) (car args))
+ (optional-loop (cdr lambda-list) (cdr formals) (cdr args)))))
+
+ (define (rest-loop lambda-list formals args)
+ (do-rest! (car lambda-list) (car formals) args))
+
+ (normal-loop whole-lambda-list whole-formals whole-args))
+
+
+\f
+;;;;
+;;;; Node sets allow insertion while the set is being traversed. This is
+;;;; node by keeping the items added during the traversal and inserting
+;;;; them later.
+;;
+;;(load-option 'rb-tree)
+;;
+;;(define-integrable (node-set/lock s) (car s))
+;;(define-integrable (node-set/elements s) (cdr s))
+;;(define-integrable (node-set/set-lock! s v) (set-car! s v))
+;;(define-integrable (node-set/set-elements! s v) (set-cdr! s v))
+;;
+;;(define-integrable (node-set/locked? s) (not (symbol? (node-set/lock s))))
+;;
+;;(define (node-set/add-unlocked! set elt)
+;; (node-set/set-elements! set (cons elt (node-set/elements set))))
+;;
+;;(define (link-nodes! from to)
+;; (define-integrable (add! set elt)
+;; (if (node-set/locked? set)
+;; (node-set/set-lock! set (cons elt (node-set/lock set)))
+;; (node-set/add-unlocked! set elt)))
+;; (add! (node/links-in to) from)
+;; (add! (node/links-out from) to))
+;;
+;;(define (nodes-linked? from to)
+;; (or (eq? from to)
+;; (node-set/member? from (node/links-in to))))
+;;
+;;(define (make-empty-node-set)
+;; (cons 'unlocked '()))
+;;
+;;(define (node-set/empty? set)
+;; (null? (node-set/elements set)))
+;;
+;;(define (node-set/member? node set)
+;; (or (memq node (node-set/elements set))
+;; (and (node-set/locked? set)
+;; (memq node (node-set/lock set)))))
+;;
+;;(define (node-set/for-each set proc)
+;; (let ((old-lock (node-set/lock set)))
+;; (node-set/set-lock! set '())
+;; (for-each proc (node-set/elements set))
+;; (if (not (null? (node-set/lock set)))
+;; (pp `(deferred . ,(node-set/lock set))))
+;; (for-each (lambda (addend)
+;; (node-set/add-unlocked! set addend))
+;; (node-set/lock set))
+;; (node-set/set-lock! set old-lock)
+;; unspecific))
+;;
+;;(define (node-set/size set)
+;; (length (node-set/elements set)))
+\f
+
+;;______________________________________________________________________________
+;;
+;; A note about the structure of the graph. About 80% of the nodes have
+;; 3 or fewer in-edges. The most popular in-degree is 0 (~35%), then
+;; 3 and 1 (at 15%) and then 2 (at 8%) [after cps conversion, one
+;; large sample].
+;;
+;; The node(s) which collect escaped values have a huge number of edges.
+;;
+;; The overhead of deciding to use the bit-strings is not worth it for
+;; graphs with < 3k nodes.
+;;
+;;(define (link-nodes! from to)
+;; (define-integrable (add! structure item accessor setter!)
+;; (let ((structure structure))
+;; (setter! structure (cons item (accessor structure)))))
+;; (add! to from node/links-in set-node/links-in!)
+;; (add! from to node/links-out set-node/links-out!)
+;; (cond ((node/connectivity to)
+;; (bit-string-set! (node/connectivity to) (node/number from)))
+;; ((>= (length (node/links-in to)) 10)
+;; (let ((bs (make-bit-string *node-count* #F)))
+;; (for-each (lambda (node)
+;; (bit-string-set! bs (node/number node)))
+;; (node/links-in to))
+;; (set-node/connectivity! to bs))))
+;; unspecific)
+;;
+;;(define (nodes-linked? from to)
+;; (cond ((eq? from to)
+;; #T)
+;; ((node/connectivity to)
+;; (bit-string-ref (node/connectivity to) (node/number from)))
+;; ((memq from (node/links-in to))
+;; #T)
+;; (else #F)))
+;;
+;;(define (make-empty-node-set)
+;; '())
+;;
+;;(define (node-set/empty? set)
+;; (null? set))
+;;
+;;(define (node-set/for-each set proc)
+;; (for-each proc set))
+;;
+;;(define (node-set/size set)
+;; (length set))
+;;______________________________________________________________________________
+
+
+\f
+;;______________________________________________________________________________
+;;
+;; Simple lists are slow and take 2n words per entry
+;;
+;;(define (link-nodes! from to)
+;; (define-integrable (add! structure item accessor setter!)
+;; (let ((structure structure))
+;; (setter! structure (cons item (accessor structure)))))
+;; (add! to from node/links-in set-node/links-in!)
+;; (add! from to node/links-out set-node/links-out!))
+;;
+;;(define (nodes-linked? from to)
+;; (or (eq? from to)
+;; (memq from (node/links-in to))))
+;;
+;;(define (make-empty-node-set)
+;; '())
+;;
+;;(define (node-set/empty? set)
+;; (null? set))
+;;
+;;(define (node-set/for-each set proc)
+;; (for-each proc set))
+;;
+;;(define (node-set/size set)
+;; (length set))
+;;______________________________________________________________________________
+\f
+;; The growing vector approach. Uses at most kN+2 works where k in 4/3.
+;; as k -> 1 the overhead reduced by the vector has to be grown more
+;; often (see GROW) below. The vector contains a count C in the first
+;; (0 index) slot and set elements in slots 1..C.
+
+(define (link-nodes! from to)
+
+ (define (initial-vector elt) (vector 1 elt))
+
+ (define (grow v)
+ ;; Fast open-coded grow operations for common cases. All vectors start
+ ;; out small and so benefit from this (I hope).
+ (case (vector-length v)
+ ((2) (vector (vector-ref v 0) (vector-ref v 1) #F))
+ ((3) (vector (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) #F))
+ (else
+ (vector-grow v (fix:quotient (fix:* (vector-length v) 4) 3)))))
+
+ (define (add! structure item accessor setter!)
+ (let ((set (accessor structure)))
+ (if set
+ (let ((index (fix:+ (vector-ref set 0) 1))
+ (vlen (vector-length set)))
+ (if (fix:>= index vlen)
+ (let ((set* (grow set)))
+ (vector-set! set* index item)
+ (vector-set! set* 0 index)
+ (setter! structure set*))
+ (begin
+ (vector-set! set index item)
+ (vector-set! set 0 index))))
+ (setter! structure (initial-vector item)))))
+
+ (add! to from node/links-in set-node/links-in!)
+ (add! from to node/links-out set-node/links-out!))
+
+(define (nodes-linked? from to)
+ (or (eq? from to)
+ (let ((set (node/links-in to)))
+ (and set
+ (let loop ((i (vector-ref set 0)))
+ (and (fix:> i 0)
+ ;; Loop unrolled 1 time is safe because the zero slot
+ ;; contains a fixnum that will never match a node
+ (or (eq? from (vector-ref set i))
+ (eq? from (vector-ref set (fix:- i 1)))
+ (loop (fix:- i 2)))))))))
+
+
+(define (make-empty-node-set)
+ '#F)
+
+(define-integrable (node-set/empty? set)
+ (eq? set '#F))
+
+(define (node-set/for-each set proc)
+ (if set
+ (let loop ((i (vector-ref set 0)))
+ (if (fix:> i 0)
+ (begin
+ (proc (vector-ref set i))
+ (loop (fix:- i 1)))))))
+
+(define (node-set/size set)
+ (if set
+ (vector-ref set 0)
+ 0))
+\f
+(define (connect-nodes! graph queue from to)
+ graph
+
+ (define (link! from to)
+ (if (not (nodes-linked? from to))
+ (link-nodes! from to)))
+
+ (link! from to)
+ (node-set/for-each (node/links-in from)
+ (lambda (from*)
+ (link! from* to)))
+ (node-set/for-each (node/links-out to)
+ (lambda (to*)
+ (link! from to*)))
+ (node-set/for-each (node/links-in from)
+ (lambda (from*)
+ (node-set/for-each (node/links-out to)
+ (lambda (to*)
+ (link! from* to*)))))
+
+ ;; Now any node newly reachable from any predecessor of FROM is in FROM's
+ ;; successors, so we can just do a one-level propagation of values
+ ;;(node/propagate! from queue)
+ ;;
+ ;; This is better as it does not needlessly propagate preexisting
+ ;; successors of from:
+ (if (value-set/union!? (node/values to) (node/values from))
+ (begin
+ (node/enqueue-applications! to queue)
+ (node/propagate! to queue))))
+
+
+
+(define (node/add-value! node value queue)
+ (if (value-set/add-singleton!? (node/values node) value)
+ (begin
+ (node/enqueue-applications! node queue)
+ (node/propagate! node queue))))
+
+(define (node/enqueue-applications! node queue)
+ (queue/enqueue!* queue (node/uses/trigger node)))
+
+(define (node/propagate! node queue)
+ ;; This is a node who's value has changed, so propagate to successors
+ (let ((values (node/values node)))
+ (node-set/for-each (node/links-out node)
+ (lambda (dest)
+ (if (value-set/union!? (node/values dest) values)
+ (node/enqueue-applications! dest queue))))))
+
+(define (node/initialize-cache! node)
+ (node/compute-initial-values! node))
+
+#|
+(define (node/compute-initial-values node)
+ ;; This is slow but works even with cycles in the DFG.
+ ;; Only works if there are no links in from a node with a reference value
+ (let ((nodes '()))
+ (let walk ((node node))
+ (if (not (memq node nodes))
+ (begin (set! nodes (cons node nodes))
+ (for-each walk (node/links-in node)))))
+ (value-set/union* (node/initial-values (car nodes))
+ (map node/initial-values (cdr nodes)))))
+|#
+
+
+(define (node/compute-initial-values! target-node)
+ ;; This is slow but works even with cycles in the DFG.
+ (let ((nodes '()))
+ (define (eval-node! node)
+ (cond ((memq node nodes)
+ unspecific)
+ ((eq? (node/values node) 'NOT-CACHED)
+ (set! nodes (cons node nodes))
+ (node-set/for-each (node/links-in node) eval-node!)
+ (let ((vs (make-value-set)))
+ (set-node/values! node vs)
+ (set-value-set/new-singletons! vs (node/initial-values node))
+ (node-set/for-each
+ (node/links-in node)
+ (lambda (input-node)
+ (if (value-set? (node/values input-node))
+ (value-set/union!? vs (node/values input-node)))))))
+ (else
+ unspecific)))
+ (eval-node! target-node)))
+\f
+(define (graph/substitite-simple-constants graph simple-constant?)
+ ;; Rewrite any node with a unique constant value K satisfying
+ ;; SIMPLE-CONSTANT? as (QUOTE K)
+ (for-each (lambda (node)
+ (if (expression-node? node)
+ (let ((value (node/unique-value node)))
+ (cond ((QUOTE/? (node/text node))
+ unspecific)
+ ((and (value/constant? value)
+ (simple-constant? (value/constant/value value)))
+ (display "\n; Constant propagation:")
+ (kmp/ppp
+ `(,node ,(node/text node) =>
+ (QUOTE ,(value/constant/value value))))
+ (form/rewrite! (node/text node)
+ `(QUOTE ,(value/constant/value value))))
+ (else unspecific)))))
+ (graph/nodes graph)))
+
+(define (graph/read-eq?-preserving-constant? value)
+ (or (fixnum? value)
+ (char? value)
+ (symbol? value)
+ (memq value '(#F () #T))))
+
+(define (graph/read-eqv?-preserving-constant? value)
+ (or (graph/read-eq?-preserving-constant? value)
+ (number? value)))
+\f
+(define (graph/display-statistics! graph)
+ (define (say . things) (for-each display things))
+ (define (histogram aspect measure)
+ (let ((data (map measure (aspect graph)))
+ (hist (make-eq-hash-table)))
+ (let loop ((data data))
+ (if (not (null? data))
+ (let ((datum (car data)))
+ (hash-table/put! hist datum (+ 1 (hash-table/get hist datum 0)))
+ (loop (cdr data)))))
+ (sort (hash-table->alist hist) (lambda (u v) (< (car u) (car v))))))
+
+ (define ((edge-count aspect) node)
+ (node-set/size (aspect node)))
+
+ (define (count-pairs object)
+ (define (count it n)
+ (if (pair? it)
+ (count (car it) (count (cdr it) (+ n 1)))
+ n))
+ (count object 0))
+
+ (say "\n; " graph
+ " " (length (graph/nodes graph))
+ " nodes " (graph/node-count graph)
+ " (" (reduce + 0 (map (lambda (node) (if (node/connectivity node) 1 0))
+ (graph/nodes graph)))
+ " with bit strings)")
+ (say "\n; Source has " (count-pairs (graph/program graph)) " pairs.")
+ (say "\n; "
+ (reduce + 0 (map (edge-count node/links-in)
+ (graph/nodes graph)))
+ " in-edges, "
+ (reduce + 0 (map (edge-count node/links-out)
+ (graph/nodes graph)))
+ " out-edges.")
+ ;;(say "\n; Histogram ((out-edges . node-count) ...)")
+ ;;(pp (histogram graph/nodes (lambda (node) (length (node/links-out node))))
+ ;; (current-output-port) #F)
+ (say "\n; Histogram ((in-edges . node-count) ...)")
+ (pp (histogram graph/nodes (edge-count node/links-in))
+ (current-output-port) #F))
+\f
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(define (find-all pattern program)
+
+ (define (match? pattern text)
+ (or (eq? pattern '?)
+ (eq? pattern text)
+ (and (symbol? pattern) (symbol? text)
+ (string-ci=? (symbol-name pattern) (symbol-name text)))
+ (and (pair? pattern) (pair? text)
+ (match? (car pattern) (car text))
+ (match? (cdr pattern) (cdr text)))))
+
+ (define (search text)
+ (if (match? pattern text)
+ (list text)
+ (let loop ((text* text)
+ (frobs '()))
+ (cond ((not (pair? text*))
+ frobs)
+ ((search (car text*))
+ => (lambda (x) (loop (cdr text*) (append! frobs x))))
+ (else (loop (cdr text*) frobs))))))
+
+ (set! *finds* (search program))
+ *finds*)
+
+(define *finds*)
+
+(define (find pattern #!optional program)
+ (find-all pattern (if (default-object? program)
+ *current-phase-input*
+ program))
+ (if (null? *finds*)
+ #F
+ (car *finds*)))
+
+(define (find* pattern #!optional program)
+ (find-all pattern (if (default-object? program)
+ *current-phase-input*
+ program))
+ *finds*)
+
+(define (refind)
+ (if (or (not *finds*)
+ (null? (cdr *finds*)))
+ #F
+ (begin (set! *finds* (cdr *finds*))
+ (car *finds*))))
+
+
+(define (parents expr #!optional program)
+ ;; EQ? parents of an expression
+ (define (find text)
+ (if (pair? text)
+ (apply
+ append
+ (if (there-exists? text (lambda (x) (eq? x expr)))
+ (list text)
+ '())
+ (map find text))
+ '()))
+ (find (if (default-object? program)
+ *current-phase-input*
+ program)))
+\f
+;;;
+;;; Local Variables:
+;;; eval: (put 'graph/for-each-node 'scheme-indent-function 1)
+;;; eval: (put 'node-set/for-each 'scheme-indent-function 1)
+;;; End:
+;;;
+;;; Edwin variables:
+;;; End:
+;;;
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+(define-structure (new-dbg-expression
+ (conc-name new-dbg-expression/)
+ (constructor new-dbg-expression/make (expr)))
+ (expr false read-only true)
+ (block false read-only false))
+
+(define-structure (new-dbg-procedure
+ (conc-name new-dbg-procedure/)
+ (constructor new-dbg-procedure/make (lam-expr lambda-list))
+ (constructor new-dbg-procedure/%make))
+ (lam-expr false read-only true)
+ (lambda-list false read-only true)
+ (block false read-only false))
+
+(define (new-dbg-procedure/copy dbg-proc)
+ (new-dbg-procedure/%make (new-dbg-procedure/lam-expr dbg-proc)
+ (new-dbg-procedure/lambda-list dbg-proc)
+ (new-dbg-procedure/block dbg-proc)))
+
+(define-structure (new-dbg-continuation
+ (conc-name new-dbg-continuation/)
+ (constructor new-dbg-continuation/make (type outer inner)))
+ (type false read-only true)
+ (outer false read-only true)
+ (inner false read-only true)
+ (block false read-only false))
+
+(define-structure (new-dbg-variable
+ (conc-name new-dbg-variable/)
+ (constructor new-dbg-variable/make (name block)))
+ (name false read-only true)
+ (original-name name read-only true)
+ (block false read-only false)
+ (original-block block read-only false)
+ (offset false read-only false)
+ (extra false read-only false))
+
+(define-structure (new-dbg-block
+ (conc-name new-dbg-block/)
+ (constructor new-dbg-block/make (type parent)))
+ (type false read-only false)
+ (variables '() read-only false)
+ (parent false read-only false)
+ (flattened false read-only false))
+
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: debug.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Useful debugging syntax
+
+(declare (usual-integrations))
+\f
+(syntax-table-define (repl/syntax-table (nearest-repl)) 'SHOW
+ (macro (form)
+ `(kmp/pp
+ (%compile-proc ',(eval (list 'quasiquote form)
+ (repl/environment (nearest-repl)))))))
+
+(syntax-table-define (repl/syntax-table (nearest-repl)) 'SHOW-RTL
+ (macro (form)
+ `(for-each
+ pp
+ (%compile-proc/rtl ',(eval (list 'quasiquote form)
+ (repl/environment (nearest-repl)))))))
+
+(syntax-table-define (repl/syntax-table (nearest-repl)) 'RUN
+ (macro (form)
+ `(execute (%compile-proc ',(eval (list 'quasiquote form)
+ (repl/environment (nearest-repl))))
+ (the-environment))))
+
+(syntax-table-define (repl/syntax-table (nearest-repl)) '%COMPILE
+ (macro (form)
+ `(%compile-proc
+ ',(eval (list 'quasiquote form)
+ (repl/environment (nearest-repl))))))
+
+(define %compile-proc
+ (lambda (form)
+ (compile
+ (compile/syntax form))))
+
+(define %compile-proc/rtl
+ (lambda (form)
+ (source->rtl
+ (compile/syntax form))))
+
+(define (compile/syntax form)
+ (syntax form (repl/syntax-table (nearest-repl))))
+
+(define &+ (make-primitive-procedure '&+))
+(define &- (make-primitive-procedure '&-))
+(define &* (make-primitive-procedure '&*))
+(define &/ (make-primitive-procedure '&/))
+(define &= (make-primitive-procedure '&=))
+(define &< (make-primitive-procedure '&<))
+(define &> (make-primitive-procedure '&>))
+\f
+#|
+
+(show (let ()
+ (define fib
+ (lambda (n)
+ (cond ((< n 0)
+ (bkpt "Fib" n))
+ ((< n 2)
+ n)
+ (else
+ (+ (fib (- n 1)) (fib (- n 2)))))))
+ (fib 6)))
+
+(show (let ()
+ (define fib
+ (lambda (n)
+ (cond ((,&< n 2)
+ n)
+ (else
+ (,&+ (fib (,&- n 1)) (fib (,&- n 2)))))))
+ fib))
+
+(show (let ()
+ (define fib
+ (lambda (n)
+ (cond ((,fix:< n 2)
+ n)
+ (else
+ (,fix:+ (fib (,fix:- n 1)) (fib (,fix:- n 2)))))))
+ fib))
+
+(show (define (smemq el l)
+ (define (phase-1 l1 l2)
+ (cond ((,not (,pair? l1)) ,false)
+ ((,eq? el (,car l1)) l1)
+ (else
+ (phase-2 (,cdr l1) l2))))
+
+ (define (phase-2 l1 l2)
+ (cond ((,not (,pair? l1)) ,false)
+ ((,eq? el (,car l1)) l1)
+ ((,eq? l1 l2) ,false)
+ (else
+ (phase-1 (,cdr l1) (,cdr l2)))))
+
+ (phase-1 l l)))
+
+(show (lambda (x)
+ (letrec ((foo (lambda () (bar x)))
+ (bar (lambda (z) (,+ z (foo)))))
+ bar)))
+
+(show (lambda (x y)
+ (if (and x (foo y))
+ (foo y)
+ (foo x))))
+
+(define (simplify/open-code? value name)
+ false)
+
+(show (lambda (x)
+ (let ((foo (lambda (y z) (,+ y z))))
+ (foo x (foo x (foo x x))))))
+
+(show (lambda (x y q w)
+ (let* ((z (foo y q x))
+ (t (foo x y w))
+ (h (foo z t y)))
+ (bar h z q))))
+
+(show (lambda (x y q w)
+ (let* ((z (foo y q x))
+ (t (foo x y w))
+ (h (foo z t y))
+ (l (foo h t w)))
+ (bar l z q))))
+
+(show (lambda (x y z w q)
+ (foo x y z)
+ (foo y z w)
+ (foo z w q)
+ (foo w q x)
+ (foo q x y)))
+
+(show (lambda (n)
+ (do ((i 0 (,+ i 1))
+ (fn 0 fn+1)
+ (fn+1 1 (,+ fn fn+1)))
+ ((,= i n) fn))))
+
+(show (lambda (ol)
+ (define (loop l accum)
+ (cond ((,pair? l)
+ (loop (,cdr l) (,cons (,car l) accum)))
+ ((,null? l)
+ accum)
+ (else
+ (error "Not a list" ol))))
+ (loop ol '())))
+
+(show (if (foo)
+ 23
+ (let ((y (bar)))
+ (lambda (x)
+ (,fix:- x y)))))
+
+(show (define (foo x)
+ (let loop ((x x))
+ (let ((y (,cons x x)))
+ (loop (,car y))))))
+
+(show (define (foo x n)
+ (let loop ((x x)
+ (n n))
+ (if (,not (,fix:> n 0))
+ x
+ (let ((y (,cons x x)))
+ (loop (,car y)
+ (,fix:- n 1)))))))
+
+|#
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: earlyrew.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Early generic arithmetic rewrite
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (earlyrew/top-level program)
+ (earlyrew/expr program))
+
+(define-macro (define-early-rewriter keyword bindings . body)
+ (let ((proc-name (symbol-append 'EARLYREW/ keyword)))
+ (call-with-values
+ (lambda () (%matchup bindings '(handler) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,names ,@body)))
+ (named-lambda (,proc-name form)
+ (earlyrew/remember ,code form))))))))
+
+(define-early-rewriter LOOKUP (name)
+ `(LOOKUP ,name))
+
+(define-early-rewriter LAMBDA (lambda-list body)
+ `(LAMBDA ,lambda-list
+ ,(earlyrew/expr body)))
+
+(define-early-rewriter CALL (rator cont #!rest rands)
+ (define (default)
+ `(CALL ,(earlyrew/expr rator)
+ ,(earlyrew/expr cont)
+ ,@(earlyrew/expr* rands)))
+ (cond ((and (QUOTE/? rator)
+ (rewrite-operator/early? (quote/text rator)))
+ => (lambda (handler)
+ (if (not (equal? cont '(QUOTE #F)))
+ (internal-error "Early rewrite done after CPS conversion?"
+ cont))
+ (apply handler (earlyrew/expr* rands))))
+ (else
+ (default))))
+
+(define-early-rewriter LET (bindings body)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (earlyrew/expr (cadr binding))))
+ bindings)
+ ,(earlyrew/expr body)))
+
+(define-early-rewriter LETREC (bindings body)
+ `(LETREC ,(lmap (lambda (binding)
+ (list (car binding)
+ (earlyrew/expr (cadr binding))))
+ bindings)
+ ,(earlyrew/expr body)))
+
+(define-early-rewriter QUOTE (object)
+ `(QUOTE ,object))
+
+(define-early-rewriter DECLARE (#!rest anything)
+ `(DECLARE ,@anything))
+
+(define-early-rewriter BEGIN (#!rest actions)
+ `(BEGIN ,@(earlyrew/expr* actions)))
+
+(define-early-rewriter IF (pred conseq alt)
+ `(IF ,(earlyrew/expr pred)
+ ,(earlyrew/expr conseq)
+ ,(earlyrew/expr alt)))
+\f
+(define (earlyrew/expr expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (earlyrew/quote expr))
+ ((LOOKUP)
+ (earlyrew/lookup expr))
+ ((LAMBDA)
+ (earlyrew/lambda expr))
+ ((LET)
+ (earlyrew/let expr))
+ ((DECLARE)
+ (earlyrew/declare expr))
+ ((CALL)
+ (earlyrew/call expr))
+ ((BEGIN)
+ (earlyrew/begin expr))
+ ((IF)
+ (earlyrew/if expr))
+ ((LETREC)
+ (earlyrew/letrec expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (earlyrew/expr* exprs)
+ (lmap (lambda (expr)
+ (earlyrew/expr expr))
+ exprs))
+
+(define (earlyrew/remember new old)
+ (code-rewrite/remember new old))
+
+(define (earlyrew/new-name prefix)
+ (new-variable prefix))
+\f
+(define *early-rewritten-operators*
+ (make-eq-hash-table 311))
+
+(define-integrable (rewrite-operator/early? rator)
+ (hash-table/get *early-rewritten-operators* rator false))
+
+(define (define-rewrite/early operator-name-or-object handler)
+ (hash-table/put! *early-rewritten-operators*
+ (if (hash-table/get *operator-properties*
+ operator-name-or-object
+ false)
+ operator-name-or-object
+ (make-primitive-procedure operator-name-or-object))
+ handler))
+
+(define (earlyrew/number? form)
+ (and (QUOTE/? form)
+ (number? (quote/text form))
+ (quote/text form)))
+
+(define (earlyrew/nothing-special x y)
+ x y ; ignored
+ false)
+\f
+(define (earlyrew/binaryop op &op-name %fixop %genop n-bits
+ #!optional opt-x opt-y right-sided?)
+ (let ((&op (make-primitive-procedure &op-name))
+ (optimize-x (if (default-object? opt-x)
+ earlyrew/nothing-special
+ opt-x))
+ (optimize-y (if (default-object? opt-y)
+ earlyrew/nothing-special
+ opt-y))
+ (right-sided? (if (default-object? right-sided?)
+ false
+ right-sided?))
+ (%test (if (zero? n-bits)
+ (lambda (name)
+ `(CALL (QUOTE ,%machine-fixnum?)
+ (QUOTE #F)
+ (LOOKUP ,name)))
+ (lambda (name)
+ `(CALL (QUOTE ,%small-fixnum?)
+ (QUOTE #F)
+ (LOOKUP ,name)
+ (QUOTE ,n-bits)))))
+ (test (if (zero? n-bits)
+ machine-fixnum?
+ (lambda (value)
+ (small-fixnum? value n-bits)))))
+ (lambda (x y)
+ (cond ((earlyrew/number? x)
+ => (lambda (x-value)
+ (cond ((earlyrew/number? y)
+ => (lambda (y-value)
+ `(QUOTE ,(op x-value y-value))))
+ ((optimize-x x-value y))
+ ((not (test x-value))
+ `(CALL (QUOTE ,%genop)
+ (QUOTE #F)
+ (QUOTE ,x-value)
+ ,y))
+ ((not *earlyrew-expand-genarith?*)
+ `(CALL (QUOTE ,&op)
+ (QUOTE #F)
+ (QUOTE ,x-value)
+ ,y))
+ (right-sided?
+ `(CALL (QUOTE ,%genop)
+ (QUOTE #F)
+ (QUOTE ,x-value)
+ ,y))
+ (else
+ (let ((y-name (earlyrew/new-name 'Y)))
+ `(CALL (LAMBDA (,y-name)
+ (IF ,(%test y-name)
+ (CALL (QUOTE ,%fixop)
+ (QUOTE #F)
+ (QUOTE ,x-value)
+ (LOOKUP ,y-name))
+ (CALL (QUOTE ,%genop)
+ (QUOTE #F)
+ (QUOTE ,x-value)
+ (LOOKUP ,y-name))))
+ ,y))))))
+\f
+ ((earlyrew/number? y)
+ => (lambda (y-value)
+ (cond ((optimize-y x y-value))
+ ((not (test y-value))
+ `(CALL (QUOTE ,%genop)
+ (QUOTE #F)
+ ,x
+ (QUOTE ,y-value)))
+ ((not *earlyrew-expand-genarith?*)
+ `(CALL (QUOTE ,&op)
+ (QUOTE #F)
+ ,x
+ (QUOTE ,y-value)))
+ (else
+ (let ((x-name (earlyrew/new-name 'X)))
+ `(CALL (LAMBDA (,x-name)
+ (IF ,(%test x-name)
+ (CALL (QUOTE ,%fixop)
+ (QUOTE #F)
+ (LOOKUP ,x-name)
+ (QUOTE ,y-value))
+ (CALL (QUOTE ,%genop)
+ (QUOTE #F)
+ (LOOKUP ,x-name)
+ (QUOTE ,y-value))))
+ ,x))))))
+ ((not *earlyrew-expand-genarith?*)
+ `(CALL (QUOTE ,&op) (QUOTE #F) ,x ,y))
+ (right-sided?
+ `(CALL (QUOTE ,%genop) (QUOTE #F) ,x ,y))
+ (else
+ (let ((x-name (earlyrew/new-name 'X))
+ (y-name (earlyrew/new-name 'Y)))
+ (bind* (list x-name y-name)
+ (list x y)
+ `(IF ,(andify (%test x-name) (%test y-name))
+ (CALL (QUOTE ,%fixop)
+ (LOOKUP ,x-name)
+ (LOOKUP ,y-name))
+ (CALL (QUOTE ,%genop)
+ (LOOKUP ,x-name)
+ (LOOKUP ,y-name))))))))))
+\f
+(define-rewrite/early '&+
+ (earlyrew/binaryop + '&+ fix:+ %+ 1
+ (lambda (x-value y)
+ (and (zero? x-value)
+ y))
+ (lambda (x y-value)
+ (and (zero? y-value)
+ x))))
+
+(define-rewrite/early '&-
+ (earlyrew/binaryop - '&- fix:- %- 1
+ earlyrew/nothing-special
+ (lambda (x y-value)
+ (and (zero? y-value)
+ x))))
+
+(define-rewrite/early 'QUOTIENT
+ ;; quotient can overflow only when dividing by 0 or -1.
+ ;; When dividing by -1 it can only overflow when the value is the
+ ;; most negative fixnum (-2^(word-size-1))
+ (earlyrew/binaryop careful/quotient 'QUOTIENT fix:quotient %quotient 1
+ (lambda (x-value y)
+ y ; ignored
+ (and (zero? x-value) `(QUOTE 0)))
+ (lambda (x y-value)
+ (cond ((zero? y-value)
+ (user-error "quotient: Division by zero"
+ x y-value))
+ ((= y-value 1)
+ x)
+ ((= y-value -1)
+ (earlyrew/negate x))
+ (else
+ false)))
+ true))
+
+(define-rewrite/early 'REMAINDER
+ (earlyrew/binaryop careful/remainder 'REMAINDER fix:remainder %remainder 0
+ (lambda (x-value y)
+ y ; ignored
+ (and (zero? x-value) `(QUOTE 0)))
+ (lambda (x y-value)
+ (cond ((zero? y-value)
+ (user-error "remainder: Division by zero"
+ x y-value))
+ ((or (= y-value 1) (= y-value -1))
+ `(QUOTE 0))
+ (else
+ false)))
+ true))
+
+(define earlyrew/negate
+ (let ((&- (make-primitive-procedure '&-)))
+ (lambda (z)
+ ;; z is assumed to be non-constant
+ (if *earlyrew-expand-genarith?*
+ (let ((z-name (earlyrew/new-name 'Z)))
+ `(CALL (LAMBDA (,z-name)
+ (IF (CALL (QUOTE ,%small-fixnum?)
+ (QUOTE #F)
+ (LOOKUP ,z-name)
+ (QUOTE 1))
+ (CALL (QUOTE ,fix:-)
+ (QUOTE #F)
+ (QUOTE 0)
+ (LOOKUP ,z-name))
+ (CALL (QUOTE ,%-)
+ (QUOTE #F)
+ (QUOTE 0)
+ (LOOKUP ,z-name))))
+ ,z))
+ `(CALL (QUOTE ,&-) (QUOTE #F) (QUOTE 0) ,z)))))
+\f
+(define-rewrite/early '&*
+ (let ((&* (make-primitive-procedure '&*)))
+ (lambda (x y)
+ (cond ((earlyrew/number? x)
+ => (lambda (x-value)
+ (cond ((earlyrew/number? y)
+ => (lambda (y-value)
+ `(QUOTE ,(* x-value y-value))))
+ ((zero? x-value)
+ `(QUOTE 0))
+ ((= x-value 1)
+ y)
+ ((= x-value -1)
+ (earlyrew/negate y))
+ ((good-factor? x-value)
+ (if (not *earlyrew-expand-genarith?*)
+ `(CALL (QUOTE ,&*) (QUOTE #F) (QUOTE ,x-value) ,y)
+ (let ((y-name (earlyrew/new-name 'Y))
+ (n-bits (good-factor->nbits x-value)))
+ `(CALL
+ (LAMBDA (,y-name)
+ (IF (CALL (QUOTE ,%small-fixnum?)
+ (QUOTE #F)
+ (LOOKUP ,y-name)
+ (QUOTE ,n-bits))
+ (CALL (QUOTE ,fix:*)
+ (QUOTE #F)
+ (QUOTE ,x-value)
+ (LOOKUP ,y-name))
+ (CALL (QUOTE ,%*)
+ (QUOTE #F)
+ (QUOTE ,x-value)
+ (LOOKUP ,y-name))))
+ ,y))))
+ (else
+ `(CALL (QUOTE ,%*) (QUOTE #F) (QUOTE ,x-value) ,y)))))
+ ((earlyrew/number? y)
+ => (lambda (y-value)
+ (cond ((zero? y-value)
+ `(QUOTE 0))
+ ((= y-value 1)
+ x)
+ ((= y-value -1)
+ (earlyrew/negate x))
+ ((good-factor? y-value)
+ (if (not *earlyrew-expand-genarith?*)
+ `(CALL (QUOTE ,&*) (QUOTE #F) ,x (QUOTE ,y-value))
+ (let ((x-name (earlyrew/new-name 'X))
+ (n-bits (good-factor->nbits y-value)))
+ (bind x-name x
+ `(IF (CALL (QUOTE ,%small-fixnum?)
+ (QUOTE #F)
+ (LOOKUP ,x-name)
+ (QUOTE ,n-bits))
+ (CALL (QUOTE ,fix:*)
+ (QUOTE #F)
+ (LOOKUP ,x-name)
+ (QUOTE ,y-value))
+ (CALL (QUOTE ,%*)
+ (QUOTE #F)
+ (LOOKUP ,x-name)
+ (QUOTE ,y-value)))))))
+ (else
+ `(CALL (QUOTE ,%*) (QUOTE #F) ,x (QUOTE ,y-value))))))
+ (else
+ `(CALL (QUOTE ,%*) (QUOTE #F) ,x ,y))))))
+\f
+;; NOTE: these could use 0 as the number of bits, but this would prevent
+;; a common RTL-level optimization triggered by CSE.
+
+(define-rewrite/early '&= (earlyrew/binaryop = '&= fix:= %= 1))
+(define-rewrite/early '&< (earlyrew/binaryop < '&< fix:< %< 1))
+(define-rewrite/early '&> (earlyrew/binaryop > '&> fix:> %> 1))
+
+(define-rewrite/early '&/
+ (lambda (x y)
+ (cond ((earlyrew/number? x)
+ => (lambda (x-value)
+ (cond ((earlyrew/number? y)
+ => (lambda (y-value)
+ `(QUOTE ,(careful// x-value y-value))))
+ ((zero? x-value)
+ `(QUOTE 0))
+ (else
+ `(CALL (QUOTE ,%/) (QUOTE #F) (QUOTE ,x-value) ,y)))))
+ ((earlyrew/number? y)
+ => (lambda (y-value)
+ (cond ((zero? y-value)
+ (user-error "/: Division by zero" x y-value))
+ ((= y-value 1)
+ x)
+ ((= y-value -1)
+ (earlyrew/negate x))
+ (else
+ `(CALL (QUOTE ,%/) (QUOTE #F) ,x (QUOTE ,y-value))))))
+ (else
+ `(CALL (QUOTE ,%/) (QUOTE #F) ,x ,y)))))
+\f
+;;;; Rewrites of unary operations in terms of binary operations
+
+(let ((unary-rewrite
+ (lambda (binary-name rand2)
+ (let ((binary-operation (make-primitive-procedure binary-name)))
+ (lambda (rand1)
+ ((rewrite-operator/early? binary-operation)
+ rand1
+ `(QUOTE ,rand2))))))
+ (special-rewrite
+ (lambda (binary-name rand2)
+ (let ((binary-operation (make-primitive-procedure binary-name)))
+ (lambda (rand1)
+ `(CALL (QUOTE ,binary-operation)
+ (QUOTE #F)
+ ,rand1
+ (QUOTE ,rand2))))))
+ (special-rewrite/left
+ (lambda (binary-name rand1)
+ (let ((binary-operation (make-primitive-procedure binary-name)))
+ (lambda (rand2)
+ `(CALL (QUOTE ,binary-operation)
+ (QUOTE #F)
+ (QUOTE ,rand1)
+ ,rand2))))))
+
+ (define-rewrite/early 'ZERO? (unary-rewrite '&= 0))
+ (define-rewrite/early 'POSITIVE? (unary-rewrite '&> 0))
+ (define-rewrite/early 'NEGATIVE? (unary-rewrite '&< 0))
+ (define-rewrite/early '1+ (unary-rewrite '&+ 1))
+ (define-rewrite/early '-1+ (unary-rewrite '&- 1))
+
+ (define-rewrite/early 'ZERO-FIXNUM?
+ (special-rewrite 'EQUAL-FIXNUM? 0))
+ (define-rewrite/early 'NEGATIVE-FIXNUM?
+ (special-rewrite 'LESS-THAN-FIXNUM? 0))
+ (define-rewrite/early 'POSITIVE-FIXNUM?
+ (special-rewrite 'GREATER-THAN-FIXNUM? 0))
+ (define-rewrite/early 'ONE-PLUS-FIXNUM
+ (special-rewrite 'PLUS-FIXNUM 1))
+ (define-rewrite/early 'MINUS-ONE-PLUS-FIXNUM
+ (special-rewrite 'MINUS-FIXNUM 1))
+
+ (define-rewrite/early 'FLONUM-ZERO? (special-rewrite 'FLONUM-EQUAL? 0.))
+ (define-rewrite/early 'FLONUM-NEGATIVE? (special-rewrite 'FLONUM-LESS? 0.))
+ (define-rewrite/early 'FLONUM-POSITIVE? (special-rewrite 'FLONUM-GREATER? 0.))
+
+ (define-rewrite/early 'FLONUM-NEGATE
+ (special-rewrite/left 'FLONUM-SUBTRACT 0.)))
+
+#|
+;; Some machines have an ABS instruction.
+;; This should be enabled according to the back end.
+
+(define-rewrite/early 'FLONUM-ABS
+ (let ((flo:> (make-primitive-procedure 'FLONUM-GREATER?))
+ (flo:- (make-primitive-procedure 'FLONUM-SUBTRACT)))
+ (lambda (x)
+ (let ((x-name (earlyrew/new-name 'X)))
+ (bind x-name x
+ `(IF (CALL (QUOTE ,flo:>) (QUOTE #F) (QUOTE 0.) (LOOKUP ,x-name))
+ (CALL (QUOTE ,flo:-) (QUOTE #F) (QUOTE 0.) (LOOKUP ,x-name))
+ (LOOKUP ,x-name)))))))
+|#
+\f
+;;;; *** Special, for now ***
+;; This is done this way because of current rtl generator
+
+(let ((allocation-rewriter
+ (lambda (name out-of-line)
+ (let ((primitive (make-primitive-procedure name)))
+ (lambda (size)
+ (let ((default
+ (lambda ()
+ `(CALL (QUOTE ,out-of-line) (QUOTE #F) ,size))))
+ (cond ((earlyrew/number? size)
+ => (lambda (nbytes)
+ (if (not (exact-nonnegative-integer? nbytes))
+ (default)
+ `(CALL (QUOTE ,primitive) (QUOTE #F) ,size))))
+ (else
+ (default)))))))))
+ (define-rewrite/early 'STRING-ALLOCATE
+ (allocation-rewriter 'STRING-ALLOCATE %string-allocate))
+ (define-rewrite/early 'FLOATING-VECTOR-CONS
+ (allocation-rewriter 'FLOATING-VECTOR-CONS %floating-vector-cons)))
+
+;; *** This can be improved by using %vector-allocate,
+;; and a non-marked header moved through the vector as it is filled. ***
+
+(define-rewrite/early 'VECTOR-CONS
+ (let ((primitive (make-primitive-procedure 'VECTOR-CONS)))
+ (lambda (size fill)
+ (define (default)
+ `(CALL (QUOTE ,%vector-cons) (QUOTE #F) ,size ,fill))
+ (cond ((earlyrew/number? size)
+ => (lambda (nbytes)
+ (if (or (not (exact-nonnegative-integer? nbytes))
+ (> nbytes *vector-cons-max-open-coded-length*))
+ (default)
+ `(CALL (QUOTE ,primitive) (QUOTE #F) ,size ,fill))))
+ (else
+ (default))))))
+
+
+(define-rewrite/early 'GENERAL-CAR-CDR
+ (let ((prim-general-car-cdr (make-primitive-procedure 'GENERAL-CAR-CDR))
+ (prim-car (make-primitive-procedure 'CAR))
+ (prim-cdr (make-primitive-procedure 'CDR)))
+ (lambda (term pattern)
+ (define (default)
+ `(CALL (QUOTE ,prim-general-car-cdr) (QUOTE #f) ,term ,pattern))
+ (cond ((earlyrew/number? pattern)
+ => (lambda (pattern)
+ (if (and (integer? pattern) (> pattern 0))
+ (let walk-bits ((num pattern)
+ (text term))
+ (if (= num 1)
+ text
+ (walk-bits (quotient num 2)
+ `(CALL (QUOTE ,(if (odd? num)
+ prim-car
+ prim-cdr))
+ (QUOTE #f)
+ ,text))))
+ (default))))
+ (else (default))))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: envconv.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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 Converter
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+;; ENVCONV replaces instances of
+;; (LOOKUP <name>)
+;; where <name> is bound in a reified frame with either of
+;; 1.
+;; (CALL (QUOTE ,%*lookup) (QUOTE #F) (LOOKUP ,env-variable)
+;; (QUOTE <name>) (QUOTE <depth>) (QUOTE <offset>))
+;; where <depth> and <offset> represent the lexical address of the binding
+;; of <name> from the referencing frame.
+;; 2.
+;; (CALL (QUOTE ,%variable-cache-ref) (QUOTE #F)
+;; (LOOKUP <cache-name>) (QUOTE <name>))
+;; where <cache-name> is a new variable bound to
+;; (CALL (QUOTE ,%make-read-variable-cache) (QUOTE #F)
+;; (LOOKUP ,env-variable) (QUOTE <name>))
+;;
+;; (UNASSIGNED? <name>), (SET! <name> <value>), and (CALL (LOOKUP <name>) ...)
+;; are translated simiarly
+;;
+;; Variable references to variables bound in reified frames are considered
+;; captured by closest reified frame to the frame in which the reference
+;; occurs. References to such captured variables may be implemented using
+;; calls or variable caches.
+;; The environment optimization level determines which of these frames
+;; use variable cells:
+;; A. If LOW, none.
+;; B. If MEDIUM, only those whose context is TOP-LEVEL. (maybe ONCE-ONLY too?)
+;; C. If HIGH, all.
+
+;; Parameters
+
+(define envconv/optimization-level 'MEDIUM)
+(define envconv/variable-caches-must-be-static? true)
+(define envconv/top-level-name (intern "#[top-level]"))
+
+(define *envconv/compile-by-procedures?* false)
+(define *envconv/procedure-result?* false)
+(define *envconv/copying?*)
+(define *envconv/separate-queue*)
+(define *envconv/top-level-program*)
+(define *envconv/debug/walking-queue* #F)
+
+(define (envconv/top-level program)
+ (fluid-let ((*envconv/copying?* false)
+ (*envconv/separate-queue* '())
+ (*envconv/top-level-program* program))
+ (let ((result (envconv/trunk 'TOP-LEVEL program
+ (lambda (copy? program*)
+ copy? ; ignored
+ program*))))
+ (fluid-let ((*envconv/debug/walking-queue* #T))
+ (for-each envconv/do-compile!
+ (reverse *envconv/separate-queue*)))
+ result)))
+
+(define-macro (define-environment-converter keyword bindings . body)
+ (let ((proc-name (symbol-append 'ENVCONV/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name env form)
+ (envconv/remember ,code
+ form
+ (envconv/env/block env)))))))))
+\f
+;;;; Environment-sensitive forms
+
+(define-environment-converter LOOKUP (env name)
+ (envconv/new-reference env name `(LOOKUP ,name)))
+
+(define-environment-converter UNASSIGNED? (env name)
+ (envconv/new-reference env name `(UNASSIGNED? ,name)))
+
+(define-environment-converter SET! (env name value)
+ (let ((value* (envconv/expr-with-name env value name)))
+ (envconv/new-reference env name `(SET! ,name ,value*))))
+
+(define (envconv/lambda env form name)
+ (let ((form*
+ (let ((lambda-list (lambda/formals form))
+ (body (lambda/body form)))
+ (if (or (not (eq? (envconv/env/context env) 'TOP-LEVEL))
+ (not *envconv/compile-by-procedures?*)
+ *envconv/procedure-result?*
+ (eq? form *envconv/top-level-program*))
+ (envconv/lambda* 'ARBITRARY env lambda-list body)
+ (envconv/compile-separately form name true env)))))
+ (envconv/remember form*
+ form
+ (if (LAMBDA/? form*)
+ (let* ((body (lambda/body form*))
+ (body-info (code-rewrite/original-form body)))
+ (cond ((not body-info) false)
+ ((new-dbg-procedure? body-info)
+ (new-dbg-block/parent
+ (new-dbg-procedure/block body-info)))
+ (else
+ (new-dbg-expression/block body-info))))
+ (envconv/env/block env)))))
+
+
+(define (envconv/lambda* context* env lambda-list body)
+ (envconv/binding-body context*
+ env
+ (lambda-list->names lambda-list)
+ body
+ (lambda (body*)
+ `(LAMBDA ,lambda-list
+ ,body*))))
+
+(define-environment-converter LET (env bindings body)
+ (let ((bindings* (lmap (lambda (binding)
+ (list (car binding)
+ (envconv/expr env (cadr binding))))
+ bindings)))
+ (envconv/binding-body (let ((context (envconv/env/context env)))
+ (if (eq? context 'TOP-LEVEL)
+ 'ONCE-ONLY
+ context))
+ env
+ (lmap car bindings)
+ body
+ (lambda (body*)
+ `(LET ,bindings*
+ ,body*)))))
+\f
+;;;; Forms removed
+
+(define-environment-converter THE-ENVIRONMENT (env)
+ (envconv/env/reify! env)
+ `(LOOKUP ,(envconv/env/reified-name env)))
+
+(define-environment-converter ACCESS (env name envxpr)
+ (cond ((equal? envxpr `(THE-ENVIRONMENT))
+ (envconv/lookup env `(LOOKUP ,name)))
+ ;; The linker cannot currently hack this
+ ((envconv/package-reference? envxpr)
+ (envconv/package-lookup (envconv/package-name envxpr) name))
+ (else
+ `(CALL (QUOTE ,%*lookup)
+ (QUOTE #F)
+ ,(envconv/expr env envxpr)
+ (QUOTE ,name)
+ ;; No lexical information known
+ (QUOTE #f)
+ (QUOTE #f)))))
+
+(define-environment-converter DEFINE (env name value)
+ (let ((value* (envconv/expr-with-name env value name)))
+ (cond ((not (envconv/env/parent env))
+ ;; Incremental at top-level
+ (envconv/env/reify! env)
+ `(CALL (QUOTE ,%*define)
+ (QUOTE #F)
+ (LOOKUP ,(envconv/env/reified-name env))
+ (QUOTE ,name)
+ ,value*))
+ ((envconv/env/locally-bound? env name)
+ (envconv/new-reference env name `(SET! ,name ,value*)))
+ (else
+ (internal-error "Unscanned definition encountered"
+ `(DEFINE ,name ,value))))))
+
+#|
+ (define-environment-converter IN-PACKAGE (env envxpr bodyxpr)
+ (if (equal? envxpr `(THE-ENVIRONMENT))
+ (envconv/expr env bodyxpr)
+ (envconv/trunk/new (envconv/env/context env)
+ (envconv/expr env envxpr)
+ bodyxpr)))
+|#
+
+(define-environment-converter IN-PACKAGE (env env-expr body-expr)
+ (if (equal? env-expr `(THE-ENVIRONMENT))
+ (envconv/expr env body-expr)
+ (envconv/split-subprogram
+ (or (eq? (envconv/env/context env) 'ARBITRARY)
+ *envconv/copying?*)
+ body-expr
+ (envconv/expr env env-expr))))
+\f
+;;;; Environment-insensitive forms
+
+;; CALL is conceptually insensitive, but common cases are optimized.
+
+(define-environment-converter CALL (env rator cont #!rest rands)
+ (define (default)
+ `(CALL ,(if (LAMBDA/? rator)
+ (envconv/remember
+ (envconv/lambda*
+ (if (eq? (envconv/env/context env) 'ARBITRARY)
+ 'ARBITRARY
+ 'ONCE-ONLY)
+ env (lambda/formals rator) (lambda/body rator))
+ rator
+ (envconv/env/block env))
+ (envconv/expr env rator))
+
+ ,(envconv/expr env cont)
+ ,@(envconv/expr* env rands)))
+
+ (cond ((LOOKUP/? rator)
+ (let ((name (lookup/name rator)))
+ (envconv/new-reference
+ env
+ name
+ `(CALL ,(envconv/remember `(LOOKUP ,name)
+ rator
+ (envconv/env/block env))
+ ,(envconv/expr env cont)
+ ,@(envconv/expr* env rands)))))
+ ((ACCESS/? rator)
+ (if (not (envconv/package-reference? (access/env-expr rator)))
+ (default)
+ (begin
+ (envconv/env/reify-top-level! env)
+ (envconv/new-reference
+ env
+ envconv/top-level-name
+ `(CALL ,(envconv/remember
+ `(ACCESS ,(access/name rator)
+ ,(envconv/expr env (access/env-expr rator)))
+ rator
+ (envconv/env/block env))
+ ,(envconv/expr env cont)
+ ,@(envconv/expr* env rands))))))
+ (else
+ (default))))
+
+(define-environment-converter BEGIN (env #!rest actions)
+ `(BEGIN ,@(envconv/expr* env actions)))
+
+(define-environment-converter IF (env pred conseq alt)
+ `(IF ,(envconv/expr env pred)
+ ,(envconv/expr env conseq)
+ ,(envconv/expr env alt)))
+
+(define-environment-converter OR (env pred alt)
+ `(OR ,(envconv/expr env pred)
+ ,(envconv/expr env alt)))
+
+(define-environment-converter DELAY (env expr)
+ `(DELAY ,(envconv/expr env expr)))
+\f
+(define-environment-converter QUOTE (env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-environment-converter DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+;;;; Dispatcher
+
+(define (envconv/expr-with-name env expr name)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (envconv/quote env expr))
+ ((LOOKUP)
+ (envconv/lookup env expr))
+ ((LAMBDA)
+ (envconv/lambda env expr name))
+ ((LET)
+ (envconv/let env expr))
+ ((DECLARE)
+ (envconv/declare env expr))
+ ((CALL)
+ (envconv/call env expr))
+ ((BEGIN)
+ (envconv/begin env expr))
+ ((IF)
+ (envconv/if env expr))
+ ((SET!)
+ (envconv/set! env expr))
+ ((UNASSIGNED?)
+ (envconv/unassigned? env expr))
+ ((OR)
+ (envconv/or env expr))
+ ((DELAY)
+ (envconv/delay env expr))
+ ((ACCESS)
+ (envconv/access env expr))
+ ((DEFINE)
+ (envconv/define env expr))
+ ((IN-PACKAGE)
+ (envconv/in-package env expr))
+ ((THE-ENVIRONMENT)
+ (envconv/the-environment env expr))
+ ((LETREC)
+ (not-yet-legal expr))
+ (else
+ (illegal expr))))
+
+(define (envconv/expr env expr)
+ (envconv/expr-with-name env expr #f))
+
+(define (envconv/expr* env exprs)
+ (lmap (lambda (expr)
+ (envconv/expr env expr))
+ exprs))
+\f
+(define (envconv/remember new old block)
+ (call-with-values
+ (lambda () (code-rewrite/original-form*/previous old))
+ (lambda (available? dbg-info)
+ (if available?
+ (if (new-dbg-procedure? dbg-info)
+ (begin
+ (if (not (new-dbg-procedure/block dbg-info))
+ (set-new-dbg-procedure/block! dbg-info block))
+ (code-rewrite/remember* new dbg-info))
+ (begin
+ (if (not (new-dbg-expression/block dbg-info))
+ (set-new-dbg-expression/block! dbg-info block))
+ (code-rewrite/remember* new dbg-info))))))
+ new)
+
+(define (envconv/split new old)
+ (let ((old* (code-rewrite/original-form old)))
+ (if old*
+ (code-rewrite/remember* new
+ (if (new-dbg-procedure? old*)
+ (new-dbg-procedure/copy old*)
+ old*)))
+ new))
+
+(define (envconv/new-name prefix)
+ (new-variable prefix))
+\f
+;;;; Environment utilities
+
+(define-structure (envconv/env
+ (conc-name envconv/env/)
+ (constructor envconv/env/%make (context parent block)))
+ (context false read-only true)
+ (reified-name false read-only false)
+ (depth (if parent
+ (1+ (envconv/env/depth parent))
+ 0)
+ read-only true)
+ (nearest-reified false read-only false)
+ (parent false read-only true)
+ (children '() read-only false)
+ (bindings '() read-only false)
+ (number 0 read-only false)
+ (captured '() read-only false)
+ (wrapper false read-only false)
+ (body false read-only false)
+ (result false read-only false)
+ (block false read-only false))
+
+(define-structure
+ (envconv/binding
+ (conc-name envconv/binding/)
+ (constructor envconv/binding/make (name env number))
+ (print-procedure
+ (standard-unparser-method 'ENVCONV/BINDING
+ (lambda (binding port)
+ (write-char #\space port)
+ (write-string (symbol-name (envconv/binding/name binding)) port)))))
+
+ (name false read-only true)
+ (env false read-only true)
+ (number false read-only true)
+ (references '() read-only false))
+
+(define-structure (envconv/separate-compilation-key
+ (conc-name envconv/key/)
+ (constructor envconv/key/make
+ (form name procedure? env)))
+ (form false read-only false) ; The form to compile later
+ (name false read-only false) ; Name, if any, for procedures
+ (procedure? false read-only false) ; Must generate a procedure?
+ (env false read-only false)) ; Environment when enqueued
+
+(define (envconv/env/make context parent)
+ (let ((env
+ (envconv/env/%make
+ context parent
+ (new-dbg-block/make (if (eq? context 'TOP-LEVEL)
+ 'FIRST-CLASS
+ 'NESTED)
+ (and parent
+ (envconv/env/block parent))))))
+ (if parent
+ (set-envconv/env/children! parent
+ (cons env (envconv/env/children parent))))
+ env))
+
+(define-integrable (envconv/env/reified? env)
+ (envconv/env/reified-name env))
+
+(define (envconv/env/reify! env)
+ (if (not (envconv/env/reified? env))
+ (let ((env-var (new-environment-variable)))
+ (set-envconv/env/reified-name! env env-var)
+ (let ((block (envconv/env/block env)))
+ (if block
+ (set-new-dbg-block/type! block 'FIRST-CLASS)))
+ (let ((parent (envconv/env/parent env)))
+ (and parent
+ (envconv/env/reify! parent))))))
+
+(define (envconv/env/reify-top-level! env)
+ (if (not (envconv/env/reified? env))
+ (let ((parent (envconv/env/parent env)))
+ (if (not parent)
+ (envconv/env/reify! env)
+ (envconv/env/reify-top-level! parent)))))
+
+(define (envconv/new-reference env name reference)
+ (let ((binding (envconv/env/lookup! env name)))
+ (set-envconv/binding/references!
+ binding
+ (cons (cons env reference)
+ (envconv/binding/references binding)))
+ reference))
+\f
+(define (envconv/env/lookup! env name)
+ (let spine-loop ((frame env) (frame* false))
+ (cond ((not frame)
+ (let* ((number (envconv/env/number frame*))
+ (binding (envconv/binding/make name frame* number)))
+ (set-envconv/env/number! frame* (1+ number))
+ (envconv/env/reify! frame*)
+ (set-envconv/env/bindings!
+ frame*
+ (cons binding (envconv/env/bindings frame*)))
+ binding))
+ ((envconv/env/lookup/local frame name))
+ (else
+ (spine-loop (envconv/env/parent frame) frame)))))
+
+(define (envconv/env/lookup/local env name)
+ (let rib-loop ((bindings (envconv/env/bindings env)))
+ (cond ((null? bindings)
+ false)
+ ((eq? name (envconv/binding/name (car bindings)))
+ (car bindings))
+ (else
+ (rib-loop (cdr bindings))))))
+
+(define (envconv/env/locally-bound? env name)
+ (envconv/env/lookup/local env name))
+
+#|
+(define (envconv/trunk/new context envcode program)
+ (envconv/trunk context program
+ (lambda (copy? program*)
+ (envconv/split-subprogram copy? program* envcode))))
+|#
+
+(define (envconv/trunk context program wrapper)
+ (let* ((copying* (or (eq? context 'ARBITRARY) *envconv/copying?*))
+ (env (envconv/env/make 'TOP-LEVEL #f))
+ (result (fluid-let ((*envconv/copying?* copying*))
+ (envconv/expr env program)))
+ (needs? (or (envconv/env/reified? env)
+ (not (null? (envconv/env/bindings env))))))
+ (envconv/process-root!
+ env
+ (envconv/env/setup!
+ env result
+ (lambda (result)
+ (wrapper copying*
+ (if (not needs?)
+ result
+ `(LET ((,(envconv/env/reified-name env)
+ (CALL (QUOTE ,%fetch-environment) (QUOTE #F))))
+ ,result))))))))
+\f
+(define (envconv/binding-body context* env names body body-wrapper)
+ (let* ((env* (envconv/env/make context* env))
+ (body*
+ (begin
+ (let loop ((number 0)
+ (names* names)
+ (bindings '()))
+ (if (null? names*)
+ (let ((block (envconv/env/block env*)))
+ (if block
+ (set-new-dbg-block/variables!
+ block
+ (map (lambda (name)
+ (new-dbg-variable/make name block))
+ names)))
+ (set-envconv/env/bindings! env* bindings)
+ (set-envconv/env/number! env* number))
+ (loop (1+ number)
+ (cdr names*)
+ (cons (envconv/binding/make (car names*) env* number)
+ bindings))))
+ (envconv/expr env* body))))
+ (envconv/env/setup!
+ env* body*
+ (if (not (envconv/env/reified? env*))
+ body-wrapper
+ (lambda (body*)
+ (body-wrapper
+ (envconv/bind-new-environment env* names body*)))))))
+
+(define (envconv/env/setup! env result wrapper)
+ (let ((result* (wrapper result)))
+ (set-envconv/env/body! env result)
+ (set-envconv/env/wrapper! env wrapper)
+ (set-envconv/env/result! env result*)
+ result*))
+
+(define (envconv/bind-new-environment env* names body*)
+ (bind (envconv/env/reified-name env*)
+ `(CALL (QUOTE ,%*make-environment)
+ (QUOTE #F)
+ (LOOKUP ,(envconv/env/reified-name (envconv/env/parent env*)))
+ (QUOTE ,(list->vector (cons lambda-tag:make-environment
+ names)))
+ ,@(lmap (lambda (name)
+ `(LOOKUP ,name))
+ names))
+ body*))
+
+(define (envconv/process-root! top-level-env top-level-program)
+ (if (envconv/env/reified? top-level-env)
+ (begin
+ (envconv/shorten-paths! top-level-env)
+ (envconv/capture! top-level-env)
+ (envconv/rewrite-references! top-level-env)))
+ top-level-program)
+\f
+(define (envconv/shorten-paths! env)
+ (set-envconv/env/nearest-reified!
+ env
+ (if (envconv/env/reified? env)
+ env
+ (envconv/env/nearest-reified (envconv/env/parent env))))
+ (for-each envconv/shorten-paths! (envconv/env/children env)))
+
+(define (envconv/capture! env)
+ (if (envconv/env/reified? env)
+ (begin
+ (for-each
+ (lambda (binding)
+ (let loop ((refs (envconv/binding/references binding)))
+ (if (not (null? refs))
+ (let* ((ref (car refs))
+ (env* (envconv/env/nearest-reified (car ref)))
+ (place (assq binding (envconv/env/captured env*))))
+ (if (not place)
+ (set-envconv/env/captured!
+ env*
+ (cons (list binding (cdr ref))
+ (envconv/env/captured env*)))
+ (set-cdr! place
+ (cons (cdr ref) (cdr place))))
+ (loop (cdr refs))))))
+ (envconv/env/bindings env))
+ (for-each envconv/capture! (envconv/env/children env)))))
+
+(define (envconv/rewrite-references! env)
+ (if (envconv/env/reified? env)
+ (begin
+ (if (not (null? (envconv/env/captured env)))
+ (let ((process-captures!
+ (case envconv/optimization-level
+ ((LOW) envconv/use-calls!)
+ ((MEDIUM)
+ (if (envconv/medium/cache? (envconv/env/context env))
+ envconv/use-caches!
+ envconv/use-calls!))
+ ((HIGH) envconv/use-caches!)
+ (else
+ (configuration-error "Illegal switch setting"
+ 'ENVCONV/OPTIMIZATION-LEVEL
+ envconv/optimization-level)))))
+ (process-captures! env)))
+ (for-each envconv/rewrite-references! (envconv/env/children env)))))
+
+(define (envconv/medium/cache? context)
+ (eq? context 'TOP-LEVEL))
+\f
+(define (envconv/use-calls! env)
+ (let ((env-name (envconv/env/reified-name env)))
+ (for-each
+ (lambda (capture)
+ (let ((binding (car capture)))
+ (let ((var-name (envconv/binding/name binding))
+ (binding-env (envconv/binding/env binding)))
+ (let* ((depth (and (envconv/env/parent binding-env)
+ (- (envconv/env/depth env)
+ (envconv/env/depth binding-env))))
+ (offset (and depth (envconv/binding/number binding))))
+ (for-each
+ (lambda (reference)
+ (let ((simple-var
+ (lambda ()
+ `(CALL (QUOTE ,%*lookup)
+ (QUOTE #f)
+ (LOOKUP ,env-name)
+ (QUOTE ,var-name)
+ (QUOTE ,depth)
+ (QUOTE ,offset)))))
+ (form/rewrite!
+ reference
+ (case (car reference)
+ ((LOOKUP)
+ (simple-var))
+ ((SET!)
+ `(CALL (QUOTE ,%*set!)
+ (QUOTE #F)
+ (LOOKUP ,env-name)
+ (QUOTE ,var-name)
+ (QUOTE ,depth)
+ (QUOTE ,offset)
+ ,(set!/expr reference)))
+ ((UNASSIGNED?)
+ `(CALL (QUOTE ,%*unassigned?)
+ (QUOTE #F)
+ (LOOKUP ,env-name)
+ (QUOTE ,var-name)
+ (QUOTE ,depth)
+ (QUOTE ,offset)))
+ ((CALL)
+ (let ((rator (call/operator reference)))
+ (case (car rator)
+ ((LOOKUP)
+ (form/rewrite! rator (simple-var)))
+ ((ACCESS)
+ ;; Only done for packages
+ (form/rewrite!
+ rator
+ (envconv/package-lookup
+ (envconv/package-name (access/env-expr rator))
+ (access/name rator))))
+ (else
+ (internal-error "Unknown reference kind"
+ reference))))
+ reference)
+ (else
+ (internal-error "Unknown reference kind"
+ reference))))))
+ (cdr capture))))))
+ (envconv/env/captured env))))
+\f
+(define (envconv/use-caches! env)
+ (let ((env-name (envconv/env/reified-name env)))
+ (define (local-operator-variable-cache-maker ignore name arity)
+ ignore ; ignored
+ `(CALL (QUOTE ,%make-operator-variable-cache)
+ (QUOTE #F)
+ (LOOKUP ,env-name)
+ (QUOTE ,name)
+ (QUOTE ,arity)))
+
+ (define (remote-operator-variable-cache-maker package-name name arity)
+ `(CALL (QUOTE ,%make-remote-operator-variable-cache)
+ (QUOTE #F)
+ (QUOTE ,package-name)
+ (QUOTE ,name)
+ (QUOTE ,arity)))
+
+ (define (read-variable-cache-maker name)
+ `(CALL (QUOTE ,%make-read-variable-cache)
+ (QUOTE #F)
+ (LOOKUP ,env-name)
+ (QUOTE ,name)))
+
+ (define (write-variable-cache-maker name)
+ `(CALL (QUOTE ,%make-write-variable-cache)
+ (QUOTE #F)
+ (LOOKUP ,env-name)
+ (QUOTE ,name)))
+
+ (define (new-cell! kind name maker)
+ (let ((place (assq name (cdr kind))))
+ (if place
+ (cadr place)
+ (let ((cell-name
+ (envconv/new-name (symbol-append name (car kind)))))
+ (declare-variable-property! cell-name '(VARIABLE-CELL))
+ (set-cdr! kind
+ (cons (list name cell-name (maker name))
+ (cdr kind)))
+ cell-name))))
+
+ (define (new-operator-cell! name arity refs by-arity maker extra)
+ (define (new-cell!)
+ (let ((cell-name
+ (envconv/new-name
+ (symbol-append name '-
+ (string->symbol (number->string arity))
+ (car refs)))))
+ (declare-variable-property! cell-name '(VARIABLE-CELL))
+ (set-cdr! refs
+ (cons (list name cell-name
+ (maker extra name arity))
+ (cdr refs)))
+ cell-name))
+ \f
+ (let ((place (assq name (cdr by-arity))))
+ (if (not place)
+ (let ((cell-name (new-cell!)))
+ (set-cdr! by-arity
+ (cons (list name (cons arity cell-name))
+ (cdr by-arity)))
+ cell-name)
+ (let ((place* (assq arity (cdr place))))
+ (if (not place*)
+ (let ((cell-name (new-cell!)))
+ (set-cdr! place
+ (cons (cons arity cell-name) (cdr place)))
+ cell-name)
+ (cdr place*))))))
+
+ (let ((read-refs (list '-READ-CELL))
+ (write-refs (list '-WRITE-CELL))
+ (exe-refs (list '-EXECUTE-CELL))
+ (exe-by-arity (list 'EXE-BY-ARITY))
+ (remote-exe-refs (list '-REMOTE-EXECUTE-CELL))
+ (remote-exe-by-package '()))
+
+ (for-each
+ (lambda (capture)
+ (let ((binding (car capture)))
+ (let ((var-name (envconv/binding/name binding)))
+ (for-each
+ (lambda (reference)
+ (form/rewrite!
+ reference
+ (case (car reference)
+ ((LOOKUP)
+ (let ((cell-name
+ (new-cell! read-refs var-name
+ read-variable-cache-maker)))
+ `(CALL (QUOTE ,%variable-cache-ref)
+ (QUOTE #F)
+ (LOOKUP ,cell-name)
+ (QUOTE ,var-name))))
+ ((SET!)
+ (let ((write-cell-name
+ (new-cell! write-refs var-name
+ write-variable-cache-maker))
+ (read-cell-name
+ (new-cell! read-refs var-name
+ read-variable-cache-maker))
+ (temp-name (envconv/new-name var-name)))
+ (bind temp-name
+ `(CALL (QUOTE ,%safe-variable-cache-ref)
+ (QUOTE #F)
+ (LOOKUP ,read-cell-name)
+ (QUOTE ,var-name))
+ `(BEGIN
+ (CALL (QUOTE ,%variable-cache-set!)
+ (QUOTE #F)
+ (LOOKUP ,write-cell-name)
+ ,(set!/expr reference)
+ (QUOTE ,var-name))
+ (LOOKUP ,temp-name)))))
+ ((UNASSIGNED?)
+ (let ((cell-name (new-cell! read-refs var-name
+ read-variable-cache-maker)))
+ `(CALL (QUOTE ,%unassigned?)
+ (QUOTE #F)
+ (CALL (QUOTE ,%safe-variable-cache-ref)
+ (QUOTE #F)
+ (LOOKUP ,cell-name)
+ (QUOTE ,var-name)))))
+ \f
+ ((CALL)
+ (let ((rator (call/operator reference)))
+ (define (operate %invoke name refs by-arity maker extra)
+ (let* ((arity (length (cdddr reference)))
+ (cell-name
+ (new-operator-cell!
+ name
+ arity
+ refs by-arity maker extra)))
+ (form/rewrite! rator `(LOOKUP ,cell-name))
+ `(CALL (QUOTE ,%invoke)
+ ,(call/continuation reference)
+ (QUOTE (,name ,arity))
+ ,rator
+ ,@(cdddr reference))))
+
+ (case (car rator)
+ ((LOOKUP)
+ (operate %invoke-operator-cache
+ var-name exe-refs exe-by-arity
+ local-operator-variable-cache-maker
+ false))
+ ((ACCESS)
+ (let ((package (envconv/package-name
+ (access/env-expr rator))))
+ (operate
+ %invoke-remote-cache
+ (access/name rator) remote-exe-refs
+ (or (assoc package remote-exe-by-package)
+ (let ((new (list package)))
+ (set! remote-exe-by-package
+ (cons new remote-exe-by-package))
+ new))
+ remote-operator-variable-cache-maker
+ package)))
+ (else
+ (internal-error "Unknown reference kind"
+ reference)))))
+ (else
+ (internal-error "Unknown reference kind"
+ reference)))))
+ (cdr capture)))))
+ (envconv/env/captured env))
+
+ ;; Rewrite top-level to bind caches, separately compile, and
+ ;; copy if necessary, according to context.
+ (form/rewrite! (envconv/env/result env)
+ ((envconv/env/wrapper env)
+ (envconv/wrap-with-cache-bindings
+ env
+ (append (cdr read-refs)
+ (cdr write-refs)
+ (cdr exe-refs)
+ (cdr remote-exe-refs))
+ (let ((form (envconv/env/body env)))
+ (envconv/split (form/preserve form)
+ form))))))))
+\f
+(define (envconv/wrap-with-cache-bindings env cells body)
+ (let ((body*
+ `(CALL (LAMBDA (,(new-continuation-variable) ,@(lmap cadr cells))
+ ,body)
+ (QUOTE #F)
+ ,@(lmap caddr cells))))
+ (if (or (eq? (envconv/env/context env) 'TOP-LEVEL)
+ (not envconv/variable-caches-must-be-static?))
+ body*
+ (envconv/split-subprogram
+ (eq? (envconv/env/context env) 'ARBITRARY)
+ `(LET ((,(envconv/env/reified-name env)
+ (CALL (QUOTE ,%fetch-environment) (QUOTE #F))))
+ ,body*)
+ `(LOOKUP ,(envconv/env/reified-name env))))))
+
+(define (envconv/split-subprogram copy? program envcode)
+ (let ((program* (envconv/compile-separately program #f #f #f)))
+ `(CALL (QUOTE ,%execute)
+ (QUOTE #F)
+ ,(if copy?
+ `(CALL (QUOTE ,%copy-program) (QUOTE #F) ,program*)
+ program*)
+ ,envcode)))
+
+(define (envconv/compile-separately form name procedure? env)
+ (let* ((form* `(QUOTE ,form))
+ (key (envconv/key/make form* name procedure? env)))
+ ;;(if *envconv/debug/walking-queue*
+ ;; (internal-error
+ ;; "ENVCONV/COMPILE-SEPARATELY: Walking queue" key))
+ (set! *envconv/separate-queue*
+ (cons key *envconv/separate-queue*))
+ form*))
+
+(define (envconv/do-compile! key)
+ ;; *** Worry about debugging info propagation ***
+ ;; It should not be difficult since it performs a single traversal
+ ;; through the compiler. However, the sequence of transforms
+ ;; needs to be collected and integrated into the current one.
+ ;; KEY is (form procedure? . name)
+ (let ((form (envconv/key/form key))
+ (procedure? (envconv/key/procedure? key))
+ (name (envconv/key/name key))
+ (env (envconv/key/env key)))
+ (call-with-values
+ (lambda ()
+ (compile-recursively (quote/text form) procedure? name))
+ (lambda (compiled must-be-called?)
+ (if must-be-called?
+ (let ((env-var-name
+ (and env (envconv/env/reified-name env))))
+ (if env-var-name
+ (let ((proc-name (envconv/new-name
+ (or name 'ENVCONV-PROCEDURE))))
+ (form/rewrite! form
+ `(LET ((,proc-name (QUOTE ,compiled)))
+ (CALL (LOOKUP ,proc-name)
+ (QUOTE #F)
+ (LOOKUP ,env-var-name)))))
+ (internal-error
+ "ENVCONV/DO-COMPILE!: environment not reified"
+ key)))
+ (form/rewrite! form `(QUOTE ,compiled)))))))
+
+;; The linker knows how to make global operator references,
+;; but could be taught how to make arbitrary package references.
+;; *** IMPORTANT: These must be captured! ****
+
+(define %system-global-environment #f)
+
+(define (envconv/package-reference? expr)
+ (equal? expr `(QUOTE ,%system-global-environment)))
+
+(define (envconv/package-name expr)
+ expr ; ignored
+ #f)
+
+(define (envconv/package-lookup package name)
+ package ; ignored
+ `(CALL (QUOTE ,%*lookup)
+ (QUOTE #F)
+ (QUOTE ,%system-global-environment)
+ (QUOTE ,name)
+ (QUOTE #f)
+ (QUOTE #f)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: expand.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Simple special form expansion
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+
+(define (expand/top-level program)
+ (expand/expr program))
+
+(define-macro (define-expander keyword bindings . body)
+ (let ((proc-name (symbol-append 'EXPAND/ keyword)))
+ (call-with-values
+ (lambda ()
+ (%matchup bindings '(handler) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,names ,@body)))
+ (named-lambda (,proc-name form)
+ (expand/remember ,code
+ form))))))))
+\f
+;;;; Core forms: simply expand components
+
+(define-expander QUOTE (object)
+ `(QUOTE ,object))
+
+(define-expander LOOKUP (name)
+ `(LOOKUP ,name))
+
+(define-expander SET! (name value)
+ `(SET! ,name ,(expand/expr value)))
+
+(define-expander LAMBDA (lambda-list body)
+ (expand/rewrite/lambda lambda-list (expand/expr body)))
+
+(define (expand/rewrite/lambda lambda-list body)
+ (cond ((memq '#!AUX lambda-list)
+ => (lambda (tail)
+ (let ((rest (list-prefix lambda-list tail))
+ (auxes (cdr tail)))
+ `(LAMBDA ,rest
+ ,(if (null? auxes)
+ body
+ `(LET ,(lmap (lambda (aux)
+ (list aux `(QUOTE ,%unassigned)))
+ auxes)
+ ,(expand/aux/sort auxes body)))))))
+ (else
+ `(LAMBDA ,lambda-list ,body))))
+
+(define-expander LET (bindings body)
+ (expand/let* expand/letify bindings body))
+
+(define-expander DECLARE (#!rest anything)
+ `(DECLARE ,@anything))
+
+(define-expander CALL (rator cont #!rest rands)
+ (if (and (pair? rator) (eq? (car rator) 'LAMBDA))
+ (let ((result
+ (let ((rator* (expand/rewrite/lambda (cadr rator) (caddr rator))))
+ (expand/let* (lambda (bindings body)
+ (expand/pseudo-letify rator bindings body))
+ (expand/bindify (cadr rator*)
+ (cons cont rands))
+ (caddr rator*)))))
+ (expand/remember (cadr result) rator)
+ result)
+ `(CALL ,(expand/expr rator)
+ ,(expand/expr cont)
+ ,@(expand/expr* rands))))
+
+(define-expander BEGIN (#!rest actions)
+ (expand/code-compress (expand/expr* actions)))
+
+(define-expander IF (pred conseq alt)
+ `(IF ,(expand/expr pred)
+ ,(expand/expr conseq)
+ ,(expand/expr alt)))
+\f
+;;;; Sort AUX bindings so that ASSCONV will do a better job.
+
+(define (expand/aux/sort auxes body)
+ (if (or (not (pair? body))
+ (not (eq? (car body) 'BEGIN)))
+ body
+ (let loop ((actions (simplify-actions (cdr body)))
+ (last false)
+ (decls '())
+ (early '())
+ (late '()))
+
+ (define (done)
+ (beginnify
+ (append decls
+ (reverse early)
+ (reverse late)
+ (cond ((not (null? actions))
+ actions)
+ ((not last)
+ (user-error "Empty body" body))
+ (else
+ ;; MIT Scheme semantics: the value of a
+ ;; DEFINE is the name defined.
+ (list `(QUOTE ,(set!/name last))))))))
+
+ (if (or (null? actions)
+ (not (pair? (car actions))))
+ (done)
+ (let ((action (car actions)))
+ (case (car action)
+ ((SET!)
+ (if (not (memq (set!/name action) auxes))
+ (done)
+ (let ((value (set!/expr action))
+ (next
+ (lambda (early* late*)
+ (loop (cdr actions) action
+ decls early* late*))))
+ (set! auxes (delq (set!/name action) auxes))
+ (if (or (not (pair? value))
+ (not (memq (car value) '(QUOTE LAMBDA))))
+ (next early (cons action late))
+ (next (cons action early) late)))))
+ ((DECLARE)
+ (loop (cdr actions)
+ last (cons action decls)
+ early late))
+ (else
+ (done))))))))
+\f
+;;;; Derived forms: macro expand
+
+(define-expander UNASSIGNED? (name)
+ `(CALL (QUOTE ,%unassigned?) (QUOTE #F) (LOOKUP ,name)))
+
+(define-expander OR (pred alt)
+ ;; Trivial optimization here.
+ (let ((new-pred (expand/expr pred))
+ (new-alt (expand/expr alt)))
+
+ (define (default)
+ (let ((new-name (expand/new-name 'OR)))
+ (bind new-name
+ new-pred
+ `(IF (LOOKUP ,new-name)
+ (LOOKUP ,new-name)
+ ,new-alt))))
+
+ (case (car new-pred)
+ ((QUOTE)
+ (case (boolean/discriminate (cadr new-pred))
+ ((TRUE)
+ new-pred)
+ ((FALSE)
+ new-alt)
+ (else ; UNKNOWN
+ (default))))
+ ((LOOKUP)
+ `(IF ,new-pred ,new-pred ,new-alt))
+ ((CALL)
+ (let ((rator (cadr new-pred)))
+ (if (and (pair? rator)
+ (eq? 'QUOTE (car rator))
+ (operator/satisfies? (cadr rator) '(PROPER-PREDICATE)))
+ `(IF ,new-pred (QUOTE #t) ,new-alt)
+ (default))))
+ (else
+ (default)))))
+
+(define-expander DELAY (expr)
+ `(CALL (QUOTE ,%make-promise)
+ (QUOTE #F)
+ (LAMBDA (,(new-continuation-variable))
+ ,(expand/expr expr))))
+\f
+(define (expand/expr expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (expand/quote expr))
+ ((LOOKUP)
+ (expand/lookup expr))
+ ((LAMBDA)
+ (expand/lambda expr))
+ ((LET)
+ (expand/let expr))
+ ((DECLARE)
+ (expand/declare expr))
+ ((CALL)
+ (expand/call expr))
+ ((BEGIN)
+ (expand/begin expr))
+ ((IF)
+ (expand/if expr))
+ ((SET!)
+ (expand/set! expr))
+ ((UNASSIGNED?)
+ (expand/unassigned? expr))
+ ((OR)
+ (expand/or expr))
+ ((DELAY)
+ (expand/delay expr))
+ ((LETREC)
+ (not-yet-legal expr))
+ ((ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (expand/expr* exprs)
+ (lmap expand/expr exprs))
+
+(define (expand/remember new old)
+ (code-rewrite/remember new old))
+
+(define (expand/new-name prefix)
+ (new-variable prefix))
+
+(define (expand/let* letify bindings body)
+ (let ((bindings* (lmap (lambda (binding)
+ (list (car binding)
+ (expand/expr (cadr binding))))
+ bindings)))
+ (let ((body* (expand/expr body)))
+ (if (null? bindings*)
+ body*
+ (letify bindings* body*)))))
+
+(define (expand/letify bindings body)
+ `(LET ,bindings
+ ,body))
+
+(define (expand/pseudo-letify rator bindings body)
+ (pseudo-letify rator bindings body expand/remember))
+
+(define (expand/bindify lambda-list operands)
+ (map (lambda (name operand) (list name operand))
+ (lambda-list->names lambda-list)
+ (lambda-list/applicate lambda-list operands)))
+\f
+(define (expand/code-compress actions)
+ (define (->vector exprs)
+ (if (not (for-all? exprs
+ (lambda (expr)
+ (and (pair? expr)
+ (eq? (car expr) 'QUOTE)))))
+ `(CALL (QUOTE ,%vector)
+ (QUOTE #F)
+ ,@exprs)
+ `(QUOTE ,(list->vector (lmap cadr exprs)))))
+
+ (define (->multi-define defns)
+ `(CALL (QUOTE ,%*define*)
+ (QUOTE #F)
+ ,(list-ref (car defns) 3)
+ (QUOTE ,(list->vector (lmap (lambda (defn)
+ (cadr (list-ref defn 4)))
+ defns)))
+ ,(->vector
+ (lmap (lambda (defn)
+ (list-ref defn 5))
+ defns))))
+
+ (define (collect defns actions)
+ (cond ((null? defns) actions)
+ ((null? (cdr defns))
+ (append defns actions))
+ (else
+ (cons (->multi-define (reverse defns))
+ actions))))
+
+ (let loop ((actions actions)
+ (defns '())
+ (actions* '()))
+ (if (null? actions)
+ (beginnify (reverse (collect defns actions*)))
+ (let ((action (car actions)))
+ (cond ((not (and (pair? action)
+ (eq? (car action) 'CALL)
+ (let ((rator (cadr action)))
+ (and (pair? rator)
+ (eq? 'QUOTE (car rator))
+ (eq? %*define (cadr rator))
+ (expand/code-compress/trivial?
+ (list-ref action 5))))))
+ (loop (cdr actions)
+ '()
+ (cons action
+ (collect defns actions*))))
+ ((or (null? defns)
+ (not (equal? (list-ref action 3)
+ (list-ref (car defns) 3))))
+ (loop (cdr actions)
+ (list action)
+ (collect defns actions*)))
+ (else
+ (loop (cdr actions)
+ (cons action defns)
+ actions*)))))))
+
+(define (expand/code-compress/trivial? expr)
+ (and (pair? expr)
+ (or (eq? (car expr) 'QUOTE)
+ (and (eq? (car expr) 'LAMBDA)
+ #| (let ((params (cadr expr)))
+ (if (or (null? params)
+ (null? cdr params)
+ (not (null? (cddr params))))
+ (internal-error
+ "EXPAND/CODE-COMPRESS/TRIVIAL? param error"
+ params)
+ (ignored-variable? (second params))))
+ |# ))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: fakeprim.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Pseudo primitives
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+;;;; Pseudo primitives
+
+(define *operator-properties*
+ (make-eq-hash-table))
+
+(define (known-operator? rator)
+ (hash-table/get *operator-properties* rator false))
+
+(define (simple-operator? rator)
+ (assq 'SIMPLE (hash-table/get *operator-properties* rator '())))
+
+(define (hook-operator? rator)
+ (assq 'OUT-OF-LINE-HOOK (hash-table/get *operator-properties* rator '())))
+
+(define (operator/satisfies? rator properties)
+ (let ((props (hash-table/get *operator-properties* rator '())))
+ (for-all? properties
+ (lambda (prop)
+ (assq prop props)))))
+
+(define (make-constant name)
+ (intern name))
+
+(define (make-operator name . properties)
+ (let ((operator (make-constant name)))
+ (hash-table/put! *operator-properties*
+ operator
+ (if (null? properties)
+ (list '(KNOWN))
+ properties))
+ operator))
+
+(define (make-operator/simple name . more)
+ (apply make-operator name
+ '(SIMPLE) '(SIDE-EFFECT-INSENSITIVE) '(SIDE-EFFECT-FREE) more))
+
+(define (make-operator/effect-sensitive name . more)
+ (apply make-operator name '(SIMPLE) '(SIDE-EFFECT-FREE) more))
+
+(define (make-operator/simple* name . more)
+ (apply make-operator name '(SIMPLE) more))
+\f
+
+(define-macro (cookie-call name . parts)
+ (define (->string x) (if (symbol? x) (symbol-name x) x))
+ (define (->sym . stuff)
+ (intern (apply string-append (map ->string stuff))))
+ (define (make-predicate)
+ `(DEFINE-INTEGRABLE (,(->sym "call/" name "?") FORM)
+ (AND (PAIR? FORM)
+ (EQ? (CAR FORM) 'CALL)
+ (PAIR? (CDR FORM))
+ (PAIR? (CADR FORM))
+ (PAIR? (CDADR FORM))
+ (EQ? (CAADR FORM) 'QUOTE)
+ (EQ? (CADADR FORM) ,name))))
+ (define (loop args path defs)
+ (define (add-def field path quoted?)
+ (let* ((base-name (->sym "call/" name "/" field))
+ (safe-name (->sym base-name "/safe"))
+ (unsafe-name (->sym base-name "/unsafe")))
+ (cons*
+ `(DEFINE-INTEGRABLE (,base-name FORM)
+ (,safe-name FORM))
+ `(DEFINE (,safe-name FORM)
+ (IF (AND (,(->sym "call/" name "?") FORM)(PAIR? FORM)
+ ,@(if quoted?
+ `((PAIR? ,path)
+ (EQ? (CAR ,path) 'QUOTE)
+ (PAIR? (CDR ,path)))
+ `()))
+ ,path
+ (INTERNAL-ERROR "Illegal Cookie call syntax" ',name FORM)))
+ `(DEFINE-INTEGRABLE (,unsafe-name FORM)
+ ,(if quoted?
+ `(CADR ,path)
+ path))
+ defs)))
+ (cond ((null? args)
+ defs)
+ ((eq? (car args) '#!REST)
+ (add-def (cadr args) path #F))
+ ((eq? (car args) '#F)
+ (loop (cdr args) `(CDR ,path) defs))
+ ((equal? (car args) ''#F)
+ (loop (cdr args) `(CDR ,path) defs))
+ ((and (pair? (car args)) (eq? (car (car args)) 'QUOTE))
+ (loop (cdr args)
+ `(CDR ,path)
+ (add-def (cadr (car args)) `(CAR ,path) #T)))
+ (else
+ (loop (cdr args)
+ `(CDR ,path)
+ (add-def (car args) `(CAR ,path) #F)))))
+ `(BEGIN ,(make-predicate)
+ ,@(reverse (loop parts `(CDDR FORM) '()))))
+\f
+(define %*lookup
+ ;; (CALL ',%*lookup <continuation> <environment>
+ ;; 'VARIABLE-NAME 'DEPTH 'OFFSET)
+ ;; Note:
+ ;; DEPTH and OFFSET are #F (unknown) or non-negative fixnums
+ ;; Introduced by envconv.scm, removed by compat.scm (replaced
+ ;; by a call to the primitive LEXICAL-REFERENCE)
+ (make-operator "#[*lookup]" '(SIDE-EFFECT-FREE)))
+
+(cookie-call %*lookup cont environment 'variable-name 'depth 'offset)
+
+
+(define %*set!
+ ;; (CALL ',%*set! <continuation> <environment>
+ ;; 'VARIABLE-NAME 'DEPTH 'OFFSET <value>)
+ ;; Note:
+ ;; DEPTH and OFFSET are #F (unknown) or non-negative fixnums
+ ;; Introduced by envconv.scm, removed by compat.scm (replaced
+ ;; by a call to the primitive LEXICAL-ASSIGNMENT)
+ (make-operator "#[*set!]"))
+
+(cookie-call %*set! cont environment 'VARIABLE-NAME 'DEPTH 'OFFSET value)
+
+(define %*unassigned?
+ ;; (CALL ',%*unassigned? <continuation> <environment>
+ ;; 'VARIABLE-NAME 'DEPTH 'OFFSET)
+ ;; Note:
+ ;; DEPTH and OFFSET are #F (unknown) or non-negative fixnums
+ ;; Introduced by envconv.scm, removed by compat.scm (replaced
+ ;; by a call to the primitive LEXICAL-UNASSIGNED?)
+ ;; Returns a boolean value
+ (make-operator "#[*unassigned?]" '(SIDE-EFFECT-FREE)))
+
+(cookie-call %*unassigned? cont environment 'variable-name 'depth 'offset)
+
+
+(define %*define
+ ;; (CALL ',%*define <continuation> <environment>
+ ;; 'VARIABLE-NAME <value>)
+ ;; Note:
+ ;; Introduced by envconv.scm, removed by compat.scm (replaced
+ ;; by a call to the primitive LOCAL-ASSIGNMENT)
+ (make-operator "#[*define]"))
+
+(cookie-call %*define cont environment 'VARIABLE-NAME value)
+
+
+(define %*define*
+ ;; (CALL ',%*define* <continuation> <environment>
+ ;; <vector of names> <vector of values>)
+ ;; Note:
+ ;; Introduced by expand.scm, removed by compat.scm (replaced
+ ;; by a call to the global procedure DEFINE-MULTIPLE)
+ (make-operator "#[*define*]"))
+
+(cookie-call %*define* cont environment 'names-vector 'values-vector)
+
+
+(define %*make-environment
+ ;; (CALL ',%*make-environment <continuation>
+ ;; <parent environment> <vector of names> <value>*)
+ ;; Note:
+ ;; Introduced by envconv.scm, removed by compat.scm (replaced
+ ;; by a call to the global procedure *MAKE-ENVIRONMENT)
+ ;; The vector of names has one MORE name than values: the
+ ;; first name is the value of the variable
+ ;; LAMBDA-TAG:MAKE-ENVIRONMENT (self-name for use by
+ ;; unsyntaxer).
+ (make-operator "#[*make-environment]" '(SIDE-EFFECT-FREE)))
+
+(cookie-call %*make-environment cont env 'names-vector #!rest values)
+
+\f
+;; %fetch-environment, %fetch-continuation, %fetch-stack-closure, and
+;; the variable cache operations are simple, but should not be
+;; substituted or reordered, hence they are not defined as
+;; effect-insensitive or effect-free
+
+(define %fetch-environment
+ ;; (CALL ',%fetch-environment '#F)
+ ;; Note:
+ ;; Introduced by envconv.scm, open coded by RTL generator.
+ ;; Appears at the top-level of expressions to be executed at
+ ;; load-time or in first-class environment code.
+ (make-operator/simple* "#[fetch-environment]" '(STATIC)))
+
+(cookie-call %fetch-environment '#F)
+
+(define %make-operator-variable-cache
+ ;; (CALL ',%make-operator-variable-cache '#F <environment>
+ ;; 'NAME 'NARGS)
+ ;; Note:
+ ;; Introduced by envconv.scm, ignored by RTL generator.
+ ;; It is required to make the trivial KMP-Scheme evaluator work
+ ;; and to guarantee no free variable references in KMP-Scheme
+ ;; code.
+ (make-operator/effect-sensitive "#[make-operator-variable-cache]"
+ '(STATIC)))
+
+(cookie-call %make-operator-variable-cache '#F environment 'NAME 'NARGS)
+
+(define %make-remote-operator-variable-cache
+ ;; (CALL ',%make-remote-operator-variable-cache '#F
+ ;; 'PACKAGE-DESCRIPTOR 'NAME 'NARGS)
+ ;; Note:
+ ;; For now, the linker only supports #F (global environment) for
+ ;; the PACKAGE-DESCRIPTOR.
+ ;; Introduced by envconv.scm, ignored by RTL generator.
+ ;; It is required to make the trivial KMP-Scheme evaluator
+ ;; work and to guarantee no free variable references in
+ ;; KMP-Scheme code.
+ (make-operator/effect-sensitive "#[make-remote-operator-variable-cache]"
+ '(STATIC)))
+
+
+(cookie-call %make-remote-operator-variable-cache '#F
+ 'PACKAGE-DESCRIPTOR 'NAME 'NARGS)
+
+(define %make-read-variable-cache
+ ;; (CALL ',%make-read-variable-cache '#F <environment> 'NAME)
+ ;; Note:
+ ;; Introduced by envconv.scm, ignored by RTL generator.
+ ;; It is required to make the trivial KMP-Scheme evaluator
+ ;; work and to guarantee no free variable references in
+ ;; KMP-Scheme code.
+ (make-operator/effect-sensitive "#[make-read-variable-cache]"
+ '(STATIC)))
+
+(cookie-call %make-read-variable-cache '#F environment 'NAME)
+
+(define %make-write-variable-cache
+ ;; (CALL ',%make-write-variable-cache '#F <environment> 'NAME)
+ ;; Note:
+ ;; Introduced by envconv.scm, ignored by RTL generator.
+ ;; It is required to make the trivial KMP-Scheme evaluator
+ ;; work and to guarantee no free variable references in
+ ;; KMP-Scheme code.
+ (make-operator/effect-sensitive "#[make-write-variable-cache]"
+ '(STATIC)))
+
+(cookie-call %make-write-variable-cache '#F environment 'NAME)
+
+\f
+(define %invoke-operator-cache
+ ;; (CALL ',%invoke-operator-cache <continuation>
+ ;; '(NAME NARGS) <operator-cache> <value>*)
+ ;; Note:
+ ;; Introduced by envconv.scm.
+ ;; NARGS is redundant with both the number of <value>*
+ ;; expressions and the expression creating the <operator-cache>
+ ;; This is used for operators to be referenced from the top-level
+ ;; (load-time) environment.
+ (make-operator "#[invoke-operator-cache]"))
+
+(cookie-call %invoke-operator-cache cont
+ 'descriptor operator-cache #!rest values)
+
+(define %invoke-remote-cache
+ ;; (CALL ',%invoke-remote-cache <continuation>
+ ;; '(NAME NARGS) <operator-cache> <value>*)
+ ;; Note:
+ ;; Introduced by envconv.scm.
+ ;; NARGS is mostly redundant with both the number of <value>*
+ ;; expressions and the expression creating the <operator-cache>
+ ;; (but see *make-environment in compat.scm for an exception)
+ ;; This is used for operators to be referenced from arbitrary
+ ;; named packages, although the linker currently only supports
+ ;; the global environment.
+ (make-operator "#[invoke-remote-operator-cache]"))
+
+(cookie-call %invoke-remote-cache cont
+ 'descriptor operator-cache #!rest values)
+
+(define %variable-cache-ref
+ ;; (CALL ',%variable-cache-ref '#F <read-variable-cache> 'NAME)
+ ;; Note:
+ ;; Introduced by envconv.scm, removed by compat.scm (replaced by a
+ ;; lot of hairy code)
+ ;; The NAME is redundant with the code that creates the variable cache
+ ;; Errors if the variable is unassigned or unbound.
+ (make-operator "#[variable-cache-ref]"
+ '(SIDE-EFFECT-FREE) '(OUT-OF-LINE-HOOK)))
+
+(cookie-call %variable-cache-ref '#F read-variable-cache 'NAME)
+
+(define %variable-cache-set!
+ ;; (CALL ',%variable-cache-set! '#F <write-variable-cache>
+ ;; <value> 'NAME)
+ ;; Note:
+ ;; Introduced by envconv.scm, removed by compat.scm (replaced by a
+ ;; lot of hairy code)
+ ;; The NAME is redundant with the code that creates the variable cache
+ (make-operator "#[variable-cache-set!]" '(OUT-OF-LINE-HOOK)))
+
+(cookie-call %variable-cache-set! '#F write-variable-cache value 'NAME)
+
+(define %safe-variable-cache-ref
+ ;; (CALL ',%safe-variable-cache-ref '#F <read-variable-cache> 'NAME)
+ ;; Note:
+ ;; Introduced by envconv.scm, removed by compat.scm (replaced by a
+ ;; lot of hairy code)
+ ;; Doesn't error if the variable is currently unassigned (but it
+ ;; does error on unbound)
+ ;; The NAME is redundant with the code that creates the variable cache
+ (make-operator "#[safe-variable-cache-ref]"
+ '(SIDE-EFFECT-FREE) '(OUT-OF-LINE-HOOK)))
+
+
+(cookie-call %safe-variable-cache-ref '#F read-variable-cache 'NAME)
+\f
+(define %variable-read-cache
+ ;; (CALL ',%variable-read-cache '#F <read-variable-cache> 'NAME)
+ ;; Note:
+ ;; Introduced by compat.scm as part of rewriting
+ ;; %variable-cache-ref and %safe-variable-cache-ref
+ ;; This declares the existence of a variable cache, but doesn't
+ ;; read the contents.
+ (make-operator/simple "#[variable-read-cache]"))
+
+(cookie-call %variable-read-cache '#F read-variable-cache 'NAME)
+
+(define %variable-write-cache
+ ;; (CALL ',%variable-write-cache '#F <write-variable-cache> 'NAME)
+ ;; Note:
+ ;; Introduced by compat.scm as part of rewriting
+ ;; %variable-cache-set!
+ ;; This declares the existence of a variable cache, but doesn't
+ ;; read the contents.
+ (make-operator/simple "#[variable-write-cache]"))
+
+(cookie-call %variable-write-cache '#F write-variable-cache 'NAME)
+
+(define %variable-cell-ref
+ ;; (CALL ',%variable-cell-ref '#F <read-variable-cache>)
+ ;; Note:
+ ;; Introduced by compat.scm as part of rewriting
+ ;; %variable-cache-ref and %safe-variable-cache-ref
+ ;; Does not checking of contents of cache (i.e. doesn't look for
+ ;; unassigned or unbound trap objects). Simply a data selector.
+ (make-operator/effect-sensitive "#[variable-cell-ref]"))
+
+(cookie-call %variable-cell-ref '#F read-variable-cache)
+
+(define %variable-cell-set!
+ ;; (CALL ',%variable-cell-ref '#F <write-variable-cache> <value>)
+ ;; Note:
+ ;; Introduced by compat.scm as part of rewriting
+ ;; %variable-cache-set!
+ ;; Simply a data mutator.
+ (make-operator/simple* "#[variable-cell-set!]"))
+
+(cookie-call %variable-cell-set! '#F write-variable-cache value)
+
+(define %hook-variable-cell-ref
+ ;; (CALL ',%hook-variable-cell-ref <continuation or '#F>
+ ;; <read-variable-cache>)
+ ;; Note:
+ ;; Introduced by compat.scm as part of rewriting
+ ;; %variable-cache-ref
+ ;; The reference must be done out of line for some reason.
+ ;; If the continuation is #F then the code generator is
+ ;; responsible for creating a return address and preserving all
+ ;; necessary state (registers) needed upon return. Otherwise
+ ;; there is no need to save state, but the variable reference
+ ;; should tail call into the continuation.
+ (make-operator "#[hook-variable-cell-ref]"
+ '(OUT-OF-LINE-HOOK) '(SPECIAL-INTERFACE)))
+
+(cookie-call %hook-variable-cell-ref cont read-variable-cache)
+
+
+(define %hook-safe-variable-cell-ref
+ ;; (CALL ',%hook-safe-variable-cell-ref <continuation or '#F>
+ ;; <read-variable-cache>)
+ ;; Note:
+ ;; Introduced by compat.scm as part of rewriting
+ ;; %safe-variable-cache-ref (qv)
+ ;; The reference must be done out of line for some reason.
+ ;; If the continuation is #F then the code generator is
+ ;; responsible for creating a return address and preserving all
+ ;; necessary state (registers) needed upon return. Otherwise
+ ;; there is no need to save state, but the variable reference
+ ;; should tail call into the continuation.
+ (make-operator "#[hook-safe-variable-cell-ref]"
+ '(OUT-OF-LINE-HOOK) '(SPECIAL-INTERFACE)))
+
+(cookie-call %hook-safe-variable-cell-ref cont read-variable-cache)
+\f
+(define %hook-variable-cell-set!
+ ;; (CALL ',%hook-safe-variable-cell-set! '#F
+ ;; <write-variable-cache> <value>)
+ ;; Note:
+ ;; Introduced by compat.scm as part of rewriting
+ ;; %variable-cache-set!
+ ;; The reference must be done out of line for some reason.
+ ;; No <continuation> is allowed because this would have been
+ ;; rewritten into something like
+ ;; (LET ((old-value ...)) (set! ...) (LOOKUP old-value))
+ (make-operator "#[hook-variable-cell-set!]"
+ '(OUT-OF-LINE-HOOK) '(SPECIAL-INTERFACE)))
+
+(cookie-call %hook-variable-cell-set! '#F write-variable-cache value)
+
+(define %copy-program
+ ;; (CALL ',%copy-program <continuation> <program>)
+ ;; Note:
+ ;; Introduced by envconv.scm and removed by compat.scm (replaced
+ ;; by a call to the global procedure COPY-PROGRAM).
+ ;; The value of <program> is a compiled expression object.
+ ;; This is generated under the following (unusual?) circumstances:
+ ;; when a closure must be generated with variable caches (for
+ ;; free references) to an environment that is reified (because,
+ ;; for example, of a call to (the-environment)) and is neither the
+ ;; global nor the top-level (load-time) environment. By
+ ;; default, the compiler switches don't allow variable caches in
+ ;; this case.
+ ;; Typical code:
+ ;; (CALL ',%copy-program (LOOKUP CONT47)
+ ;; '#[COMPILED-EXPRESSION 23])
+ (make-operator "#[copy-program]"))
+
+(cookie-call %copy-program cont program)
+
+
+(define %execute
+ ;; (CALL ',%execute <continuation> <program> <environment>)
+ ;; Note:
+ ;; Introduced by envconv.scm and removed by compat.scm (replaced
+ ;; by a call to the primitive procedure SCODE-EVAL).
+ ;; The value of <program> is a compiled expression object.
+ ;; Typical code:
+ ;; (CALL ',%execute (LOOKUP CONT47)
+ ;; '#[COMPILED-EXPRESSION 23] (LOOKUP ENV43))
+ (make-operator "#[execute]"))
+
+(cookie-call %execute cont program environment)
+
+(define %internal-apply
+ ;; (CALL ',%internal-apply <continuation> 'NARGS <procedure> <value>*)
+ ;; Note:
+ ;; NARGS = number of <value> expressions
+ ;; Introduced by applicat.scm.
+ (make-operator "#[internal-apply]"))
+
+(cookie-call %internal-apply cont 'NARGS procedure #!REST values)
+
+
+(define %primitive-apply
+ ;; (CALL ',%primitive-apply <continuation>
+ ;; 'NARGS '<primitive-object> <value>*)
+ ;; Note:
+ ;; NARGS = number of <value> expressions
+ ;; Introduced by applicat.scm and removed by compat.scm (replaced
+ ;; by %PRIMITIVE-APPLY/COMPATIBLE).
+ (make-operator "#[primitive-apply]"))
+
+(cookie-call %primitive-apply cont 'NARGS 'primitive-object #!rest values)
+\f
+(define %unspecific
+ ;; Magic cookie representing an ignorable value
+ (make-constant "#[unspecific]"))
+
+(define %unassigned
+ ;; The value of variables that do not yet have values ...
+ (make-constant "#[unassigned]"))
+
+(define %unassigned?
+ ;; (CALL ',%unassigned? '#F <value>)
+ ;; Note:
+ ;; Introduced by envconv.scm and expand.scm from the MIT Scheme
+ ;; special form (UNASSIGNED? <variable name>)
+ (make-operator/simple "#[unassigned?]" '(PROPER-PREDICATE)))
+
+(cookie-call %unassigned? '#F value)
+
+
+(define %reference-trap?
+ ;; (CALL ',%reference-trap? '#F <value>)
+ ;; Note:
+ ;; Introduced by compat.scm as part of the rewrite of
+ ;; %variable-cache-ref, %safe-variable-cache-ref, and
+ ;; %variable-cache-set!
+ (make-operator/simple "#[reference-trap?]" '(PROPER-PREDICATE)))
+
+(cookie-call %reference-trap? '#F value)
+
+(define %cons
+ ;; (CALL ',%cons '#F <value> <value>)
+ ;; Note:
+ ;; Introduced by LAMBDA-LIST/APPLICATE to do early application of
+ ;; a known lexpr (avoids an out-of-line call at runtime)
+ (make-operator/simple "#[cons]"))
+
+(cookie-call %cons '#F car-value cdr-value)
+
+(define %vector
+ ;; (CALL ',%vector '#F <value>*)
+ ;; Note:
+ ;; Introduced by expand.scm for DEFINE-MULTIPLE
+ (make-operator/simple "#[vector]"))
+
+(cookie-call %vector '#F #!rest values)
+
+(define %make-promise
+ ;; (CALL ',%make-promise '#F <thunk>)
+ ;; Note:
+ ;; Introduced by expand.scm for DELAY
+ (make-operator/simple "#[make-promise]"))
+(cookie-call %make-promise '#F thunk)
+
+(define %make-cell
+ ;; (CALL ',%make-cell '#F <value> 'NAME)
+ ;; Note:
+ ;; Introduced by assconv.scm for local assigned variables.
+ (make-operator/simple "#[make-cell]"))
+(cookie-call %make-cell '#F value 'NAME)
+
+(define %cell-ref
+ ;; (CALL ',%CALL '#F <cell> 'NAME)
+ ;; Note:
+ ;; Introduced by assconv.scm for read references to local assigned
+ ;; variables.
+ (make-operator/effect-sensitive "#[cell-ref]"))
+(cookie-call %cell-ref '#F cell 'NAME)
+
+(define %cell-set!
+ ;; (CALL ',%CALL '#F <cell> <value> 'NAME)
+ ;; Note:
+ ;; Introduced by assconv.scm for write references to local
+ ;; assigned variables.
+ ;; Returns no value, because the rewrite is to something like
+ ;; (LET ((old-value ...))
+ ;; (CALL ',%cell-set! ...)
+ ;; (LOOKUP old-value))
+ (make-operator/simple* "#[cell-set!]" '(UNSPECIFIC-RESULT)))
+
+(cookie-call %cell-set! '#F cell value 'NAME)
+\f
+(define %vector-index
+ ;; (CALL ',%vector-index '#F 'VECTOR 'NAME)
+ ;; Note:
+ ;; VECTOR is a vector of symbols, including NAME
+ ;; Returns the index of NAME within the vector.
+ ;; Introduced by closconv.scm and removed (constant folded) by
+ ;; indexify.scm. Used for referencing variables in closures and
+ ;; stack frames.
+ (make-operator/simple "#[vector-index]"))
+(cookie-call %vector-index '#F 'VECTOR 'NAME)
+
+;; %heap-closure-ref, %stack-closure-ref, and %static-binding-ref are not
+;; properly simple, but they can be considered such because %heap-closure-set!,
+;; %make-stack-closure, and %static-binding-set! are used only in limited ways.
+
+(define %make-heap-closure
+ ;; (CALL ',%make-heap-closure '#F <lambda-expression> 'VECTOR
+ ;; <value>*)
+ ;; Note:
+ ;; Introduced by closconv.scm (first time it is invoked).
+ ;; VECTOR is a vector of symbols whose length is the same as the
+ ;; number of <value> expressions.
+ (make-operator/simple "#[make-heap-closure]"))
+
+(cookie-call %make-heap-closure '#F lambda-expression 'VECTOR #!rest values)
+
+(define %heap-closure-ref
+ ;; (CALL ',%heap-closure-ref '#F <closure> <offset> 'NAME)
+ ;; Note:
+ ;; Introduced by closconv.scm (first time it is invoked)
+ (make-operator/simple "#[heap-closure-ref]"))
+(cookie-call %heap-closure-ref '#F closure offset 'NAME)
+
+(define %heap-closure-set!
+ ;; (CALL ',%heap-closure-set! '#F <closure> <offset> <value> 'NAME)
+ (make-operator/simple* "#[heap-closure-set!]" '(UNSPECIFIC-RESULT)))
+(cookie-call %heap-closure-set! '#F closure offset value 'NAME)
+
+(define %make-trivial-closure
+ ;; (CALL ',%make-trivial-closure '#F <lambda-expression or LOOKUP>)
+ ;; Note:
+ ;; Introduced by closconv.scm (first time it is invoked).
+ ;; Constructs an externally callable procedure object (all free
+ ;; variables are accessible through the variable caching
+ ;; mechanism).
+ ;; A LOOKUP is permitted only in a LETREC at the top level of a
+ ;; program. It is used to export one of the mutually recursive
+ ;; procedures introduced by the LETREC to the external
+ ;; environment.
+ (make-operator/simple "#[make-trivial-closure]"))
+(cookie-call %make-trivial-closure '#F procedure)
+
+(define %make-static-binding
+ ;; (CALL ',%make-static-binding '#F <value> 'NAME)
+ ;; Note:
+ ;; Generate a static binding cell for NAME, containing <value>.
+ ;; Introduced by staticfy.scm (not currently working).
+ (make-operator/simple "#[make-static-binding]"))
+(cookie-call %make-static-binding '#F value 'NAME)
+
+(define %static-binding-ref
+ ;; (CALL ',%static-binding-ref '#F <static-cell> 'NAME)
+ ;; Note:
+ ;; Introduced by staticfy.scm (not currently working).
+ (make-operator/simple "#[static-binding-ref]"))
+(cookie-call %static-binding-ref '#F static-cell 'NAME)
+
+(define %static-binding-set!
+ ;; (CALL ',%static-binding-set! '#F <static-cell> <value> 'NAME)
+ ;; Note:
+ ;; Introduced by staticfy.scm (not currently working).
+ (make-operator/simple* "#[static-binding-set!]" '(UNSPECIFIC-RESULT)))
+(cookie-call %static-binding-set! '#F static-cell value 'NAME)
+\f
+(define %make-return-address
+ ;; (CALL ',%make-return-address '#F <lambda-expression>)
+ ;; Note:
+ ;; Used internally in rtlgen.scm when performing trivial rewrites
+ ;; before calling itself recursively.
+ (make-operator/simple "#[make-return-address]"))
+(cookie-call %make-return-address '#F lambda-expression)
+
+;; %fetch-continuation is not static, but things get confused otherwise
+;; It is handled specially by lamlift and closconv
+
+(define %fetch-continuation
+ ;; (CALL ',%fetch-continuation '#F)
+ ;; Note:
+ ;; Grab return address, for use in top-level expressions since they
+ ;; (unlike procedures) do not receive a continuation.
+ ;; Introduced by cpsconv.scm.
+ (make-operator/simple* "#[fetch-continuation]" '(STATIC)))
+(cookie-call %fetch-continuation '#F)
+
+(define %invoke-continuation
+ ;; (CALL ',%invoke-continuation <continuation> <value>*)
+ ;; Note:
+ ;; Introduced by cpsconv.scm
+ (make-operator "#[invoke-continuation]"))
+(cookie-call %invoke-continuation cont #!rest values)
+
+(define %fetch-stack-closure
+ ;; (CALL ',%fetch-stack-closure '#F 'VECTOR)
+ ;; Note:
+ ;; VECTOR contains symbols only.
+ ;; This is supposed to return a pointer to the current top of
+ ;; stack, which contains values (or cells for values) of the
+ ;; variables named in VECTOR. In fact, rtlgen.scm knows about
+ ;; this special case and generates no output code.
+ (make-operator/simple* "#[fetch-stack-closure]"))
+(cookie-call %fetch-stack-closure '#F 'VECTOR)
+
+(define %make-stack-closure
+ ;; (CALL ',%make-stack-closure '#F <lambda-expression or '#F>
+ ;; 'VECTOR <value>*)
+ ;; Note:
+ ;; This appears *only* as the continuation of some KMP-Scheme CALL.
+ ;; If a lambda-expression is supplied, it pushes the values on the
+ ;; stack (creating a stack closure of the format specified) and
+ ;; loads the return address specified by the lambda-expression
+ ;; into the return address location (register or stack
+ ;; location). If no lambda expression is provided, simply
+ ;; pushes the values.
+ ;; Introduced by closconv.scm specifying a lambda expression, and
+ ;; by compat.scm with #F.
+ (make-operator/simple "#[make-stack-closure]"))
+(cookie-call %make-stack-closure '#F lambda-expression 'VECTOR #!rest values)
+
+(define %stack-closure-ref
+ ;; (CALL ',%stack-closure-ref '#F <closure> <offset> 'NAME)
+ ;; Note:
+ ;; Introduced by closconv.scm.
+ ;; Handled specially by rtlgen.scm
+ (make-operator/simple "#[stack-closure-ref]"))
+(cookie-call %stack-closure-ref '#F closure offset 'NAME)
+\f
+(define %machine-fixnum?
+ ;; (CALL ',%machine-fixnum? '#F <value>)
+ ;; Note:
+ ;; #T if <value> is a fixnum on the target machine, else #F
+ (make-operator/simple "#[machine-fixnum?]" '(PROPER-PREDICATE)))
+(cookie-call %machine-fixnum? '#F value)
+
+(define %small-fixnum?
+ ;; (CALL ',%small-fixnum? '#F <value> 'FIXNUM)
+ ;; Note:
+ ;; #T iff <value> is a fixnum on the target machine and all of top
+ ;; FIXNUM+1 bits are the same (i.e. the top FIXNUM precision bits
+ ;; match the sign bit, i.e. it can be represented in FIXNUM fewer
+ ;; bits than a full fixnum on the target machine). This is used
+ ;; in the expansion of generic arithmetic to guarantee no
+ ;; overflow is possible on the target machine.
+ ;; If FIXNUM is 0, then this is the same as %machine-fixnum?
+ (make-operator/simple "#[small-fixnum?]" '(PROPER-PREDICATE)))
+
+(cookie-call %small-fixnum? '#F value 'precision-bits)
+
+(define (make-operator/out-of-line name . more)
+ (apply make-operator name
+ '(SIDE-EFFECT-INSENSITIVE)
+ '(SIDE-EFFECT-FREE)
+ '(OUT-OF-LINE-HOOK)
+ more))
+
+;; The following operations are used as:
+;; (CALL ',<operator> <continuation or #F> <value1> <value2>)
+;; Note:
+;; If the continuation is #F then the code generator is responsible
+;; for creating a return address and preserving all necessary
+;; state (registers) needed upon return. Otherwise there is no
+;; need to save state, but the operation should tail call into the
+;; continuation.
+
+(define %+ (make-operator/out-of-line "#[+]"))
+(define %- (make-operator/out-of-line "#[-]"))
+(define %* (make-operator/out-of-line "#[*]"))
+(define %/ (make-operator/out-of-line "#[/]"))
+(define %quotient (make-operator/out-of-line "#[quotient]"))
+(define %remainder (make-operator/out-of-line "#[remainder]"))
+(define %= (make-operator/out-of-line "#[=]" '(PROPER-PREDICATE)))
+(define %< (make-operator/out-of-line "#[<]" '(PROPER-PREDICATE)))
+(define %> (make-operator/out-of-line "#[>]" '(PROPER-PREDICATE)))
+
+(define *vector-cons-max-open-coded-length* 5)
+
+(define %vector-cons
+ ;; (CALL ',%vector-cons <continuation or #F> <length> <fill-value>)
+ ;; Note:
+ ;; If the continuation is #F then the code generator is responsible
+ ;; for creating a return address and preserving all necessary
+ ;; state (registers) needed upon return. Otherwise there is no
+ ;; need to save state, but the operation should tail call into the
+ ;; continuation.
+ (make-operator/out-of-line "#[vector-cons]"))
+\f
+(define %string-allocate
+ ;; (CALL ',%string-allocate <continuation or #F> <length>)
+ ;; Note:
+ ;; If the continuation is #F then the code generator is responsible
+ ;; for creating a return address and preserving all necessary
+ ;; state (registers) needed upon return. Otherwise there is no
+ ;; need to save state, but the operation should tail call into the
+ ;; continuation.
+ (make-operator/out-of-line "#[string-allocate]"))
+
+(define %floating-vector-cons
+ ;; (CALL ',%floating-vector-cons <continuation or #F> <length>)
+ ;; Note:
+ ;; If the continuation is #F then the code generator is responsible
+ ;; for creating a return address and preserving all necessary
+ ;; state (registers) needed upon return. Otherwise there is no
+ ;; need to save state, but the operation should tail call into the
+ ;; continuation.
+ (make-operator/out-of-line "#[floating-vector-cons]"))
+
+;;; Inform the compiler about system primitives
+
+(for-each
+ (lambda (simple-operator)
+ (hash-table/put! *operator-properties*
+ simple-operator
+ (list '(SIMPLE)
+ '(SIDE-EFFECT-INSENSITIVE)
+ '(SIDE-EFFECT-FREE)
+ '(PROPER-PREDICATE))))
+ (list not eq? null? false?
+ boolean? cell? pair? vector? %record? string?
+ fixnum? index-fixnum? flo:flonum? object-type?
+ fix:= fix:> fix:< fix:<= fix:>=
+ fix:zero? fix:positive? fix:negative?
+ flo:= flo:> flo:< #| flo:<= flo:>= |#
+ flo:zero? flo:positive? flo:negative?))
+
+(for-each
+ (lambda (simple-operator)
+ (hash-table/put! *operator-properties*
+ simple-operator
+ (list '(SIMPLE)
+ '(SIDE-EFFECT-FREE)
+ '(PROPER-PREDICATE))))
+ (list (make-primitive-procedure 'HEAP-AVAILABLE? 1)
+ ))
+
+(for-each
+ (lambda (simple-operator)
+ (hash-table/put! *operator-properties*
+ simple-operator
+ (list '(SIMPLE)
+ '(SIDE-EFFECT-INSENSITIVE)
+ '(SIDE-EFFECT-FREE))))
+ (list make-cell cons vector %record string-allocate flo:vector-cons
+ system-pair-cons %record-length vector-length flo:vector-length
+ object-type object-datum
+ (make-primitive-procedure 'PRIMITIVE-OBJECT-SET-TYPE)
+ fix:-1+ fix:1+ fix:+ fix:- fix:*
+ fix:quotient fix:remainder ; fix:gcd
+ fix:andc fix:and fix:or fix:xor fix:not fix:lsh
+ flo:+ flo:- flo:* flo:/
+ flo:negate flo:abs flo:sqrt
+ flo:floor flo:ceiling flo:truncate flo:round
+ flo:exp flo:log flo:sin flo:cos flo:tan flo:asin
+ flo:acos flo:atan flo:atan2 flo:expt
+ flo:floor->exact flo:ceiling->exact
+ flo:truncate->exact flo:round->exact
+ ascii->char integer->char char->ascii char-code char->integer))
+\f
+(for-each
+ (lambda (simple-operator)
+ (hash-table/put! *operator-properties*
+ simple-operator
+ (list '(SIMPLE)
+ '(SIDE-EFFECT-FREE))))
+ (list cell-contents car cdr %record-ref vector-ref string-ref
+ string-length vector-8b-ref flo:vector-ref
+ system-pair-car system-pair-cdr
+ system-hunk3-cxr0 system-hunk3-cxr1 system-hunk3-cxr2
+ (make-primitive-procedure 'PRIMITIVE-GET-FREE)
+ (make-primitive-procedure 'PRIMITIVE-OBJECT-REF)))
+
+(for-each
+ (lambda (operator)
+ (hash-table/put! *operator-properties*
+ operator
+ (list '(SIMPLE) '(UNSPECIFIC-RESULT))))
+ (list set-cell-contents! set-car! set-cdr! %record-set! vector-set!
+ string-set! vector-8b-set! flo:vector-set!
+ (make-primitive-procedure 'PRIMITIVE-INCREMENT-FREE)
+ (make-primitive-procedure 'PRIMITIVE-OBJECT-SET!)))
+
+(for-each
+ (lambda (prim-name)
+ (hash-table/put! *operator-properties*
+ (make-primitive-procedure prim-name)
+ (list '(SIDE-EFFECT-FREE)
+ '(SIDE-EFFECT-INSENSITIVE)
+ '(OUT-OF-LINE-HOOK)
+ '(OPEN-CODED-PREDICATE)
+ '(PROPER-PREDICATE))))
+ '(&= &< &>))
+
+(for-each
+ (lambda (prim-name)
+ (hash-table/put! *operator-properties*
+ (make-primitive-procedure prim-name)
+ (list '(SIDE-EFFECT-FREE)
+ '(SIDE-EFFECT-INSENSITIVE)
+ '(OUT-OF-LINE-HOOK))))
+ '(&+ &- &* &/ quotient remainder))
+\f
+;;;; Compatibility operators
+
+(define %primitive-apply/compatible
+ ;; (CALL ',%primitive-apply/compatible '#F 'NARGS
+ ;; '<primitive-object>)
+ ;; Note:
+ ;; Introduced by compat.scm from %primitive-apply
+ (make-operator "#[primitive-apply 2]"))
+(cookie-call %primitive-apply/compatible '#F 'NARG primitive-object)
+
+;;; Operators for calling procedures, with a description of the calling
+;; convention.
+;;
+;; Note these have not been implemented but please leave them here for
+;; when we come back to passing unboxed floats.
+
+(define %call/convention
+ ;; (CALL ',%call/convention <cont> <convention> <op> <value*>)
+ ;; Note:
+ ;; Introduced by compat.scm from CALL
+ (make-operator "#[call 2]"))
+
+(define %invoke-operator-cache/convention
+ ;; (CALL ',%invoke-operator-cache/convention <cont> <convention>
+ ;; '(NAME NARGS) <cache> <value>*)
+ ;; Note:
+ ;; Introduced by compat.scm from %invoke-operator-cache
+ (make-operator "#[invoke-operator-cache 2]"))
+
+(define %invoke-remote-cache/convention
+ ;; (CALL ',%invoke-remote-cache/convention <cont> <convention>
+ ;; '(NAME NARGS) <cache> <value>*)
+ ;; Note:
+ ;; Introduced by compat.scm from %invoke-remote-cache
+ (make-operator "#[invoke-remote-cache 2]"))
+
+(define %internal-apply/convention
+ ;; (CALL ',%interna-apply/convention <cont> <convention>
+ ;; 'NARGS <procedure> <value>*)
+ ;; Note:
+ ;; Introduced by compat.scm from %internal-apply
+ (make-operator "#[internal-apply 2]"))
+
+(define %primitive-apply/convention
+ ;; (CALL ',%primitive-apply/convention <cont> <convention>
+ ;; 'NARGS '<primitive-object> <value>*)
+ ;; Note:
+ ;; Introduced by compat.scm from %primitive-apply
+ (make-operator "#[primitive-apply 2]"))
+
+(define %invoke-continuation/convention
+ ;; (CALL ',%invoke-continuation/convention <cont> <convention>
+ ;; <value>*)
+ ;; Note:
+ ;; Introduced by compat.scm from %invoke-continuation
+ (make-operator "#[invoke-continuation 2]"))
+
+(define %fetch-parameter-frame
+ ;; (CALL ',%fetch-parameter-frame '#F <convention>)
+ ;; Note:
+ ;; This is supposed to return an accessor for local parameters.
+ ;; In fact, rtlgen.scm knows about this special case and generates
+ ;; no output code. It is used to set an initial model of how
+ ;; parameters are passed in to a procedure, so it must appear
+ ;; immediately after the parameter list for a LAMBDA expression.
+ (make-operator "#[fetch-parameter-frame]"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; Syntax abstractions
+
+(let-syntax
+ ((kmp-form-accessors
+ (macro (name . args)
+ (define (->string x) (if (symbol? x) (symbol-name x) x))
+ (define (->sym . stuff)
+ (intern (apply string-append (map ->string stuff))))
+ (define (loop args path defs)
+ (define (add-def field path)
+ (let ((base-name (->sym name "/" field))
+ (safe-name (->sym name "/" field "/safe"))
+ (unsafe-name (->sym name "/" field "/unsafe")))
+ (cons* `(DEFINE-INTEGRABLE (,base-name FORM)
+ (,safe-name FORM))
+ `(DEFINE-INTEGRABLE (,unsafe-name FORM)
+ ,path)
+ `(DEFINE (,safe-name FORM)
+ (IF (AND (PAIR? FORM)
+ (EQ? (CAR FORM) ',name))
+ ,path
+ (INTERNAL-ERROR "Illegal KMP syntax" ',name FORM)))
+ defs)))
+ (cond ((null? args)
+ defs)
+ ((eq? (car args) '#!REST)
+ (add-def (cadr args) path))
+ ((eq? (car args) '#F)
+ (loop (cdr args) `(CDR ,path) defs))
+ (else
+ (loop (cdr args)
+ `(CDR ,path)
+ (add-def (car args) `(CAR ,path))))))
+ `(BEGIN 1 ;bogon for 0 defs
+ ,@(reverse (loop args `(CDR FORM) '())))))
+
+ (alternate-kmp-form
+ (macro (name . args)
+ `(kmp-form-accessors ,name . ,args)))
+ (kmp-form
+ (macro (name . args)
+ `(BEGIN (DEFINE-INTEGRABLE (,(symbol-append name '/?) FORM)
+ (AND (PAIR? FORM)
+ (EQ? (CAR FORM) ',name)))
+ (kmp-form-accessors ,name . ,args)))))
+
+ ;; Generate KMP accessors like QUOTE/TEXT (doesn't check head of
+ ;; form) and QUOTE/TEXT/SAFE (requires head of form to be QUOTE)
+
+ (kmp-form QUOTE text)
+ (kmp-form LOOKUP name)
+ (kmp-form LAMBDA formals body)
+ (kmp-form LET bindings body)
+ (kmp-form DECLARE #!rest declarations)
+ (kmp-form CALL operator continuation #!rest operands)
+ (alternate-kmp-form
+ CALL #F #!rest cont-and-operands)
+ (kmp-form BEGIN #!rest exprs) ; really 1 or more
+ (kmp-form IF predicate consequent alternate)
+ (kmp-form LETREC bindings body)
+
+ (kmp-form SET! name expr)
+ (kmp-form ACCESS name env-expr)
+ (kmp-form DEFINE name expr)
+ (kmp-form THE-ENVIRONMENT)
+ (kmp-form IN-PACKAGE env-expr expr)
+ )
--- /dev/null
+(load-option 'hash-table)
+
+(define make-attribute make-eq-hash-table)
+
+(define (set-attribute! object attribute value)
+ (hash-table/put! attribute object value))
+
+(define (get-attribute object attribute)
+ (hash-table/get attribute object #F))
+
+(define (adj-transpose vertices adj)
+ ;; Given a graph (vertices and adjacency matrix) construct the
+ ;; inverse adjacency matrix
+ (define adj/T (make-attribute))
+ (for-every vertices
+ (lambda (v)
+ (for-every (adj v)
+ (lambda (u)
+ (set-attribute! u adj/T (cons v (or (get-attribute u adj/T) '())))))))
+ (lambda (v)
+ (or (get-attribute v adj/T) '())))
+
+(define (strongly-connected-components vertices adj)
+
+ ;; Inputs: a list of VERTICES, and a function ADJ from a vertex to the
+ ;; adjacency list for that vertex. Return a list of components,
+ ;; where each component is a list of vertices.
+ ;;
+ ;; Example:
+ ;; (define vertices '(c d b a e f g h))
+ ;; (define (adj v)
+ ;; (case v
+ ;; ((a) '(b))
+ ;; ((b) '(c f e))
+ ;; ((c) '(g d))
+ ;; ((d) '(c h))
+ ;; ((e) '(f a))
+ ;; ((f) '(g))
+ ;; ((g) '(f h))
+ ;; ((h) '(h))
+ ;; (else (error "Bad vertex" v))))
+ ;; (strongly-connected-components vertices adj)
+ ;; => ((h) (f g) (d c) (e a b))
+ ;;
+ ;; Reference: Algorithm and example from: Cormen, Leiserson & Rivest,
+ ;; Introduction to ALGORITHMS, p489
+
+ (define (dfs-1 vertices adj)
+
+ (define time 0)
+ (define seen? (make-attribute))
+ (define finish (make-attribute))
+
+ (define (visit u)
+ (set-attribute! u seen? #T)
+ (for-each (lambda (v)
+ (if (not (get-attribute v seen?))
+ (visit v)))
+ (adj u))
+ (set! time (+ time 1))
+ (set-attribute! u finish time))
+
+ (for-each (lambda (vertex)
+ (if (not (get-attribute vertex seen?))
+ (visit vertex)))
+ vertices)
+
+ (lambda (v) (get-attribute v finish)))
+
+
+ (define (dfs-2 vertices adj)
+
+ (define seen? (make-attribute))
+ (define components '())
+ (define component '())
+
+ (define (visit u)
+ (set-attribute! u seen? #T)
+ (set! component (cons u component))
+ (for-each (lambda (v)
+ (if (not (get-attribute v seen?))
+ (visit v)))
+ (adj u)))
+
+ (for-each (lambda (vertex)
+ (if (not (get-attribute vertex seen?))
+ (begin (set! component '())
+ (visit vertex)
+ (set! components (cons component components)))))
+ vertices)
+ components)
+
+ (let ((finish (dfs-1 vertices adj)))
+ (dfs-2 (sort vertices (lambda (u v) (> (finish u) (finish v))))
+ (adj-transpose vertices adj))))
+
+
+(define (distribute-component-property components component->property
+ vertex-acknowledge-property!)
+ ;; For each component to something to every member of that component based on
+ ;; some property of the component.
+ (for-each (lambda (component)
+ (let ((property (component->property component)))
+ (for-each (lambda (vertex)
+ (vertex-acknowledge-property! vertex property))
+ component)))
+ components))
+
+
+(define (s-c-c->adj components adj)
+ ;; Given a list of strongly connected components and the adjacency relation
+ ;; over the vertices in those components, return the adjacency matrix for
+ ;; the strongly connect components themselves.
+ (define new-adj (make-attribute))
+ (define elements (make-attribute))
+ (define (adjoin elem set)
+ (if (memq elem set)
+ set
+ (cons elem set)))
+ (define (v->s-c-c vertex) (get-attribute vertex elements))
+ (define (result s-c-c)
+ (or (get-attribute s-c-c new-adj)
+ (error "S-C-C->ADJ: No such strongly connected component"
+ s-c-c components)))
+ ;; Elements maps a vertex to the strongly connected component containing it
+ (for-every components
+ (lambda (component)
+ (for-every component
+ (lambda (vertex)
+ (set-attribute! vertex elements component)))))
+ (for-every components
+ (lambda (component)
+ (set-attribute! component new-adj '())))
+ ;; Calculate the adjacency matrix
+ (for-every components
+ (lambda (component)
+ (for-every component
+ (lambda (vertex)
+ (let ((adjacent (adj vertex)))
+ (for-every adjacent
+ (lambda (adj-vertex)
+ (let ((new-component (v->s-c-c adj-vertex)))
+ (if (not (eq? new-component component))
+ (set-attribute! component new-adj
+ (adjoin new-component (result component))))))))))))
+ result)
+
+
+(define (make-in-cycle? vertices adj)
+ ;; Takes: a set (list) of vertices and an adjacency function from that
+ ;; set to a list of neighbours. Returns: a predicate on a vertex
+ ;; determining if that vertex is on a cycle
+
+ (define vertex->component (make-attribute))
+
+ (for-each (lambda (component)
+ (for-each (lambda (vertex)
+ (set-attribute! vertex vertex->component component))
+ component))
+ (strongly-connected-components vertices adj))
+
+ (lambda (vertex)
+ (let ((component (get-attribute vertex vertex->component)))
+ (and (pair? component)
+ (or (pair? (cdr component))
+ (memq vertex (adj vertex)))))))
+
+
+(define (make-breaks-cycle? vertices adj #!optional break-vertices)
+ ;; Takes VERTICES & ADJ as above. Decides which elemenent of a cycle are
+ ;; `harmless' and which should break-points to break cycles.
+ ;; BREAK-VERTICES is a list of vertices where we want to break already.
+
+ (define seen? (make-attribute))
+ ;; The seen? marker is either
+ ;; . #F - never,
+ ;; . #T - breaks cycle,
+ ;; . <n> found to be safe in dfs generation <n>
+ (define generation 0)
+
+ (define (visit u)
+ (let ((attr (get-attribute u seen?)))
+ (cond ((eq? attr #T) #T)
+ ((eq? attr #F)
+ (set-attribute! u seen? generation)
+ (for-each visit (adj u)))
+ ((= generation attr)
+ (set-attribute! u seen? #T)
+ #T)
+ (else
+ #F))))
+
+ (if (not (default-object? break-vertices))
+ (for-each (lambda (u) (set-attribute! u seen? #T)) break-vertices))
+
+ ;; slight improvement - look for trivial loops first
+ (for-each (lambda (u)
+ (if (memq u (adj u))
+ (set-attribute! u seen? #T)))
+ vertices)
+
+ (lambda (v)
+ (set! generation (1+ generation))
+ (visit v)
+ (if (eq? #T (get-attribute v seen?))
+ #T
+ #F)))
+
+
+(define (dfs-dag-walk vertices adj operation)
+ ;; Visit all nodes in the graph defined by VERTICES and ADJ, performing
+ ;; OPERATION at every vertex. OPERATION takes the current vertex and a
+ ;; list of vertices as returned by ADJ. The DFS ensures (provided the
+ ;; graph is a DAG) that OPERATION has already been called on all the
+ ;; members of this list, and is visited exactly once.
+ ;;
+ ;; Example: sum the values over the children:
+ ;; (dfs-dag-walk Vertices Adj
+ ;; (lambda (vertex children)
+ ;; (set-vertex-value!
+ ;; vertex
+ ;; (apply + (vertex-value vertex) (map vertex-value children)))))
+
+ (define seen? (make-attribute))
+ (define (visit u)
+ (if (not (get-attribute u seen?))
+ (let ((adj-list (adj u)))
+ (set-attribute! u seen? #T)
+ (for-each visit adj-list)
+ (operation u adj-list))))
+ (for-each visit vertices))
+
+
+
+(define (dfs-dag-sum vertices adj function)
+ ;; Returns a procedure on members of VERTICES which returns the DFS sum
+ ;; function FUNCTION of a vertex. FUNCTION takes the current vertex and
+ ;; a list of values for the vertices returned by ADJ. The DFS ensures
+ ;; (provided the graph is a DAG) that FUNCTION has already been computed
+ ;; for all ADJacent vertices and that FUNCTION is called at most once for
+ ;; any vertex.
+ ;;
+ ;; Note: the procedure returned is lazy, and should be forced if your program
+ ;; relies upon a side-effect produced by FUNCTION.
+ ;;
+ ;; Example: sum the values over the children:
+ ;; ((dfs-dag-walk Vertices Adj
+ ;; (lambda (vertex children-values)
+ ;; (apply + (vertex-value vertex) chilren)))
+ ;; a-vertex) => the-sum
+
+ (define seen? (make-attribute))
+ (define value (make-attribute))
+ (define (visit u)
+ (if (not (get-attribute u seen?))
+ (begin
+ (set-attribute! u seen? #T)
+ (let ((result (function u (map visit (adj u)))))
+ (set-attribute! u value result)
+ result))
+ (get-attribute u value)))
+ vertices ;; ignored
+ visit)
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: indexify.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Constant folder for closure and stack closure indices
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (indexify/top-level program)
+ (indexify/expr program))
+
+(define-macro (define-indexifier keyword bindings . body)
+ (let ((proc-name (symbol-append 'INDEXIFY/ keyword)))
+ (call-with-values
+ (lambda () (%matchup bindings '(handler) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,names ,@body)))
+ (named-lambda (,proc-name form)
+ (indexify/remember ,code form))))))))
+
+(define-indexifier LOOKUP (name)
+ `(LOOKUP ,name))
+
+(define-indexifier LAMBDA (lambda-list body)
+ `(LAMBDA ,lambda-list
+ ,(indexify/expr body)))
+
+(define-indexifier LET (bindings body)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (indexify/expr (cadr binding))))
+ bindings)
+ ,(indexify/expr body)))
+
+(define-indexifier LETREC (bindings body)
+ `(LETREC ,(lmap (lambda (binding)
+ (list (car binding)
+ (indexify/expr (cadr binding))))
+ bindings)
+ ,(indexify/expr body)))
+
+(define-indexifier IF (pred conseq alt)
+ `(IF ,(indexify/expr pred)
+ ,(indexify/expr conseq)
+ ,(indexify/expr alt)))
+
+(define-indexifier QUOTE (object)
+ `(QUOTE ,object))
+
+(define-indexifier DECLARE (#!rest anything)
+ `(DECLARE ,@anything))
+
+(define-indexifier BEGIN (#!rest actions)
+ `(BEGIN ,@(indexify/expr* actions)))
+\f
+(define-indexifier CALL (rator cont #!rest rands)
+ (let ((constant? (lambda (form)
+ (and (pair? form)
+ (eq? (car form) 'QUOTE)))))
+ (cond ((or (not (constant? rator))
+ (not (eq? (cadr rator) %vector-index)))
+ `(CALL ,(indexify/expr rator)
+ ,(indexify/expr cont)
+ ,@(indexify/expr* rands)))
+ ((or (not (equal? cont '(QUOTE #F)))
+ (not (= (length rands) 2))
+ (not (constant? (car rands)))
+ (not (constant? (cadr rands))))
+ (internal-error "Unexpected use of %vector-index"
+ `(CALL ,rator ,cont ,@rands)))
+ (else
+ `(QUOTE ,(vector-index (cadr (car rands))
+ (cadr (cadr rands))))))))
+
+(define (indexify/expr expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (indexify/quote expr))
+ ((LOOKUP)
+ (indexify/lookup expr))
+ ((LAMBDA)
+ (indexify/lambda expr))
+ ((LET)
+ (indexify/let expr))
+ ((DECLARE)
+ (indexify/declare expr))
+ ((CALL)
+ (indexify/call expr))
+ ((BEGIN)
+ (indexify/begin expr))
+ ((IF)
+ (indexify/if expr))
+ ((LETREC)
+ (indexify/letrec expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (indexify/expr* exprs)
+ (lmap (lambda (expr)
+ (indexify/expr expr))
+ exprs))
+
+(define (indexify/remember new old)
+ (code-rewrite/remember new old))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: inlate.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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->KMP Scheme
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (inlate/top-level scode)
+ (inlate/remember (inlate/scode scode)
+ (new-dbg-expression/make scode)))
+
+(define-macro (define-inlator scode-type components . body)
+ (let ((proc-name (symbol-append 'INLATE/ scode-type))
+ (destructor (symbol-append scode-type '-COMPONENTS)))
+ `(define ,proc-name
+ (let ((handler (lambda ,components ,@body)))
+ (named-lambda (,proc-name form)
+ (inlate/remember (,destructor form handler)
+ (new-dbg-expression/make form)))))))
+
+(define (inlate/sequence+ form)
+ ;; Kludge
+ (if (not (open-block? form))
+ (inlate/sequence form)
+ (inlate/remember
+ (let ((form* (open-block-components form unscan-defines)))
+ (if (sequence? form*)
+ (beginnify (lmap inlate/scode (sequence-actions form*)))
+ (inlate/scode form*)))
+ (new-dbg-expression/make form))))
+
+(define (inlate/constant object)
+ `(QUOTE ,(if (unassigned-reference-trap? object) %unassigned object)))
+
+(define-inlator VARIABLE (name)
+ `(LOOKUP ,name))
+
+(define-inlator ASSIGNMENT (name svalue)
+ `(SET! ,name ,(inlate/scode svalue)))
+
+(define-inlator DEFINITION (name svalue)
+ `(DEFINE ,name ,(inlate/scode svalue)))
+
+(define-inlator THE-ENVIRONMENT ()
+ `(THE-ENVIRONMENT))
+
+(define (inlate/lambda form)
+ (lambda-components form
+ (lambda (name req opt rest aux decls sbody)
+ name ; Not used
+ (let* ((lambda-list
+ (append req
+ (if (null? opt)
+ '()
+ (cons '#!OPTIONAL opt))
+ (if (not rest)
+ '()
+ (list '#!REST rest))
+ (if (null? aux)
+ '()
+ (cons '#!AUX aux))))
+ (new
+ `(LAMBDA ,(cons (new-continuation-variable) lambda-list)
+ ,(let ((body (inlate/scode sbody)))
+ (if (null? decls)
+ body
+ (beginnify
+ (list `(DECLARE ,@decls)
+ body)))))))
+ (inlate/remember new
+ (new-dbg-procedure/make form lambda-list))))))
+
+(define (inlate/lambda* name req opt rest aux decls sbody)
+ name ; ignored
+ `(LAMBDA ,(append (cons (new-continuation-variable) req)
+ (if (null? opt)
+ '()
+ (cons '#!OPTIONAL opt))
+ (if (not rest)
+ '()
+ (list '#!REST rest))
+ (if (null? aux)
+ '()
+ (cons '#!AUX aux)))
+ ,(let ((body (inlate/scode sbody)))
+ (if (null? decls)
+ body
+ (beginnify
+ (list `(DECLARE ,@decls)
+ body))))))
+\f
+(define-inlator IN-PACKAGE (environment expression)
+ `(IN-PACKAGE ,(inlate/scode environment)
+ ,(inlate/scode expression)))
+
+(define-inlator COMBINATION (rator rands)
+ (let-syntax ((ucode-primitive
+ (macro (name)
+ (make-primitive-procedure name))))
+ (let-syntax ((is-operator?
+ (macro (value name)
+ `(or (eq? ,value (ucode-primitive ,name))
+ (and (absolute-reference? ,value)
+ (eq? (absolute-reference-name ,value)
+ ',name))))))
+ (if (and (is-operator? rator LEXICAL-UNASSIGNED?)
+ (not (null? rands))
+ (the-environment? (car rands))
+ (not (null? (cdr rands)))
+ (symbol? (cadr rands)))
+ `(UNASSIGNED? ,(cadr rands))
+ `(CALL ,(inlate/scode rator)
+ (QUOTE #F) ; continuation
+ ,@(lmap inlate/scode rands))))))
+
+(define-inlator COMMENT (text body)
+ text ; ignored
+ (inlate/scode body))
+
+(define-inlator SEQUENCE (actions)
+ (beginnify (lmap inlate/scode actions)))
+
+(define-inlator CONDITIONAL (pred conseq alt)
+ `(IF ,(inlate/scode pred)
+ ,(inlate/scode conseq)
+ ,(inlate/scode alt)))
+
+(define-inlator DISJUNCTION (pred alt)
+ `(OR ,(inlate/scode pred)
+ ,(inlate/scode alt)))
+
+(define-inlator ACCESS (environment name)
+ `(ACCESS ,name ,(inlate/scode environment)))
+
+(define-inlator DELAY (expression)
+ `(DELAY ,(inlate/scode expression)))
+\f
+(define inlate/scode
+ (let ((dispatch-vector
+ (make-vector (microcode-type/code-limit) inlate/constant)))
+
+ (let-syntax
+ ((dispatch-entry
+ (macro (type handler)
+ `(VECTOR-SET! DISPATCH-VECTOR ,(microcode-type type)
+ (LAMBDA (EXPR)
+ (,handler EXPR))))))
+
+ (let-syntax
+ ((dispatch-entries
+ (macro (types handler)
+ `(BEGIN ,@(map (lambda (type)
+ `(DISPATCH-ENTRY ,type ,handler))
+ types))))
+ (standard-entry
+ (macro (name)
+ `(DISPATCH-ENTRY ,name ,(symbol-append 'INLATE/ name)))))
+
+ ;; quotations are treated as constants.
+ (standard-entry access)
+ (standard-entry assignment)
+ (standard-entry comment)
+ (standard-entry conditional)
+ (standard-entry definition)
+ (standard-entry delay)
+ (standard-entry disjunction)
+ (standard-entry variable)
+ (standard-entry in-package)
+ (standard-entry the-environment)
+ (dispatch-entries (combination-1 combination-2 combination
+ primitive-combination-0
+ primitive-combination-1
+ primitive-combination-2
+ primitive-combination-3)
+ inlate/combination)
+ (dispatch-entries (lambda lexpr extended-lambda) inlate/lambda)
+ (dispatch-entries (sequence-2 sequence-3) inlate/sequence+))
+
+ (named-lambda (inlate/expression expression)
+ ((vector-ref dispatch-vector (object-type expression))
+ expression)))))
+
+;; Utilities
+
+(define (inlate/remember new old)
+ (code-rewrite/remember* new old))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: lamlift.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Lambda lifter
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (lamlift/top-level program)
+ (let* ((env (lamlift/env/%make 'STATIC #F 0))
+ (program* (lamlift/expr env (lifter/letrecify program))))
+ (lamlift/analyze! env)
+ program*))
+
+(define lamlift/*lift-stubs-aggressively?* #F)
+
+(define-macro (define-lambda-lifter keyword bindings . body)
+ (let ((proc-name (symbol-append 'LAMLIFT/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name env form)
+ (lamlift/remember ,code
+ form))))))))
+
+(define-lambda-lifter LOOKUP (env name)
+ (call-with-values
+ (lambda () (lamlift/lookup* env name 'ORDINARY))
+ (lambda (ref binding)
+ (set-lamlift/binding/operand-uses! binding
+ (cons ref (lamlift/binding/operand-uses binding)))
+ ref)))
+
+(define-lambda-lifter LAMBDA (env lambda-list body)
+ (call-with-values
+ (lambda ()
+ (lamlift/lambda* 'DYNAMIC env lambda-list body))
+ (lambda (expr* env*)
+ env* ; ignored
+ expr*)))
+
+(define (lamlift/lambda* context env lambda-list body)
+ ;; (values expr* env*)
+ (let* ((env* (lamlift/env/make
+ context env (lambda-list->names lambda-list)))
+ (expr* `(LAMBDA ,lambda-list ,(lamlift/expr env* body))))
+ (set-lamlift/env/form! env* expr*)
+ (values expr* env*)))
+
+(define-lambda-lifter LET (env bindings body)
+ (lamlift/let* 'LET env bindings body))
+
+(define-lambda-lifter LETREC (env bindings body)
+ (lamlift/let* 'LETREC env bindings body))
+\f
+(define-lambda-lifter CALL (env rator cont #!rest rands)
+ (cond ((LOOKUP/? rator)
+ (call-with-values
+ (lambda () (lamlift/lookup* env (lookup/name rator) 'OPERATOR))
+ (lambda (rator* binding)
+ (let ((result
+ `(CALL ,(lamlift/remember rator* rator)
+ ,(lamlift/expr env cont)
+ ,@(lamlift/expr* env rands))))
+ (set-lamlift/binding/calls!
+ binding
+ (cons result (lamlift/binding/calls binding)))
+ result))))
+ ((LAMBDA/? rator)
+ (let ((ll (lambda/formals rator))
+ (body (lambda/body rator))
+ (cont+rands (cons cont rands)))
+ (guarantee-simple-lambda-list ll)
+ (guarantee-argument-list cont+rands (length ll))
+ (let ((bindings (map list ll cont+rands)))
+ (call-with-values
+ (lambda ()
+ (lamlift/lambda*
+ (binding-context-type 'CALL
+ (lamlift/env/context env)
+ bindings)
+ env ll body))
+ (lambda (rator* env*)
+ (let ((bindings* (lamlift/bindings env* env bindings)))
+ (set-lamlift/env/split?! env* 'UNNECESSARY)
+ `(CALL ,(lamlift/remember rator* rator)
+ ,@(lmap cadr bindings*))))))))
+ (else
+ `(CALL ,(lamlift/expr env rator)
+ ,(lamlift/expr env cont)
+ ,@(lamlift/expr* env rands)))))
+
+(define-lambda-lifter QUOTE (env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-lambda-lifter DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+(define-lambda-lifter BEGIN (env #!rest actions)
+ `(BEGIN ,@(lamlift/expr* env actions)))
+
+(define-lambda-lifter IF (env pred conseq alt)
+ `(IF ,(lamlift/expr env pred)
+ ,(lamlift/expr env conseq)
+ ,(lamlift/expr env alt)))
+\f
+(define (lamlift/expr env expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE) (lamlift/quote env expr))
+ ((LOOKUP) (lamlift/lookup env expr))
+ ((LAMBDA) (lamlift/lambda env expr))
+ ((LET) (lamlift/let env expr))
+ ((DECLARE) (lamlift/declare env expr))
+ ((CALL) (lamlift/call env expr))
+ ((BEGIN) (lamlift/begin env expr))
+ ((IF) (lamlift/if env expr))
+ ((LETREC) (lamlift/letrec env expr))
+ ((SET! UNASSIGNED? OR DELAY ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (lamlift/expr* env exprs)
+ (lmap (lambda (expr)
+ (lamlift/expr env expr))
+ exprs))
+
+(define (lamlift/remember new old)
+ (code-rewrite/remember new old))
+
+(define (lamlift/split new old)
+ (let ((old* (code-rewrite/original-form old)))
+ (if old*
+ (code-rewrite/remember*
+ new
+ (if (new-dbg-procedure? old*)
+ (new-dbg-procedure/copy old*)
+ old*)))
+ new))
+
+(define (lamlift/new-name prefix)
+ (new-variable prefix))
+\f
+(define-structure (lamlift/env
+ (conc-name lamlift/env/)
+ (constructor lamlift/env/%make (context parent depth))
+ (print-procedure
+ (standard-unparser-method 'LAMLIFT/ENV
+ (lambda (env port)
+ (write-char #\space port)
+ (write (lamlift/env/context env) port)
+ (write-char #\space port)
+ (write (car (or (lamlift/env/form env) '(ROOT))) port)
+ (write-char #\space port)
+ (write (lamlift/env/depth env) port)))))
+
+ (context false read-only true) ; STATIC or DYNAMIC
+ (parent false read-only true) ; #F or another environment
+ (children '() read-only false)
+ (depth 0 read-only true) ; depth from root
+ (bound '() read-only false) ; A list of LAMLIFT/BINDINGs
+
+ ;; Each of the next two slots is a list of associations between bindings
+ ;; and lists of references: Each association is a list headed by a
+ ;; binding, with the rest of the list being a list of references:
+ ;; (LAMLIFT/BINDING reference reference ...) where reference is
+ ;; (LOOKUP <var>)
+ (free-ordinary-refs '() read-only false)
+ (free-operator-refs '() read-only false)
+
+ (form false read-only false)
+
+ ;; When this is a lambda's env and the lambda is bound to a name, BINDING
+ ;; is that LAMLIFT/BINDING. #F implies either this frame is an anonymous
+ ;; lambda or a let(rec) frame.
+ (binding false read-only false)
+
+ (split? 'YES read-only false) ; 'YES, 'NO, or 'UNNECESSARY
+
+ ;; Formals to be added (formerly free variables)
+ (extended '() read-only false)
+
+ ;; The new parent for this frame should we choose to drift it up. This
+ ;; is the highest frame that could be a parent without adding new
+ ;; extra parameters.
+ (drift-frame #F read-only false)
+ )
+
+(define-structure (lamlift/binding
+ (conc-name lamlift/binding/)
+ (constructor lamlift/binding/make (name env))
+ (print-procedure
+ (standard-unparser-method 'LAMLIFT/BINDING
+ (lambda (v port)
+ (write-char #\space port)
+ (write-string (symbol-name (lamlift/binding/name v))
+ port)))))
+
+ (name #F read-only true)
+ (env #F read-only true) ; a LAMLIFT/ENV
+ (calls '() read-only false) ; List of call sites
+ (operand-uses '() read-only false) ; List of operand use (LOOKUP <name>)
+ (value #F read-only false)) ; a LAMLIFT/ENV for use in body
+
+(define-integrable (lamlift/binding/operator-only? binding)
+ (null? (lamlift/binding/operand-uses binding)))
+
+(define (lamlift/env/make context parent names)
+ (let* ((depth (if parent (1+ (lamlift/env/depth parent)) 0))
+ (env (lamlift/env/%make context parent depth)))
+ (set-lamlift/env/bound! env
+ (map (lambda (name)
+ (lamlift/binding/make name env))
+ names))
+ (set-lamlift/env/children! parent (cons env (lamlift/env/children parent)))
+ env))
+
+(define (lamlift/lookup* env name kind)
+ ;; (values copied-reference-form binding)
+ (define (traverse fetch store!)
+ (let walk-spine ((env env))
+ (cond ((not env)
+ (free-var-error name))
+ ((lamlift/binding/find (lamlift/env/bound env) name)
+ => (lambda (binding)
+ (values `(LOOKUP ,(lamlift/binding/name binding))
+ binding)))
+ (else
+ (call-with-values
+ (lambda () (walk-spine (lamlift/env/parent env)))
+ (lambda (ref binding)
+ (let* ((free (fetch env))
+ (place (assq binding free)))
+ (if (not place)
+ (store! env (cons (list binding ref) free))
+ (set-cdr! place (cons ref (cdr place))))
+ (values ref binding))))))))
+
+ (case kind
+ ((ORDINARY)
+ (traverse lamlift/env/free-ordinary-refs
+ set-lamlift/env/free-ordinary-refs!))
+ ((OPERATOR)
+ (traverse lamlift/env/free-operator-refs
+ set-lamlift/env/free-operator-refs!))
+ (else
+ (internal-error "Unknown reference kind" kind))))
+\f
+(define (lamlift/binding/find bindings name)
+ (let find ((bindings bindings))
+ (and (not (null? bindings))
+ (let ((binding (car bindings)))
+ (if (not (eq? name (lamlift/binding/name (car bindings))))
+ (find (cdr bindings))
+ binding)))))
+
+(define (lamlift/renames env names)
+ (lmap (lambda (name)
+ (cons name
+ (if (not (lamlift/bound? env name))
+ name
+ (variable/rename name))))
+ names))
+
+(define (lamlift/rename-lambda-list lambda-list pairs)
+ (lmap (lambda (token)
+ (let ((pair (assq token pairs)))
+ (if (not pair)
+ token
+ (cdr pair))))
+ lambda-list))
+
+(define (lamlift/bound? env name)
+ (let loop ((env env))
+ (and env
+ (or (lamlift/binding/find (lamlift/env/bound env) name)
+ (loop (lamlift/env/parent env))))))
+
+(define (lamlift/let* keyword outer-env bindings body)
+ (let* ((inner-env (lamlift/env/make
+ (binding-context-type keyword
+ (lamlift/env/context outer-env)
+ bindings)
+ outer-env
+ (lmap car bindings)))
+ (expr* `(,keyword
+ ,(lamlift/bindings
+ inner-env
+ (if (eq? keyword 'LETREC) inner-env outer-env)
+ bindings)
+ ,(lamlift/expr inner-env body))))
+ (set-lamlift/env/form! inner-env expr*)
+ expr*))
+\f
+(define (lamlift/bindings binding-env body-env bindings)
+ (lmap (lambda (binding)
+ (let ((name (car binding))
+ (value (cadr binding)))
+ (list
+ name
+ (if (not (LAMBDA/? value))
+ (lamlift/expr body-env value)
+ (call-with-values
+ (lambda ()
+ (lamlift/lambda* 'DYNAMIC ; bindings are dynamic
+ body-env
+ (lambda/formals value)
+ (lambda/body value)))
+ (lambda (value* lambda-body-env)
+ (let ((binding
+ (or (lamlift/binding/find
+ (lamlift/env/bound binding-env) name)
+ (internal-error "Missing binding" name))))
+ (set-lamlift/env/binding! lambda-body-env binding)
+ (set-lamlift/binding/value! binding lambda-body-env)
+ value*)))))))
+ bindings))
+
+(define (lamlift/analyze! env)
+ (lamlift/decide-split! env)
+ (lamlift/decide! env)
+ ;;(bkpt 'about-to-rewrite)
+ (lamlift/rewrite! env)
+)
+
+(define (lamlift/decide-split! env)
+ (cond ((lamlift/env/binding env) ; This LAMBDA has a known binding
+ => (lambda (binding)
+ (if (lamlift/binding/operator-only? binding)
+ (set-lamlift/env/split?! env 'NO)))))
+ (for-each lamlift/decide-split! (lamlift/env/children env)))
+
+(define (lamlift/decide! env)
+ (let ((form (lamlift/env/form env)))
+ (cond ((or (eq? form #F) ; root env
+ (LET/? form))
+ (lamlift/decide!* (lamlift/env/children env)))
+ ((LETREC/? form)
+ (lamlift/decide/letrec! env))
+ ((LAMBDA/? form)
+ (lamlift/decide/lambda! env)
+ (lamlift/decide!* (lamlift/env/children env)))
+ (else
+ (internal-error "Unknown binding form" form)))))
+
+(define (lamlift/decide!* envs)
+ (for-each lamlift/decide! envs))
+\f
+(define (lamlift/decide/lambda! env)
+ (case (lamlift/env/split? env)
+ ((NO YES)
+ (set-lamlift/env/extended! env (lamlift/decide/imports env '())))
+ ((UNNECESSARY)
+ (set-lamlift/env/extended! env '()))
+ (else
+ (internal-error "Unknown split field" env))))
+
+(define (lamlift/decide/imports env avoid)
+ ;; Find all free references in ENV except those in AVOID. Requires
+ ;; that ?? all LAMBDA siblings already have their LAMLIFT/ENV/EXTENDED
+ ;; slot calculated, as we have to pass their extensions as well.
+ (define (filter-refs refs avoid)
+ ;; Remove static bindings and members of AVOID from REFS
+ (list-transform-negative refs
+ (lambda (free-ref)
+ (let ((binding (car free-ref)))
+ (or (lamlift/static-binding? binding)
+ (lamlift/binding-lifts-to-static-frame? binding)
+ (memq binding avoid))))))
+ (union-map*
+ (lmap (lambda (free-ref)
+ ;; Extract the name of the variable
+ (cadr (cadr free-ref)))
+ (filter-refs (lamlift/env/free-ordinary-refs env)
+ '()))
+ (lambda (free-ref)
+ (let* ((binding (car free-ref))
+ (value (lamlift/binding/value binding)))
+ ;; If this free reference is visibly bound to a LAMBDA
+ ;; expression, then the free variables of that LAMBDA are also
+ ;; free variables of this expression; otherwise, just the
+ ;; variable itself.
+ (if (not value)
+ (list (cadr (cadr free-ref)))
+ (lamlift/env/extended value))))
+ (filter-refs (lamlift/env/free-operator-refs env)
+ avoid)))
+
+(define (lamlift/static-binding? binding)
+ (and (eq? (lamlift/env/context (lamlift/binding/env binding)) 'STATIC)
+ (not (pseudo-static-variable? (lamlift/binding/name binding)))))
+
+(define (lamlift/binding-lifts-to-static-frame? binding)
+ (let ((value (lamlift/binding/value binding)))
+ (and value
+ (let ((drift-frame (lamlift/env/drift-frame value)))
+ (and drift-frame
+ (eq? (lamlift/env/context drift-frame) 'STATIC))))))
+\f
+
+
+(define (lamlift/applicate! call reorder lambda-list var extra-args)
+ (form/rewrite!
+ call
+ `(CALL (LOOKUP ,var)
+ ,@(reorder (append extra-args
+ (lambda-list/applicate lambda-list
+ (call/cont-and-operands call)))))))
+
+(define (lamlift/reorderer original final)
+ ;; This is slow...
+ (lambda (args)
+ (let ((pairs (map list original args)))
+ (map (lambda (final)
+ (cadr (assq final pairs)))
+ final))))
+\f
+(define (lamlift/decide/letrec! letrec-env)
+
+ (define (decide-remaining-children! child-bindings-done)
+ (let ((children-done (lmap lamlift/binding/value child-bindings-done)))
+ (for-each (lambda (child)
+ (lamlift/decide!* (lamlift/env/children child)))
+ children-done)
+ (lamlift/decide!*
+ (delq* children-done (lamlift/env/children letrec-env)))))
+
+ (let ((bound (lamlift/env/bound letrec-env)))
+ ;; All these cases are optimizations.
+ (cond ((null? bound)
+ (decide-remaining-children! '()))
+ ((and (eq? (lamlift/env/context letrec-env) 'STATIC)
+ (for-all? bound
+ (lambda (binding)
+ (let ((env* (lamlift/binding/value binding)))
+ (eq? (lamlift/env/split? env*) 'NO)))))
+ ;; A static frame with none of the LAMBDAs appearing in
+ ;; operand position (i.e. no splitting)
+ (decide-remaining-children! bound))
+ ((eq? (lamlift/env/context letrec-env) 'STATIC)
+ (let ((splits (list-transform-negative bound
+ (lambda (binding)
+ (let ((env* (lamlift/binding/value binding)))
+ (eq? (lamlift/env/split? env*) 'NO))))))
+ (for-each
+ (lambda (binding)
+ (let ((env* (lamlift/binding/value binding)))
+ ;; No bindings need be added before lifting this,
+ ;; because all free references from a static frame
+ ;; are to static variables and hence lexically
+ ;; visible after lifting.
+ (set-lamlift/env/extended! env* '())))
+ splits)
+ (decide-remaining-children! splits)))
+ (else
+ (lamlift/decide/letrec!/dynamic-frame letrec-env)
+ (decide-remaining-children! bound)))))
+\f
+(define (lamlift/decide/letrec!/dynamic-frame letrec-env)
+
+ (define (letrec-binding? binding)
+ (eq? (lamlift/binding/env binding) letrec-env))
+
+ (define (letrec-self-references list-of-binding.reference)
+ (list-transform-positive list-of-binding.reference
+ (lambda (binding.reference)
+ (letrec-binding? (car binding.reference)))))
+
+ (define (letrec-other-references list-of-binding.reference)
+ (list-transform-negative list-of-binding.reference
+ (lambda (binding.reference)
+ (letrec-binding? (car binding.reference)))))
+
+ (define (make-adj-list list-of-binding.reference)
+ (map (lambda (binding.reference)
+ (lamlift/binding/value (car binding.reference)))
+ (letrec-self-references list-of-binding.reference)))
+
+ (define (lamlift/env/free-all-refs env)
+ (append (lamlift/env/free-ordinary-refs env)
+ (lamlift/env/free-operator-refs env)))
+
+ ;; remember that components are lists of nodes
+ (define-integrable component-exemplar car)
+
+ (let* ((nodes (map lamlift/binding/value (lamlift/env/bound letrec-env)))
+
+ (reference-adj
+ (eq?-memoize
+ (lambda (node-env)
+ (make-adj-list (lamlift/env/free-all-refs node-env)))))
+ (reference-components
+ (strongly-connected-components nodes reference-adj))
+ (reference-dag-adj (s-c-c->adj reference-components reference-adj))
+
+ (call-adj
+ (eq?-memoize
+ (lambda (node-env)
+ (make-adj-list (lamlift/env/free-operator-refs node-env)))))
+ (call-components (strongly-connected-components nodes call-adj))
+ (call-dag-adj (s-c-c->adj call-components call-adj)))
+
+ (define (component-free-dynamic-names component-members)
+ ;; calculate ordinary extended parameters
+ (union-map*
+ '()
+ (lambda (node)
+ (lamlift/decide/imports node (lamlift/env/bound letrec-env)))
+ component-members))
+
+ (define (combine-names my-new-names callees-new-names)
+ ;;* Ought to reorder CALLEES-NEW-NAMES to reduce amount of register
+ ;; shuffling and take into account existing arguments.
+ ;;* This version ensures that the arguments passed to callees preceed the
+ ;; new extra arguments, and the new argument list is coherent with at
+ ;; least one callee.
+ (define (adjoin names set) (append set (delq* set names)))
+ (adjoin my-new-names (fold-left adjoin '() callees-new-names)))
+
+ (define (component-drift-frame-depth component maximum-from-dag-children)
+ ;; Search for a drift frame by depth, picking the deepest frame that
+ ;; imposes a restriction.
+
+ (define (binding/drifted-frame-depth binding)
+ ;; Find the depth of a binding, taking into account that it might be a
+ ;; binding to a lambda that was drifted up from some outer frame.
+ (define (default) (lamlift/env/depth (lamlift/binding/env binding)))
+ (let ((value (lamlift/binding/value binding)))
+ (if value
+ (let ((drift-frame (lamlift/env/drift-frame value)))
+ (if drift-frame
+ (lamlift/env/depth drift-frame)
+ (default)))
+ (default))))
+
+ (define (maximum-over-binding.references-list list maximum)
+ (if (null? list)
+ maximum
+ (maximum-over-binding.references-list
+ (cdr list)
+ (max maximum (binding/drifted-frame-depth (car (car list)))))))
+
+ (define (node-maximum maximum node)
+ (maximum-over-binding.references-list
+ (letrec-other-references (lamlift/env/free-ordinary-refs node))
+ (maximum-over-binding.references-list
+ (letrec-other-references (lamlift/env/free-operator-refs node))
+ maximum)))
+
+ (fold-left node-maximum maximum-from-dag-children component))
+
+ (let ((depth-of-static-frame
+ (lamlift/env/depth (lamlift/find-static-frame letrec-env))))
+ ;; This has to be a walk, not a sum: COMPONENT-DRIFT-FRAME-DEPTH
+ ;; (indirectly) uses the drift-frame slot, so this has to be set
+ ;; immediately.
+ (dfs-dag-walk reference-components reference-dag-adj
+ (lambda (component children)
+ (let* ((children-depths
+ (map (lambda (c)
+ (lamlift/env/depth
+ (lamlift/env/drift-frame (component-exemplar c))))
+ children))
+ (drift-depth
+ (component-drift-frame-depth
+ component
+ (fold-left max depth-of-static-frame children-depths)))
+ (drift-frame
+ (lamlift/env/depth->frame letrec-env drift-depth)))
+ (for-each (lambda (node)
+ (set-lamlift/env/drift-frame! node drift-frame))
+ component)))))
+
+ (let ((component->extra-names
+ (dfs-dag-sum call-components call-dag-adj
+ (lambda (component callees-extendeds)
+ (combine-names (component-free-dynamic-names component)
+ callees-extendeds)))))
+ (distribute-component-property
+ call-components component->extra-names set-lamlift/env/extended!))))
+
+\f
+(define (lamlift/env/find-frame start-env predicate?)
+ (let loop ((env start-env))
+ (cond ((not env)
+ (internal-error "Cant find frame satisfying" predicate? start-env))
+ ((predicate? env)
+ env)
+ (else
+ (loop (lamlift/env/parent env))))))
+
+(define (lamlift/find-static-frame env)
+ (define (static-frame? env)
+ (eq? (lamlift/env/context env) 'STATIC))
+ (lamlift/env/find-frame env static-frame?))
+
+(define (lamlift/env/depth->frame env depth)
+ (lamlift/env/find-frame env (lambda (e) (= depth (lamlift/env/depth e)))))
+
+(define lamlift/lift!
+ (lifter/make
+ (lambda (env) (lamlift/env/form (lamlift/find-static-frame env)))))
+\f
+(define (lamlift/rewrite! env)
+ (let ((form (lamlift/env/form env)))
+ (cond ((or (eq? form #F) ; root env
+ (LET/? form))
+ (lamlift/rewrite!* (lamlift/env/children env)))
+ ((LETREC/? form)
+ (lamlift/rewrite!* (lamlift/env/children env)))
+ ((LAMBDA/? form)
+ (lamlift/rewrite!* (lamlift/env/children env))
+ (lamlift/rewrite/lambda! env))
+ (else
+ (internal-error "Unknown binding form" form)))))
+
+(define (lamlift/rewrite!* envs)
+ (for-each lamlift/rewrite! envs))
+
+(define (lamlift/rewrite/lambda! env)
+ (if (not (eq? (lamlift/env/split? env) 'UNNECESSARY))
+ (lamlift/rewrite/lambda/finish! env)))
+
+(define (lamlift/rewrite/lambda/finish! env)
+ (define (make-new-name)
+ (lamlift/new-name
+ (if (lamlift/env/binding env)
+ (lamlift/binding/name (lamlift/env/binding env))
+ 'LAMBDA)))
+ (let* ((form (lamlift/env/form env))
+ (orig-lambda-list (lambda/formals form))
+ (extra-formals (lamlift/env/extended env))
+ (lifted-name (make-new-name))
+ (split? (or (not (eq? (lamlift/env/split? env) 'NO))
+ (hairy-lambda-list? orig-lambda-list))))
+ (let* ((lambda-list**
+ (append extra-formals (lambda-list->names orig-lambda-list)))
+ (lifted-lambda-list
+ ;; continuation variable always leftmost
+ (call-with-values
+ (lambda ()
+ (list-split lambda-list** referenced-continuation-variable?))
+ (lambda (cont-vars other-vars)
+ (if (or (null? cont-vars)
+ (not (null? (cdr cont-vars))))
+ (internal-error "Creating LAMBDA with non-unique continuation"
+ env))
+ (append cont-vars other-vars)))))
+ ;; If this LAMBDA expression has a name, find all call sites and
+ ;; rewrite to pass additional arguments
+ (cond ((lamlift/env/binding env)
+ => (lambda (binding)
+ (let ((reorder
+ (lamlift/reorderer lambda-list** lifted-lambda-list)))
+ (for-each
+ (lambda (call)
+ (lamlift/applicate!
+ call reorder orig-lambda-list lifted-name
+ (lmap (lambda (arg-name) `(LOOKUP ,arg-name))
+ extra-formals)))
+ (lamlift/binding/calls binding))))))
+ (let ((lifted-form `(LAMBDA ,lifted-lambda-list ,(lambda/body form)))
+ (stub-lambda
+ (lambda (body-lambda-name)
+ ;; Should be modified to preserve complete alpha renaming
+ `(LAMBDA ,orig-lambda-list
+ (CALL (LOOKUP ,body-lambda-name)
+ ,@(lmap (lambda (name)
+ (if (or *after-cps-conversion?*
+ (not (continuation-variable? name)))
+ `(LOOKUP ,name)
+ `(QUOTE #F)))
+ lifted-lambda-list)))))
+ (lift-stub?
+ (or
+ ;; The stub can drift to a static frame, the stub is named,
+ ;; and there are operand uses that expect it to be in a static
+ ;; frame (because we did not add the static-liftable stubs to
+ ;; the extended parameter lists)
+ (and (lamlift/env/drift-frame env)
+ (eq? (lamlift/env/context (lamlift/env/drift-frame env))
+ 'STATIC)
+ (lamlift/env/binding env)
+ (not (null? (lamlift/binding/operand-uses
+ (lamlift/env/binding env)))))
+ ;; Add your favourite other reasons here:
+ lamlift/*lift-stubs-aggressively?*
+ #F))
+ (lift-to-drift-frame
+ (lambda (name lambda-form)
+ ((lifter/make
+ (lambda (env)
+ (lamlift/env/form (lamlift/env/drift-frame env))))
+ env name lambda-form))))
+
+ ;; Rewrite the stub to call the split version with additional arguments
+ (lamlift/split lifted-form form)
+ (form/rewrite!
+ form
+ (cond (lift-stub?
+ (let ((stub-name (make-new-name)))
+ (for-each
+ (lambda (reference)
+ (form/rewrite! reference `(LOOKUP ,stub-name)))
+ (lamlift/binding/operand-uses (lamlift/env/binding env)))
+ (lift-to-drift-frame stub-name (stub-lambda lifted-name))
+ `(QUOTE #F)))
+ (split?
+ (stub-lambda lifted-name))
+ (else `(QUOTE #F))))
+ (lamlift/lift! env lifted-name lifted-form)))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: laterew.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Late generic arithmetic rewrite
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (laterew/top-level program)
+ (laterew/expr program))
+
+(define-macro (define-late-rewriter keyword bindings . body)
+ (let ((proc-name (symbol-append 'LATEREW/ keyword)))
+ (call-with-values
+ (lambda () (%matchup bindings '(handler) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,names ,@body)))
+ (named-lambda (,proc-name form)
+ (laterew/remember ,code form))))))))
+
+(define-late-rewriter LOOKUP (name)
+ `(LOOKUP ,name))
+
+(define-late-rewriter LAMBDA (lambda-list body)
+ `(LAMBDA ,lambda-list
+ ,(laterew/expr body)))
+
+(define-late-rewriter LET (bindings body)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (laterew/expr (cadr binding))))
+ bindings)
+ ,(laterew/expr body)))
+
+(define-late-rewriter LETREC (bindings body)
+ `(LETREC ,(lmap (lambda (binding)
+ (list (car binding)
+ (laterew/expr (cadr binding))))
+ bindings)
+ ,(laterew/expr body)))
+
+(define-late-rewriter QUOTE (object)
+ `(QUOTE ,object))
+
+(define-late-rewriter DECLARE (#!rest anything)
+ `(DECLARE ,@anything))
+
+(define-late-rewriter BEGIN (#!rest actions)
+ `(BEGIN ,@(laterew/expr* actions)))
+
+(define-late-rewriter IF (pred conseq alt)
+ `(IF ,(laterew/expr pred)
+ ,(laterew/expr conseq)
+ ,(laterew/expr alt)))
+\f
+(define-late-rewriter CALL (rator #!rest rands)
+ (cond ((and (QUOTE/? rator)
+ (rewrite-operator/late? (quote/text rator)))
+ => (lambda (handler)
+ (handler (laterew/expr* rands))))
+ (else
+ `(CALL ,(laterew/expr rator)
+ ,@(laterew/expr* rands)))))
+
+
+(define (laterew/expr expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (laterew/quote expr))
+ ((LOOKUP)
+ (laterew/lookup expr))
+ ((LAMBDA)
+ (laterew/lambda expr))
+ ((LET)
+ (laterew/let expr))
+ ((DECLARE)
+ (laterew/declare expr))
+ ((CALL)
+ (laterew/call expr))
+ ((BEGIN)
+ (laterew/begin expr))
+ ((IF)
+ (laterew/if expr))
+ ((LETREC)
+ (laterew/letrec expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (laterew/expr* exprs)
+ (lmap (lambda (expr)
+ (laterew/expr expr))
+ exprs))
+
+(define (laterew/remember new old)
+ (code-rewrite/remember new old))
+
+(define (laterew/new-name prefix)
+ (new-variable prefix))
+\f
+;;;; Late open-coding of generic arithmetic
+
+(define (laterew/binaryop op %fixop %genop n-bits #!optional right-sided?)
+ (let ((right-sided?
+ (if (default-object? right-sided?)
+ false
+ right-sided?))
+ (%test
+ (cond ((not (number? n-bits))
+ (lambda (name constant-rand)
+ `(CALL (QUOTE ,%small-fixnum?)
+ (QUOTE #F)
+ (LOOKUP ,name)
+ (QUOTE ,(n-bits constant-rand)))))
+ #|
+ ;; Always open code as %small-fixnum?
+ ;; So that generic arithmetic can be
+ ;; recognized=>optimized at the RTL level
+ ((zero? n-bits)
+ (lambda (name constant-rand)
+ constant-rand ; ignored
+ `(CALL (QUOTE ,%machine-fixnum?)
+ (QUOTE #F)
+ (LOOKUP ,name))))
+ |#
+ (else
+ (lambda (name constant-rand)
+ constant-rand ; ignored
+ `(CALL (QUOTE ,%small-fixnum?)
+ (QUOTE #F)
+ (LOOKUP ,name)
+ (QUOTE ,n-bits)))))))
+ (lambda (rands)
+ (let ((cont (car rands))
+ (x (cadr rands))
+ (y (caddr rands)))
+ (laterew/verify-hook-continuation cont)
+ (let ((%continue
+ (if (eq? (car cont) 'QUOTE)
+ (lambda (expr)
+ expr)
+ (lambda (expr)
+ `(CALL (QUOTE ,%invoke-continuation)
+ ,cont
+ ,expr)))))
+
+ (cond ((laterew/number? x)
+ => (lambda (x-value)
+ (cond ((laterew/number? y)
+ => (lambda (y-value)
+ `(QUOTE ,(op x-value y-value))))
+ (right-sided?
+ `(CALL (QUOTE ,%genop) ,cont ,x ,y))
+ (else
+ (let ((y-name (laterew/new-name 'Y)))
+ `(LET ((,y-name ,y))
+ (IF ,(%test y-name x-value)
+ ,(%continue
+ `(CALL (QUOTE ,%fixop)
+ (QUOTE #f)
+ (QUOTE ,x-value)
+ (LOOKUP ,y-name)))
+ (CALL (QUOTE ,%genop)
+ ,cont
+ (QUOTE ,x-value)
+ (LOOKUP ,y-name)))))))))
+\f
+ ((laterew/number? y)
+ => (lambda (y-value)
+ (let ((x-name (laterew/new-name 'X)))
+ `(LET ((,x-name ,x))
+ (IF ,(%test x-name y-value)
+ ,(%continue
+ `(CALL (QUOTE ,%fixop)
+ (QUOTE #f)
+ (LOOKUP ,x-name)
+ (QUOTE ,y-value)))
+ (CALL (QUOTE ,%genop)
+ ,cont
+ (LOOKUP ,x-name)
+ (QUOTE ,y-value)))))))
+ (right-sided?
+ `(CALL (QUOTE ,%genop) ,cont ,x ,y))
+ (else
+ (let ((x-name (laterew/new-name 'X))
+ (y-name (laterew/new-name 'Y)))
+ `(LET ((,x-name ,x)
+ (,y-name ,y))
+ ;; There is no AND, since this occurs
+ ;; after macro-expansion
+ (IF ,(andify (%test x-name false)
+ (%test y-name false))
+ ,(%continue
+ `(CALL (QUOTE ,%fixop)
+ (QUOTE #F)
+ (LOOKUP ,x-name)
+ (LOOKUP ,y-name)))
+ (CALL (QUOTE ,%genop)
+ ,cont
+ (LOOKUP ,x-name)
+ (LOOKUP ,y-name))))))))))))
+
+
+(define (laterew/verify-hook-continuation cont)
+ (if (not (or (QUOTE/? cont)
+ (LOOKUP/? cont)
+ (CALL/%stack-closure-ref? cont)))
+ (internal-error "Unexpected continuation to out-of-line hook"
+ cont))
+ unspecific)
+\f
+(define *late-rewritten-operators*
+ (make-eq-hash-table 311))
+
+(define-integrable (rewrite-operator/late? rator)
+ (hash-table/get *late-rewritten-operators* rator false))
+
+(define (define-rewrite/late operator-name-or-object handler)
+ (hash-table/put! *late-rewritten-operators*
+ (if (hash-table/get *operator-properties*
+ operator-name-or-object
+ false)
+ operator-name-or-object
+ (make-primitive-procedure operator-name-or-object))
+ handler))
+
+(define (laterew/number? form)
+ (and (QUOTE/? form)
+ (number? (quote/text form))
+ (quote/text form)))
+
+(define-rewrite/late '&+
+ (laterew/binaryop + fix:+ %+ 1))
+
+(define-rewrite/late '&-
+ (laterew/binaryop - fix:- %- 1))
+
+(define-rewrite/late '&*
+ (laterew/binaryop * fix:* %* good-factor->nbits))
+
+;; NOTE: these could use 0 as the number of bits, but this would prevent
+;; a common RTL-level optimization triggered by CSE.
+
+(define-rewrite/late '&=
+ (laterew/binaryop = fix:= %= 1))
+
+(define-rewrite/late '&<
+ (laterew/binaryop < fix:< %< 1))
+
+(define-rewrite/late '&>
+ (laterew/binaryop > fix:> %> 1))
+
+(define-rewrite/late 'QUOTIENT
+ (laterew/binaryop careful/quotient fix:quotient %quotient
+ (lambda (value)
+ (cond ((zero? value)
+ (user-error "QUOTIENT by 0"))
+ ((= value -1)
+ ;; Most negative fixnum overflows!
+ 1)
+ (else
+ 0)))
+ true))
+
+(define-rewrite/late 'REMAINDER
+ (laterew/binaryop careful/remainder fix:remainder %remainder
+ (lambda (value)
+ (if (zero? value)
+ (user-error "REMAINDER by 0")
+ 0))
+ true))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: load.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Load script
+
+(declare (usual-integrations))
+\f
+(define (reload file)
+ (fluid-let ((syntaxer/default-environment (nearest-repl/environment)))
+ (load-latest file)))
+
+(define (loadup)
+ (load-option 'HASH-TABLE)
+ (load "synutl")
+ (fluid-let ((syntaxer/default-environment (nearest-repl/environment)))
+ (load "midend") ; top level
+ (load "utils")
+ (load "fakeprim") ; pseudo primitives
+ (load "dbgstr")
+ (load "inlate")
+ (load "envconv")
+ (load "expand")
+ (load "assconv")
+ (load "cleanup")
+ (load "earlyrew")
+ (load "lamlift")
+ (load "closconv")
+ ;; (load "staticfy") ; broken, for now
+ (load "applicat")
+ (load "simplify")
+ (load "cpsconv")
+ (load "laterew")
+ (load "compat") ; compatibility with current code
+ (load "stackopt")
+ (load "indexify")
+ (load "rtlgen")
+ ;; The following are not necessary for execution
+ (load "debug")
+ (load "triveval")))
+
+(define (load.scm:init)
+ (if (not (environment-bound? (nearest-repl/environment) 'execute))
+ (load/push-hook! loadup)))
\ No newline at end of file
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+;;;; Phase structure
+
+(define *phases-to-show* '())
+(define *announce-phases?* false)
+(define *debugging?* true)
+(define *current-phase-input* false)
+(define *entry-label*)
+
+(define debugging-phase-wrapper
+ (let ((pending-message #F))
+
+ (lambda (proc this-phase next-phase)
+ (define (show-message message)
+ (newline)
+ ;(write-string ";---")
+ (write-string message)
+ (write this-phase))
+
+ (define (show-program message program)
+ (newline)
+ (write-char #\Page)
+ (if pending-message
+ (display pending-message))
+ (set! pending-message #F)
+ (show-message message)
+ (write-string " #@") (display (hash program))
+ (if *kmp-output-abbreviated?*
+ (begin
+ (write-string " (*kmp-output-abbreviated?* is #T)")
+ (newline)
+ (kmp/ppp program))
+ (begin
+ (newline)
+ (kmp/pp program))))
+
+ (define (show? phase)
+ (and phase
+ (let ((switch *phases-to-show*))
+ (or (eq? switch 'ALL)
+ (memq phase switch)))))
+
+ (lambda (program)
+ (set! *current-phase* this-phase)
+ (set! *current-phase-input* (and *debugging?* program))
+ (if *announce-phases?*
+ (begin
+ (newline)
+ (write-string ";; Phase ")
+ (write this-phase)))
+ (if (not (show? this-phase))
+ (proc program)
+ (begin
+ (with-kmp-output-port
+ (lambda ()
+ (show-program "Input to phase " program)))
+ (let ((result (proc program)))
+ (if (show? next-phase)
+ (set! pending-message
+ (with-output-to-string
+ (lambda ()
+ (show-message "Output from phase "))))
+ (with-kmp-output-port
+ (lambda ()
+ (show-program "Output from phase " result))))
+ result)))))))
+
+(define (phase-wrapper rewrite)
+ (lambda (program)
+ (let ((table *code-rewrite-table*))
+ (set! *previous-code-rewrite-table* table)
+ (set! *code-rewrite-table* (and table (code/rewrite-table/make)))
+ (rewrite program))))
+
+(define (dummy-phase rewrite)
+ (lambda (program)
+ (set! *code-rewrite-table* *previous-code-rewrite-table*)
+ (rewrite program)))
+\f
+;;;; Top level
+
+(define *current-phase* 'UNKNOWN)
+(define *allow-random-choices?* false)
+(define *after-cps-conversion?* false)
+(define *lift-closure-lambdas?* false)
+(define *flush-closure-calls?* false)
+(define *order-of-argument-evaluation* 'ANY) ; LEFT-TO-RIGHT, RIGHT-TO-LEFT
+(define *earlyrew-expand-genarith?* false)
+(define *sup-good-factor* 512)
+(define *variable-properties* false)
+(define *previous-code-rewrite-table* false)
+(define *code-rewrite-table* false)
+
+(let-syntax ((cascade
+ (macro all
+ (let ((name (generate-uninterned-symbol 'FORM)))
+ (let loop ((result name)
+ (all all))
+ (if (null? all)
+ `(lambda (,name)
+ ,result)
+ (loop `((debugging-phase-wrapper
+ (phase-wrapper ,(car all))
+ ',(car all)
+ ',(if (null? (cdr all))
+ false
+ (cadr all)))
+ ,result)
+ (cdr all))))))))
+
+ (define compile-0
+ (cascade inlate/top-level ; scode->kmp-scheme
+ ))
+
+ (define compile-1
+ (cascade envconv/top-level ; eliminate free variables
+ ; and (the-environment)
+ ; introducing cache references
+ ; rewriting LOOKUP, SET!, etc.
+ ))
+
+ (define compile-2
+ (cascade alphaconv/top-level ; makes all bindings have unique names
+ expand/top-level ; rewrite OR, and DELAY
+ assconv/top-level ; eliminate SET! and introduce LETREC
+ ; rewriting LOOKUP and SET!
+ cleanup/top-level/1 ; as below
+ earlyrew/top-level ; rewrite -1+ into -, etc.
+ lamlift/top-level/1 ; flatten environment structure
+ ; splitting lambda nodes if necessary
+ closconv/top-level/1 ; introduce %make-heap-closure
+ ; and %heap-closure-ref
+ ; after this pass there are no
+ ; non-local variable references
+ ;; staticfy/top-level ; broken, for now
+ applicat/top-level ; get rid of #!OPTIONAL and #!REST when
+ ; calling known operators
+ ; Introduce %internal-apply
+ simplify/top-level/1 ; 1st-half of beta substitution
+ ; replace variable operators with
+ ; lambda expressions
+ cleanup/top-level/2 ; 2nd-half of beta substitution
+ ; substituting values for bindings
+ cpsconv/top-level/1 ; cps conversion, sequencing of
+ ; parallel expressions
+ simplify/top-level/2 ; as above
+ cleanup/top-level/3 ; as above
+ lamlift/top-level/2 ; as above
+\f
+ closconv/top-level/2 ; as above, but using
+ ; %make-stack-closure and
+ ; %stack-closure-ref
+ simplify/top-level/3 ; as above
+ cleanup/top-level/4 ; as above
+
+ closan/top-level/split
+ simplify/top-level/4 ; as above
+ cleanup/top-level/5 ; as above
+
+ closan/top-level/widen
+ simplify/top-level/5 ; as above
+ cleanup/top-level/6 ; as above
+
+ laterew/top-level ; rewrite &+, vector-cons,
+ cleanup/top-level/7 ; as above
+ compat/top-level ; rewrite code for compatibility
+ ; with current compiled code
+ stackopt/top-level ; reformat stack closures to use
+ ; common formats (prefixes)
+ ;; stackopt/optional-debugging-paranoia
+ indexify/top-level ; rewrite %vector-index
+ ))
+
+ (define %optimized-kmp->rtl
+ (cascade rtlgen/top-level))
+
+ (define compile-0*
+ (cascade (dummy-phase compile-0)
+ (dummy-phase compile-1)
+ (dummy-phase compile-2)))
+
+ (define compile-1*
+ (cascade (dummy-phase compile-1)
+ (dummy-phase compile-2))))
+
+(define (within-midend recursive? thunk)
+ (fluid-let ((*current-phase* false)
+ (*current-phase-input* false)
+ (*variable-properties*
+ (if (not recursive?)
+ (make-variable-properties)
+ (copy-variable-properties)))
+ (*after-cps-conversion?* false)
+ (*previous-code-rewrite-table* false)
+ (*code-rewrite-table*
+ (if (not recursive?)
+ (code/rewrite-table/make)
+ (code/rewrite-table/copy *code-rewrite-table*))))
+ (if (not recursive?)
+ (begin
+ ;; Initialize the uninterned symbol generator
+ ;; in order to obtain comparable programs
+ (generate-uninterned-symbol 'initial)
+ (generate-uninterned-symbol 0)
+ (initialize-new-variable!)))
+ (thunk)))
+
+(define *last-code-rewrite-table*)
+
+(define (compile program)
+ (within-midend false
+ (lambda ()
+ (let ((result (compile-0* program)))
+ (set! *last-code-rewrite-table* *code-rewrite-table*)
+ result))))
+
+(define (scode->kmp program)
+ (compile-0 program))
+
+(define (optimize-kmp recursive? program)
+ (compile-1* program))
+
+(define (kmp->rtl program)
+ (fluid-let ((*entry-label* false))
+ (let ((code (%optimized-kmp->rtl program)))
+ (values code *entry-label*))))
+
+(define (compile-recursively program procedure? name)
+ ;; (values result must-be-called?)
+ (compile-recursively/new program procedure? name))
+\f
+;; Some of these have independent names only for debugging
+
+(define (cpsconv/top-level/1 program)
+ (let ((result (cpsconv/top-level program)))
+ (set! *after-cps-conversion?* true)
+ result))
+
+(define (lamlift/top-level/1 program)
+ (lamlift/top-level program))
+
+(define (lamlift/top-level/2 program)
+ (lamlift/top-level program))
+
+(define (closan/top-level/split program)
+ (split-and-drift program))
+
+(define (closan/top-level/widen program)
+ (widen-parameter-lists program))
+
+(define (closconv/top-level/1 program)
+ (closconv/top-level program *after-cps-conversion?*))
+
+(define (closconv/top-level/2 program)
+ (closconv/top-level program *after-cps-conversion?*))
+
+(define (simplify/top-level/1 program)
+ (simplify/top-level program))
+
+(define (simplify/top-level/2 program)
+ (simplify/top-level program))
+
+(define (simplify/top-level/3 program)
+ (simplify/top-level program))
+
+(define (simplify/top-level/4 program)
+ (simplify/top-level program))
+
+(define (simplify/top-level/5 program)
+ (simplify/top-level program))
+
+(define (simplify/top-level/6 program)
+ (simplify/top-level program))
+
+(define (cleanup/top-level/1 program)
+ (cleanup/top-level program))
+
+(define (cleanup/top-level/2 program)
+ (fluid-let ((*flush-closure-calls?* true))
+ (cleanup/top-level program)))
+
+(define (cleanup/top-level/3 program)
+ (cleanup/top-level program))
+
+(define (cleanup/top-level/4 program)
+ (cleanup/top-level program))
+
+(define (cleanup/top-level/5 program)
+ (cleanup/top-level program))
+
+(define (cleanup/top-level/6 program)
+ (cleanup/top-level program))
+
+(define (cleanup/top-level/7 program)
+ (cleanup/top-level program))
+\f
+;;;; Debugging aids
+
+;;; Errors and warnings
+
+;; These should have their own condition types so that specific handlers
+;; can be established.
+
+(define (configuration-error complaint . reasons)
+ (apply error complaint *current-phase* reasons))
+
+(define (internal-error complaint . reasons)
+ (apply error complaint *current-phase* reasons))
+
+(define (user-error complaint . reasons)
+ (apply error complaint *current-phase* reasons))
+
+(define (internal-warning complaint . reasons)
+ (apply warn complaint *current-phase* reasons))
+
+(define (user-warning complaint . reasons)
+ (apply warn complaint *current-phase* reasons))
+
+(define (illegal form)
+ (internal-error "Illegal KMP form" form))
+
+(define (no-longer-legal form)
+ (internal-error "Unexpected KMP form -- should have been expanded"
+ form))
+
+(define (not-yet-legal form)
+ (internal-error "Unexpected KMP form -- should not occur yet"
+ form))
+
+(define (free-var-error name)
+ (internal-error "Free variable found" name))
+
+(define (unimplemented name)
+ (internal-error "Unimplemented procedure" name))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlgen.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; ??
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define *rtlgen/procedures*)
+(define *rtlgen/continuations*)
+(define *rtlgen/object-queue*)
+(define *rtlgen/delayed-objects*)
+(define *rtlgen/fold-tag-predicates?* true)
+(define *rtlgen/fold-simple-value-tests?* #T)
+
+(define (rtlgen/top-level program)
+ (initialize-machine-register-map!)
+ (fluid-let ((*rtlgen/object-queue* (queue/make))
+ (*rtlgen/delayed-objects* '())
+ (*rtlgen/procedures* '())
+ (*rtlgen/continuations* '()))
+ (call-with-values
+ (lambda ()
+ (if *procedure-result?*
+ (rtlgen/top-level-procedure program)
+ (rtlgen/expression program)))
+ (lambda (root label)
+ (queue/drain! *rtlgen/object-queue* rtlgen/dispatch)
+ (set! *entry-label* label)
+ (append! root
+ (fold-right append!
+ (fold-right append! '()
+ (reverse! *rtlgen/continuations*))
+ (reverse! *rtlgen/procedures*)))))))
+
+(define (rtlgen/expression form)
+ (let ((label (rtlgen/new-name 'EXPRESSION)))
+ (values (rtlgen/%%procedure label form rtlgen/wrap-expression)
+ label)))
+
+(define (rtlgen/top-level-procedure form)
+ (define (fail)
+ (internal-error
+ "Improperly formatted top-level procedure expression"))
+ (define result (form/match rtlgen/outer-expression-pattern form))
+ (if (not result)
+ (fail))
+ (let ((continuation-name (cadr (assq rtlgen/?cont-name result)))
+ (env-name (cadr (assq rtlgen/?env-name result))))
+ (let loop ((body (third form)))
+ (cond
+ ((LET/? body)
+ ;; Assume static binding
+ (loop (let/body body)))
+ ((LETREC/? body)
+ (rtlgen/letrec/bindings (letrec/bindings body))
+ (loop (letrec/body body)))
+ ((form/match rtlgen/top-level-trivial-closure-pattern body)
+ => (lambda (result)
+ (let ((cont-name (cadr (assq rtlgen/?cont-name result)))
+ (lam-expr (cadr (assq rtlgen/?lambda-expression result))))
+ (if (not (eq? continuation-name cont-name))
+ (fail)
+ (let* ((label (rtlgen/new-name 'TOP-LEVEL))
+ (code (rtlgen/%%procedure
+ label lam-expr rtlgen/wrap-trivial-closure)))
+ (values code label))))))
+ ((form/match rtlgen/top-level-heap-closure-pattern body)
+ => (lambda (result)
+ (let ((cont-name (cadr (assq rtlgen/?cont-name result))))
+ (if (not (eq? continuation-name cont-name))
+ (fail)
+ (let* ((label (rtlgen/new-name 'TOP-LEVEL-CLOSURE))
+ (code
+ (rtlgen/%%procedure label
+ `(LAMBDA (,cont-name ,env-name)
+ ,body)
+ rtlgen/wrap-trivial-closure)))
+ (set! *procedure-result?* 'CALL-ME)
+ (values code label))))))
+ (else (fail))))))
+\f
+(define (rtlgen/dispatch desc)
+ (let ((kind (vector-ref desc 0))
+ (label (vector-ref desc 1))
+ (object (vector-ref desc 2)))
+ (case kind
+ ((CONTINUATION)
+ (rtlgen/continuation label object))
+ ((PROCEDURE)
+ (rtlgen/procedure label object))
+ ((CLOSURE)
+ (rtlgen/closure label object))
+ ((TRIVIAL-CLOSURE)
+ (rtlgen/trivial-closure label object))
+ (else
+ (internal-error "Unknown object kind" desc)))))
+
+(define (rtlgen/enqueue! desc)
+ (queue/enqueue! *rtlgen/object-queue* desc))
+
+(define (rtlgen/trivial-closure label lam-expr)
+ (rtlgen/%procedure label lam-expr rtlgen/wrap-trivial-closure))
+
+(define (rtlgen/closure label lam-expr)
+ (rtlgen/%procedure label lam-expr rtlgen/wrap-closure))
+
+(define (rtlgen/procedure label lam-expr)
+ (rtlgen/%procedure label lam-expr rtlgen/wrap-procedure))
+
+(define (rtlgen/%procedure label lam-expr wrap)
+ (set! *rtlgen/procedures*
+ (cons (rtlgen/%%procedure label lam-expr wrap)
+ *rtlgen/procedures*))
+ unspecific)
+
+(define (rtlgen/%%procedure label lam-expr wrap)
+ ;; This is called directly for top-level expressions and procedures.
+ ;; All other calls are from rtlgen/%procedure which adds the result
+ ;; to the list of all procedures (*rtlgen/procedures*)
+ (rtlgen/%body-with-stack-references label lam-expr wrap
+ (lambda ()
+ (let ((lambda-list (lambda/formals lam-expr))
+ (body (lambda/body lam-expr)))
+ (rtlgen/body
+ body
+ (lambda (body*) (wrap label body* lambda-list 0))
+ (lambda () (rtlgen/initial-state lambda-list false body)))))))
+
+(define (rtlgen/wrap-expression label body lambda-list saved-size)
+ lambda-list ; Not used
+ saved-size ; only continuations
+ (cons `(EXPRESSION ,label)
+ (rtlgen/wrap-with-interrupt-check/expression
+ body
+ `(INTERRUPT-CHECK:CONTINUATION ,label (MACHINE-CONSTANT 1)))))
+
+(define (rtlgen/wrap-continuation label body lambda-list saved-size)
+ (let* ((arity (lambda-list/count-names lambda-list))
+ (frame-size
+ (+ (- saved-size 1) ; Don't count the return address
+ (- arity
+ (min arity (rtlgen/number-of-argument-registers))))))
+ (cons `(RETURN-ADDRESS ,label
+ (MACHINE-CONSTANT ,frame-size)
+ (MACHINE-CONSTANT 1))
+ (rtlgen/wrap-with-interrupt-check/continuation
+ body
+ `(INTERRUPT-CHECK:CONTINUATION ,label (MACHINE-CONSTANT 2))))))
+
+(define (rtlgen/wrap-closure label body lambda-list saved-size)
+ saved-size ; only continuations have this
+ (let ((frame-size (lambda-list/count-names lambda-list)))
+ (cons `(CLOSURE ,label (MACHINE-CONSTANT ,frame-size))
+ (rtlgen/wrap-with-interrupt-check/procedure
+ true
+ body
+ `(INTERRUPT-CHECK:CLOSURE (MACHINE-CONSTANT ,frame-size))))))
+
+(define (rtlgen/wrap-trivial-closure label body lambda-list saved-size)
+ saved-size ; only continuations have this
+ (let ((frame-size (lambda-list/count-names lambda-list)))
+ (cons `(TRIVIAL-CLOSURE ,label
+ ,@(map
+ (lambda (value)
+ `(MACHINE-CONSTANT ,value))
+ (lambda-list/arity-info lambda-list)))
+ (rtlgen/wrap-with-interrupt-check/procedure
+ true
+ body
+ `(INTERRUPT-CHECK:PROCEDURE ,label (MACHINE-CONSTANT ,frame-size))))))
+
+(define (rtlgen/wrap-procedure label body lambda-list saved-size)
+ saved-size ; only continuations have this
+ (let ((frame-size (lambda-list/count-names lambda-list)))
+ (cons `(PROCEDURE ,label (MACHINE-CONSTANT ,frame-size))
+ (rtlgen/wrap-with-interrupt-check/procedure
+ false
+ body
+ `(INTERRUPT-CHECK:PROCEDURE ,label
+ (MACHINE-CONSTANT ,frame-size))))))
+\f
+(define (rtlgen/continuation label lam-expr)
+ (set! *rtlgen/continuations*
+ (cons (rtlgen/%%continuation
+ label lam-expr rtlgen/wrap-continuation)
+ *rtlgen/continuations*))
+ unspecific)
+
+(define *rtlgen/frame-size* false)
+
+(define (rtlgen/->number-of-args-on-stack lambda-list frame-vector)
+ ;; The lambda list is like (cont arg1 ... argn) including #!optional, etc.
+ ;; The frame-vector is #(saved1 ... savedm argk+1 ... argn)
+ ;; Returns n-k
+ ;; NOTE: Assumes that the arguments passed on the stack are taken
+ ;; from the end of the formal parameter list.
+ (let ((n (vector-length frame-vector)))
+ (let loop ((lst (reverse (lambda-list->names lambda-list)))
+ (i (- n 1)))
+ (if (or (null? lst)
+ (negative? i)
+ (not (eq? (vector-ref frame-vector i) (car lst))))
+ (- n i 1)
+ (loop (cdr lst) (- i 1))))))
+
+(define (rtlgen/%%continuation label lam-expr wrap)
+ (rtlgen/%body-with-stack-references label lam-expr wrap
+ (lambda () (internal-error "continuation without stack frame" lam-expr))))
+
+(define (rtlgen/%body-with-stack-references label lam-expr wrap no-stack-refs)
+ (cond ((form/match rtlgen/continuation-pattern lam-expr)
+ => (lambda (result)
+ (let ((lambda-list (cadr (assq rtlgen/?lambda-list result)))
+ (frame-vector (cadr (assq rtlgen/?frame-vector result)))
+ (body (cadr (assq rtlgen/?continuation-body
+ result))))
+ (let ((frame-size (vector-length frame-vector)))
+ (fluid-let ((*rtlgen/frame-size* frame-size))
+ (rtlgen/body
+ body
+ (lambda (body*)
+ (let ((saved-size
+ (- frame-size
+ (rtlgen/->number-of-args-on-stack
+ lambda-list frame-vector))))
+ (wrap label body* lambda-list saved-size)))
+ (lambda ()
+ (rtlgen/initial-state lambda-list
+ frame-vector body))))))))
+ (else (no-stack-refs))))
+\f
+(define (rtlgen/initial-state params frame-vector body)
+
+ (define env '())
+ (define (add-binding! name reg home)
+ (let ((binding (rtlgen/binding/make name reg home)))
+ (set! env (cons binding env))
+ binding))
+
+ (define register-arg-positions-used '())
+ (define (add-used! home i)
+ (if (rtlgen/register? home)
+ (set! register-arg-positions-used
+ (cons i register-arg-positions-used))))
+
+ (define (do-register-params params)
+ (let ((first-stack-param ; stop at first stack param
+ (if frame-vector
+ (let ((n-on-stack
+ (rtlgen/->number-of-args-on-stack params frame-vector)))
+ (if (zero? n-on-stack)
+ #F
+ (vector-ref frame-vector
+ (- (vector-length frame-vector)
+ n-on-stack))))
+ #F)))
+ (let loop ((params params)
+ (i 0))
+ (cond ((or (null? params) (eq? (car params) first-stack-param))
+ 'done)
+ ((memq (car params) '(#!rest #!optional))
+ (loop (cdr params) i))
+ (else
+ (let* ((home (rtlgen/argument-home i))
+ (reg (rtlgen/new-reg))
+ (home-syllable (and (rtlgen/register? home) home)))
+ (rtlgen/emit!/1 `(ASSIGN ,reg ,home))
+ (add-binding! (car params) reg home-syllable)
+ (add-used! home i)
+ (loop (cdr params) (+ i 1))))))))
+
+ (define (do-continuation name stack-offset)
+ ;; We previously removed the assignment if NAME wasn't a
+ ;; referenced-continuation-variable, but that caused problems
+ ;; because "unreferenced" in this case actually means "never
+ ;; invoked", not "never passed as an argument"! However, we
+ ;; must be careful to make sure we dont think that the
+ ;; unreferenced continuation has a stack slot!
+ (let* ((used? (referenced-continuation-variable? name))
+ (source (cond ((not used?)
+ `(CONSTANT unused-continuation-variable))
+ ((rtlgen/cont-in-stack?)
+ (rtlgen/stack-ref stack-offset))
+ (else
+ (rtlgen/reference-to-cont))))
+ (home (if used? source #F))
+ (coerce? (and used? (rtlgen/tagged-entry-points?)))
+ (raw-reg (rtlgen/new-reg))
+ (cont-reg (if coerce? (rtlgen/new-reg) raw-reg)))
+ (rtlgen/emit!/1
+ `(ASSIGN ,raw-reg ,source))
+ (if coerce?
+ (rtlgen/emit!/1
+ `(ASSIGN ,cont-reg (COERCE-VALUE-CLASS ,raw-reg ADDRESS))))
+ (add-binding! name cont-reg home)))
+
+ (define (do-closure name stack-offset)
+ (let* ((source (if (rtlgen/closure-in-stack?)
+ (rtlgen/stack-ref stack-offset)
+ (rtlgen/reference-to-closure)))
+ (coerce? (rtlgen/tagged-entry-points?))
+ (raw-reg (rtlgen/new-reg))
+ (closure-reg (if coerce? (rtlgen/new-reg) raw-reg)))
+ (rtlgen/emit!/1
+ `(ASSIGN ,raw-reg ,source))
+ (if coerce?
+ (rtlgen/emit!/1
+ `(ASSIGN ,closure-reg (COERCE-VALUE-CLASS ,raw-reg ADDRESS))))
+ (add-binding! name closure-reg source)))
+
+ (let* ((continuation-name (if (and (pair? params)
+ (continuation-variable? (car params)))
+ (car params)
+ #F))
+ (sans-cont (if continuation-name (cdr params) params))
+ (closure-name (if (and (pair? sans-cont)
+ (closure-variable? (car sans-cont)))
+ (car sans-cont)
+ #F))
+ (sans-special (if closure-name (cdr sans-cont) sans-cont))
+
+ (receives-continuation?
+ (and continuation-name
+ (referenced-continuation-variable? continuation-name)))
+ (closure-offset (and (rtlgen/closure-in-stack?)
+ (if closure-name 0 #F)))
+ (continuation-offset (and (rtlgen/cont-in-stack?)
+ receives-continuation?
+ (if closure-offset 1 0)))
+ (stack-offset-adjustment (+ 1 (max (or closure-offset -1)
+ (or continuation-offset -1)))))
+
+ (do-register-params sans-special)
+ (let* ((closure-binding
+ (and closure-name (do-closure closure-name closure-offset)))
+ (continuation-binding
+ (and continuation-name
+ (do-continuation continuation-name continuation-offset))))
+
+ (rtlgen/state/stmt/make
+ (if frame-vector
+ (rtlgen/initial-stack-state
+ env register-arg-positions-used
+ stack-offset-adjustment
+ frame-vector body)
+ env)
+ (and receives-continuation? continuation-binding)
+ closure-binding
+ (+ (if frame-vector
+ (vector-length frame-vector)
+ 0)
+ stack-offset-adjustment)))))
+
+\f
+(define (rtlgen/find-preferred-call stmt)
+ ;; (values call operator unconditional?)
+ (define (tail-call? form)
+ (let ((cont (call/continuation form)))
+ (or (LOOKUP/? cont)
+ (form/match rtlgen/stack-overwrite-pattern cont))))
+
+ (let ((unconditional? true)
+ (tail-call false)
+ (other-call false)
+ (any-call false))
+ (let walk ((form stmt))
+ (and (pair? form)
+ (case (car form)
+ ((CALL)
+ (if (LOOKUP/? (call/operator form))
+ (if (and (not tail-call) (tail-call? form))
+ (set! tail-call form)
+ (set! other-call form))
+ (set! any-call form))
+ unspecific)
+ ((LET)
+ (walk (let/body form)))
+ ((IF)
+ (set! unconditional? false)
+ (walk (if/consequent form))
+ (walk (if/alternate form)))
+ ((BEGIN)
+ (walk (car (last-pair (cdr form)))))
+ (else
+ false))))
+ (let ((call (or tail-call other-call any-call)))
+ (values call (and call (call/operator call)) unconditional?))))
+\f
+(define (rtlgen/initial-stack-state
+ env register-arg-positions-used
+ stack-offset-adjustment
+ frame-vector body)
+
+ (define (first-stack-offset)
+ (+ (vector-length frame-vector)
+ stack-offset-adjustment
+ -1))
+
+ (define (default env handled)
+ ;; Continuation dealt with specially
+ (let loop ((stack-offset (first-stack-offset))
+ (i 0)
+ (env env))
+ (cond ((= i (vector-length frame-vector)) env)
+ ((continuation-variable? (vector-ref frame-vector i))
+ (loop (- stack-offset 1) (+ i 1) env))
+ (else
+ (loop (- stack-offset 1)
+ (+ i 1)
+ (let ((name (vector-ref frame-vector i)))
+ (if (memq name handled)
+ env
+ (cons (let ((home (rtlgen/stack-ref stack-offset)))
+ (rtlgen/binding/make name
+ (rtlgen/->register home) home))
+ env))))))))
+
+ ;; Try to target register assignments from stack locations
+ (call-with-values
+ (lambda () (rtlgen/find-preferred-call body))
+ (lambda (call rator unconditional?)
+ unconditional? ; ignored
+ (if (or (not call) (QUOTE/? rator))
+ ;; THIS IS OVERKILL. We need to analyze the "known operators" and do
+ ;; something to target well for things like %internal-apply.
+ ;; Or ditch this and have Daniel write a good register
+ ;; allocator.
+ (default env '())
+ (let ((max-index (rtlgen/number-of-argument-registers))
+ (first-offset (first-stack-offset)))
+ ;; Directly target the arguments registers for a likely
+ ;; call and move any stack references into the argument
+ ;; registers for that particular call. All other stack
+ ;; references will be targeted to default locations.
+ (let target ((rands (call/operands call))
+ (env env)
+ (names '())
+ (arg-position 0))
+ (cond ((or (null? rands) (>= arg-position max-index))
+ (default env names))
+ ((form/match rtlgen/stack-overwrite-pattern (car rands))
+ => (lambda (result)
+ (let ((name (cadr (assq rtlgen/?var-name result)))
+ (offset
+ (- first-offset
+ (cadr (assq rtlgen/?offset result)))))
+ (if (or (memq name names)
+ (memq arg-position register-arg-positions-used))
+ (target (cdr rands) env names (+ arg-position 1))
+ (let* ((home (rtlgen/argument-home arg-position))
+ (reg (rtlgen/new-reg)))
+ (rtlgen/emit!
+ (list
+ (rtlgen/read-stack-loc home offset)
+ `(ASSIGN ,reg ,home)))
+ (target (cdr rands)
+ `(,(rtlgen/binding/make
+ name
+ reg
+ (rtlgen/stack-offset offset))
+ . ,env)
+ (cons name names)
+ (+ arg-position 1)))))))
+ (else
+ (target (cdr rands) env names (+ arg-position 1))))))))))
+\f
+(define *rtlgen/next-rtl-pseudo-register*)
+(define *rtlgen/pseudo-register-values*)
+(define *rtlgen/pseudo-registers*)
+(define *rtlgen/statements*)
+(define *rtlgen/words-allocated*)
+(define *rtlgen/stack-depth*)
+(define *rtlgen/max-stack-depth*)
+(define *rtlgen/form-calls-external?*)
+(define *rtlgen/form-calls-internal?*)
+(define *rtlgen/form-returns?*)
+
+(define (rtlgen/body form wrap gen-state)
+ (fluid-let ((*rtlgen/next-rtl-pseudo-register* 0)
+ (*rtlgen/pseudo-registers* '())
+ (*rtlgen/pseudo-register-values* '())
+ (*rtlgen/words-allocated* 0)
+ (*rtlgen/stack-depth* 0)
+ (*rtlgen/max-stack-depth* 0)
+ (*rtlgen/statements* (queue/make))
+ (*rtlgen/form-calls-internal?* false)
+ (*rtlgen/form-calls-external?* false)
+ (*rtlgen/form-returns?* false))
+ (rtlgen/stmt (gen-state) form)
+ (rtlgen/renumber-pseudo-registers!
+ (rtlgen/first-pseudo-register-number))
+ (wrap (queue/contents *rtlgen/statements*))))
+
+(define (rtlgen/wrap-with-interrupt-check/expression body desc)
+ ;; *** For now, this does not check interrupts.
+ ;; The environment must be handled specially ***
+ desc ; ignored
+ body)
+
+(define (rtlgen/wrap-with-interrupt-check/procedure external? body desc)
+ (rtlgen/wrap-with-intrpt-check (and (rtlgen/generate-interrupt-checks?)
+ (or *rtlgen/form-calls-external?*
+ (and (not external?)
+ *rtlgen/form-calls-internal?*)))
+ (and (rtlgen/generate-heap-checks?)
+ (not (= *rtlgen/words-allocated* 0))
+ *rtlgen/words-allocated*)
+ (and (rtlgen/generate-stack-checks?)
+ (not (= *rtlgen/max-stack-depth* 0))
+ *rtlgen/max-stack-depth*)
+ body
+ desc))
+
+(define (rtlgen/wrap-with-interrupt-check/continuation body desc)
+ ;; For now, this is dumb about interrupt checks.
+ (rtlgen/wrap-with-intrpt-check (rtlgen/generate-interrupt-checks?)
+ (and (rtlgen/generate-heap-checks?)
+ (not (= *rtlgen/words-allocated* 0))
+ *rtlgen/words-allocated*)
+ (and (rtlgen/generate-stack-checks?)
+ (not (= *rtlgen/max-stack-depth* 0))
+ *rtlgen/max-stack-depth*)
+ body
+ desc))
+\f
+(define (rtlgen/wrap-with-intrpt-check calls? heap-check? stack-check?
+ body desc)
+ (if (not (or calls? heap-check? stack-check?))
+ body
+ (cons `(,(car desc) ,calls? ,heap-check? ,stack-check? ,@(cdr desc))
+ body)))
+
+(define-integrable (rtlgen/emit! insts)
+ (queue/enqueue!* *rtlgen/statements* insts))
+
+(define-integrable (rtlgen/emit!/1 inst)
+ (queue/enqueue! *rtlgen/statements* inst))
+
+(define-integrable (rtlgen/declare-allocation! nwords)
+ ;; *** NOTE: This does not currently include floats! ***
+ (set! *rtlgen/words-allocated* (+ nwords *rtlgen/words-allocated*))
+ unspecific)
+
+(define (rtlgen/declare-stack-allocation! nwords)
+ (let ((new (+ nwords *rtlgen/stack-depth*)))
+ (set! *rtlgen/stack-depth* new)
+ (if (> new *rtlgen/max-stack-depth*)
+ (set! *rtlgen/max-stack-depth* new)))
+ unspecific)
+
+(define (rtlgen/stack-allocation/protect thunk) ; /compatible ?
+ (let ((sd *rtlgen/stack-depth*)
+ (msd *rtlgen/max-stack-depth*))
+ (let ((result (thunk)))
+ (set! *rtlgen/stack-depth* sd)
+ (set! *rtlgen/max-stack-depth* msd)
+ result)))
+
+(define (rtlgen/emit-alternatives! gen1 gen2 need-merge?)
+ (let ((merge-label (and need-merge? (rtlgen/new-name 'MERGE))))
+ (let ((orig-depth *rtlgen/stack-depth*)
+ (orig-heap *rtlgen/words-allocated*)
+ (orig-values *rtlgen/pseudo-register-values*))
+ (gen1)
+ (if merge-label
+ (rtlgen/emit!/1 `(JUMP ,merge-label)))
+ (let ((heap-after-one *rtlgen/words-allocated*))
+ (set! *rtlgen/stack-depth* orig-depth)
+ (set! *rtlgen/words-allocated* orig-heap)
+ (set! *rtlgen/pseudo-register-values* orig-values)
+ (gen2)
+ (if merge-label
+ (rtlgen/emit!/1 `(LABEL ,merge-label)))
+ (let ((heap-after-two *rtlgen/words-allocated*))
+ (set! *rtlgen/stack-depth* orig-depth)
+ (if (> heap-after-one heap-after-two)
+ (set! *rtlgen/words-allocated* heap-after-one))
+ (set! *rtlgen/pseudo-register-values* orig-values)
+ unspecific)))))
+\f
+(define-integrable (rtlgen/register? frob)
+ (and (pair? frob)
+ (eq? (car frob) 'REGISTER)))
+
+(define-integrable (rtlgen/%pseudo-register? frob)
+ (not (null? (cddr frob))))
+
+(define-integrable (rtlgen/%machine-register? frob)
+ (null? (cddr frob)))
+
+(define-integrable (rtlgen/machine-register? frob)
+ (and (rtlgen/register? frob)
+ (rtlgen/%machine-register? frob)))
+
+(define (rtlgen/new-reg)
+ (let ((next-reg *rtlgen/next-rtl-pseudo-register*))
+ (set! *rtlgen/next-rtl-pseudo-register* (+ next-reg 1))
+ (let ((result `(REGISTER ,next-reg PSEUDO)))
+ (set! *rtlgen/pseudo-registers* (cons result *rtlgen/pseudo-registers*))
+ result)))
+
+(define (rtlgen/renumber-pseudo-registers! base)
+ (for-each (lambda (reg)
+ (set-cdr! (cdr reg) '())
+ (set-car! (cdr reg) (+ (cadr reg) base)))
+ *rtlgen/pseudo-registers*))
+
+(define (rtlgen/assign! rand* rand)
+ (if (not (rtlgen/register? rand*))
+ (internal-error "rtlgen/assign! invoked on non-register"))
+ (if (rtlgen/%pseudo-register? rand*)
+ ;; Pseudo register
+ (set! *rtlgen/pseudo-register-values*
+ (cons (list rand* rand)
+ *rtlgen/pseudo-register-values*)))
+ (rtlgen/emit!/1 `(ASSIGN ,rand* ,rand)))
+
+(define (rtlgen/assign!* instructions)
+ (for-each
+ (lambda (instruction)
+ (if (and (pair? instruction)
+ (eq? (first instruction) 'ASSIGN)
+ (rtlgen/register? (second instruction)))
+ (rtlgen/assign! (second instruction) (third instruction))
+ (rtlgen/emit!/1 instruction)))
+ instructions))
+
+(define (rtlgen/->register rand)
+ (if (rtlgen/register? rand)
+ rand
+ (let ((rand* (rtlgen/new-reg)))
+ (rtlgen/assign! rand* rand)
+ rand*)))
+
+(define (rtlgen/value-assignment state value)
+ (let* ((target (rtlgen/state/expr/target state))
+ (target*
+ (case (car target)
+ ((ANY)
+ (rtlgen/new-reg))
+ ((REGISTER)
+ target)
+ (else
+ (internal-error "Unexpected target for value" target)))))
+ (rtlgen/assign! target* value)
+ target*))
+\f
+;;;; Stack and Heap allocation
+
+(define (rtlgen/heap-push! elts)
+ (rtlgen/declare-allocation! (length elts))
+ (if (rtlgen/heap-post-increment?)
+ (rtlgen/heap-push!/post-increment elts)
+ (rtlgen/heap-push!/bump-once elts)))
+
+(define (rtlgen/heap-push!/post-increment elts)
+ (let ((free (rtlgen/reference-to-free)))
+ (rtlgen/emit!
+ (map (lambda (elt)
+ `(ASSIGN (POST-INCREMENT ,free 1) ,(rtlgen/->register elt)))
+ elts))))
+
+(define (rtlgen/heap-push!/post-increment elts)
+ (let ((free (rtlgen/reference-to-free)))
+ (for-each
+ (lambda (elt)
+ (rtlgen/emit!/1
+ `(ASSIGN (POST-INCREMENT ,free 1) ,(rtlgen/->register elt))))
+ elts)))
+
+
+
+(define (rtlgen/heap-push!/bump-once elts)
+ (let ((free (rtlgen/reference-to-free)))
+ (do ((i 0 (+ i 1))
+ (elts elts (cdr elts))
+ (acc '() (cons `(ASSIGN (OFFSET ,free (MACHINE-CONSTANT ,i))
+ ,(rtlgen/->register (car elts)))
+ acc)))
+ ((null? elts)
+ (rtlgen/emit!
+ (reverse!
+ (cons `(ASSIGN ,free (OFFSET-ADDRESS ,free (MACHINE-CONSTANT ,i)))
+ acc)))))))
+
+(define (rtlgen/stack-push! elts)
+ (rtlgen/declare-stack-allocation! (length elts))
+ (if (rtlgen/stack-pre-increment?)
+ (rtlgen/stack-push!/pre-increment elts)
+ (rtlgen/stack-push!/bump-once elts)))
+
+(define-integrable (rtlgen/stack-push!/1 elt)
+ (rtlgen/stack-push! (list elt)))
+
+(define (rtlgen/stack-push!/pre-increment elts)
+ (let ((sp (rtlgen/reference-to-sp)))
+ (rtlgen/emit!
+ (map (lambda (elt)
+ `(ASSIGN (PRE-INCREMENT ,sp -1) ,(rtlgen/->register elt)))
+ elts))))
+
+(define (rtlgen/stack-push!/bump-once elts)
+ (let ((nelts (length elts)))
+ (do ((i (- nelts 1) (- i 1))
+ (elts elts (cdr elts))
+ (acc '() (cons (rtlgen/write-stack-loc
+ (rtlgen/->register (car elts))
+ i)
+ acc)))
+ ((null? elts)
+ (rtlgen/emit!
+ (cons (rtlgen/bop-stack-pointer (- 0 nelts))
+ (reverse! acc)))))))
+
+(define (rtlgen/stack-pop!)
+ (let ((target (rtlgen/new-reg)))
+ (rtlgen/%stack-pop! target)
+ target))
+
+(define (rtlgen/%stack-pop! target)
+ (let ((rsp (rtlgen/reference-to-sp)))
+ (if (rtlgen/stack-post-increment?)
+ (rtlgen/emit!/1
+ `(ASSIGN ,target (POST-INCREMENT ,rsp 1)))
+ (rtlgen/emit!
+ (list (rtlgen/read-stack-loc target 0)
+ (rtlgen/bop-stack-pointer 1))))))
+
+(define (rtlgen/bop-stack-pointer! n)
+ (if (not (= n 0))
+ (rtlgen/emit!/1 (rtlgen/bop-stack-pointer n))))
+\f
+;;;; Machine-dependent parameters
+;; *** Currently Spectrum-specific ***
+
+;; The rtlgen/reference-* are expected to return an RTL register reference
+
+(define (rtlgen/cont-in-stack?)
+ continuation-in-stack?)
+
+(define (rtlgen/closure-in-stack?)
+ closure-in-stack?)
+
+(define (rtlgen/reference-to-free)
+ (interpreter-free-pointer))
+
+(define-integrable (rtlgen/reference-to-sp)
+ (interpreter-stack-pointer))
+
+(define-integrable (rtlgen/stack-ref n)
+ `(OFFSET ,(rtlgen/reference-to-sp) (MACHINE-CONSTANT ,n)))
+
+(define-integrable (rtlgen/stack-offset n)
+ `(OFFSET-ADDRESS ,(rtlgen/reference-to-sp) (MACHINE-CONSTANT ,n)))
+
+(define #|-integrable|# (rtlgen/bop-stack-pointer n)
+ `(ASSIGN ,(rtlgen/reference-to-sp) ,(rtlgen/stack-offset n)))
+
+(define-integrable (rtlgen/read-stack-loc reg n)
+ `(ASSIGN ,reg ,(rtlgen/stack-ref n)))
+
+(define-integrable (rtlgen/write-stack-loc reg n)
+ `(ASSIGN ,(rtlgen/stack-ref n) ,reg))
+
+(define (rtlgen/stack-ref? syllable)
+ (and (pair? syllable)
+ (eq? (first syllable) 'OFFSET)
+ (eq? (second syllable) (rtlgen/reference-to-sp))))
+
+(define (rtlgen/reference-to-regs)
+ (interpreter-regs-pointer))
+
+
+(define (rtlgen/reference-to-cont)
+ ;; defined only if not cont-in-stack?
+ (interpreter-continuation-register))
+
+(define (rtlgen/reference-to-closure)
+ (interpreter-closure-register))
+
+(define (rtlgen/fetch-memtop)
+ (interpreter-memtop-register))
+
+(define (rtlgen/fetch-int-mask)
+ (interpreter-int-mask-register))
+
+(define (rtlgen/fetch-environment)
+ (interpreter-environment-register))
+\f
+;; *rtlgen/argument-registers*
+;; This is a parameter in machin.scm
+;; for index = 0, it must be the same as reference-to-val
+;; This should leave some temps (e.g. 1, 28, 29, 30)
+
+(define rtlgen/reference-to-val
+ (let ((reg (vector-ref *rtlgen/argument-registers* 0)))
+ (lambda () `(REGISTER ,reg))))
+
+(define (rtlgen/argument-registers)
+ (if (rtlgen/cont-in-stack?)
+ (vector->list *rtlgen/argument-registers*)
+ (cons (rtl:register-number (rtlgen/reference-to-closure))
+ (vector->list *rtlgen/argument-registers*))))
+
+#|
+(define (rtlgen/available-registers available)
+ (let ((arg-regs (rtlgen/argument-registers)))
+ ;; Order is important!
+ (append arg-regs
+ (eq-set-difference (delq rtlgen/cont-register available)
+ arg-regs))))
+|#
+(define (rtlgen/available-registers available)
+ (let ((arg-regs (rtlgen/argument-registers)))
+ ;; Order is important!
+ (append arg-regs
+ (eq-set-difference (if (rtlgen/cont-in-stack?)
+ available
+ (delq (rtl:register-number
+ (rtlgen/reference-to-cont))
+ available))
+ arg-regs))))
+
+(define (rtlgen/number-of-argument-registers)
+ (vector-length *rtlgen/argument-registers*))
+
+(define (rtlgen/home-offset reg-index)
+ (pseudo-register-offset reg-index))
+
+(define (rtlgen/argument-home index)
+ (let ((vlen (vector-length *rtlgen/argument-registers*)))
+ (if (< index vlen)
+ `(REGISTER ,(vector-ref *rtlgen/argument-registers* index))
+ (internal-error "more arguments than registers" index))))
+
+;; rtlgen/interpreter-call/argument-home moved to machin.sc,
+
+(define (rtlgen/first-pseudo-register-number)
+ number-of-machine-registers)
+
+(define (rtlgen/number-of-pseudo-register-homes)
+ number-of-temporary-registers)
+\f
+;;;; Machine-dependent parameters (continued)
+
+(define (rtlgen/stack-post-increment?)
+ stack-use-pre/post-increment?)
+
+(define (rtlgen/stack-pre-increment?)
+ stack-use-pre/post-increment?)
+
+(define (rtlgen/heap-post-increment?)
+ heap-use-pre/post-increment?)
+
+
+(define (rtlgen/indexed-loads? type)
+ (machine/indexed-loads? type))
+
+(define (rtlgen/indexed-stores? type)
+ (machine/indexed-stores? type))
+
+(define (rtlgen/tagged-entry-points?)
+ (not untagged-entries?))
+
+(define (rtlgen/tagged-closures?)
+ ;; Closures are represented as entry points
+ (rtlgen/tagged-entry-points?))
+
+(define (rtlgen/cont-adjustment)
+ ;; This needs to be a parameter in machin.scm
+ ;; Distance in bytes between a raw continuation
+ ;; (as left behind by JSR) and the real continuation
+ ;; (after descriptor)
+ (machine/cont-adjustment))
+
+(define (rtlgen/closure-adjustment)
+ 0)
+
+(define-integrable rtlgen/chars-per-object
+ (quotient address-units-per-object address-units-per-packed-char))
+
+(define (rtlgen/chars->words nchars)
+ ;; Rounds up to word size and includes a zero byte.
+ (quotient (+ nchars rtlgen/chars-per-object) rtlgen/chars-per-object))
+
+(define (rtlgen/words->chars nwords)
+ (* nwords rtlgen/chars-per-object))
+
+(define rtlgen/fp->words
+ (let ((objects-per-float
+ (quotient address-units-per-float address-units-per-object)))
+ (lambda (nfp)
+ (* objects-per-float nfp))))
+
+(define (rtlgen/closure-first-offset)
+ (closure-first-offset 1 0))
+
+(define (rtlgen/closure-prefix-size)
+ (closure-object-first-offset 1))
+
+(define (rtlgen/floating-align-free)
+ (let ((free (rtlgen/reference-to-free)))
+ (rtlgen/emit!/1 `(ASSIGN ,free (ALIGN-FLOAT ,free)))))
+
+(define (rtlgen/generate-interrupt-checks?)
+ true)
+
+(define (rtlgen/generate-heap-checks?)
+ true)
+
+(define (rtlgen/generate-stack-checks?)
+ true)
+
+(define rtlgen/unassigned-object
+ (let ((tag (machine-tag 'REFERENCE-TRAP)))
+ (lambda ()
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) (MACHINE-CONSTANT 0)))))
+\f
+(define (rtlgen/preserve-state state)
+ ;; (values gen-prefix gen-suffix)
+ ;; IMPORTANT: this depends crucially on the fact that variables are
+ ;; bound to objects. The exceptions to this are the continuation
+ ;; and variable caches that are treated specially. In the future,
+ ;; when variables are bound to floats and other non-objects, they
+ ;; will have to be tagged and handled appropriately.
+
+ (define (invoke-thunk thunk)
+ (thunk))
+
+ (define (preserve infos)
+ (let loop ((infos infos)
+ (prefix '())
+ (suffix '()))
+
+ (define (%preserve&restore preserve restore)
+ (loop (cdr infos)
+ (cons preserve prefix)
+ (cons restore suffix)))
+
+ (define (preserve&restore reg how value)
+ (if (not (pair? value))
+ (internal-error "Bad preservation" reg how value))
+ (%preserve&restore
+ (lambda () (rtlgen/emit!/1 `(PRESERVE ,reg ,how)))
+ (lambda () (rtlgen/emit!/1 `(RESTORE ,reg ,value)))))
+
+ (define (box/unbox-preserve&restore reg value box-gen unbox-gen)
+ (if (rtlgen/stack-ref? value)
+ (%preserve&restore
+ (lambda ()
+ (rtlgen/emit!/1
+ `(ASSIGN ,value ,(rtlgen/->register (box-gen state)))))
+ (lambda ()
+ (rtlgen/emit!
+ `((ASSIGN ,reg ,(unbox-gen value))
+ (ASSIGN ,value ,reg)))))
+ (%preserve&restore
+ (lambda ()
+ (rtlgen/stack-push!/1 (rtlgen/->register (box-gen state))))
+ (lambda ()
+ (rtlgen/emit!
+ `((ASSIGN ,reg ,(unbox-gen (rtlgen/stack-pop!)))
+ (ASSIGN ,value ,reg)))))))
+
+ (if (null? infos)
+ (values (lambda ()
+ (for-each invoke-thunk (reverse prefix)))
+ (lambda ()
+ (for-each invoke-thunk suffix)))
+ (let* ((first (car infos))
+ (name (vector-ref first 0))
+ (reg (vector-ref first 1))
+ (value (vector-ref first 2))
+ (how (vector-ref first 3)))
+ name ; unused
+ (case how
+ ((SAVE)
+ (preserve&restore reg 'SAVE reg))
+ ((IF-AVAILABLE RECOMPUTE)
+ (preserve&restore reg how value))
+ ((PUSH)
+ ;; These cases should really communicate with the LAP level
+ ;; rather than emitting voluminous code
+ (cond ((continuation-variable? name)
+ (box/unbox-preserve&restore reg value
+ rtlgen/boxed-continuation
+ rtlgen/unboxed-continuation))
+ ((closure-variable? name)
+ (box/unbox-preserve&restore reg value
+ rtlgen/boxed-closure
+ rtlgen/unboxed-closure))
+ (else
+ (internal-error "Cannot preserve by PUSHing"
+ (car infos)))))
+ (else
+ (internal-error "Unknown preservation kind" how)))))))
+\f
+ (call-with-values
+ (lambda ()
+ (list-split (rtlgen/preservation-state state
+ *rtlgen/pseudo-register-values*)
+ (lambda (info)
+ (eq? (vector-ref info 3) 'PUSH))))
+ (lambda (pushed-info other-info)
+ (call-with-values
+ (lambda ()
+ (list-split other-info
+ (lambda (info)
+ (eq? (vector-ref info 3) 'RECOMPUTE))))
+ (lambda (recomputed maybe-preserved)
+ (preserve (append pushed-info
+ (reverse recomputed)
+ maybe-preserved)))))))
+
+(define (rtlgen/preservation-state state orig-reg-defns)
+ ;; Returns a list to 4-vectors:
+ ;; #(variable-name register home PUSH/SAVE/RECOMPUTE/IF-AVAILABLE)
+
+ (define (check result)
+ (if (not (= (length (remove-duplicates
+ (map (lambda (4v) (second (vector-ref 4v 1))) result)))
+ (length result)))
+ (begin
+ (internal-warning "Duplicate preservation:")
+ (pp `((,(length (rtlgen/state/env state)) bindings)
+ (,(length orig-reg-defns) orig-reg-defns)
+ (,(length result) result)))))
+ result)
+
+ (define (preservations-from-state state)
+ (let loop
+ ((bindings
+ (list-transform-positive (rtlgen/state/env state)
+ (lambda (binding)
+ (rtlgen/register? (rtlgen/binding/place binding)))))
+ (preservations '()))
+ (if (null? bindings)
+ preservations
+ (let* ((binding (car bindings))
+ (name (rtlgen/binding/name binding))
+ (reg (rtlgen/binding/place binding))
+ (regno (second reg)))
+ (loop
+ (cdr bindings)
+ (if (assq regno preservations)
+ preservations
+ (cons
+ (cons regno
+ (cond ((variable-cache-variable? name)
+ => (lambda (info)
+ (vector name reg (cadr info) 'RECOMPUTE)))
+ (else
+ (vector
+ name
+ reg
+ (rtlgen/binding/home binding)
+ (cond ((eq? binding
+ (rtlgen/state/continuation state))
+ 'PUSH)
+ ((eq? binding
+ (rtlgen/state/closure state))
+ 'PUSH)
+ (else 'SAVE))))))
+ preservations)))))))
+
+ ;; The following loop is basically optional; it could be replaced by
+ ;; (reverse (map cdr (preservations-from-state state)))
+ ;;
+ ;; You *MUST* generate PRESERVEs for all registers that are referenced in
+ ;; the state, since they will be referenced by RTL code after the
+ ;; return point. All other registers are optionally saved: if they
+ ;; can be saved safely (i.e. they are guaranteed to to be valid
+ ;; Scheme objects), they are. Later on, CSE will decide to reuse
+ ;; some of these registers. Thus, not saving a register inhibits
+ ;; CSE but doesn't change the correctness of the algorithm. Those
+ ;; values which are unboxed must be preserved some other way, for
+ ;; example by recomputing it from the objects from which it was
+ ;; derived.
+
+
+ (let loop
+ ((reg-defns (reverse orig-reg-defns))
+ (preservations (preservations-from-state state)))
+
+ (if (null? reg-defns)
+ (check (reverse! (map cdr preservations)))
+ (let* ((defn (car reg-defns))
+ (reg (car defn))
+ (value (cadr defn))
+ (regno (cadr reg)))
+
+ (define (ignore)
+ (loop (cdr reg-defns) preservations))
+
+ (define (preserve)
+ (loop (cdr reg-defns)
+ (cons (cons regno (vector false reg false 'SAVE))
+ preservations)))
+
+ (define (maybe-preserve)
+ (loop (cdr reg-defns)
+ (cons (cons regno (vector false reg value 'IF-AVAILABLE))
+ preservations)))
+
+ (define (reg-preserved? reg)
+ (and (rtlgen/%pseudo-register? reg)
+ (assq (cadr reg) preservations)))
+\f
+ (define (compute)
+ (loop (cdr reg-defns)
+ (cons (cons (cadr reg)
+ (vector false reg value 'RECOMPUTE))
+ preservations)))
+
+ (define (non-pointer-memory-operation)
+ (let ((index (caddr value)))
+ (cond ((not (reg-preserved? (cadr value)))
+ (ignore))
+ ((or (not (rtlgen/register? index))
+ (reg-preserved? index))
+ (compute))
+ (else
+ (ignore)))))
+
+ (if (assq regno preservations)
+ (ignore)
+ (case (car value)
+ ((REGISTER) ; Added by JSM
+ ;;(bkpt "; case = register")
+ (if (reg-preserved? value)
+ (internal-warning
+ "rtlgen/preservation-state register preserved"
+ reg value)
+ (internal-warning
+ "rtlgen/preservation-state register not preserved"
+ reg value))
+ (ignore))
+ ((OFFSET)
+ ;; *** Kludge ***
+ (let ((old (reg-preserved? (cadr value))))
+ (if (or (not old)
+ (not (vector-ref (cdr old) 2))
+ (not (memq (car (vector-ref (cdr old) 2))
+ '(VARIABLE-CACHE ASSIGNMENT-CACHE))))
+ (preserve)
+ (compute))))
+ ((FLOAT->OBJECT CONS-POINTER CONS-NON-POINTER)
+ ;; This assumes they are proper objects, and therefore
+ ;; can be preserved on their own
+ (preserve))
+ ((CONS-CLOSURE)
+ (if (rtlgen/tagged-entry-points?)
+ (ignore)
+ (preserve)))
+ ((OFFSET-ADDRESS BYTE-OFFSET-ADDRESS FLOAT-OFFSET-ADDRESS)
+ (non-pointer-memory-operation))
+ ((OBJECT->ADDRESS OBJECT->TYPE OBJECT->DATUM OBJECT->FLOAT)
+ (if (reg-preserved? (cadr value))
+ (compute)
+ (ignore)))
+ ((FLOAT-OFFSET)
+ ;; *** These should be preserved, since the preservation
+ ;; mechanism should handle floating objects. For now... ***
+ (non-pointer-memory-operation))
+ ((BYTE-OFFSET)
+ (non-pointer-memory-operation))
+ ((ENTRY:PROCEDURE ENTRY:CONTINUATION)
+ (compute))
+ ((VARIABLE-CACHE ASSIGNMENT-CACHE)
+ (compute))
+ ((CONSTANT)
+ (maybe-preserve))
+ ((FIXNUM-2-ARGS FIXNUM-1-ARG FLONUM-2-ARGS FLONUM-2-ARG)
+ ;;(internal-warning
+ ;; "rtlgen/preservation-state: arithmetic" value)
+ (preserve))
+ (else
+ (internal-warning
+ "rtlgen/preservation-state: unknown operation" value)
+ (ignore))))))))
+\f
+;;;; RTL generation of statements
+
+(define-macro (define-rtl-generator/stmt keyword bindings . body)
+ (let ((proc-name (symbol-append 'RTLGEN/ keyword '/STMT)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler state) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name state form)
+ ,code)))))))
+
+(define-rtl-generator/stmt LET (state bindings body)
+ (define (default)
+ (rtlgen/let* state bindings body rtlgen/stmt rtlgen/state/stmt/new-env))
+ (cond ((or (not (eq? 'STATIC (binding-context-type 'LET 'STATIC bindings)))
+ (and (not (null? bindings))
+ (continuation-variable? (caar bindings))))
+ (default))
+ ((or (null? bindings)
+ (not (null? (cdr bindings)))
+ (not (form/match rtlgen/fetch-env-pattern
+ (cadr (car bindings)))))
+ (rtlgen/stmt state body))
+ (else
+ (default))))
+
+(define rtlgen/fetch-env-pattern
+ `(CALL (QUOTE ,%fetch-environment) (QUOTE #F)))
+
+(define (rtlgen/let* state bindings body rtlgen/body rtlgen/state/new-env)
+ (let* ((env (rtlgen/state/env state))
+ (rands (rtlgen/expr* state (lmap cadr bindings))))
+ (rtlgen/body (rtlgen/state/new-env
+ state
+ (map* env
+ (lambda (binding rand)
+ (rtlgen/binding/make (car binding) rand false))
+ bindings
+ rands))
+ body)))
+
+(define-rtl-generator/stmt BEGIN (state #!rest actions)
+ (if (null? actions)
+ (internal-error "Empty BEGIN"))
+ (let loop ((next (car actions))
+ (rest (cdr actions)))
+ (if (null? rest)
+ (rtlgen/stmt state next)
+ (begin
+ (rtlgen/stmt/begin state next)
+ (loop (car rest) (cdr rest))))))
+
+(define (rtlgen/stmt/begin state form)
+ (define (illegal-action)
+ (internal-error "Illegal BEGIN action" form))
+ (cond ((not (pair? form))
+ (illegal-action))
+ ((DECLARE/? form)
+ false)
+ (else
+ (rtlgen/expr (rtlgen/state/->expr state '(NONE)) form))))
+\f
+(define-rtl-generator/stmt CALL (state rator cont #!rest rands)
+ ;; This CALL must be in tail-recursive position of the combination
+ (define (bad-rator)
+ (internal-error "Illegal CALL statement operator" rator))
+ (cond
+ ((QUOTE/? rator)
+ (rtlgen/call* state (quote/text rator) cont rands))
+ ((LOOKUP/? rator)
+ (set! *rtlgen/form-calls-internal?* true)
+ (rtlgen/jump state (lookup/name rator) cont rands))
+ ((LAMBDA/? rator)
+ (let ((call `(CALL ,rator ,cont ,@rands)))
+ (cond ((not (null? rands)) (bad-rator))
+ ((form/match rtlgen/extended-call-pattern call)
+ ;; /compatible
+ ;; Compatibility only, extended stack frame
+ => (lambda (result)
+ (rtlgen/extended-call state result call)))
+ ((form/match rtlgen/call-lambda-with-stack-closure-pattern call)
+ => (lambda (result)
+ (rtlgen/call-lambda-with-stack-closure
+ state result call rator cont rands)))
+ (else (bad-rator)))))
+ (else (bad-rator))))
+
+(define (rtlgen/extended-call state match-result call)
+ (let (#| (cont-name (cadr (assq rtlgen/?cont-name match-result))) |#
+ (rator (cadr (assq rtlgen/?rator match-result)))
+ (frame-vector* (cadr (assq rtlgen/?frame-vector* match-result)))
+ (closure-elts* (cadr (assq rtlgen/?closure-elts* match-result)))
+ (rands (cadr (assq rtlgen/?rands match-result)))
+ (ret-add (cadr (assq rtlgen/?return-address match-result)))
+ (frame-vector (cadr (assq rtlgen/?frame-vector match-result)))
+ (closure-elts (cadr (assq rtlgen/?closure-elts match-result))))
+ (if (not (LAMBDA/? ret-add))
+ (internal-error "Bad extended call" call)
+ (rtlgen/call* state
+ rator
+ `(CALL (QUOTE ,%make-stack-closure)
+ (QUOTE #F)
+ (QUOTE #F)
+ (QUOTE ,(list->vector
+ (append (vector->list frame-vector)
+ (vector->list frame-vector*))))
+ ,@closure-elts
+ (CALL (QUOTE ,%make-return-address)
+ (QUOTE #F)
+ ,ret-add)
+ ,@closure-elts*)
+ rands))))
+
+
+(define (rtlgen/call-lambda-with-stack-closure state dict call rator cont rands)
+ ;; (CALL (LAMBDA (CONT) ...)
+ ;; (call %make-stack-closure ...))
+ ;; This is nasty because the LAMBDA has free variables which might be
+ ;; stack references and the stack might contain a (raw) closure
+ ;; pointer.
+ ;;
+ ;; We rely on the fact that the state bindings for stack resident names
+ ;; are already loaded into pseudo-registers, as are the continuation
+ ;; and closure pointers. We also rely on the continuation CONT
+ ;; being a make-stack-closure that saves the current valid
+ ;; continuation.
+ ;;
+ ;; Most of the work is loading the continuation (register or stack
+ ;; location) with the right value, and making a state for compiling
+ ;; the body of the LAMBDA in-line.
+
+ (define (bad-rator)
+ (internal-error "Illegal CALL statement operator" rator))
+
+ (internal-warning "call-lambda-with-stack-closure" call)
+
+ ;; Sanity check: we can only rearrange the stack if all stack references
+ ;; have already been loaded into pseudo-registers. This may include
+ ;; the continuation and closure pointer.
+ (for-each
+ (lambda (binding)
+ (define (on-stack? syllable)
+ (form/match
+ `(OFFSET ,(rtlgen/reference-to-sp)
+ (MACHINE-CONSTANT ,(->pattern-variable 'offset)))
+ syllable))
+ (if (and (on-stack? (rtlgen/binding/home binding))
+ (not (rtlgen/register?
+ (rtlgen/binding/place binding))))
+ (internal-error "Stack variable not in register" binding)))
+ (rtlgen/state/stmt/env state))
+
+ (let ((cont-var (cadr (assq rtlgen/?cont-name dict)))
+ (code-body (cadr (assq rtlgen/?body dict))))
+ (let* ((old-closure-binding (rtlgen/state/stmt/closure state))
+ (clos-reg (and old-closure-binding (rtlgen/new-reg)))
+ (new-closure-binding
+ (and old-closure-binding
+ (rtlgen/binding/make
+ (rtlgen/binding/name old-closure-binding)
+ clos-reg
+ (rtlgen/binding/home old-closure-binding))))
+ (old-continuation-binding (rtlgen/state/stmt/continuation state))
+ (cont-label
+ (rtlgen/continuation-is-stack-closure state cont bad-rator #F #T))
+ (cont-adj (rtlgen/cont-adjustment))
+ (label-reg (rtlgen/new-reg))
+ (cont-reg (if (zero? cont-adj) label-reg (rtlgen/new-reg)))
+ (new-continuation-home
+ (if (rtlgen/cont-in-stack?)
+ (rtlgen/stack-ref
+ (if (and (rtlgen/closure-in-stack?) new-closure-binding) 1 0))
+ (rtlgen/reference-to-cont)))
+ (new-continuation-binding
+ (rtlgen/binding/make cont-var cont-reg new-continuation-home))
+ (new-size
+ (+ (if (and (rtlgen/cont-in-stack?) new-continuation-binding) 1 0)
+ (if (and (rtlgen/closure-in-stack?) new-closure-binding) 1 0))))
+
+ (if (not cont-label)
+ (internal-error "call-lambda-with-stack-closure and no label" call))
+
+ ;; JIM says "I don't see what guarantees
+ ;; me that no one needs the current value
+ ;; of the physical continuation register!"
+ ;; SRA: It should be saved by the stack rewriting.
+
+ ;; Allocate stack space for stack-based values:
+ (rtlgen/bop-stack-pointer! (- new-size))
+
+ (rtlgen/emit!/1
+ `(ASSIGN ,label-reg (ENTRY:CONTINUATION ,cont-label)))
+ (if (not (zero? cont-adj))
+ (rtlgen/emit!/1
+ `(ASSIGN ,cont-reg
+ (BYTE-OFFSET-ADDRESS ,label-reg
+ (MACHINE-CONSTANT ,(- 0 cont-adj))))))
+
+ (if (rtlgen/cont-in-stack?)
+ (begin
+ ;; write the continuation into the stack
+ (rtlgen/emit!/1
+ `(ASSIGN ,(rtlgen/binding/home new-continuation-binding)
+ ,cont-reg)))
+ (begin
+ (rtlgen/emit!/1
+ `(ASSIGN ,(rtlgen/reference-to-cont) ,cont-reg))))
+
+ (if old-closure-binding
+ (begin
+ (if (rtlgen/closure-in-stack?)
+ (begin
+ ;; write closure pointer back into stack
+ (rtlgen/emit!/1
+ `(ASSIGN ,(rtlgen/binding/home old-closure-binding)
+ ,(rtlgen/binding/place old-closure-binding)))))
+ (rtlgen/emit!/1
+ `(ASSIGN ,clos-reg ,(rtlgen/binding/place old-closure-binding)))))
+
+ ;;(bkpt "\n;;; rtlgen/call-lambda-with-stack-closure")
+
+ (let ((new-state
+ (rtlgen/state/stmt/make
+ `(,new-continuation-binding
+ ,@(if new-closure-binding (list new-closure-binding) '())
+ . ,(rtlgen/state/stmt/env state))
+ new-continuation-binding
+ new-closure-binding
+ new-size)))
+ (bkpt 'hi)
+ (rtlgen/stmt new-state code-body)))))
+
+
+(define-rtl-generator/stmt LETREC (state bindings body)
+ (rtlgen/letrec/bindings bindings)
+ (rtlgen/stmt state body))
+
+(define (rtlgen/letrec/bindings bindings)
+ (set! *rtlgen/delayed-objects*
+ (fold-right (lambda (binding rest)
+ (cons (cons (car binding)
+ (vector 'PROCEDURE false (cadr binding)))
+ rest))
+ *rtlgen/delayed-objects*
+ bindings))
+ unspecific)
+\f
+(define-rtl-generator/stmt IF (state pred conseq alt)
+ (rtlgen/if* state pred conseq alt rtlgen/stmt false))
+
+(define (rtlgen/if* state pred conseq alt rtlgen/form need-merge?)
+ (let ((true-label (rtlgen/new-name 'TRUE))
+ (false-label (rtlgen/new-name 'FALSE)))
+ (call-with-values
+ (lambda ()
+ (rtlgen/predicate state true-label false-label pred))
+ (lambda (true-label-taken? false-label-taken?)
+ (define (do-true)
+ (rtlgen/with-label true-label rtlgen/form state conseq))
+ (define (do-false)
+ (rtlgen/with-label false-label rtlgen/form state alt))
+ (cond ((not true-label-taken?)
+ (if (not false-label-taken?)
+ (internal-error "Predicate takes neither branch" pred))
+ (do-false))
+ ((not false-label-taken?)
+ (do-true))
+ (else
+ (rtlgen/emit-alternatives! do-true do-false need-merge?)))))))
+
+(define (rtlgen/stmt state expr)
+ ;; No meaningful value
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((LET)
+ (rtlgen/let/stmt state expr))
+ ((CALL)
+ (rtlgen/call/stmt state expr))
+ ((IF)
+ (rtlgen/if/stmt state expr))
+ ((BEGIN)
+ (rtlgen/begin/stmt state expr))
+ ((LETREC)
+ (rtlgen/letrec/stmt state expr))
+ ((QUOTE LOOKUP LAMBDA DECLARE)
+ (internal-error "Illegal statement" expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+\f
+(define (rtlgen/with-label label generator state expr)
+ (rtlgen/emit!/1 `(LABEL ,label))
+ (generator state expr))
+
+(define (rtlgen/predicate state true-label false-label pred)
+ (let ((tl (list true-label 0))
+ (fl (list false-label 0)))
+ (let ((loc (rtlgen/expr (rtlgen/state/->expr state `(PREDICATE ,tl ,fl))
+ pred)))
+ (if loc
+ (internal-warning "Predicate returned a value" pred loc))
+ (values (not (zero? (cadr tl)))
+ (not (zero? (cadr fl)))))))
+
+(define (rtlgen/reference-true-label! target)
+ (let ((true-label (cadr target)))
+ (set-car! (cdr true-label) (+ (cadr true-label) 1))
+ (car true-label)))
+
+(define (rtlgen/reference-false-label! target)
+ (let ((false-label (caddr target)))
+ (set-car! (cdr false-label) (+ (cadr false-label) 1))
+ (car false-label)))
+\f
+(define (rtlgen/branch/true state)
+ (let ((cont (rtlgen/state/expr/target state)))
+ (rtlgen/emit!/1 `(JUMP ,(rtlgen/reference-true-label! cont)))))
+
+(define (rtlgen/branch/false state)
+ (let ((cont (rtlgen/state/expr/target state)))
+ (rtlgen/emit!/1 `(JUMP ,(rtlgen/reference-false-label! cont)))))
+
+(define (rtlgen/branch/likely state predicate)
+ (let ((cont (rtlgen/state/expr/target state)))
+ (rtlgen/emit!
+ (list `(JUMPC ,predicate ,(rtlgen/reference-true-label! cont))
+ `(JUMP ,(rtlgen/reference-false-label! cont))))
+ false))
+
+(define (rtlgen/branch/unlikely state predicate)
+ (let ((cont (rtlgen/state/expr/target state)))
+ (rtlgen/emit!
+ (list `(JUMPC (NOT ,predicate) ,(rtlgen/reference-false-label! cont))
+ `(JUMP ,(rtlgen/reference-true-label! cont))))
+ false))
+
+(define (rtlgen/branch/unpredictable state predicate)
+ (let ((cont (rtlgen/state/expr/target state)))
+ (rtlgen/emit!
+ (list `(JUMPC (UNPREDICTABLE ,predicate)
+ ,(rtlgen/reference-true-label! cont))
+ `(JUMP ,(rtlgen/reference-false-label! cont))))
+ false))
+
+(define (rtlgen/branch/false? state loc)
+ (let* ((cont (rtlgen/state/expr/target state))
+ (default
+ (lambda ()
+ (let ((reg (rtlgen/->register loc)))
+ (rtlgen/emit!
+ (list `(JUMPC (NOT (PRED-1-ARG FALSE? ,reg))
+ ,(rtlgen/reference-true-label! cont))
+ `(JUMP ,(rtlgen/reference-false-label! cont))))))))
+ (if (not (rtlgen/constant? loc))
+ (default)
+ (case (boolean/discriminate (rtlgen/constant-value loc))
+ ((FALSE)
+ (rtlgen/emit!/1 `(JUMP ,(rtlgen/reference-false-label! cont))))
+ ((TRUE)
+ (rtlgen/emit!/1 `(JUMP ,(rtlgen/reference-true-label! cont))))
+ (else
+ (default)))))
+ false)
+\f
+(define (rtlgen/call* state rator* cont rands)
+ (define (bad-rator)
+ (internal-error "Illegal CALL statement operator" rator*))
+
+ (define (verify-rands len)
+ (if (not (= len (length rands)))
+ (internal-error "Wrong number of arguments" rator* rands)))
+
+ (cond ((eq? rator* %invoke-continuation)
+ (set! *rtlgen/form-returns?* true)
+ (rtlgen/return state cont rands))
+ ((eq? rator* %internal-apply)
+ (set! *rtlgen/form-calls-external?* true)
+ (rtlgen/%apply state (second rands) cont
+ (quote/text (first rands)) (cddr rands)))
+ ((eq? rator* %invoke-operator-cache)
+ (set! *rtlgen/form-calls-external?* true)
+ (rtlgen/invoke-operator-cache state
+ 'INVOCATION:UUO-LINK
+ (first rands) ; name+nargs
+ cont
+ (cddr rands))) ; exprs
+ ((eq? rator* %invoke-remote-cache)
+ (set! *rtlgen/form-calls-external?* true)
+ (rtlgen/invoke-operator-cache state
+ 'INVOCATION:GLOBAL-LINK
+ (first rands) ; name+nargs
+ cont
+ (cddr rands))) ; exprs
+ ((eq? rator* %primitive-apply/compatible)
+ (verify-rands 2) ; arity, primitive
+ (set! *rtlgen/form-calls-external?* true)
+ (rtlgen/invoke-primitive/compatible state
+ (first rands) ; nargs
+ (second rands) ; prim
+ cont))
+ ((hash-table/get *open-coders* rator* false)
+ (set! *rtlgen/form-returns?* true)
+ (if (not (operator/satisfies? rator* '(SPECIAL-INTERFACE)))
+ (begin
+ (rtlgen/invoke-out-of-line state rator* cont rands))
+ (rtlgen/invoke-special state rator* cont rands)))
+ (else
+ (bad-rator))))
+\f
+(define (rtlgen/return state cont exprs)
+ (define (illegal-continuation)
+ (internal-error "Unexpected continuation for return" cont))
+ (rtlgen/exprs->call-registers state #F exprs)
+ (cond ((LOOKUP/? cont)
+ (let* ((adj (rtlgen/cont-adjustment))
+ (rcont (rtlgen/state/reference-to-cont state))
+ (result (if (zero? adj) rcont (rtlgen/new-reg))))
+ (rtlgen/bop-stack-pointer! (rtlgen/state/stmt/size state))
+ (if (not (zero? adj))
+ (rtlgen/emit!/1
+ `(ASSIGN ,result
+ (BYTE-OFFSET-ADDRESS ,rcont
+ (MACHINE-CONSTANT ,adj)))))
+ (rtlgen/emit!/1
+ `(INVOCATION:REGISTER 0
+ #F
+ ,result
+ #F
+ (MACHINE-CONSTANT 1)))))
+ ((CALL/%stack-closure-ref? cont)
+ (let ((size (rtlgen/state/stmt/size state)))
+ (let* ((offset (- size 1))
+ (obj (rtlgen/new-reg))
+ (retad (if (rtlgen/tagged-entry-points?)
+ (rtlgen/new-reg)
+ obj)))
+ (rtlgen/emit!
+ (list (rtlgen/read-stack-loc obj offset)
+ (rtlgen/bop-stack-pointer size)))
+ (if (rtlgen/tagged-entry-points?)
+ (rtlgen/emit!/1
+ `(ASSIGN ,retad (OBJECT->ADDRESS ,obj))))
+ (rtlgen/emit!/1
+ `(INVOCATION:REGISTER 0
+ #F
+ ,retad
+ #F
+ (MACHINE-CONSTANT 1))))))
+ ((CALL/%make-stack-closure? cont)
+ ;; This will not work for stack closures used just to push
+ ;; arguments, but it makes no sense to encounter that case
+ ;;(let ((handler (rtlgen/continuation-is-stack-closure
+ ;; state cont illegal-continuation #F #F)))
+ ;; (rtlgen/emit!
+ ;; (rtlgen/%%continuation
+ ;; 'FAKE-LABEL handler
+ ;; (lambda (label body saved-size arity)
+ ;; saved-size arity ; Unused
+ ;; (if (not (eq? label 'FAKE-LABEL))
+ ;; (internal-error "New label generated for FAKE-LABEL"))
+ ;; body))))
+ (let ((label (rtlgen/continuation-is-stack-closure
+ state cont illegal-continuation #F #T)))
+ (if label
+ (begin
+ ;; Cant use jump because jump in an internal edge in rtl graph
+ ;;(rtlgen/emit!/1 `(JUMP ,label))
+
+ ;; The mention of the continuation is necessary otherwise the
+ ;; lap linearizer fails to see the continuation and discards
+ ;; it.
+ (rtlgen/emit!/1 `(ASSIGN ,(rtlgen/new-reg)
+ (ENTRY:CONTINUATION ,label)))
+ (rtlgen/emit!/1
+ `(INVOCATION:PROCEDURE 0 #F ,label (MACHINE-CONSTANT 1)))
+
+ ;; This also works but produces poor code:
+ ;;(let ((reg (rtlgen/new-reg)))
+ ;; (rtlgen/emit!
+ ;; `((ASSIGN ,reg (ENTRY:CONTINUATION ,label))
+ ;; (INVOCATION:REGISTER 0 #F ,reg #F (MACHINE-CONSTANT 1)))))
+ )
+ ;; If it was not a label then ../continuation-is-stack-closure
+ ;; left the raw continuation in the standard place:
+ (let* ((adj (rtlgen/cont-adjustment))
+ (rcont (if (rtlgen/cont-in-stack?)
+ (rtlgen/new-reg)
+ (rtlgen/state/reference-to-cont state)))
+ (result (if (zero? adj) rcont (rtlgen/new-reg))))
+ (if (rtlgen/cont-in-stack?)
+ (rtlgen/stack-pop! rcont))
+ (if (not (zero? adj))
+ (rtlgen/emit!/1
+ `(ASSIGN ,result
+ (BYTE-OFFSET-ADDRESS ,rcont
+ (MACHINE-CONSTANT ,adj)))))
+ (rtlgen/emit!/1
+ `(INVOCATION:REGISTER 0
+ #F
+ ,result
+ #F
+ (MACHINE-CONSTANT 1)))))))
+ (else (illegal-continuation))))
+
+
+(define (rtlgen/continuation-label->object label)
+ (rtlgen/continuation->object `(ENTRY:CONTINUATION ,label)))
+
+(define-integrable (rtlgen/continuation->object cont)
+ (rtlgen/entry->object cont))
+
+(define compiled-entry-tag
+ (machine-tag 'COMPILED-ENTRY))
+
+(define (rtlgen/entry->object cont)
+ (if (not (rtlgen/tagged-entry-points?))
+ cont
+ (let ((rand (rtlgen/->register cont)))
+ `(CONS-POINTER (MACHINE-CONSTANT ,compiled-entry-tag)
+ ,rand))))
+\f
+(define (rtlgen/%apply state rator cont nargs rands)
+ (let ((rator (rtlgen/->register
+ (rtlgen/expr (rtlgen/state/->expr state '(ANY))
+ rator))))
+ (rtlgen/invoke
+ state cont rands
+ (lambda (cont-label)
+ (rtlgen/emit!/1
+ `(INVOCATION:NEW-APPLY ,(+ nargs 1)
+ ,cont-label
+ ,rator
+ (MACHINE-CONSTANT 0)))))))
+
+(define (rtlgen/invoke-operator-cache state kind name+arity cont rands)
+ (if (not (QUOTE/? name+arity))
+ (internal-error "Unexpected execute cache descriptor" name+arity))
+ (let ((name+arity* (cadr name+arity)))
+ (let ((name (car name+arity*))
+ (nargs* (cadr name+arity*)))
+ (let ((nargs
+ (if nargs*
+ (if (and #F ; SRA - no longer true!
+ (not (= nargs* (length rands))))
+ (internal-error
+ "RTLGEN/INVOKE-OPERATOR-CACHE: actuals/args mismatch"
+ nargs* (length rands))
+ nargs*)
+ (length rands))))
+ (rtlgen/invoke
+ state cont rands
+ (lambda (cont-label)
+ (rtlgen/emit!/1 `(,kind ,(+ nargs 1) ,cont-label ,name))))))))
+
+(define (rtlgen/invoke-primitive/compatible state nargs prim cont)
+ (rtlgen/invoke/compatible
+ state cont
+ (lambda (cont-label)
+ (rtlgen/emit!/1
+ `(INVOCATION:PRIMITIVE ,(+ (cadr nargs) 1) ,cont-label
+ ,(cadr prim))))))
+
+(define (rtlgen/invoke-out-of-line state rator* cont rands)
+ (rtlgen/exprs->call-registers state #F rands)
+ (rtlgen/open-code/out-of-line
+ (rtlgen/continuation-setup/jump! state cont)
+ rator*))
+
+(define (rtlgen/invoke-special state rator* cont rands)
+ (let ((rands* (rtlgen/expr* state rands)))
+ (rtlgen/with-local-continuation
+ state cont
+ (lambda (cont-label)
+ (rtlgen/open-code/special cont-label rator* rands*)))))
+
+(define (rtlgen/with-local-continuation state cont codegen)
+ (rtlgen/stack-allocation/protect ; /compatible
+ (lambda ()
+ (let ((cont-label (rtlgen/continuation-setup/saved! state cont)))
+ (if cont-label
+ (codegen cont-label)
+ (let ((label* (rtlgen/new-name 'AFTER-HOOK)))
+ (codegen label*)
+ (rtlgen/emit!
+ (list `(RETURN-ADDRESS ,label*
+ (MACHINE-CONSTANT 0)
+ (MACHINE-CONSTANT 1))
+ `(POP-RETURN)))))))))
+
+(define (rtlgen/invoke/compatible state cont jump-gen)
+ ;; rands will be on the stack by now
+ (jump-gen (rtlgen/continuation-setup/compatible! state cont)))
+
+(define (rtlgen/invoke state cont rands jump-gen)
+ ;; SRA - should the continuation setup be done before call register setup
+ ;; to reduce register pressure (as saved argument registers might
+ ;; then be dead) ?? -- NO: the registers may be set up from the
+ ;; stack-frame, so it must be setup after -- is this true??
+ (rtlgen/exprs->call-registers state #F rands)
+ ; JSM ... double check this
+ (jump-gen (rtlgen/continuation-setup/jump! state cont)))
+
+(define (rtlgen/continuation-setup/compatible! state cont)
+ (define (bad-cont)
+ (internal-error "Unexpected CALL continuation [compatible!]"
+ cont))
+ (rtlgen/continuation-is-stack-closure state cont bad-cont #T #T))
+
+(define (rtlgen/exprs->call-registers state *self* rands)
+ ;; *self* is either #F or the expression which must be loaded into
+ ;; the closure register before calling the destination procedure.
+ (define (rtlgen/possibly-used-regs env form)
+ (let loop ((vars (form/%free-vars form false))
+ (regs '()))
+ (if (null? vars)
+ regs
+ (let* ((var (car vars))
+ (place (rtlgen/binding/find var env)))
+ (cond ((not place)
+ (if (or (get-variable-property var 'VARIABLE-CELL)
+ (get-variable-property var 'FRAME-VARIABLE)
+ (assq var *rtlgen/delayed-objects*))
+ (loop (cdr vars) regs)
+ (free-var-error var)))
+ ((rtlgen/machine-register? (rtlgen/binding/home place))
+ (loop (cdr vars)
+ (eqv-set-adjoin (cadr (rtlgen/binding/home place))
+ regs)))
+ (else
+ (loop (cdr vars) regs)))))))
+ (define (do-rand rand target)
+ (let ((result (rtlgen/expr (rtlgen/state/->expr state target)
+ rand)))
+ (if (not (equal? result target))
+ (internal-error "Argument value not in expected place"
+ result))))
+
+ (let* ((env (rtlgen/state/env state))
+ (arg-info
+ (do ((arg-number 0 (+ arg-number 1))
+ (rands rands (cdr rands))
+ (result
+ (if *self*
+ `((,(rtlgen/reference-to-closure)
+ ,*self*
+ ,(rtlgen/possibly-used-regs env *self*)))
+ '())
+ (let ((target (rtlgen/argument-home arg-number)))
+ (cons
+ (list target
+ (car rands)
+ (rtlgen/possibly-used-regs env (car rands)))
+ result))))
+ ((null? rands)
+ result))))
+
+ (call-with-values
+ (lambda ()
+ (list-split arg-info (lambda (arg) (rtlgen/register? (car arg)))))
+ (lambda (->regs ->homes)
+ (let ((->homes*
+ (map (lambda (arg)
+ (cons (rtlgen/new-reg) arg))
+ ->homes)))
+ (for-each (lambda (arg)
+ (do-rand (caddr arg) (car arg)))
+ ->homes*)
+ (let* ((pairs (map (lambda (info) (cons (cadr (car info)) info))
+ ->regs))
+ (sorted
+ (map (lambda (result)
+ (let ((pair (assv (car (vector-ref result 1))
+ pairs)))
+ (cond ((not pair)
+ (internal-error
+ "Parallel assignment found a register"
+ result))
+ ((vector-ref result 0) ; early?
+ (cons (rtlgen/new-reg) (cdr pair)))
+ (else
+ (cons (cadr pair) (cdr pair))))))
+ (parallel-assignment
+ (map (lambda (arg)
+ (cons (cadr (car arg)) (caddr arg)))
+ ->regs)))))
+ (for-each (lambda (arg)
+ (do-rand (caddr arg) (car arg)))
+ sorted)
+ (for-each (lambda (arg)
+ (if (not (eq? (car arg) (cadr arg)))
+ (rtlgen/emit!/1 `(ASSIGN ,(cadr arg) ,(car arg)))))
+ sorted))
+ (for-each (lambda (arg)
+ (rtlgen/emit!/1 `(ASSIGN ,(cadr arg) ,(car arg))))
+ ->homes*))))))
+
+(define (rtlgen/expr-results->call-registers state rands)
+ state ; Not used
+ (define (make-descr rand home) (cons rand home))
+ ; (define (descr/rand descr) (car descr))
+ (define (descr/home descr) (cdr descr))
+
+ (let ((homes (let process ((rands rands) (i 0))
+ (if (null? rands)
+ '()
+ (cons (make-descr (car rands) (rtlgen/argument-home i))
+ (process (cdr rands) (1+ i))))))
+ (temps (map (lambda (ignore) ignore (rtlgen/new-reg)) rands)))
+
+ (for-each (lambda (rand temp)
+ (rtlgen/emit!/1 `(ASSIGN ,temp ,rand)))
+ rands
+ temps)
+ (for-each (lambda (temp descr)
+ (rtlgen/emit!/1 `(ASSIGN ,(descr/home descr) ,temp)))
+ temps
+ homes)))
+\f
+(define (rtlgen/jump state var-name cont rands)
+ (let* ((cont-label (rtlgen/continuation-setup/jump! state cont))
+ (label (rtlgen/enqueue-delayed-object! var-name 'PROCEDURE)))
+ (let* ((proc-info (rtlgen/find-delayed-object var-name))
+ (lambda-expr (vector-ref proc-info 2))
+ (params (and (LAMBDA/? lambda-expr)
+ (lambda/formals lambda-expr))))
+ (if (not params)
+ (internal-error "rtlgen/jump: bad destination"
+ var-name lambda-expr))
+ (let* ((needs-self? (and (pair? (cdr params))
+ (closure-variable? (cadr params))))
+ (true-rands (if needs-self? (cdr rands) rands)))
+ (if needs-self?
+ (rtlgen/exprs->call-registers state (car rands) (cdr rands))
+ (rtlgen/exprs->call-registers state #F rands))
+ (rtlgen/emit!/1
+ `(INVOCATION:PROCEDURE 0 ,cont-label ,label
+ (MACHINE-CONSTANT ,(+ (length true-rands) 1))))))))
+
+(define (rtlgen/continuation-setup/jump! state cont)
+ (define (bad-cont)
+ (internal-error "Unexpected CALL continuation [jump!]"
+ cont))
+ (cond ((LOOKUP/? cont)
+ ;; Continuation already in the right place!
+ (rtlgen/pop state))
+ ((CALL/%stack-closure-ref? cont)
+ ;; This assumes it is the continuation variable!
+ (rtlgen/reload-continuation&pop state))
+ ((CALL/%make-stack-closure? cont)
+ (rtlgen/continuation-is-stack-closure
+ state cont bad-cont #F #T))
+ (else
+ (bad-cont))))
+\f
+(define (rtlgen/pop state)
+ (cond ((and state
+ (rtlgen/state/stmt/size state))
+ => rtlgen/%pop))
+ false)
+
+(define (rtlgen/%pop size)
+ ;; Pop off the current stack frame, but be sure to leave the current
+ ;; continuation (which may be at the top of the stack) in the usual
+ ;; place.
+ (cond ((zero? size) false) ; No work to do
+ ((rtlgen/cont-in-stack?)
+ (let ((tempreg (rtlgen/stack-pop!)))
+ (rtlgen/bop-stack-pointer! (- size 1))
+ (rtlgen/emit!/1 (rtlgen/write-stack-loc tempreg 0))))
+ (else
+ (rtlgen/bop-stack-pointer! size))))
+
+(define (rtlgen/reload-continuation&pop state)
+ (rtlgen/%reload-continuation&pop (rtlgen/state/stmt/guaranteed-size state)))
+
+(define (rtlgen/%reload-continuation&pop size)
+ (let* ((adj (rtlgen/cont-adjustment))
+ (in-stack? (rtlgen/cont-in-stack?))
+ (pop? (and (= size 1)
+ (rtlgen/stack-post-increment?)
+ (not in-stack?)))
+ (offset (cond (pop? 0)
+ (in-stack? (- size 1))
+ (else size)))
+ (contreg (if in-stack?
+ (rtlgen/new-reg)
+ (rtlgen/reference-to-cont)))
+ (tempreg (if (zero? adj)
+ contreg
+ (rtlgen/new-reg)))
+ (contobj (if (rtlgen/tagged-entry-points?)
+ (rtlgen/new-reg)
+ tempreg)))
+ (cond (pop?
+ (rtlgen/%stack-pop! contobj))
+ (else
+ (rtlgen/emit!/1 (rtlgen/read-stack-loc contobj (- size 1)))
+ (rtlgen/bop-stack-pointer! offset)))
+ (if (rtlgen/tagged-entry-points?)
+ (rtlgen/emit!/1 `(ASSIGN ,tempreg (OBJECT->ADDRESS ,contobj))))
+ (if (not (zero? adj))
+ (rtlgen/emit!/1
+ `(ASSIGN ,contreg
+ (BYTE-OFFSET-ADDRESS ,tempreg
+ (MACHINE-CONSTANT ,(- 0 adj))))))
+ (if in-stack? (rtlgen/emit!/1 (rtlgen/write-stack-loc contreg 0))))
+ false)
+
+(define (rtlgen/boxed-continuation state)
+ (let ((adj (rtlgen/cont-adjustment))
+ (raw (rtlgen/->register (rtlgen/state/reference-to-cont state))))
+ (rtlgen/continuation->object
+ (if (zero? adj)
+ raw
+ (rtlgen/->register
+ `(BYTE-OFFSET-ADDRESS ,raw (MACHINE-CONSTANT ,adj)))))))
+
+(define (rtlgen/unboxed-continuation reg)
+ (let ((adj (rtlgen/cont-adjustment))
+ (untagged (if (rtlgen/tagged-entry-points?)
+ `(OBJECT->ADDRESS ,(rtlgen/->register reg))
+ reg)))
+ (if (zero? adj)
+ untagged
+ `(BYTE-OFFSET-ADDRESS ,(rtlgen/->register untagged)
+ (MACHINE-CONSTANT ,(- adj))))))
+
+(define (rtlgen/boxed-closure state)
+ (let ((adj (rtlgen/closure-adjustment))
+ (raw (rtlgen/->register (rtlgen/state/reference-to-closure state))))
+ (rtlgen/entry->object
+ (if (zero? adj)
+ raw
+ (rtlgen/->register
+ `(BYTE-OFFSET-ADDRESS ,raw (MACHINE-CONSTANT ,adj)))))))
+
+(define (rtlgen/unboxed-closure reg)
+ (let ((adj (rtlgen/closure-adjustment))
+ (untagged (if (rtlgen/tagged-entry-points?)
+ `(OBJECT->ADDRESS ,(rtlgen/->register reg))
+ reg)))
+ (if (zero? adj)
+ untagged
+ `(BYTE-OFFSET-ADDRESS ,(rtlgen/->register untagged)
+ (MACHINE-CONSTANT ,(- adj))))))
+
+\f
+(define (rtlgen/continuation-is-stack-closure
+ state cont bad-cont allow-sharp-f? enqueue?)
+ ;; Returns the continuation's label or #F if not known, adjusts
+ ;; the stack to match the model specified by the continuation, and
+ ;; moves the continuation to the standard location (register or top
+ ;; of stack)
+ (define (core) (rtlgen/setup-stack-closure! state cont))
+ (define (setup! label)
+ (if (not label)
+ ;; Not a true subproblem, no need to stack
+ ;; check if this is the only stuff on the stack.
+ (rtlgen/stack-allocation/protect core)
+ (core))
+ label)
+ (if (not (CALL/%make-stack-closure? cont)) (bad-cont))
+ (let ((handler (call/%make-stack-closure/lambda-expression cont)))
+ (cond ((LAMBDA/? handler)
+ (setup!
+ (if enqueue?
+ (rtlgen/enqueue-object! handler 'CONTINUATION)
+ handler)))
+ ((LOOKUP/? handler) ;stack adjustment using unboxed cont.
+ (if (rtlgen/cont-in-stack?)
+ (let ((temp-reg (rtlgen/state/reference-to-cont state)))
+ (setup! false)
+ (rtlgen/stack-push!/1 temp-reg)
+ false)
+ (setup! false)))
+ ((CALL/%stack-closure-ref? handler) ;
+ (if (rtlgen/state/continuation state)
+ (internal-error "Continuation has a raw continuation"
+ cont state))
+ (rtlgen/setup-stack-closure/saved-continuation
+ (rtlgen/state/stmt/guaranteed-size state)
+ handler
+ (lambda () (setup! false))))
+ ((and allow-sharp-f? (equal? ''#F handler))
+ (setup! false))
+ (else (bad-cont)))))
+
+
+(define (rtlgen/setup-stack-closure/saved-continuation size ref rearrange!)
+ ;; A continuation is returning/tailing using a saved & boxed continuation/
+ ;; Assumption: the %stack-closure-ref REF is to the base of the stack frame.
+ ;; This looks too much like RTLGEN/%RELOAD-CONTINUATION&POP for comfort
+ ref ; Unused
+ (let* ((adj (rtlgen/cont-adjustment))
+ (in-stack? (rtlgen/cont-in-stack?))
+ (contreg (if in-stack?
+ (rtlgen/new-reg)
+ (rtlgen/reference-to-cont)))
+ (tempreg (if (zero? adj)
+ contreg
+ (rtlgen/new-reg)))
+ (contobj (if (rtlgen/tagged-entry-points?)
+ (rtlgen/new-reg)
+ tempreg)))
+ (rtlgen/emit!
+ (list (rtlgen/read-stack-loc contobj (- size 1))))
+ (if (rtlgen/tagged-entry-points?)
+ (rtlgen/emit!/1 `(ASSIGN ,tempreg (OBJECT->ADDRESS ,contobj))))
+ (if (not (zero? adj))
+ (rtlgen/emit!/1
+ `(ASSIGN ,contreg
+ (BYTE-OFFSET-ADDRESS ,tempreg
+ (MACHINE-CONSTANT ,(- 0 adj))))))
+ (rearrange!)
+ (if in-stack? (rtlgen/stack-push!/1 contreg)))
+ false)
+
+
+(define (rtlgen/continuation-setup/saved! state cont)
+ (define (bad-cont)
+ (internal-error "Unexpected CALL continuation [saved!]" cont))
+ (cond
+ ((LOOKUP/? cont)
+ (if state
+ (let ((temp-reg (rtlgen/new-reg)))
+ (rtlgen/assign! temp-reg (rtlgen/boxed-continuation state))
+ (rtlgen/bop-stack-pointer! (rtlgen/state/stmt/size state))
+ (rtlgen/stack-push!/1 temp-reg)
+ (rtlgen/stack-push!/1 (rtlgen/boxed-continuation state))))
+ false)
+ ((CALL/%stack-closure-ref? cont)
+ ;; This assumes that (a) it is the continuation variable and (b) it is at
+ ;; the base of the frame.
+ (let ((offset
+ (let ((offset (call/%stack-closure-ref/offset cont)))
+ (if (and (QUOTE/? offset)
+ (number? (quote/text offset)))
+ (quote/text offset)
+ (internal-error "Unexpected offset to %stack-closure-ref"
+ offset)))))
+ (rtlgen/bop-stack-pointer! offset)
+ false))
+ ((CALL/%make-stack-closure? cont)
+ (rtlgen/continuation-is-stack-closure state cont bad-cont #F #T))
+ (else (bad-cont))))
+\f
+(define (rtlgen/setup-stack-closure! state cont)
+ (let* ((size (rtlgen/state/stmt/size state))
+ (elts (call/%make-stack-closure/values cont))
+ (size* (length elts)))
+
+ (define (is-continuation-lookup? form)
+ (and (LOOKUP/? form)
+ (continuation-variable? (lookup/name form))))
+
+ (define (is-continuation-stack-ref? form)
+ (and (CALL/%stack-closure-ref? form)
+ (continuation-variable?
+ (quote/text (call/%stack-closure-ref/name form)))))
+
+ (define (returning-with-stack-arguments?)
+ ;; The pushed values are all parameters, not saved values as this is a
+ ;; reduction or return.
+ (let ((lambda-slot (call/%make-stack-closure/lambda-expression cont)))
+ (or (is-continuation-stack-ref? lambda-slot)
+ (is-continuation-lookup? lambda-slot))))
+
+ (define (overwrite elts)
+ (do ((frame-offset 0 (+ frame-offset 1))
+ (stack-offset (- size 1) (- stack-offset 1))
+ (elts elts (cdr elts)))
+ ((null? elts))
+ (let ((result (form/match rtlgen/stack-overwrite-pattern (car elts))))
+ (cond ((and result
+ (= (cadr (assq rtlgen/?offset result))
+ frame-offset)))
+ ((and (zero? frame-offset)
+ (not (is-continuation-lookup? (car elts)))
+ (not (returning-with-stack-arguments?)))
+ (internal-error "Unexpected previous continuation (1)" cont))
+ ((and (is-continuation-lookup? (car elts))
+ (not (zero? frame-offset))
+ (internal-error "Continuation saved at non-0 slot" cont)))
+ (else
+ (let* ((loc (rtlgen/->register
+ (rtlgen/expr (rtlgen/state/->expr state '(ANY))
+ (car elts)))))
+ (rtlgen/emit!/1
+ (rtlgen/write-stack-loc loc stack-offset))))))))
+
+ (cond ((not (or (is-continuation-stack-ref? (first elts))
+ (is-continuation-lookup? (first elts))
+ (returning-with-stack-arguments?)))
+ (internal-error "Unexpected previous continuation (2)" cont))
+ ((> size* size)
+ (overwrite (list-head elts size))
+ (rtlgen/stack-push!
+ (rtlgen/expr* state (list-tail elts size))))
+ (else
+ (overwrite elts)
+ (rtlgen/bop-stack-pointer! (- size size*))))))
+\f
+;;;; RTL generation of expressions and pseudo-expressions
+
+(define-macro (define-rtl-generator/expr keyword bindings . body)
+ (let ((proc-name (symbol-append 'RTLGEN/ keyword '/EXPR)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler state) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name state form)
+ ,code)))))))
+
+(define-rtl-generator/expr LOOKUP (state name)
+ (let ((place (rtlgen/binding/find name (rtlgen/state/env state))))
+ (cond ((not place)
+ (free-var-error name))
+ ((eq? place (rtlgen/state/continuation state))
+ (rtlgen/expr/simple-value state (rtlgen/boxed-continuation state)))
+ ((eq? place (rtlgen/state/closure state))
+ (rtlgen/expr/simple-value state (rtlgen/boxed-closure state)))
+ (else
+ (rtlgen/expr/simple-value state (rtlgen/binding/place place))))))
+
+(define map-any-%unassigneds
+ (let ((trap (make-unassigned-reference-trap)))
+ (lambda (object)
+ (cond ((pair? object)
+ (cons
+ (map-any-%unassigneds (car object))
+ (map-any-%unassigneds (cdr object))))
+ ((vector? object)
+ (vector-map object map-any-%unassigneds))
+ ((eq? object %unassigned)
+ (unmap-reference-trap trap))
+ (else object)))))
+
+(define-rtl-generator/expr QUOTE (state object)
+ (rtlgen/expr/simple-value
+ state
+ (if (eq? object %unassigned)
+ (rtlgen/unassigned-object)
+ `(CONSTANT ,(if (eq? object %unspecific)
+ unspecific
+ (map-any-%unassigneds object))))))
+
+(define (rtlgen/expr/simple-value state loc)
+ (let ((target (rtlgen/state/expr/target state)))
+ (case (car target)
+ ((ANY)
+ loc)
+ ((REGISTER)
+ (rtlgen/assign! target loc)
+ target)
+ ((PREDICATE)
+ (rtlgen/branch/false? state loc))
+ ((NONE)
+ (internal-error "Unexpected target kind for value" state))
+ (else
+ (internal-error "Unknown target kind" state)))))
+
+(define-rtl-generator/expr LET (state bindings body)
+ (rtlgen/let* state bindings body rtlgen/expr rtlgen/state/expr/new-env))
+
+(define-rtl-generator/expr IF (state pred conseq alt)
+ (let ((state*
+ (if (eq? (car (rtlgen/state/expr/target state)) 'ANY)
+ (rtlgen/state/->expr state (rtlgen/new-reg))
+ state)))
+ (rtlgen/if* state* pred conseq alt rtlgen/pseudo-stmt
+ (not (eq? (car (rtlgen/state/expr/target state*))
+ 'PREDICATE)))
+ (let ((target (rtlgen/state/expr/target state*)))
+ (and (eq? (car target) 'REGISTER)
+ target))))
+\f
+(define (rtlgen/pseudo-stmt state expr)
+ (let* ((target (rtlgen/state/expr/target state))
+ (result (rtlgen/expr state expr)))
+ (case (car target)
+ ((REGISTER)
+ (if (not (equal? result target))
+ (internal-error "Non-register result when register demanded"
+ target result)))
+ ((PREDICATE)
+ (if result
+ (internal-error "Result for predicate found" target result)))
+ ((NONE))
+ (else
+ (internal-error "Illegal expression predicate target" target)))))
+
+(define-rtl-generator/expr CALL (state rator cont #!rest rands)
+ (define (illegal message)
+ (internal-error message `(CALL ,rator ,cont ,@rands)))
+ (cond ((not (equal? cont '(QUOTE #F)))
+ (illegal "CALL expression with non-false continuation"))
+ ((not (and (QUOTE/? rator)
+ (pseudo-simple-operator? (quote/text rator))))
+ (illegal "CALL expression with non-simple operator"))
+ (else
+ (let ((rator (quote/text rator)))
+ (cond ((eq? rator %make-trivial-closure)
+ (rtlgen/expr/make-trivial-closure state (car rands)))
+ ((eq? rator %make-heap-closure)
+ (rtlgen/expr/make-closure state rands))
+ ((eq? rator %stack-closure-ref)
+ (rtlgen/expr/stack-closure-ref state rands))
+ ((eq? rator %make-return-address)
+ (rtlgen/expr/make-return-address state (car rands)))
+ ((eq? rator %variable-read-cache)
+ (rtlgen/variable-cache state (cadr rands) 'VARIABLE-CACHE))
+ ((eq? rator %variable-write-cache)
+ (rtlgen/variable-cache state (cadr rands) 'ASSIGNMENT-CACHE))
+ ((eq? rator %make-stack-closure)
+ (internal-error "CALL to make-stack-closure" cont rands))
+ (else
+ (let* ((rands* (rtlgen/expr* state rands))
+ (target (rtlgen/state/expr/target state)))
+ (case (car target)
+ ((ANY REGISTER)
+ (rtlgen/open-code/value state rands* rator))
+ ((PREDICATE)
+ (rtlgen/open-code/pred state rands* rator))
+ ((NONE)
+ (rtlgen/open-code/stmt state rands* rator))
+ (else
+ (internal-error "Unknown value destination"
+ target
+ `(CALL ,rator ,cont
+ ,@rands)))))))))))
+
+(define (rtlgen/variable-cache state name keyword)
+ (if (not (QUOTE/? name))
+ (internal-error "Unexpected variable cache name" name))
+ (rtlgen/value-assignment state `(,keyword ,(quote/text name))))
+\f
+(define (rtlgen/expr/make-return-address state rand)
+ state ; ignored
+ (rtlgen/continuation-label->object
+ (rtlgen/enqueue-object! rand 'CONTINUATION)))
+
+(define (rtlgen/expr/make-trivial-closure state rand)
+ (define (finish! entry-label)
+ (let ((label-reg (rtlgen/new-reg)))
+ (rtlgen/assign! label-reg `(ENTRY:PROCEDURE ,entry-label))
+ (rtlgen/value-assignment state (rtlgen/entry->object label-reg))))
+ (cond ((LOOKUP/? rand)
+ (finish!
+ (rtlgen/enqueue-delayed-object! (lookup/name rand) 'TRIVIAL-CLOSURE)))
+ ((LAMBDA/? rand)
+ (finish! (rtlgen/enqueue-object! rand 'TRIVIAL-CLOSURE)))
+ (else
+ (internal-error "Unexpected argument to make-trivial-closure" rand))))
+
+(define (rtlgen/enqueue-object! object kind)
+ (let ((label* (rtlgen/new-name kind)))
+ (rtlgen/enqueue! (vector kind label* object))
+ label*))
+
+(define (rtlgen/enqueue-delayed-object! name kind)
+ (let ((place (assq name *rtlgen/delayed-objects*)))
+ (if (not place)
+ (internal-error "Unknown binding for operand" name kind))
+ (let* ((vec (cdr place))
+ (label (vector-ref vec 1)))
+ (cond ((not label)
+ (let ((label* (car place)))
+ (vector-set! vec 0 kind)
+ (vector-set! vec 1 label*)
+ (rtlgen/enqueue! vec)
+ label*))
+ ((not (eq? (vector-ref vec 0) kind))
+ (internal-error "Inconsistent usage"
+ (vector-ref vec 2)
+ (vector-ref vec 0)
+ kind))
+ (else
+ label)))))
+
+(define (rtlgen/find-delayed-object name)
+ ;; Lookup by name, result is #(kind label object)
+ (let ((result (assq name *rtlgen/delayed-objects*)))
+ (if (not result)
+ (internal-error
+ "rtlgen/find-delayed-object: not found" name)
+ (cdr result))))
+\f
+(define (rtlgen/expr/make-closure state rands)
+ (if (or (null? rands)
+ (null? (cdr rands))
+ (not (LAMBDA/? (first rands))))
+ (internal-error "Unexpected argument to rtlgen/expr/make-closure"))
+ ;; (second rands) is closure name vector, ignored
+ (rtlgen/make-closure* state
+ (lambda-list/arity-info
+ (cdr (lambda/formals (first rands))))
+ (rtlgen/enqueue-object! (first rands) 'CLOSURE)
+ (rtlgen/expr* state (cddr rands))))
+
+(define (rtlgen/make-closure* state arity-info label elts)
+ (let ((clos (rtlgen/new-reg))
+ (nelts (length elts)))
+ (rtlgen/declare-allocation! (+ (rtlgen/closure-prefix-size) nelts))
+ (rtlgen/assign! clos
+ `(CONS-CLOSURE (ENTRY:PROCEDURE ,label)
+ ,(car arity-info)
+ ,(cadr arity-info)
+ ,nelts))
+ (do ((elts elts (cdr elts))
+ (offset (rtlgen/closure-first-offset) (+ offset 1)))
+ ((null? elts) 'DONE)
+ (rtlgen/emit!/1
+ `(ASSIGN (OFFSET ,clos (MACHINE-CONSTANT ,offset))
+ ,(rtlgen/->register (car elts)))))
+ (rtlgen/value-assignment state (rtlgen/entry->object clos))))
+\f
+(define (rtlgen/expr state expr)
+ ;; returns result-location
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((LOOKUP)
+ (rtlgen/lookup/expr state expr))
+ ((QUOTE)
+ (rtlgen/quote/expr state expr))
+ ((CALL)
+ (rtlgen/call/expr state expr))
+ ((IF)
+ (rtlgen/if/expr state expr))
+ ((LET)
+ (rtlgen/let/expr state expr))
+ ((LAMBDA BEGIN LETREC DECLARE)
+ (internal-error "Illegal expression" expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (rtlgen/expr* state exprs)
+ ;; returns list of result-locations
+ (let ((state (rtlgen/state/->expr state '(ANY))))
+ (let loop ((exprs exprs)
+ (results '()))
+ (if (null? exprs)
+ (reverse! results)
+ (loop (cdr exprs)
+ (cons (rtlgen/expr state (car exprs))
+ results))))))
+
+(define (rtlgen/remember new old)
+ old ; ignored
+ new)
+
+(define (rtlgen/new-name prefix)
+ (generate-uninterned-symbol prefix))
+\f
+;;;; States
+;;
+;; States contain the contextual information needed to translate a piece
+;; of KMP code into RTL. There are statement states (for reductions)
+;; and expression states (for open-coded subproblems). States are
+;; initially set up at procedure (continuation etc) entry.
+;; RTLGEN/STATE/->EXPR is the only way to construct an expression
+;; state. It builds on some existing (statement or expression)
+;; state.
+;;
+;; The ENV is a map from names to machine places. RTLGEN/STATE/ENV
+;; retrives the state and (RTLGEN/STATE/NEW-ENV/variant state env)
+;; returns a new state like the old but with a different ENV.
+;;
+;; CLOSURE and CONTINUATION are set to the bindings for the heap closure
+;; and continuation parameters, or #F if that parameter is absent
+;; (e.g. continuations are not themselves passed a continuation).
+;; These bindings are also in ENV. The binding is to an RTL register
+;; containing to the RAW object, which may have been loaded from
+;; either the stack or standard registers.
+;;
+;; Statements are compiled in the context of a stack frame. SIZE is the
+;; number of elements on the stack, INCLUDING the continuation and
+;; closure pointer if these are on the stack.
+;;
+;; Expressions are compiled in the context of a target. A target may be
+;; any of the following:
+;; (ANY) any location will do
+;; (NONE) the value is not required
+;; (REGISTER number) target this register
+;; (PREDICATE (true-label count) (false-label count))
+;; `target' is a predicate. The count slots are initially 0 and are
+;; updated to count the number of branches to the true and false
+;; labels.
+
+(define-structure (rtlgen/state/stmt
+ (conc-name rtlgen/state/stmt/)
+ (constructor rtlgen/state/stmt/make))
+ (env '() read-only true)
+ (continuation #F read-only true)
+ (closure #F read-only true)
+ (size false read-only true))
+
+(define-structure (rtlgen/state/expr
+ (conc-name rtlgen/state/expr/)
+ (constructor %rtlgen/state/expr/make))
+ (env '() read-only true)
+ (continuation #F read-only true)
+ (closure #F read-only true)
+ (target false read-only true))
+
+;; RTLGEN/STATE/{ENV,CONTINUATION,CLOSURE} all depend on the fact that
+;; both states have the same layout and that there is no error
+;; checking by default. Otherwise they could be written to dispatch.
+
+(define-integrable (rtlgen/state/env state)
+ (rtlgen/state/stmt/env state))
+
+(define-integrable (rtlgen/state/continuation state)
+ (rtlgen/state/stmt/continuation state))
+
+(define-integrable (rtlgen/state/closure state)
+ (rtlgen/state/stmt/closure state))
+
+(define (rtlgen/state/reference-to-cont state)
+ (if (rtlgen/state/continuation state)
+ (rtlgen/binding/place (rtlgen/state/continuation state))
+ (internal-error "No continuation in this state " state)))
+
+(define (rtlgen/state/reference-to-closure state)
+ (if (rtlgen/state/closure state)
+ (rtlgen/binding/place (rtlgen/state/closure state))
+ (internal-error "No continuation in this state " state)))
+
+(define-integrable (rtlgen/state/->expr state target)
+ (%rtlgen/state/expr/make (rtlgen/state/env state)
+ (rtlgen/state/continuation state)
+ (rtlgen/state/closure state)
+ target))
+
+(define (rtlgen/state/stmt/new-env state env)
+ (rtlgen/state/stmt/make env
+ (rtlgen/state/stmt/continuation state)
+ (rtlgen/state/stmt/closure state)
+ (rtlgen/state/stmt/size state)))
+
+(define (rtlgen/state/expr/new-env state env)
+ (%rtlgen/state/expr/make env
+ (rtlgen/state/expr/continuation state)
+ (rtlgen/state/expr/closure state)
+ (rtlgen/state/expr/target state)))
+
+(define (rtlgen/state/stmt/guaranteed-size state)
+ (or (and (rtlgen/state/stmt? state) (rtlgen/state/stmt/size state))
+ (internal-error "Cannot find stack frame size" state)))
+
+;; In the state structures, ENV is a list of bindings:
+
+(define-structure (rtlgen/binding
+ (conc-name rtlgen/binding/)
+ (constructor rtlgen/binding/make)
+ (print-procedure
+ (standard-unparser-method 'RTLGEN/BINDING
+ (lambda (binding port)
+ (write-char #\space port)
+ (write (rtlgen/binding/name binding) port)))))
+ (name #F read-only true)
+ (place #F read-only true) ; Where it is currently
+ (home #F read-only true))
+
+(define (rtlgen/binding/find name env)
+ (let loop ((env env))
+ (cond ((null? env) #F)
+ ((eq? name (rtlgen/binding/name (car env)))
+ (car env))
+ (else (loop (cdr env))))))
+\f
+;;;; Open coding
+
+(define *open-coders*
+ (make-eq-hash-table))
+
+(define-integrable (rtlgen/get-open-coder rator)
+ (let ((open-coder (hash-table/get *open-coders* rator false)))
+ (if (not open-coder)
+ (internal-error "No open coder known" rator)
+ open-coder)))
+
+(define-integrable (rtlgen/get-open-coder/checked rator rands)
+ (let ((open-coder (rtlgen/get-open-coder rator)))
+ (if (and (rtlgen/open-coder/nargs open-coder)
+ (not (= (length rands) (rtlgen/open-coder/nargs open-coder))))
+ (user-error "Wrong number of arguments" rator)
+ open-coder)))
+
+(define (rtlgen/open-code/pred state rands rator)
+ ;; No meaningful value
+ (let ((open-coder (rtlgen/get-open-coder/checked rator rands)))
+ ((rtlgen/open-coder/pred open-coder) state rands open-coder)))
+
+(define (rtlgen/open-code/stmt state rands rator)
+ ;; No meaningful value
+ (let ((open-coder (rtlgen/get-open-coder/checked rator rands)))
+ ((rtlgen/open-coder/stmt open-coder) state rands open-coder)))
+
+(define (rtlgen/open-code/value state rands rator)
+ ;; Returns location of result
+ (let ((open-coder (rtlgen/get-open-coder/checked rator rands)))
+ ((rtlgen/open-coder/value open-coder) state rands open-coder)))
+
+(define (rtlgen/open-code/out-of-line cont-label rator)
+ ;; No meaningful value
+ (let ((open-coder (hash-table/get *open-coders* rator false)))
+ (cond ((not open-coder)
+ (internal-error "No open coder known" rator))
+ (else
+ ((rtlgen/open-coder/outl open-coder) cont-label open-coder)))))
+
+(define (rtlgen/open-code/special cont-label rator rands)
+ ;; No meaningful value
+ (let ((open-coder (rtlgen/get-open-coder/checked rator rands)))
+ ((rtlgen/open-coder/special open-coder) cont-label rands open-coder)))
+
+
+(define-structure (rtlgen/open-coder
+ (conc-name rtlgen/open-coder/)
+ (constructor rtlgen/open-coder/make))
+ (rator false read-only true)
+ (nargs false read-only true)
+ (value false read-only true)
+ (stmt false read-only true)
+ (pred false read-only true)
+ (outl false read-only true)
+ (special false read-only true))
+\f
+(define (define-open-coder name-or-object nargs
+ vhandler shandler phandler ohandler sphandler)
+ (let ((rator (if (hash-table/get *operator-properties* name-or-object false)
+ name-or-object
+ (make-primitive-procedure name-or-object nargs))))
+ (hash-table/put!
+ *open-coders*
+ rator
+ (rtlgen/open-coder/make rator nargs
+ vhandler shandler phandler
+ ohandler sphandler))))
+
+(define (rtlgen/no-predicate-open-coder state rands open-coder)
+ state rands ; ignored
+ (internal-error "Statement operation used as predicate"
+ (rtlgen/open-coder/rator open-coder)))
+
+(define (rtlgen/no-stmt-open-coder state rands open-coder)
+ state rands ; ignored
+ (internal-error "Predicate/value operation used as statement"
+ (rtlgen/open-coder/rator open-coder)))
+
+(define (rtlgen/no-value-open-coder state rands open-coder)
+ state rands ; ignored
+ (internal-error "Statement operation used as value"
+ (rtlgen/open-coder/rator open-coder)))
+
+(define (rtlgen/no-out-of-line-open-coder cont-label open-coder)
+ cont-label ; ignored
+ (internal-error "Attempt to call open-coded operation"
+ (rtlgen/open-coder/rator open-coder)))
+
+(define (rtlgen/no-special-open-coder cont-label rator rands open-coder)
+ cont-label rator rands ; ignored
+ (internal-error "Attempt to call open-coded operation"
+ (rtlgen/open-coder/rator open-coder)))
+\f
+(define (define-open-coder/pred name-or-object nargs handler)
+ (define-open-coder name-or-object nargs
+ (rtlgen/pred->value handler)
+ rtlgen/no-stmt-open-coder
+ handler
+ rtlgen/no-out-of-line-open-coder
+ rtlgen/no-special-open-coder))
+
+(define (define-open-coder/stmt name-or-object nargs handler)
+ (define-open-coder name-or-object nargs
+ rtlgen/no-value-open-coder
+ handler
+ rtlgen/no-predicate-open-coder
+ rtlgen/no-out-of-line-open-coder
+ rtlgen/no-special-open-coder))
+
+(define (define-open-coder/value name-or-object nargs handler)
+ (define-open-coder name-or-object nargs
+ handler
+ rtlgen/no-stmt-open-coder
+ (rtlgen/value->pred handler)
+ rtlgen/no-out-of-line-open-coder
+ rtlgen/no-special-open-coder))
+
+(define (define-open-coder/out-of-line name-or-object nargs handler)
+ (define-open-coder name-or-object nargs
+ (rtlgen/out-of-line->value handler)
+ (rtlgen/out-of-line->stmt handler)
+ (rtlgen/out-of-line->pred handler)
+ handler
+ rtlgen/no-special-open-coder))
+
+(define (define-open-coder/special name-or-object nargs handler)
+ (define-open-coder name-or-object nargs
+ (rtlgen/special->value handler)
+ (rtlgen/special->stmt handler)
+ (rtlgen/special->pred handler)
+ rtlgen/no-out-of-line-open-coder
+ handler))
+\f
+(define (rtlgen/pred->value handler)
+ (lambda (state rands open-coder)
+ (let* ((target (rtlgen/state/expr/target state))
+ (target* (case (car target)
+ ((ANY)
+ (rtlgen/new-reg))
+ ((REGISTER)
+ target)
+ (else
+ (internal-error "Unexpected value target" target
+ (rtlgen/open-coder/rator
+ open-coder))))))
+ (let ((merge-label (rtlgen/new-name 'MERGE))
+ (true-label (rtlgen/new-name 'TRUE))
+ (false-label (rtlgen/new-name 'FALSE)))
+ (handler (rtlgen/state/->expr
+ state
+ `(PREDICATE ,(list true-label 0) ,(list false-label 0)))
+ rands open-coder)
+ (rtlgen/assign!*
+ `((LABEL ,true-label)
+ (ASSIGN ,target* (CONSTANT ,#t))
+ (JUMP ,merge-label)
+ (LABEL ,false-label)
+ (ASSIGN ,target* (CONSTANT ,#f))
+ (LABEL ,merge-label)))
+ target*))))
+
+(define (rtlgen/value->pred handler)
+ (lambda (state rands open-coder)
+ (rtlgen/branch/false? state
+ (handler (rtlgen/state/->expr state '(ANY))
+ rands open-coder))))
+
+(define (rtlgen/with-preservation state code-gen-1 code-gen-2)
+ (rtlgen/stack-allocation/protect ; /compatible ?
+ (lambda ()
+ (call-with-values
+ (lambda () (rtlgen/preserve-state state))
+ (lambda (gen-prefix gen-suffix)
+ (let ((cont-label (rtlgen/new-name 'CONT)))
+ (gen-prefix)
+ (code-gen-1 cont-label)
+ (rtlgen/emit!/1
+ `(RETURN-ADDRESS ,cont-label
+ (MACHINE-CONSTANT ,(if (not *rtlgen/frame-size*)
+ 0
+ (- *rtlgen/frame-size* 1)))
+ (MACHINE-CONSTANT 1)))
+ (let ((result (code-gen-2 state)))
+ (gen-suffix)
+ result)))))))
+
+(define (rtlgen/out-of-line->pred handler)
+ (rtlgen/value->pred (rtlgen/out-of-line->value handler)))
+
+#|
+(define (rtlgen/out-of-line->stmt handler)
+ ;; /compatible
+ (lambda (state rands open-coder)
+ (rtlgen/with-preservation
+ state
+ (lambda (cont-label)
+ (rtlgen/stack-push!
+ (cons (rtlgen/continuation-label->object cont-label)
+ (reverse rands)))
+ (handler cont-label open-coder))
+ (lambda (state)
+ state ; ignored
+ unspecific))))
+
+(define (rtlgen/out-of-line->value handler)
+ ;; /compatible
+ (lambda (state rands open-coder)
+ (rtlgen/with-preservation
+ state
+ (lambda (cont-label)
+ (rtlgen/stack-push!
+ (cons (rtlgen/continuation-label->object cont-label)
+ (reverse rands)))
+ (handler cont-label open-coder))
+ (lambda (state)
+ (rtlgen/value-assignment state (rtlgen/reference-to-val))))))
+|#
+
+(define (rtlgen/out-of-line->stmt handler)
+ (lambda (state rands open-coder)
+ (rtlgen/with-preservation
+ state
+ (lambda (cont-label)
+ (rtlgen/expr-results->call-registers state rands)
+ (handler cont-label open-coder))
+ (lambda (state)
+ state ; ignored
+ unspecific))))
+
+(define (rtlgen/out-of-line->value handler)
+ (lambda (state rands open-coder)
+ (rtlgen/with-preservation
+ state
+ (lambda (cont-label)
+ (rtlgen/expr-results->call-registers state rands)
+ (handler cont-label open-coder))
+ (lambda (state)
+ (rtlgen/value-assignment state (rtlgen/reference-to-val))))))
+
+(define (rtlgen/special->pred handler)
+ (rtlgen/value->pred (rtlgen/special->value handler)))
+
+(define (rtlgen/special->stmt handler)
+ (lambda (state rands open-coder)
+ (rtlgen/with-preservation
+ state
+ (lambda (cont-label)
+ (handler cont-label rands open-coder))
+ (lambda (state)
+ state ; ignored
+ unspecific))))
+
+(define (rtlgen/special->value handler)
+ (lambda (state rands open-coder)
+ (rtlgen/with-preservation
+ state
+ (lambda (cont-label)
+ (handler cont-label rands open-coder))
+ (lambda (state)
+ (rtlgen/value-assignment state (rtlgen/reference-to-val))))))
+\f
+;;;; Open-coded predicates
+
+;;; These open codings do not do anything about type and range checking.
+;;; Such things are assumed to have been done by an earlier stage.
+
+(let* ((simple-value-tester
+ (lambda (rtlgen/branch/<preference>)
+ (lambda (name rtl-pred compile-time-pred?)
+ (define-open-coder/pred name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((rand (car rands)))
+ (cond ((or (not (rtlgen/constant? rand))
+ (not *rtlgen/fold-simple-value-tests?*))
+ (let* ((rand* (rtlgen/->register rand)))
+ (rtlgen/branch/<preference>
+ state `(PRED-1-ARG ,rtl-pred ,rand*))))
+ ((compile-time-pred? (rtlgen/constant-value rand))
+ (rtlgen/branch/true state))
+ (else
+ (rtlgen/branch/false state)))))))))
+ (define-simple-value-test
+ (simple-value-tester rtlgen/branch/likely))
+ (define-simple-value-test/inverted
+ (simple-value-tester rtlgen/branch/unlikely)))
+
+ (define-simple-value-test/inverted 'NULL? 'NULL? null?)
+ (define-simple-value-test/inverted 'NOT 'FALSE? not)
+ (define-simple-value-test/inverted 'FALSE? 'FALSE? false?)
+ (define-simple-value-test 'FIXNUM? 'FIXNUM? fixnum?)
+ (define-simple-value-test %machine-fixnum? 'FIXNUM? fixnum?)
+ (define-simple-value-test 'INDEX-FIXNUM? 'INDEX-FIXNUM? index-fixnum?))
+
+(let ((define-simple-tag-test
+ (lambda (name tag)
+ (define-open-coder/pred name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((rand (car rands)))
+ (cond ((or (not (rtlgen/constant? rand))
+ (not *rtlgen/fold-tag-predicates?*))
+ (let* ((rand* (rtlgen/->register rand))
+ (rand** (rtlgen/new-reg)))
+ (rtlgen/assign! rand** `(OBJECT->TYPE ,rand*))
+ (rtlgen/branch/likely state
+ `(TYPE-TEST ,rand** ,tag))))
+ ((object-type? tag (rtlgen/constant-value rand))
+ (rtlgen/branch/true state))
+ (else
+ (rtlgen/branch/false state)))))))))
+ (define-simple-tag-test 'CELL? (machine-tag 'CELL))
+ (define-simple-tag-test 'PAIR? (machine-tag 'PAIR))
+ (define-simple-tag-test 'VECTOR? (machine-tag 'VECTOR))
+ (define-simple-tag-test '%RECORD? (machine-tag 'RECORD))
+ (define-simple-tag-test 'STRING? (machine-tag 'STRING))
+ (define-simple-tag-test 'BIT-STRING? (machine-tag 'VECTOR-1B))
+ (define-simple-tag-test 'FLONUM? (machine-tag 'FLONUM)))
+\f
+(define-open-coder/pred 'EQ? 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((rand1 (car rands))
+ (rand2 (cadr rands)))
+ (cond ((or (not (rtlgen/constant? rand1))
+ (not (rtlgen/constant? rand2))
+ (not *rtlgen/fold-tag-predicates?*))
+ (let* ((rand1* (rtlgen/->register rand1))
+ (rand2* (rtlgen/->register rand2)))
+ (rtlgen/branch/unlikely state `(EQ-TEST ,rand1* ,rand2*))))
+ ((eq? (rtlgen/constant-value rand1) (rtlgen/constant-value rand2))
+ (rtlgen/branch/true state))
+ (else
+ (rtlgen/branch/false state))))))
+
+(define-open-coder/pred %unassigned? 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand1 (rtlgen/->register (car rands)))
+ (rand2 (rtlgen/->register (rtlgen/unassigned-object))))
+ (rtlgen/branch/unlikely state `(EQ-TEST ,rand1 ,rand2)))))
+
+(define-open-coder/pred %reference-trap? 1
+ (let ((tag (machine-tag 'REFERENCE-TRAP)))
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand (rtlgen/->register (car rands)))
+ (temp (rtlgen/new-reg)))
+ (rtlgen/assign! temp `(OBJECT->TYPE ,rand))
+ (rtlgen/branch/unlikely state `(TYPE-TEST ,temp ,tag))))))
+\f
+(define-open-coder/pred 'OBJECT-TYPE? 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((tag (car rands))
+ (obj (rtlgen/->register (second rands)))
+ (obj* (rtlgen/new-reg)))
+ (rtlgen/assign! obj* `(OBJECT->TYPE ,obj))
+ (cond ((rtlgen/constant? tag)
+ (rtlgen/branch/likely
+ state
+ `(TYPE-TEST ,obj* ,(rtlgen/constant-value tag))))
+ (else
+ (let* ((tag* (rtlgen/->register tag))
+ (tag** (rtlgen/new-reg)))
+ (rtlgen/assign! tag** `(OBJECT->DATUM ,tag*))
+ (rtlgen/branch/likely state `(EQ-TEST ,obj* ,tag**))))))))
+
+(define-integrable (rtlgen/constant? syllable)
+ (and (pair? syllable)
+ (eq? (car syllable) 'CONSTANT)))
+
+(define-integrable (rtlgen/constant-value syllable)
+ (cadr syllable))
+
+(define-integrable (rtlgen/integer-constant? syllable)
+ (and (rtlgen/constant? syllable)
+ (number? (rtlgen/constant-value syllable))
+ (rtlgen/constant-value syllable)))
+
+(define-open-coder/pred %small-fixnum? 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((value (rtlgen/->register (car rands)))
+ (nbits (cadr rands)))
+ (if (not (rtlgen/constant? nbits))
+ (internal-error "small-fixnum? needs constant nbits" nbits))
+ (rtlgen/branch/likely
+ state
+ `(PRED-2-ARGS SMALL-FIXNUM?
+ ,value
+ (MACHINE-CONSTANT ,(rtlgen/constant-value nbits)))))))
+
+(let ((define-fixnum-predicate
+ (lambda (proc name rtlgen/branch)
+ (define-open-coder/pred proc 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand1 (rtlgen/->register (car rands)))
+ (rand2 (rtlgen/->register (cadr rands))))
+ (rtlgen/branch
+ state
+ `(FIXNUM-PRED-2-ARGS ,name ,rand1 ,rand2))))))))
+ (define-fixnum-predicate fix:= 'EQUAL-FIXNUM?
+ rtlgen/branch/unlikely)
+ (define-fixnum-predicate fix:< 'LESS-THAN-FIXNUM?
+ rtlgen/branch/unpredictable)
+ (define-fixnum-predicate fix:> 'GREATER-THAN-FIXNUM?
+ rtlgen/branch/unpredictable))
+
+(let ((define-flonum-predicate
+ (lambda (proc name rtlgen/branch)
+ (define-open-coder/pred proc 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand1 (rtlgen/->register (car rands)))
+ (rand2 (rtlgen/->register (cadr rands)))
+ (flo1 (rtlgen/new-reg))
+ (flo2 (rtlgen/new-reg)))
+ (rtlgen/assign! flo1 `(OBJECT->FLOAT ,rand1))
+ (rtlgen/assign! flo2 `(OBJECT->FLOAT ,rand2))
+ (rtlgen/branch state
+ `(FLONUM-PRED-2-ARGS ,name ,flo1 ,flo2))))))))
+ (define-flonum-predicate flo:= 'FLONUM-EQUAL?
+ rtlgen/branch/unlikely)
+ (define-flonum-predicate flo:< 'FLONUM-LESS?
+ rtlgen/branch/unpredictable)
+ (define-flonum-predicate flo:> 'FLONUM-GREATER?
+ rtlgen/branch/unpredictable))
+\f
+#|
+;; These don't work, because the operands are evaluated by this point,
+;; and one of the operands is (LOOKUP ,cache-name) where cache-name
+;; is unbound!
+
+(let ((define-reference-to-cache
+ (lambda (%variable-cache keyword)
+ (define-open-coder/value %variable-cache 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((name (second rands)))
+ (if (not (QUOTE/? name))
+ (internal-error "Unexpected variable cache name" name))
+ (rtlgen/value-assignment state `(,keyword ,(cadr name)))))))))
+
+ (define-reference-to-cache %variable-read-cache 'VARIABLE-CACHE)
+ (define-reference-to-cache %variable-write-cache 'ASSIGNMENT-CACHE))
+|#
+
+(for-each
+ (lambda (prim-name)
+ (define-open-coder/value prim-name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((rand (rtlgen/->register (first rands))))
+ (rtlgen/value-assignment state `(OBJECT->TYPE ,rand))))))
+ '(OBJECT-TYPE
+ PRIMITIVE-OBJECT-TYPE))
+
+(define-open-coder/value 'OBJECT-DATUM 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((rand (rtlgen/->register (first rands))))
+ (rtlgen/value-assignment state `(OBJECT->DATUM ,rand)))))
+
+(define-open-coder/value 'PRIMITIVE-OBJECT-SET-TYPE 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((tag (first rands))
+ (obj (rtlgen/->register (second rands))))
+ (let ((obj* (rtlgen/new-reg)))
+ (rtlgen/assign! obj* `(OBJECT->DATUM ,obj))
+ (cond ((rtlgen/constant? tag)
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER
+ (MACHINE-CONSTANT ,(rtlgen/constant-value tag))
+ ,obj*)))
+ (else
+ (let* ((tag* (rtlgen/->register tag))
+ (tag** (rtlgen/new-reg)))
+ (rtlgen/assign! tag** `(OBJECT->DATUM ,tag*))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER ,tag** ,obj*)))))))))
+\f
+(define (rtlgen/cons state rands tag)
+ (rtlgen/heap-push! rands)
+ (rtlgen/value-assignment
+ state
+ `(CONS-POINTER
+ ,tag
+ ,(rtlgen/->register
+ `(OFFSET-ADDRESS ,(rtlgen/reference-to-free)
+ (MACHINE-CONSTANT ,(- 0 (length rands))))))))
+
+(let ((define-tagged-allocator
+ (lambda (name arity tag)
+ (define-open-coder/value name arity
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (rtlgen/cons state rands `(MACHINE-CONSTANT ,tag)))))))
+ (define-tagged-allocator 'MAKE-CELL 1 (machine-tag 'CELL))
+ (define-tagged-allocator %make-static-binding 1 (machine-tag 'CELL))
+ (define-tagged-allocator 'CONS 2 (machine-tag 'PAIR))
+ (define-tagged-allocator %cons 2 (machine-tag 'PAIR)))
+
+(define-open-coder/value %make-cell 2
+ (let ((tag (machine-tag 'CELL)))
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (rtlgen/cons state (list (first rands)) `(MACHINE-CONSTANT ,tag)))))
+
+(define-open-coder/value %make-promise 1
+ (let ((tag (machine-tag 'DELAYED)))
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (rtlgen/cons state
+ (cons `(CONSTANT 0) rands)
+ `(MACHINE-CONSTANT ,tag)))))
+
+(let ((define-vector-allocator
+ (lambda (name tag)
+ (define-open-coder/value name false
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (rtlgen/cons state
+ (cons `(CONSTANT ,(length rands)) rands)
+ `(MACHINE-CONSTANT ,tag)))))))
+ (define-vector-allocator 'VECTOR (machine-tag 'VECTOR))
+ (define-vector-allocator %vector (machine-tag 'VECTOR))
+ (define-vector-allocator '%RECORD (machine-tag 'RECORD)))
+
+(define-open-coder/value 'SYSTEM-PAIR-CONS 3
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (rtlgen/cons state
+ (cdr rands)
+ (let ((tag (car rands)))
+ (if (rtlgen/constant? tag)
+ `(MACHINE-CONSTANT ,(rtlgen/constant-value tag))
+ (rtlgen/->register tag))))))
+\f
+(define-open-coder/value 'STRING-ALLOCATE 1
+ (let ((string-tag (machine-tag 'STRING))
+ (nmv-tag (machine-tag 'MANIFEST-NM-VECTOR)))
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((char-len (rtlgen/allocate-length (first rands) 'STRING-ALLOCATE)))
+ (let* ((free (rtlgen/reference-to-free))
+ (result (rtlgen/value-assignment
+ state
+ `(CONS-POINTER (MACHINE-CONSTANT ,string-tag)
+ ,free)))
+ (word-len (rtlgen/chars->words char-len))
+ (nmv-header (rtlgen/new-reg))
+ (slen (rtlgen/new-reg))
+ (zero (rtlgen/new-reg)))
+ (rtlgen/declare-allocation! (+ word-len 2))
+ (rtlgen/assign!*
+ `((ASSIGN ,nmv-header
+ (CONS-NON-POINTER (MACHINE-CONSTANT ,nmv-tag)
+ (MACHINE-CONSTANT ,(+ word-len 1))))
+ (ASSIGN (OFFSET ,free (MACHINE-CONSTANT 0)) ,nmv-header)
+ (ASSIGN ,slen (CONSTANT ,char-len))
+ (ASSIGN (OFFSET ,free (MACHINE-CONSTANT 1)) ,slen)
+ (ASSIGN ,free
+ (OFFSET-ADDRESS ,free
+ (MACHINE-CONSTANT ,(+ word-len 2))))
+ (ASSIGN ,zero (MACHINE-CONSTANT 0))
+ (ASSIGN (OFFSET ,free (MACHINE-CONSTANT -1)) ,zero)))
+ result)))))
+
+(define-open-coder/value 'FLOATING-VECTOR-CONS 1
+ (let ((fv-tag (machine-tag 'FLOATING-POINT-VECTOR))
+ (nmv-tag (machine-tag 'MANIFEST-NM-VECTOR)))
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (rtlgen/floating-align-free)
+ (let* ((free (rtlgen/reference-to-free))
+ (result (rtlgen/value-assignment
+ state
+ `(CONS-POINTER (MACHINE-CONSTANT ,fv-tag)
+ ,free)))
+ (len (rtlgen/allocate-length (first rands) 'FLOATING-VECTOR-CONS))
+ (word-len (rtlgen/fp->words len))
+ (nmv-header (rtlgen/new-reg)))
+ (rtlgen/declare-allocation! (+ word-len 1))
+ (rtlgen/assign!*
+ `((ASSIGN ,nmv-header
+ (CONS-NON-POINTER (MACHINE-CONSTANT ,nmv-tag)
+ (MACHINE-CONSTANT ,word-len)))
+ (ASSIGN (OFFSET ,free (MACHINE-CONSTANT 0)) ,nmv-header)
+ (ASSIGN ,free
+ (OFFSET-ADDRESS ,free
+ (MACHINE-CONSTANT
+ ,(+ word-len 1))))))
+ result))))
+\f
+(define-open-coder/value 'VECTOR-CONS 2
+ (let ((vector-tag (machine-tag 'VECTOR)))
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((len (rtlgen/allocate-length (first rands) 'VECTOR-CONS))
+ (fill (rtlgen/->register (second rands))))
+ (if (> len *vector-cons-max-open-coded-length*)
+ (internal-error "Open coding VECTOR-CONS with too large a length"
+ len))
+ (rtlgen/cons state
+ (cons `(CONSTANT ,len) (make-list len fill))
+ vector-tag)))))
+
+;; *** STRING-ALLOCATE, FLOATING-VECTOR-CONS, and perhaps VECTOR-CONS
+;; should always be in-lined, even when the length argument is not known.
+;; They can do a late back out when there is no space, much like generic
+;; arithmetic backs out when the operands are not appropriate fixnums. ***
+
+(define (rtlgen/allocate-length len proc)
+ (if (not (rtlgen/integer-constant? len))
+ (internal-error
+ "Open coding allocation primitive with non-constant/non-integer length"
+ len proc))
+ (rtlgen/constant-value len))
+\f
+(define-open-coder/value %variable-cell-ref 1
+ (lambda (state rands open-coder)
+ open-coder
+ (let ((cell (rtlgen/->register (first rands))))
+ (rtlgen/value-assignment state `(OFFSET ,cell (MACHINE-CONSTANT 0))))))
+
+(define-open-coder/value %static-binding-ref 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((name (second rands)))
+ (if (not (rtlgen/constant? name))
+ (internal-error "Unexpected name to static-binding-ref" name))
+ (let ((cell (rtlgen/->register
+ `(STATIC-CELL ,(rtlgen/constant-value name)))))
+ (rtlgen/value-assignment state
+ `(OFFSET ,cell (MACHINE-CONSTANT 0)))))))
+
+#|
+;; This is not done this way because stack closures are handled specially,
+;; with RTL registers assigned early to their elements to allow painless
+;; stack reformatting later.
+;; In particular, %stack-closure-ref cannot be open-coded in the normal
+;; way because it wants to examine the rands BEFORE rtl generation.
+
+(define-open-coder/value %stack-closure-ref 3
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((closure (rtlgen/->register (first rands)))
+ (offset (second rands)))
+ (if (not (rtlgen/integer-constant? offset))
+ (internal-error "Non-constant index to stack-closure-ref" offset))
+ (rtlgen/value-assignment
+ state
+ `(OFFSET ,closure
+ (MACHINE-CONSTANT ,(rtlgen/constant-value offset)))))))
+|#
+
+(define (rtlgen/expr/stack-closure-ref state rands)
+ (let ((name (third rands)))
+ (if (not (QUOTE/? name))
+ (internal-error "Unexpected name to stack-closure-ref" rands))
+ (let* ((name* (quote/text name))
+ (place (rtlgen/binding/find name* (rtlgen/state/env state))))
+ (if (not place)
+ (internal-error "stack binding not found" name*)
+ (rtlgen/expr/simple-value state (rtlgen/binding/place place))))))
+
+(define (rtlgen/fixed-selection state rand offset)
+ (let* ((rand (rtlgen/->register rand))
+ (address (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/value-assignment state
+ `(OFFSET ,address (MACHINE-CONSTANT ,offset)))))
+\f
+(let ((define-fixed-selector
+ (lambda (name tag offset arity)
+ tag ; unused
+ (define-open-coder/value name arity
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (rtlgen/fixed-selection state (first rands) offset))))))
+ (define-fixed-selector 'CELL-CONTENTS (machine-tag 'CELL) 0 1)
+ (define-fixed-selector %cell-ref (machine-tag 'CELL) 0 2)
+ (define-fixed-selector 'CAR (machine-tag 'PAIR) 0 1)
+ (define-fixed-selector 'CDR (machine-tag 'PAIR) 1 1)
+ (define-fixed-selector 'SYSTEM-PAIR-CAR false 0 1)
+ (define-fixed-selector 'SYSTEM-PAIR-CDR false 1 1)
+ (define-fixed-selector 'SYSTEM-HUNK3-CXR0 false 0 1)
+ (define-fixed-selector 'SYSTEM-HUNK3-CXR1 false 1 1)
+ (define-fixed-selector 'SYSTEM-HUNK3-CXR2 false 2 1))
+
+(let ((define-indexed-selector
+ (lambda (name tag offset arity)
+ tag ; unused
+ (define-open-coder/value name arity
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((index (second rands)))
+ (cond ((rtlgen/integer-constant? index)
+ (rtlgen/fixed-selection
+ state
+ (first rands)
+ (+ offset (rtlgen/constant-value index))))
+ ((rtlgen/indexed-loads? 'WORD)
+ ;; This allows CSE of the offset-address
+ (let* ((rand (rtlgen/->register (first rands)))
+ (index* (rtlgen/->register index))
+ (address (rtlgen/new-reg))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign!
+ ptr
+ `(OFFSET-ADDRESS ,address
+ (MACHINE-CONSTANT ,offset)))
+ (rtlgen/value-assignment state
+ `(OFFSET ,ptr ,index*))))
+ (else
+ (let* ((rand (rtlgen/->register (first rands)))
+ (index* (rtlgen/->register index))
+ (address (rtlgen/new-reg))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign! ptr
+ `(OFFSET-ADDRESS ,address ,index*))
+ (rtlgen/value-assignment
+ state
+ `(OFFSET ,ptr (MACHINE-CONSTANT ,offset))))))))))))
+ (define-indexed-selector 'VECTOR-REF (machine-tag 'VECTOR) 1 2)
+ (define-indexed-selector '%RECORD-REF (machine-tag 'RECORD) 1 2)
+ ;; NOTE: This assumes that the result of the following two is always
+ ;; an object. If it isn't it could be incorrectly preserved, and...
+ (define-indexed-selector 'SYSTEM-VECTOR-REF false 1 2)
+ (define-indexed-selector 'PRIMITIVE-OBJECT-REF false 0 2))
+\f
+(define-open-coder/value %heap-closure-ref 3
+ (let ((offset (rtlgen/closure-first-offset)))
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((index (second rands)))
+ (cond ((not (rtlgen/integer-constant? index))
+ (internal-error "%heap-closure-ref with non-constant offset"
+ rands))
+ ((rtlgen/tagged-closures?)
+ (rtlgen/fixed-selection state
+ (first rands)
+ (+ offset
+ (rtlgen/constant-value index))))
+ (else
+ (rtlgen/value-assignment
+ state
+ `(OFFSET ,(rtlgen/->register (first rands))
+ (MACHINE-CONSTANT
+ ,(+ offset (rtlgen/constant-value index)))))))))))
+
+;; NOTE: These do not use rtlgen/assign! because the length field
+;; may not be an object, and the preservation code assumes that
+;; the OFFSET address syllable always denotes an object.
+
+(let* ((fixnum-tag (machine-tag 'POSITIVE-FIXNUM))
+ (define-fixnumized-selector/tagged
+ (lambda (name tag off)
+ tag
+ (define-open-coder/value name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (field (rtlgen/new-reg))
+ (datum (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign!*
+ (list
+ `(ASSIGN ,field (OFFSET ,address (MACHINE-CONSTANT ,off)))
+ `(ASSIGN ,datum (OBJECT->DATUM ,field))))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,fixnum-tag)
+ ,datum)))))))
+ (define-fixnumized-selector
+ (lambda (name tag off)
+ tag
+ (define-open-coder/value name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand (rtlgen/->register (car rands)))
+ (address (rtlgen/new-reg))
+ (field (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign! field `(OFFSET ,address (MACHINE-CONSTANT ,off)))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,fixnum-tag)
+ ,field))))))))
+ (define-fixnumized-selector/tagged 'VECTOR-LENGTH (machine-tag 'VECTOR) 0)
+ (define-fixnumized-selector/tagged '%RECORD-LENGTH (machine-tag 'RECORD) 0)
+ (define-fixnumized-selector/tagged 'SYSTEM-VECTOR-SIZE false 1)
+ (define-fixnumized-selector 'STRING-LENGTH (machine-tag 'STRING) 1)
+ (define-fixnumized-selector 'BIT-STRING-LENGTH (machine-tag 'STRING) 1))
+\f
+(define-open-coder/value 'FLOATING-VECTOR-LENGTH 1
+ (let ((factor (rtlgen/fp->words 1))
+ (tag (machine-tag 'POSITIVE-FIXNUM)))
+ (cond ((= factor 1)
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (field (rtlgen/new-reg))
+ (datum (rtlgen/new-reg)))
+ (rtlgen/assign!*
+ (list
+ `(ASSIGN ,address (OBJECT->ADDRESS ,rand))
+ `(ASSIGN ,field (OFFSET ,address (MACHINE-CONSTANT 0)))
+ `(ASSIGN ,datum (OBJECT->DATUM ,field))))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) ,datum)))))
+ ((power-of-two? factor)
+ => (lambda (shift)
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (field (rtlgen/new-reg))
+ (datum (rtlgen/new-reg))
+ (constant (rtlgen/new-reg))
+ (datum2 (rtlgen/new-reg)))
+ (rtlgen/assign!*
+ (list
+ `(ASSIGN ,address (OBJECT->ADDRESS ,rand))
+ `(ASSIGN ,field (OFFSET ,address (MACHINE-CONSTANT 0)))
+ `(ASSIGN ,datum (OBJECT->DATUM ,field))
+ `(ASSIGN ,constant (CONSTANT ,(- 0 shift)))
+ `(ASSIGN ,datum2 (FIXNUM-2-ARGS FIXNUM-LSH ,datum ,constant #F))))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) ,datum2))))))
+ (else
+ (internal-error
+ "Floating-point values have unexpected size in words" factor)))))
+
+(let ((define-fixnum-primitive/1
+ (lambda (prim-name operation-name)
+ (define-open-coder/value prim-name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let ((rand (rtlgen/->register (first rands))))
+ (rtlgen/value-assignment state
+ `(FIXNUM-1-ARG ,operation-name ,rand #F)))))))
+ (define-fixnum-primitive/2
+ (lambda (prim-name operation-name)
+ (define-open-coder/value prim-name 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand1 (rtlgen/->register (first rands)))
+ (rand2 (rtlgen/->register (second rands))))
+ (rtlgen/value-assignment state
+ `(FIXNUM-2-ARGS ,operation-name
+ ,rand1 ,rand2 #F))))))))
+ #| DIVIDE-FIXNUM GCD-FIXNUM |#
+ (define-fixnum-primitive/2 'PLUS-FIXNUM 'PLUS-FIXNUM)
+ (define-fixnum-primitive/2 'MINUS-FIXNUM 'MINUS-FIXNUM)
+ (define-fixnum-primitive/2 'MULTIPLY-FIXNUM 'MULTIPLY-FIXNUM)
+ (define-fixnum-primitive/2 'FIXNUM-QUOTIENT 'FIXNUM-QUOTIENT)
+ (define-fixnum-primitive/2 'FIXNUM-REMAINDER 'FIXNUM-REMAINDER)
+ (define-fixnum-primitive/2 'FIXNUM-ANDC 'FIXNUM-ANDC)
+ (define-fixnum-primitive/2 'FIXNUM-AND 'FIXNUM-AND)
+ (define-fixnum-primitive/2 'FIXNUM-OR 'FIXNUM-OR)
+ (define-fixnum-primitive/2 'FIXNUM-XOR 'FIXNUM-XOR)
+ (define-fixnum-primitive/2 'FIXNUM-LSH 'FIXNUM-LSH)
+ (define-fixnum-primitive/1 'ONE-PLUS-FIXNUM 'ONE-PLUS-FIXNUM)
+ (define-fixnum-primitive/1 'MINUS-ONE-PLUS-FIXNUM 'MINUS-ONE-PLUS-FIXNUM)
+ (define-fixnum-primitive/1 'FIXNUM-NOT 'FIXNUM-NOT))
+\f
+(let ((define-flonum-primitive/1
+ (lambda (prim-name operation)
+ (define-open-coder/value prim-name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand (rtlgen/->register (first rands)))
+ (flo (rtlgen/new-reg)))
+ (rtlgen/assign! flo `(OBJECT->FLOAT ,rand))
+ (rtlgen/value-assignment
+ state
+ `(FLOAT->OBJECT
+ ,(rtlgen/->register
+ `(FLONUM-1-ARG ,operation ,flo #F)))))))))
+ (define-flonum-primitive/2
+ (lambda (prim-name operation)
+ (define-open-coder/value prim-name 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand1 (rtlgen/->register (first rands)))
+ (rand2 (rtlgen/->register (second rands)))
+ (flo1 (rtlgen/new-reg))
+ (flo2 (rtlgen/new-reg)))
+ (rtlgen/assign! flo1 `(OBJECT->FLOAT ,rand1))
+ (rtlgen/assign! flo2 `(OBJECT->FLOAT ,rand2))
+ (rtlgen/value-assignment
+ state
+ `(FLOAT->OBJECT
+ ,(rtlgen/->register
+ `(FLONUM-2-ARGS ,operation ,flo1 ,flo2 #F))))))))))
+
+ (define-flonum-primitive/1 'FLONUM-ABS 'FLONUM-ABS)
+ (define-flonum-primitive/1 'FLONUM-ACOS 'FLONUM-ACOS)
+ (define-flonum-primitive/1 'FLONUM-ASIN 'FLONUM-ASIN)
+ (define-flonum-primitive/1 'FLONUM-ATAN 'FLONUM-ATAN)
+ (define-flonum-primitive/1 'FLONUM-CEILING 'FLONUM-CEILING)
+ (define-flonum-primitive/1 'FLONUM-CEILING->EXACT 'FLONUM-CEILING->EXACT)
+ (define-flonum-primitive/1 'FLONUM-COS 'FLONUM-COS)
+ (define-flonum-primitive/1 'FLONUM-EXP 'FLONUM-EXP)
+ (define-flonum-primitive/1 'FLONUM-FLOOR 'FLONUM-FLOOR)
+ (define-flonum-primitive/1 'FLONUM-FLOOR->EXACT 'FLONUM-FLOOR->EXACT)
+ (define-flonum-primitive/1 'FLONUM-LOG 'FLONUM-LOG)
+ (define-flonum-primitive/1 'FLONUM-NEGATE 'FLONUM-NEGATE)
+ (define-flonum-primitive/1 'FLONUM-NORMALIZE 'FLONUM-NORMALIZE)
+ (define-flonum-primitive/1 'FLONUM-ROUND 'FLONUM-ROUND)
+ (define-flonum-primitive/1 'FLONUM-ROUND->EXACT 'FLONUM-ROUND->EXACT)
+ (define-flonum-primitive/1 'FLONUM-SIN 'FLONUM-SIN)
+ (define-flonum-primitive/1 'FLONUM-SQRT 'FLONUM-SQRT)
+ (define-flonum-primitive/1 'FLONUM-TAN 'FLONUM-TAN)
+ (define-flonum-primitive/1 'FLONUM-TRUNCATE 'FLONUM-TRUNCATE)
+ (define-flonum-primitive/1 'FLONUM-TRUNCATE->EXACT 'FLONUM-TRUNCATE->EXACT)
+
+ (define-flonum-primitive/2 'FLONUM-ADD 'FLONUM-ADD)
+ (define-flonum-primitive/2 'FLONUM-ATAN2 'FLONUM-ATAN2)
+ (define-flonum-primitive/2 'FLONUM-DENORMALIZE 'FLONUM-DENORMALIZE)
+ (define-flonum-primitive/2 'FLONUM-DIVIDE 'FLONUM-DIVIDE)
+ (define-flonum-primitive/2 'FLONUM-EXPT 'FLONUM-EXPT)
+ (define-flonum-primitive/2 'FLONUM-MULTIPLY 'FLONUM-MULTIPLY)
+ (define-flonum-primitive/2 'FLONUM-SUBTRACT 'FLONUM-SUBTRACT))
+\f
+(let ((char-tag (machine-tag 'CHARACTER))
+ (fixnum-tag (machine-tag 'POSITIVE-FIXNUM)))
+ (let ((define-datum-conversion
+ (lambda (name output-tag)
+ (define-open-coder/value name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand* (rtlgen/->register (first rands)))
+ (temp (rtlgen/new-reg)))
+ (rtlgen/assign! temp `(OBJECT->DATUM ,rand*))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,output-tag)
+ ,temp)))))))
+
+ (define-masked-datum-conversion
+ (lambda (name mask)
+ (define-open-coder/value name 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((rand* (rtlgen/->register (first rands)))
+ (temp (rtlgen/new-reg))
+ (mask-reg (rtlgen/new-reg))
+ (masked (rtlgen/new-reg)))
+ (rtlgen/assign!*
+ `((ASSIGN ,temp (OBJECT->DATUM ,rand*))
+ (ASSIGN ,mask-reg (CONSTANT ,mask))
+ (ASSIGN ,masked
+ (FIXNUM-2-ARGS FIXNUM-AND ,temp ,mask-reg #F))))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,fixnum-tag)
+ ,masked))))))))
+
+ (define-datum-conversion 'INTEGER->CHAR char-tag)
+ (define-datum-conversion 'ASCII->CHAR char-tag)
+ (define-masked-datum-conversion 'CHAR->ASCII #xff)
+ (define-masked-datum-conversion 'CHAR-CODE #x7f)
+ (define-datum-conversion 'CHAR->INTEGER fixnum-tag)))
+\f
+(let* ((off (rtlgen/words->chars 2))
+ (define-string-reference
+ (lambda (name tag)
+ (define-open-coder/value name 2
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((index (second rands))
+ (rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (byte (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (cond ((rtlgen/constant? index)
+ (let ((index* (rtlgen/constant-value index)))
+ (rtlgen/assign! byte
+ `(BYTE-OFFSET ,address
+ (MACHINE-CONSTANT
+ ,(+ off index*))))))
+ ((rtlgen/indexed-loads? 'BYTE)
+ (let* ((index* (rtlgen/->register index))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign!
+ ptr
+ `(BYTE-OFFSET-ADDRESS ,address
+ (MACHINE-CONSTANT ,off)))
+ (rtlgen/assign! byte `(BYTE-OFFSET ,ptr ,index*))))
+ (else
+ (let* ((index* (rtlgen/->register index))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign!
+ ptr
+ `(BYTE-OFFSET-ADDRESS ,address ,index*))
+ (rtlgen/assign!
+ byte
+ `(BYTE-OFFSET ,ptr
+ (MACHINE-CONSTANT ,off))))))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) ,byte))))))))
+ (define-string-reference 'VECTOR-8B-REF (machine-tag 'POSITIVE-FIXNUM))
+ (define-string-reference 'STRING-REF (machine-tag 'CHARACTER)))
+\f
+(define-open-coder/value 'FLOATING-VECTOR-REF 2
+ (let ((factor (rtlgen/fp->words 1)))
+ (if (= factor 1)
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((index (second rands))
+ (rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (float (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (cond ((rtlgen/constant? index)
+ (let ((index* (rtlgen/constant-value index)))
+ (rtlgen/assign! float
+ `(FLOAT-OFFSET ,address
+ (MACHINE-CONSTANT
+ ,(+ 1 index*))))))
+ ((rtlgen/indexed-loads? 'FLOAT)
+ (let* ((index* (rtlgen/->register index))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign!
+ ptr
+ `(FLOAT-OFFSET-ADDRESS ,address (MACHINE-CONSTANT 1)))
+ (rtlgen/assign! float `(FLOAT-OFFSET ,ptr ,index*))))
+ (else
+ (let* ((index* (rtlgen/->register index))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign!
+ ptr
+ `(FLOAT-OFFSET-ADDRESS ,address ,index*))
+ (rtlgen/assign!
+ float
+ `(FLOAT-OFFSET ,ptr (MACHINE-CONSTANT 1))))))
+ (rtlgen/value-assignment state `(FLOAT->OBJECT ,float))))
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((index (second rands))
+ (rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (ptr (rtlgen/new-reg))
+ (float (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign! ptr `(OFFSET-ADDRESS ,address (MACHINE-CONSTANT 1)))
+ (cond ((rtlgen/constant? index)
+ (let ((index* (rtlgen/constant-value index)))
+ (rtlgen/assign!
+ float
+ `(FLOAT-OFFSET ,ptr (MACHINE-CONSTANT ,index*)))))
+ ((rtlgen/indexed-loads? 'FLOAT)
+ (let ((index* (rtlgen/->register index)))
+ (rtlgen/assign! float `(FLOAT-OFFSET ,ptr ,index*))))
+ (else
+ (let* ((index* (rtlgen/->register index))
+ (ptr2 (rtlgen/new-reg)))
+ (rtlgen/assign! ptr2
+ `(FLOAT-OFFSET-ADDRESS ,ptr ,index*))
+ (rtlgen/assign!
+ float
+ `(FLOAT-OFFSET ,ptr2 (MACHINE-CONSTANT 0))))))
+ (rtlgen/value-assignment state `(FLOAT->OBJECT ,float)))))))
+\f
+(define (rtlgen/fixed-mutation rands offset)
+ (let* ((rand (rtlgen/->register (first rands)))
+ (value (rtlgen/->register (second rands)))
+ (address (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/emit!/1
+ `(ASSIGN (OFFSET ,address (MACHINE-CONSTANT ,offset))
+ ,value))))
+
+(define-open-coder/stmt %variable-cell-set! 2
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (let* ((cell (rtlgen/->register (first rands)))
+ (value (rtlgen/->register (second rands))))
+ (rtlgen/emit!/1 `(ASSIGN (OFFSET ,cell (MACHINE-CONSTANT 0))
+ ,value)))))
+
+(define-open-coder/stmt %static-binding-set! 3
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (let ((name (third rands)))
+ (if (not (rtlgen/constant? name))
+ (internal-error "Unexpected name to static-binding-set!" name))
+ (let ((cell (rtlgen/->register
+ `(STATIC-CELL ,(rtlgen/constant-value name))))
+ (value (rtlgen/->register (second rands))))
+ (rtlgen/emit!/1
+ `(ASSIGN (OFFSET ,cell (MACHINE-CONSTANT 0)) ,value))))))
+\f
+(let ((define-fixed-mutator
+ (lambda (name tag offset arity)
+ tag ; unused
+ (define-open-coder/stmt name arity
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (rtlgen/fixed-mutation rands offset))))))
+ (define-fixed-mutator 'SET-CELL-CONTENTS! (machine-tag 'CELL) 0 2)
+ (define-fixed-mutator %cell-set! (machine-tag 'CELL) 0 3)
+ (define-fixed-mutator 'SET-CAR! (machine-tag 'PAIR) 0 2)
+ (define-fixed-mutator 'SET-CDR! (machine-tag 'PAIR) 1 2)
+ (define-fixed-mutator 'SET-STRING-LENGTH! (machine-tag 'STRING) 1 2))
+
+(let ((define-indexed-mutator
+ (lambda (name tag offset arity)
+ tag ; unused
+ (define-open-coder/stmt name arity
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (let ((index (second rands)))
+ (cond ((rtlgen/constant? index)
+ (rtlgen/fixed-mutation
+ (list (first rands) (third rands))
+ (+ offset (rtlgen/constant-value index))))
+ ((rtlgen/indexed-stores? 'WORD)
+ (let* ((rand (rtlgen/->register (first rands)))
+ (index* (rtlgen/->register index))
+ (value (rtlgen/->register (third rands)))
+ (address (rtlgen/new-reg))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign!
+ ptr
+ `(OFFSET-ADDRESS ,address
+ (MACHINE-CONSTANT ,offset)))
+ (rtlgen/emit!/1
+ `(ASSIGN (OFFSET ,ptr ,index*) ,value))))
+ (else
+ (let* ((rand (rtlgen/->register (first rands)))
+ (index* (rtlgen/->register index))
+ (value (rtlgen/->register (third rands)))
+ (address (rtlgen/new-reg))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign! ptr
+ `(OFFSET-ADDRESS ,address ,index*))
+ (rtlgen/emit!/1
+ `(ASSIGN (OFFSET ,ptr (MACHINE-CONSTANT ,offset))
+ ,value)))))))))))
+ (define-indexed-mutator 'VECTOR-SET! (machine-tag 'VECTOR) 1 3)
+ (define-indexed-mutator '%RECORD-SET! (machine-tag 'RECORD) 1 3)
+ (define-indexed-mutator 'PRIMITIVE-OBJECT-SET! false 0 3))
+\f
+(define-open-coder/stmt %heap-closure-set! 4
+ (let ((offset (rtlgen/closure-first-offset)))
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (let ((index (second rands)))
+ (cond ((not (rtlgen/constant? index))
+ (internal-error "%heap-closure-set! with non-constant offset"
+ rands))
+ ((rtlgen/tagged-closures?)
+ (rtlgen/fixed-mutation
+ (list (first rands) (third rands))
+ (+ offset (rtlgen/constant-value index))))
+ (else
+ (rtlgen/emit!/1
+ `(ASSIGN (OFFSET ,(rtlgen/->register (car rands))
+ (MACHINE-CONSTANT
+ ,(+ offset (rtlgen/constant-value index))))
+ ,(rtlgen/->register (caddr rands))))))))))
+
+(let* ((off (rtlgen/words->chars 2))
+ (define-string-mutation
+ (lambda (name)
+ (define-open-coder/stmt name 3
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (let* ((index (second rands))
+ (rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (value (rtlgen/->register (third rands)))
+ (byte (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign! byte `(OBJECT->DATUM ,value))
+ (cond ((rtlgen/constant? index)
+ (let* ((index* (rtlgen/constant-value index)))
+ (rtlgen/emit!/1
+ `(ASSIGN (BYTE-OFFSET ,address
+ (MACHINE-CONSTANT
+ ,(+ off index*)))
+ ,byte))))
+ ((rtlgen/indexed-stores? 'BYTE)
+ (let* ((index* (rtlgen/->register index))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign!
+ ptr
+ `(BYTE-OFFSET-ADDRESS ,address
+ (MACHINE-CONSTANT ,off)))
+ (rtlgen/emit!/1
+ `(ASSIGN (BYTE-OFFSET ,ptr ,index*) ,byte))))
+ (else
+ (let* ((index* (rtlgen/->register index))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign!
+ ptr
+ `(BYTE-OFFSET-ADDRESS ,address ,index*))
+ (rtlgen/emit!/1
+ `(ASSIGN (BYTE-OFFSET ,ptr (MACHINE-CONSTANT ,off))
+ ,byte)))))))))))
+ (define-string-mutation 'VECTOR-8B-SET!)
+ (define-string-mutation 'STRING-SET!))
+\f
+(define-open-coder/stmt 'FLOATING-VECTOR-SET! 3
+ (let ((factor (rtlgen/fp->words 1)))
+ (if (= factor 1)
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (let* ((index (second rands))
+ (rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (value (rtlgen/->register (third rands)))
+ (float (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign! float `(OBJECT->FLOAT ,value))
+ (cond ((rtlgen/constant? index)
+ (let ((index* (rtlgen/constant-value index)))
+ (rtlgen/emit!/1
+ `(ASSIGN (FLOAT-OFFSET ,address
+ (MACHINE-CONSTANT ,(+ 1 index*)))
+ ,float))))
+ ((rtlgen/indexed-stores? 'FLOAT)
+ (let* ((index* (rtlgen/->register index))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign!
+ ptr
+ `(FLOAT-OFFSET-ADDRESS ,address (MACHINE-CONSTANT 1)))
+ (rtlgen/emit!/1
+ `(ASSIGN (FLOAT-OFFSET ,ptr ,index*) ,float))))
+ (else
+ (let* ((index* (rtlgen/->register index))
+ (ptr (rtlgen/new-reg)))
+ (rtlgen/assign! ptr
+ `(FLOAT-OFFSET-ADDRESS ,address ,index*))
+ (rtlgen/emit!/1
+ `(ASSIGN (FLOAT-OFFSET ,ptr (MACHINE-CONSTANT 1))
+ ,float)))))))
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (let* ((index (second rands))
+ (rand (rtlgen/->register (first rands)))
+ (address (rtlgen/new-reg))
+ (ptr (rtlgen/new-reg))
+ (value (rtlgen/->register (third rands)))
+ (float (rtlgen/new-reg)))
+ (rtlgen/assign! address `(OBJECT->ADDRESS ,rand))
+ (rtlgen/assign! ptr `(OFFSET-ADDRESS ,address
+ (MACHINE-CONSTANT 1)))
+ (rtlgen/assign! float `(OBJECT->FLOAT ,value))
+ (cond ((rtlgen/constant? index)
+ (let ((index* (rtlgen/constant-value index)))
+ (rtlgen/emit!/1
+ `(ASSIGN (FLOAT-OFFSET ,ptr
+ (MACHINE-CONSTANT ,index*))
+ ,float))))
+ ((rtlgen/indexed-stores? 'FLOAT)
+ (let ((index* (rtlgen/->register index)))
+ (rtlgen/emit!/1
+ `(ASSIGN (FLOAT-OFFSET ,ptr ,index*) ,float))))
+ (else
+ (let* ((index* (rtlgen/->register index))
+ (ptr2 (rtlgen/new-reg)))
+ (rtlgen/assign! ptr2
+ `(FLOAT-OFFSET-ADDRESS ,ptr ,index*))
+ (rtlgen/emit!/1
+ `(ASSIGN (FLOAT-OFFSET ,ptr2 (MACHINE-CONSTANT 0))
+ ,float))))))))))
+\f
+;;;; Miscellaneous system primitives
+
+(define-open-coder/pred 'HEAP-AVAILABLE? 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((free (rtlgen/reference-to-free))
+ (memtop (rtlgen/->register (rtlgen/fetch-memtop)))
+ (rand (rtlgen/->register (first rands)))
+ (temp1 (rtlgen/new-reg))
+ (temp2 (rtlgen/new-reg)))
+ (rtlgen/assign!*
+ `((ASSIGN ,temp1 (OBJECT->DATUM ,rand))
+ (ASSIGN ,temp2 (OFFSET-ADDRESS ,free ,temp1))))
+ (rtlgen/branch/likely
+ state
+ `(FIXNUM-PRED-2-ARGS LESS-THAN-FIXNUM? ,temp2 ,memtop)))))
+
+(define-open-coder/value 'PRIMITIVE-GET-FREE 1
+ (lambda (state rands open-coder)
+ open-coder ; ignored
+ (let* ((free (rtlgen/reference-to-free))
+ (rand (rtlgen/->register (first rands)))
+ (temp (rtlgen/new-reg)))
+ (rtlgen/assign! temp `(OBJECT->DATUM ,rand))
+ (rtlgen/value-assignment state `(CONS-POINTER ,temp ,free)))))
+
+(define-open-coder/stmt 'PRIMITIVE-INCREMENT-FREE 1
+ (lambda (state rands open-coder)
+ state open-coder ; ignored
+ (let* ((free (rtlgen/reference-to-free))
+ (rand (rtlgen/->register (first rands)))
+ (temp (rtlgen/new-reg)))
+ (rtlgen/assign!*
+ `((ASSIGN ,temp (OBJECT->DATUM ,rand))
+ (ASSIGN ,free (OFFSET-ADDRESS ,free ,temp)))))))
+
+(define-open-coder/value 'GET-INTERRUPT-ENABLES 0
+ (let ((tag (machine-tag 'POSITIVE-FIXNUM)))
+ (lambda (state rands open-coder)
+ open-coder rands ; ignored
+ (let ((int-mask (rtlgen/->register (rtlgen/fetch-int-mask))))
+ (rtlgen/value-assignment
+ state
+ `(CONS-NON-POINTER (MACHINE-CONSTANT ,tag) ,int-mask))))))
+
+(define-open-coder/value %fetch-environment 0
+ (lambda (state rands open-coder)
+ rands open-coder ; ignored
+ (rtlgen/value-assignment state (rtlgen/fetch-environment))))
+\f
+;;;; Out of line hooks
+
+(let ((define-out-of-line-primitive
+ (lambda (operator prim-name arity)
+ (let ((primitive (make-primitive-procedure prim-name)))
+ (define-open-coder/out-of-line operator arity
+ (lambda (cont-label open-coder)
+ open-coder ; ignored
+ (rtlgen/emit!/1
+ `(INVOCATION:SPECIAL-PRIMITIVE ,(+ arity 1)
+ ,cont-label
+ ,primitive))))))))
+ (define-out-of-line-primitive %+ '&+ 2)
+ (define-out-of-line-primitive %- '&- 2)
+ (define-out-of-line-primitive %* '&* 2)
+ (define-out-of-line-primitive %/ '&/ 2)
+ (define-out-of-line-primitive %quotient 'QUOTIENT 2)
+ (define-out-of-line-primitive %remainder 'REMAINDER 2)
+ (define-out-of-line-primitive %= '&= 2)
+ (define-out-of-line-primitive %< '&< 2)
+ (define-out-of-line-primitive %> '&> 2)
+ (define-out-of-line-primitive %string-allocate 'STRING-ALLOCATE 1)
+ (define-out-of-line-primitive %floating-vector-cons 'FLOATING-VECTOR-CONS 1)
+ (define-out-of-line-primitive %vector-cons 'VECTOR-CONS 2))
+
+(let ((define-variable-ref
+ (lambda (operator safe?)
+ (define-open-coder/special operator 1
+ (lambda (cont-label rands open-coder)
+ open-coder ; ignored
+ (let ((cell (rtlgen/->register (first rands)))
+ (cell-loc (rtlgen/interpreter-call/argument-home 1)))
+ (rtlgen/assign!*
+ (list `(ASSIGN ,cell-loc ,cell)
+ `(INTERPRETER-CALL:CACHE-REFERENCE ,cont-label
+ ,cell-loc
+ ,safe?)))))))))
+ (define-variable-ref %hook-variable-cell-ref false)
+ (define-variable-ref %hook-safe-variable-cell-ref true))
+
+(define-open-coder/special %hook-variable-cell-set! 2
+ (lambda (cont-label rands open-coder)
+ open-coder ; ignored
+ (let ((cell (rtlgen/->register (first rands)))
+ (value (rtlgen/->register (second rands)))
+ (cell-loc (rtlgen/interpreter-call/argument-home 1))
+ (value-loc (rtlgen/interpreter-call/argument-home 2)))
+ (rtlgen/assign!*
+ (list `(ASSIGN ,value-loc ,value)
+ `(ASSIGN ,cell-loc ,cell)
+ `(INTERPRETER-CALL:CACHE-ASSIGNMENT ,cont-label
+ ,cell-loc
+ ,value-loc))))))
+\f
+(let ((unexpected
+ (lambda all
+ (let ((open-coder (car (last-pair all))))
+ (internal-error "Unexpected operator"
+ (rtlgen/open-coder/rator open-coder))))))
+
+ (for-each
+ (lambda (operation)
+ (define-open-coder operation false
+ unexpected unexpected unexpected unexpected unexpected))
+ ;; These are rewritten by earlier stages or handled specially.
+ ;; They should never be found.
+ (list %vector-index %variable-cache-ref %variable-cache-set!
+ %safe-variable-cache-ref %stack-closure-ref
+ %internal-apply %primitive-apply %invoke-continuation
+ %invoke-operator-cache %invoke-remote-cache
+ %make-read-variable-cache %make-write-variable-cache
+ %make-operator-variable-cache %fetch-continuation
+ %fetch-stack-closure %make-stack-closure
+ %*define %execute %*define* %*make-environment
+ %copy-program %*lookup %*set! %*unassigned?
+ ;; Replaced for compatibility
+ %make-heap-closure %make-trivial-closure)))
+
+#|
+;; Missing:
+
+'SET-INTERRUPT-ENABLES!
+|#
+\f
+;;;; Patterns
+
+(define rtlgen/?lambda-list (->pattern-variable 'LAMBDA-LIST))
+(define rtlgen/?frame-var (->pattern-variable 'FRAME-VAR))
+(define rtlgen/?frame-vector (->pattern-variable 'FRAME-VECTOR))
+(define rtlgen/?frame-vector* (->pattern-variable 'FRAME-VECTOR*))
+(define rtlgen/?continuation-body (->pattern-variable 'CONTINUATION-BODY))
+(define rtlgen/?rator (->pattern-variable 'RATOR))
+(define rtlgen/?return-address (->pattern-variable 'RETURN-ADDRESS))
+(define rtlgen/?closure-elts (->pattern-variable 'CLOSURE-ELTS))
+(define rtlgen/?closure-elts* (->pattern-variable 'CLOSURE-ELTS*))
+(define rtlgen/?rands (->pattern-variable 'RANDS))
+(define rtlgen/?cont-name (->pattern-variable 'CONT-NAME))
+(define rtlgen/?env-name (->pattern-variable 'ENV-NAME))
+(define rtlgen/?body (->pattern-variable 'BODY))
+(define rtlgen/?closed-vars (->pattern-variable 'CLOSED-VARS))
+(define rtlgen/?closed-over-env-var
+ (->pattern-variable 'CLOSED-OVER-ENV-VAR))
+
+(define rtlgen/?closure-name (->pattern-variable 'CLOSURE-NAME))
+(define rtlgen/?offset (->pattern-variable 'OFFSET))
+(define rtlgen/?var-name (->pattern-variable 'VAR-NAME))
+
+(define rtlgen/?lambda-expression (->pattern-variable 'LAMBDA-EXPRESSION))
+
+(define rtlgen/continuation-pattern
+ `(LAMBDA ,rtlgen/?lambda-list
+ (LET ((,rtlgen/?frame-var
+ (CALL (QUOTE ,%fetch-stack-closure)
+ (QUOTE #F)
+ (QUOTE ,rtlgen/?frame-vector))))
+ ,rtlgen/?continuation-body)))
+
+(define rtlgen/stack-overwrite-pattern
+ `(CALL (QUOTE ,%stack-closure-ref)
+ (QUOTE #F)
+ (LOOKUP ,rtlgen/?closure-name)
+ (QUOTE ,rtlgen/?offset)
+ (QUOTE ,rtlgen/?var-name)))
+
+(define rtlgen/outer-expression-pattern
+ `(LAMBDA (,rtlgen/?cont-name ,rtlgen/?env-name)
+ ,rtlgen/?body))
+
+(define rtlgen/top-level-trivial-closure-pattern
+ `(CALL (QUOTE ,%invoke-continuation)
+ (LOOKUP ,rtlgen/?cont-name)
+ (CALL (QUOTE ,%make-trivial-closure)
+ (QUOTE #F)
+ ,rtlgen/?lambda-expression)))
+
+(define rtlgen/top-level-heap-closure-pattern
+ `(CALL (QUOTE ,%invoke-continuation)
+ (LOOKUP ,rtlgen/?cont-name)
+ (CALL (QUOTE ,%make-heap-closure)
+ (QUOTE #F)
+ ,rtlgen/?lambda-expression
+ ,rtlgen/?closed-vars
+ ,rtlgen/?closed-over-env-var)))
+
+(define rtlgen/extended-call-pattern
+ `(CALL (LAMBDA (,rtlgen/?cont-name)
+ (CALL (QUOTE ,rtlgen/?rator)
+ (CALL (QUOTE ,%make-stack-closure)
+ (QUOTE #F)
+ (QUOTE #F)
+ (QUOTE ,rtlgen/?frame-vector*)
+ (LOOKUP ,rtlgen/?cont-name)
+ ,@rtlgen/?closure-elts*)
+ ,@rtlgen/?rands))
+ (CALL (QUOTE ,%make-stack-closure)
+ (QUOTE #F)
+ ,rtlgen/?return-address
+ (QUOTE ,rtlgen/?frame-vector)
+ ,@rtlgen/?closure-elts)))
+
+(define rtlgen/make-stack-closure-handler-pattern
+ `(CALL ',%make-stack-closure
+ '#F
+ ,rtlgen/?lambda-expression
+ (QUOTE ,rtlgen/?frame-vector*)
+ ,rtlgen/?return-address
+ ,@rtlgen/?closure-elts*))
+
+(define rtlgen/lambda-expr-pattern
+ `(LAMBDA ,rtlgen/?lambda-list ,rtlgen/?body))
+
+(define rtlgen/call-lambda-with-stack-closure-pattern
+ `(CALL (LAMBDA (,rtlgen/?cont-name) ,rtlgen/?body)
+ (CALL ',%make-stack-closure
+ '#F
+ ,rtlgen/?lambda-expression
+ (QUOTE ,rtlgen/?frame-vector*)
+ ,rtlgen/?return-address
+ ,@rtlgen/?closure-elts*)))
+
+\f
+#|
+;; New RTL:
+
+(INVOCATION:REGISTER 0 #F (REGISTER n) #F (MACHINE-CONSTANT nregs))
+(INVOCATION:PROCEDURE 0 cont-label label (MACHINE-CONSTANT nregs))
+;; if cont-label is not false, this is expected to set up the
+;; continuation in the standard location (register or top of stack)
+
+(INVOCATION:NEW-APPLY
+ frame-size cont-label (REGISTER dest) (MACHINE-CONSTANT nregs))
+;; if cont-label is not false, this is expected to set up the
+;; continuation in the standard location (register or top of stack)
+
+(RETURN-ADDRESS label (MACHINE-CONSTANT n) (MACHINE-CONSTANT m))
+ n --> number of items saved on the stack
+ m --> arity
+(PROCEDURE label (MACHINE-CONSTANT frame-size))
+(TRIVIAL-CLOSURE label (MACHINE-CONSTANT min) (MACHINE-CONSTANT max))
+(CLOSURE label (MACHINE-CONSTANT n))
+(EXPRESSION label)
+
+(INTERRUPT-CHECK:CLOSURE intrpt? heap? stack? (MACHINE-CONSTANT fs))
+(INTERRUPT-CHECK:PROCEDURE intrpt? heap? stack? label (MACHINE-CONSTANT fs))
+(INTERRUPT-CHECK:CONTINUATION intrpt? heap? stack? label (MACHINE-CONSTANT fs))
+;; fs is the frame size, including the continuation and the
+;; self-reference (heap closures only)
+
+(ASSIGN (REGISTER n) (ALIGN-FLOAT (REGISTER m))) ; float alignment
+(ASSIGN (REGISTER n) (STATIC-CELL name)) ; static binding
+(ASSIGN (REGISTER n) ; type & range check
+ (PRED-2-ARGS SMALL-FIXNUM?
+ (REGISTER m)
+ (MACHINE-CONSTANT nbits)))
+(PRESERVE (REGISTER n) <how>)
+(RESTORE (REGISTER m) <expression> <how>)
+
+;; where how is one of SAVE, IF-AVAILABLE, and RECOMPUTE
+
+|#
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: simplify.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Substitute simple and used-only-once parameters
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (simplify/top-level program)
+ (simplify/expr #F program))
+
+(define-macro (define-simplifier keyword bindings . body)
+ (let ((proc-name (symbol-append 'SIMPLIFY/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name env form)
+ (simplify/remember ,code
+ form))))))))
+
+(define-simplifier LOOKUP (env name)
+ (let ((ref `(LOOKUP ,name)))
+ (simplify/lookup*! env name ref #T)))
+
+(define-simplifier LAMBDA (env lambda-list body)
+ `(LAMBDA ,lambda-list
+ ,(simplify/expr
+ (simplify/env/make env
+ (lmap simplify/binding/make (lambda-list->names lambda-list)))
+ body)))
+
+(define-simplifier QUOTE (env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-simplifier DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+(define-simplifier BEGIN (env #!rest actions)
+ `(BEGIN ,@(simplify/expr* env actions)))
+
+(define-simplifier IF (env pred conseq alt)
+ `(IF ,(simplify/expr env pred)
+ ,(simplify/expr env conseq)
+ ,(simplify/expr env alt)))
+\f
+(define (do-simplification env mutually-recursive? bindings body continue)
+ ;; BINDINGS is a list of triples: (environment name expression)
+ ;; where ENVIRONMENT is either #F or the environment for the lambda
+ ;; expression bound to this name
+ (define unsafe-cyclic-reference?
+ (if mutually-recursive?
+ (let ((finder (association-procedure eq? second)))
+ (make-breaks-cycle? (map second bindings)
+ (lambda (name)
+ (let* ((triple (finder name bindings))
+ (env (first triple)))
+ (if env
+ (simplify/env/free-calls env)
+ '())))))
+ (lambda (lambda-expr) lambda-expr #F)))
+
+ (simplify/bindings env unsafe-cyclic-reference?
+ (simplify/delete-parameters env bindings
+ unsafe-cyclic-reference?)
+ body continue))
+
+(define-simplifier CALL (env rator cont #!rest rands)
+ (define (do-ops rator*)
+ `(CALL ,rator*
+ ,(simplify/expr env cont)
+ ,@(simplify/expr* env rands)))
+
+ (cond ((LOOKUP/? rator)
+ (let* ((name (lookup/name rator))
+ (rator* (simplify/remember `(LOOKUP ,name) rator))
+ (result (do-ops rator*)))
+ (simplify/lookup*! env name result #F)))
+ ((LAMBDA/? rator)
+ (guarantee-simple-lambda-list (lambda/formals rator)) ;Miller & Adams
+ (let* ((lambda-list (lambda/formals rator))
+ (env0 (simplify/env/make env
+ (lmap simplify/binding/make lambda-list)))
+ (body* (simplify/expr env0 (caddr rator)))
+ (bindings* (map (lambda (name value)
+ (simplify/binding&value env name value))
+ lambda-list
+ (cons cont rands))))
+ (do-simplification env0 #F bindings* body*
+ (lambda (bindings* body*)
+ (simplify/pseudo-letify rator bindings* body*)))))
+ (else
+ (do-ops (simplify/expr env rator)))))
+
+(define-simplifier LET (env bindings body)
+ (let* ((env0 (simplify/env/make env
+ (lmap (lambda (binding) (simplify/binding/make (car binding)))
+ bindings)))
+ (body* (simplify/expr env0 body))
+ (bindings*
+ (lmap (lambda (binding)
+ (simplify/binding&value env (car binding) (cadr binding)))
+ bindings)))
+ (do-simplification env0 #F bindings* body* simplify/letify)))
+
+(define-simplifier LETREC (env bindings body)
+ (let* ((env0 (simplify/env/make env
+ (lmap (lambda (binding) (simplify/binding/make (car binding)))
+ bindings)))
+ (body* (simplify/expr env0 body))
+ (bindings*
+ (lmap (lambda (binding)
+ (simplify/binding&value env0 (car binding) (cadr binding)))
+ bindings)))
+ (do-simplification env0 #T bindings* body* simplify/letrecify)))
+\f
+(define (simplify/binding&value env name value)
+ (if (not (LAMBDA/? value))
+ (list false name (simplify/expr env value))
+ (let* ((lambda-list (lambda/formals value))
+ (env1 (simplify/env/make env
+ (lmap simplify/binding/make
+ (lambda-list->names lambda-list)))))
+ (let ((value*
+ `(LAMBDA ,lambda-list
+ ,(simplify/expr env1 (lambda/body value)))))
+ (list env1 name (simplify/remember value* value))))))
+
+(define (simplify/delete-parameters env0 bindings unsafe-cyclic-reference?)
+ ;; ENV0 is the current environment frame
+ ;; BINDINGS is parallel to that, but is a list of
+ ;; (frame* name expression) triplet lists as returned by
+ ;; simplify/binding&value, where frame* is either #F or the frame
+ ;; for the LAMBDA expression that is bound to this name
+ (for-each
+ (lambda (bnode triplet)
+ (let ((env1 (first triplet))
+ (name (second triplet))
+ (value (third triplet)))
+ (and env1
+ (null? (simplify/binding/ordinary-refs bnode))
+ (not (null? (simplify/binding/operator-refs bnode)))
+ ;; Don't bother if it will be open coded
+ (not (null? (cdr (simplify/binding/operator-refs bnode))))
+ (not (simplify/open-code? name value unsafe-cyclic-reference?))
+ ;; At this point, env1 and triplet represent a LAMBDA
+ ;; expression to which there are no regular references and
+ ;; which will not be open coded. We consider altering its
+ ;; formal parameter list.
+ (let ((unrefd
+ (list-transform-positive (simplify/env/bindings env1)
+ (lambda (bnode*)
+ (and (null? (simplify/binding/ordinary-refs bnode*))
+ (null? (simplify/binding/operator-refs bnode*))
+ (not (continuation-variable?
+ (simplify/binding/name bnode*))))))))
+ (and (not (null? unrefd))
+ (for-each (lambda (unrefd)
+ (simplify/maybe-delete unrefd
+ bnode
+ (caddr triplet)))
+ unrefd))))))
+ (simplify/env/bindings env0)
+ bindings)
+ (lmap cdr bindings))
+
+(define (simplify/maybe-delete unrefd bnode form)
+ (let ((position (simplify/operand/position unrefd form))
+ (operator-refs (simplify/binding/operator-refs bnode)))
+ (and (positive? position) ; continuation/ignore must remain
+ (if (for-all? operator-refs
+ (lambda (call)
+ (simplify/deletable-operand? call position)))
+ (begin
+ (for-each
+ (lambda (call)
+ (simplify/delete-operand! call position))
+ operator-refs)
+ (simplify/delete-parameter! form position))))))
+
+(define (simplify/operand/position bnode* form)
+ (let ((name (simplify/binding/name bnode*)))
+ (let loop ((ll (cadr form))
+ (index 0))
+ (cond ((null? ll)
+ (internal-error "Missing operand" name form))
+ ((eq? name (car ll)) index)
+ ((or (eq? (car ll) '#!OPTIONAL)
+ (eq? (car ll) '#!REST))
+ -1)
+ (else
+ (loop (cdr ll) (+ index 1)))))))
+\f
+(define (simplify/deletable-operand? call position)
+ (let loop ((rands (call/cont-and-operands call))
+ (position position))
+ (and (not (null? rands))
+ (if (zero? position)
+ (form/simple&side-effect-free? (car rands))
+ (loop (cdr rands) (- position 1))))))
+
+(define (simplify/delete-operand! call position)
+ (form/rewrite!
+ call
+ `(CALL ,(call/operator call)
+ ,@(list-delete/index (call/cont-and-operands call) position))))
+
+(define (simplify/delete-parameter! form position)
+ (set-car! (cdr form)
+ (list-delete/index (cadr form) position)))
+
+(define (list-delete/index l index)
+ (let loop ((l l)
+ (index index)
+ (accum '()))
+ (if (zero? index)
+ (append (reverse accum) (cdr l))
+ (loop (cdr l)
+ (- index 1)
+ (cons (car l) accum)))))
+\f
+(define (simplify/bindings env0 unsafe-cyclic-reference? bindings body letify)
+ ;; ENV0 is the current environment frame
+ ;; BINDINGS is parallel to that, but is a list of
+ ;; (name expression) two-lists as returned by
+ ;; simplify/delete-parameters
+ (let* ((frame-bindings (simplify/env/bindings env0))
+ (unused
+ (list-transform-positive frame-bindings
+ (lambda (binding)
+ (and (null? (simplify/binding/ordinary-refs binding))
+ (null? (simplify/binding/operator-refs binding)))))))
+ (call-with-values
+ (lambda ()
+ (list-split unused
+ (lambda (binding)
+ (let* ((place (assq (simplify/binding/name binding)
+ bindings)))
+ (form/simple&side-effect-free? (cadr place))))))
+ (lambda (simple-unused hairy-unused)
+ ;; simple-unused can be flushed, since they have no side effects
+ (let ((bindings* (delq* (lmap (lambda (simple)
+ (assq (simplify/binding/name simple)
+ bindings))
+ simple-unused)
+ bindings))
+ (not-simple-unused (delq* simple-unused frame-bindings)))
+ (if (or (not (eq? *order-of-argument-evaluation* 'ANY))
+ (null? hairy-unused))
+ (let ((new-env
+ (simplify/env/modified-copy env0 not-simple-unused)))
+ (simplify/bindings* new-env bindings* unsafe-cyclic-reference? body letify))
+ (let ((hairy-bindings
+ (lmap (lambda (hairy)
+ (assq (simplify/binding/name hairy)
+ bindings*))
+ hairy-unused))
+ (used-bindings (delq* hairy-unused not-simple-unused)))
+ (beginnify
+ (append
+ (map cadr hairy-bindings)
+ (list
+ (let ((new-env (simplify/env/modified-copy env0 used-bindings)))
+ (simplify/bindings* new-env (delq* hairy-bindings bindings*)
+ unsafe-cyclic-reference? body letify))))))))))))
+\f
+(define (simplify/bindings* env0 bindings unsafe-cyclic-reference? body letify)
+ ;; ENV0 is the current environment frame, as simplified by simplify/bindings
+ ;; BINDINGS is parallel to that, but is a list of
+ ;; (name expression) two-lists as returned by
+ ;; simplify/delete-parameters
+ (let* ((frame-bindings (simplify/env/bindings env0))
+ (to-substitute
+ (list-transform-positive frame-bindings
+ (lambda (node)
+ (let* ((name (simplify/binding/name node))
+ (value (second (assq name bindings))))
+ (and (pair? value)
+ (let ((ordinary (simplify/binding/ordinary-refs node))
+ (operator (simplify/binding/operator-refs node)))
+ (if (LAMBDA/? value)
+ (or (and (null? ordinary)
+ (or (null? (cdr operator))
+ (simplify/open-code?
+ name value unsafe-cyclic-reference?)))
+ (and (null? operator)
+ (null? (cdr ordinary))))
+ (and (= (+ (length ordinary) (length operator)) 1)
+ (simplify/substitute? value body))))))))))
+ (for-each
+ (lambda (node)
+ (simplify/substitute! node
+ (cadr (assq (simplify/binding/name node)
+ bindings))))
+ to-substitute)
+ ;; This works only as long as all references are replaced.
+ (letify (delq* (lmap (lambda (node)
+ (assq (simplify/binding/name node)
+ bindings))
+ to-substitute)
+ bindings)
+ body)))
+\f
+(define (simplify/substitute? value body)
+ (or (form/simple&side-effect-insensitive? value)
+ (and *after-cps-conversion?*
+ (CALL/? body)
+ (form/simple&side-effect-free? value)
+ (not (form/satisfies? value '(STATIC))))))
+
+;; Note: this only works if no variable free in value is captured
+;; at any reference in node.
+;; This is currently true by construction, but may not be in the future.
+
+(define (simplify/substitute! node value)
+ (for-each (lambda (ref)
+ (form/rewrite! ref value))
+ (simplify/binding/ordinary-refs node))
+ (for-each (lambda (ref)
+ (form/rewrite! ref `(CALL ,value ,@(cddr ref))))
+ (simplify/binding/operator-refs node)))
+
+(define (simplify/pseudo-letify rator bindings body)
+ (pseudo-letify rator bindings body simplify/remember))
+
+(define (simplify/letify bindings body)
+ `(LET ,bindings ,body))
+
+(define (simplify/letrecify bindings body)
+ `(LETREC ,bindings ,body))
+
+(define (simplify/open-code? name value unsafe-cyclic-reference?)
+ ;; VALUE must be a lambda expression
+ (let ((body (lambda/body value)))
+ (or (QUOTE/? body)
+ (LOOKUP/? body)
+ (and *after-cps-conversion?*
+ (CALL/? body)
+ (<= (length (call/cont-and-operands body))
+ (1+ (length (lambda/formals value))))
+ (not (unsafe-cyclic-reference? name))
+ (for-all? (cdr body)
+ (lambda (element)
+ (or (QUOTE/? element)
+ (LOOKUP/? element))))))))
+\f
+(define (simplify/expr env expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (simplify/quote env expr))
+ ((LOOKUP)
+ (simplify/lookup env expr))
+ ((LAMBDA)
+ (simplify/lambda env expr))
+ ((LET)
+ (simplify/let env expr))
+ ((DECLARE)
+ (simplify/declare env expr))
+ ((CALL)
+ (simplify/call env expr))
+ ((BEGIN)
+ (simplify/begin env expr))
+ ((IF)
+ (simplify/if env expr))
+ ((LETREC)
+ (simplify/letrec env expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (simplify/expr* env exprs)
+ (lmap (lambda (expr)
+ (simplify/expr env expr))
+ exprs))
+
+(define (simplify/remember new old)
+ (code-rewrite/remember new old))
+
+(define (simplify/new-name prefix)
+ (new-variable prefix))
+
+(define-structure
+ (simplify/binding
+ (conc-name simplify/binding/)
+ (constructor simplify/binding/make (name))
+ (print-procedure
+ (standard-unparser-method 'SIMPLIFY/BINDING
+ (lambda (binding port)
+ (write-char #\space port)
+ (write-string (symbol-name (simplify/binding/name binding)) port)))))
+
+ (name false read-only true)
+ (ordinary-refs '() read-only false)
+ (operator-refs '() read-only false))
+
+(define-structure (simplify/env
+ (conc-name simplify/env/)
+ (constructor simplify/env/make (parent bindings)))
+ (bindings '() read-only true)
+ (parent #F read-only true)
+ ;; This is used to mark calls to names free in this frame but bound
+ ;; in the parent frame ... used to detect mutual recursion in LETREC.
+ (free-calls '() read-only false))
+
+(define (simplify/env/modified-copy old-env new-bindings)
+ (let ((result (simplify/env/make (simplify/env/parent old-env)
+ new-bindings)))
+ (set-simplify/env/free-calls! result
+ (simplify/env/free-calls old-env))
+ result))
+
+
+(define simplify/env/frame-lookup
+ (association-procedure (lambda (x y) (eq? x y)) simplify/binding/name))
+
+(define (simplify/lookup*! env name reference ordinary?)
+ (let loop ((prev #F)
+ (env env))
+ (cond ((not env) (free-var-error name))
+ ((simplify/env/frame-lookup name (simplify/env/bindings env))
+ => (lambda (binding)
+ (if ordinary?
+ (set-simplify/binding/ordinary-refs!
+ binding
+ (cons reference (simplify/binding/ordinary-refs binding)))
+ (begin
+ (set-simplify/binding/operator-refs!
+ binding
+ (cons reference (simplify/binding/operator-refs binding)))
+ (if prev
+ (set-simplify/env/free-calls!
+ prev
+ (cons name (simplify/env/free-calls prev))))))
+ reference))
+ (else (loop env (simplify/env/parent env))))))
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+;;;; CLOSURE ANALYZERS
+
+;;; A closure analyzer is just a phase that requires a dataflow graph to perform
+;;; its function. Maybe we should rename it some day.
+
+(define (make-dataflow-analyzer transformer)
+ (lambda (KMP-Program)
+ (let* ((new-text (copier/top-level KMP-Program dataflow/remember))
+ (graph (dataflow/top-level new-text)))
+ (transformer new-text graph (graph/closures graph)))))
+\f
+;;;; SPLIT-AND-DRIFT
+
+;;; Goal: the output code has (CALL (LOOKUP ...) ...) only when the
+;;; target is a known lambda expression. Otherwise it will be
+;;; (CALL ',%INTERNAL-APPLY <continuation> <operator> <operand>...)
+
+;;; This phase splits closures that have at least one "known call site" (i.e. a
+;;; call site where the closure is the only possible destination), moving the
+;;; body to a top-level LETREC and replacing all of the known calls with direct
+;;; references to the moved code, avoiding the indirect jump via the closure
+;;; object.
+
+;;; There is a screw case that requires us to deal with %make-trivial-closure
+;;; with a LOOKUP rather than a LAMBDA expression as the code body. These
+;;; closures form a simple special case, since the body doesn't need to be
+;;; moved, but the calls must still be rewritten.
+
+;;; If we start with:
+;;; (LETREC ((foo (lambda (x) (foo 3))))
+;;; (list foo foo))
+;;; We'd like to generate something like:
+;;; (LETREC ((foo (make-trivial-closure ...))) (list foo foo))
+;;; but that isn't legal in KMP-Scheme because the right hand side of
+;;; a LETREC binding must be a LAMBDA expression.
+
+;;; After conversion, the code above becomes:
+;;; (LETREC ((foo (lambda (cont-43 x)
+;;; (CALL (LOOKUP foo) (LOOKUP cont-43) '3))))
+;;; (CALL ',%list cont-85
+;;; (CALL ',%make-trivial-closure '#F (LOOKUP foo))
+;;; (CALL ',%make-trivial-closure '#F (LOOKUP foo)))
+
+;;; Note: the assumption here is that code generation guarantees that
+;;; both calls to %make-trivial-closure generate the same (EQ?)
+;;; object.
+
+;;; We can't replace the LOOKUPs inside of %make-trivial-closure with
+;;; LAMBDAs because the resulting procedures wouldn't be EQ? as
+;;; required by the original source code.
+
+(define split-and-drift
+ (make-dataflow-analyzer
+ (lambda (code graph closures)
+ graph ; Not needed
+ (let* ((output-code `(LET () ,code))
+ ;; LET inserted so we can create a LETREC frame inside, if
+ ;; needed, in find-lambda-drift-frame
+ (lambda-drift-point (find-lambda-drift-frame output-code)))
+ (let ((movable-closures
+ ;; Movable iff there is a call that is always and only to an
+ ;; instance of this closure.
+ (list-transform-positive closures
+ (lambda (closure)
+ (and (not (value/closure/escapes? closure))
+ (there-exists? (value/closure/call-sites closure)
+ (lambda (call-site)
+ (operator-is-unique? call-site))))))))
+ (for-every movable-closures
+ (lambda (closure)
+ (split-closure-and-drift closure lambda-drift-point)))
+ output-code)))))
+\f
+;;; Split and drift operations
+
+(define drift-lambda!
+ ;; Extends the LETREC-expr with a binding for new-name to lambda-expr
+ (let* ((bindings (->pattern-variable 'BINDINGS))
+ (body (->pattern-variable 'BODY))
+ (pattern `(LETREC ,bindings ,body)))
+ (lambda (LETREC-expr new-name lambda-expr)
+ (cond ((form/match pattern LETREC-expr)
+ => (lambda (match-result)
+ (let ((bindings (cadr (assq bindings match-result)))
+ (body (cadr (assq body match-result))))
+ (form/rewrite! LETREC-expr
+ `(LETREC ((,new-name ,lambda-expr) ,@bindings)
+ ,body)))))
+ (else
+ (internal-error "No LETREC in DRIFT-LAMBDA!" LETREC-expr))))))
+
+(define (make-closure->lambda-expression make-closure-expression)
+ ;; (Values lambda-expr format)
+ (cond ((CALL/%make-heap-closure? make-closure-expression)
+ (values
+ (CALL/%make-heap-closure/lambda-expression make-closure-expression)
+ 'HEAP))
+ ((CALL/%make-trivial-closure? make-closure-expression)
+ (values
+ (CALL/%make-trivial-closure/procedure make-closure-expression)
+ 'TRIVIAL))
+ ((CALL/%make-stack-closure? make-closure-expression)
+ (values
+ (CALL/%make-stack-closure/lambda-expression make-closure-expression)
+ 'STACK))
+ (else (internal-error
+ "Unexpected expression in make-closure->lambda-expression"
+ make-closure-expression))))
+\f
+;;; Split and drift operations, continued
+
+(define (split-closure-and-drift closure lambda-drift-point)
+ (let ((mutable-call-sites ; Call only this closure
+ (list-transform-positive (value/closure/call-sites closure)
+ (lambda (call-site)
+ (operator-is-unique? call-site)))))
+ (call-with-values
+ (lambda ()
+ (make-closure->lambda-expression (value/text closure)))
+ (lambda (lambda-expr format)
+ ;; LAMBDA-EXPR is the body of the closure: either a LAMBDA or
+ ;; LOOKUP expression;
+ ;; FORMAT is 'TRIVIAL, 'STACK, or 'HEAP
+ (cond ((eq? format 'STACK) 'not-yet-implemented)
+ ((LOOKUP/? lambda-expr) ; See screw case above
+ (for-every mutable-call-sites
+ (lambda (site)
+ (let ((form (application/text site)))
+ ;; FORM is (CALL ',%internal-apply <continuation>
+ ;; <nargs> <operator> <operand>...)
+ (form/rewrite! form
+ `(BEGIN
+ ,(fifth form) ; In case of side-effects!
+ (CALL ,lambda-expr ,(third form)
+ ,@(list-tail form 5))))))))
+
+ ((LAMBDA/? lambda-expr)
+ ;; Clean up the lambda bindings to remove optionals and lexprs in
+ ;; the lifted version.
+ (let* ((lambda-list (cadr lambda-expr))
+ (names (lambda-list->names lambda-list))
+ (lifted-lambda
+ `(LAMBDA ,names ,(third lambda-expr)))
+ (new-name (closan/new-name 'CLOSURE-GUTS)))
+ (drift-lambda! ; Drift to top-level LETREC
+ lambda-drift-point new-name lifted-lambda)
+ (form/rewrite! lambda-expr
+ ;; Rewrite body of closing code to call new top-level LAMBDA
+ (if *after-cps-conversion?*
+ `(LAMBDA ,lambda-list
+ (CALL (LOOKUP ,new-name)
+ ,@(map (lambda (name) `(LOOKUP ,name)) names)))
+ `(LAMBDA ,lambda-list
+ (CALL (LOOKUP ,new-name) (QUOTE #F) ; Continuation
+ ,@(map (lambda (name) `(LOOKUP ,name))
+ (cdr names))))))
+ (for-every mutable-call-sites
+ (lambda (site)
+ ;; Rewrite calls that are known to be to heap or trivial
+ ;; closures, bypassing the closure and going
+ ;; direct to the top-level LAMBDA
+ (let ((form (application/text site)))
+ ;; FORM is
+ ;; (CALL ',%internal-apply <continuation>
+ ;; <nargs> <operator> <operand>...)
+ (form/rewrite! form
+ (case format
+ ((TRIVIAL)
+ `(BEGIN
+ ,(fifth form) ; In case of side-effects!
+ (CALL (LOOKUP ,new-name)
+ ,(third form)
+ ,@(lambda-list/applicate
+ (cdr lambda-list)
+ (list-tail form 5)))))
+ ((HEAP)
+ `(CALL (LOOKUP ,new-name)
+ ,(third form)
+ ,@(lambda-list/applicate
+ (cdr lambda-list)
+ (list-tail form 4))))
+ (else (internal-error "Unknown format"
+ format)))))))))
+ (else (internal-error "Unknown handler" lambda-expr)))))))
+\f
+;;; Support operations for split-and-drift
+
+(define (find-lambda-drift-frame code)
+ (define (loop previous code)
+ (define (insert-LETREC!)
+ (let ((old-body (let/body previous)))
+ (if (LETREC/? old-body)
+ old-body
+ (let ((result `(LETREC () ,old-body)))
+ (form/rewrite! previous `(LET ,(let/bindings previous) ,result))
+ result))))
+ ;; Unwrap all static (and pseudo-static) bindings, and force the
+ ;; next level to be a LETREC. Return a pointer to the LETREC.
+ (cond ((LET/? code)
+ (let ((bindings (let/bindings code))
+ (body (LET/body code)))
+ (if (for-all? bindings
+ (lambda (binding)
+ (let ((value (cadr binding)))
+ (form/static? value))))
+ (loop code body)
+ (insert-LETREC!))))
+ (else (insert-LETREC!))))
+
+ (if (not (and (LET/? code) (null? (let/bindings code))))
+ (internal-error "Incorrect outer form for FIND-LAMBDA-DRIFT-FRAME"
+ code))
+ (loop code (let/body code)))
+
+;;; General utility routines
+
+(define (closan/new-name prefix)
+ (new-variable prefix))
+
+(define (for-every things proc)
+ (for-each proc things))
+
+(define (operator-is-unique? call-site)
+ ;; Call-site is an application structure, or a symbol denoting an
+ ;; external known call site.
+ (if (symbol? call-site)
+ #F
+ (node/unique-value (application/operator-node call-site))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: stackopt.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Stack optimization (reordering)
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+#| Big Note A
+
+This optimizer works by building a model of the current stack frame,
+with parent and child links mapping from the state of the stack frame
+at one point in time to the state earlier/later. It then attempts to
+make the frames similar by assigning the slots in the frame to contain
+the same object where possible, thus reducing shuffling. The bulk of
+the reordering calculation is contained in the procedures
+STACKOPT/REARRANGE! and STACKOPT/REARRANGE/PROCESS!.
+
+The algorithm is complicated by two issues: some elements of a stack
+frame have fixed locations that cannot be changed at a given point in
+the computation: values pushed for calls to primitives, and values
+pushed for passing the last arguments to unknown procedures with a
+large number of arguments. The former case is detectable because the
+call to MAKE-STACK-CLOSURE (which announces the new format of the
+stack frame) will not contain a LAMBDA expression in the
+CALL/%MAKE-STACK-CLOSURE/LAMBDA-EXPRESSION slot.
+
+The latter case is detected by looking at the vector of names
+available to the continuation (from the
+CALL/%FETCH-STACK-CLOSURE/VECTOR slot that must exist within the
+lambda-expresion) and comparing it with the names
+available at the call side in the CALL/%MAKE-STACK-CLOSURE/VECTOR
+slot. These will have a common prefix consisting of the values to be
+saved, followed in one case by the parameters being passed on the
+stack and in the other the values being passed to the continuation on
+the stack. Only the common prefix is subject to reordering, the other
+parts being fixed by the parameter passing convention.
+
+There is one unusual property of the stack model currently produced.
+Consider the case of a many-argument call to a procedure where the
+continuation receives many values. We produce a separate model for
+the stack frame on the call side (showing the values saved on the
+stack for use in the continuation plus the values being passed as
+parameters to the called procedure on the stack) and the stack frame
+on the continuation side (showing the values saved on the stack plus
+the values being supplied by the procedure to the continuation). We
+require the following property of any implementation of the reordering
+algorithm: the stack slot assignments provided for the saved values in
+these two frames must be identical -- the compiler is free to reorder
+them in any way, but the reordering must be the same on both sides of
+the call. This is in addition to the requirement that the slot
+assignments for the parameters and values are fixed by the calling
+sequence.
+
+ THEOREM AND PROOF
+
+THEOREM: The stack slot assignments provided for the saved values in
+these two frames will be identical.
+
+We prove the following stronger property of the *CURRENT* algorithm,
+from which the theorem follows directly.
+
+THEOREM: For any frame with a single child in which the names of the
+unwired variables and the numbers of the unwired slots are the same in
+the parent and child, the slot assignments for these variables will be
+the same in the parent and the child.
+
+PROOF: Inductively on the number of unwired names/slots in the parent
+frame. If there are no unwired names/slots then the theorem follows
+trivially. We prove that wiring a name to a slot in either the parent
+or child frame preserves the invariant.
+
+Whenever an assignment transforms an unwired name to a wired
+name, the assignment is propagated to the parent and all children of
+the model in which the assignment occurs (see PROPAGATE in
+STACKOPT/REARRANGE/PROCESS!). For convenience, let us call the models
+PARENT and CHILD. We consider two cases:
+ a: An assignment is generated in PARENT. It will be propagated to
+ CHILD. By our induction hypothesis, the child will have both the
+ name and the slot unwired, and will proceed to wire them
+ together.
+ b: An assignment is generated in CHILD. Conversely, it will be
+ propagated to PARENT, where the induction hypothesis also implies
+ that the name and slot are free, hence will be wired.
+
+End of Big Note A |#
+\f
+(define (stackopt/top-level program)
+ (stackopt/expr false program))
+
+(define-macro (define-stack-optimizer keyword bindings . body)
+ (let ((proc-name (symbol-append 'STACKOPT/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler state) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name state form)
+ (stackopt/remember ,code
+ form))))))))
+
+(define-stack-optimizer LOOKUP (state name)
+ state ; ignored
+ `(LOOKUP ,name))
+
+(define-stack-optimizer LAMBDA (state lambda-list body)
+ state ; ignored
+ `(LAMBDA ,lambda-list
+ ,(stackopt/expr false body)))
+
+(define-stack-optimizer LET (state bindings body)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (stackopt/expr false (cadr binding))))
+ bindings)
+ ,(stackopt/expr state body)))
+
+(define-stack-optimizer LETREC (state bindings body)
+ `(LETREC ,(lmap (lambda (binding)
+ (list (car binding)
+ (stackopt/expr false (cadr binding))))
+ bindings)
+ ,(stackopt/expr state body)))
+
+(define-stack-optimizer QUOTE (state object)
+ state ; ignored
+ (if (eq? object %make-stack-closure)
+ (internal-error "Explicit make-stack-closure")
+ `(QUOTE ,object)))
+
+(define-stack-optimizer DECLARE (state #!rest anything)
+ state ; ignored
+ `(DECLARE ,@anything))
+
+(define-stack-optimizer IF (state pred conseq alt)
+ `(IF ,(stackopt/expr false pred)
+ ,(stackopt/expr state conseq)
+ ,(stackopt/expr state alt)))
+
+(define-stack-optimizer BEGIN (state #!rest actions)
+ (if (null? actions)
+ `(BEGIN)
+ (let ((actions* (reverse actions)))
+ `(BEGIN ,@(stackopt/expr* false (reverse (cdr actions*)))
+ ,(stackopt/expr state (car actions*))))))
+\f
+(define-stack-optimizer CALL (state rator cont #!rest rands)
+ (with-letfied-nested-stack-closures rator cont rands
+ (lambda (rator cont rands)
+ (define (wrap cont*)
+ `(CALL ,(stackopt/expr false rator)
+ ,cont*
+ ,@(stackopt/expr* false rands)))
+ (cond ((form/match stackopt/cont-pattern cont)
+ => (lambda (result)
+ (wrap (stackopt/call/can-see-both-frames
+ state
+ (call/%make-stack-closure/lambda-expression cont)
+ result))))
+ ((call/%make-stack-closure? cont)
+ (wrap (stackopt/call/terminal state cont)))
+ (else
+ (wrap (stackopt/expr false cont)))))))
+
+(define (with-letfied-nested-stack-closures rator cont rands
+ receiver-of-rator+cont+rands)
+ ;; The loop does the `letifying' transformation until there are no
+ ;; calls to %make-stack-closure in the top-level position.
+ ;; (CALL <procedure>
+ ;; (CALL 'make-stack-closure
+ ;; #F
+ ;; <lambda>
+ ;; #<frame>
+ ;; (CALL 'make-stack-closure #F ...)
+ ;; ...)
+ ;; ...)
+ ;; Is transformed to
+ ;; (CALL (LAMBDA (cont)
+ ;; (CALL <procedure>
+ ;; (CALL 'make-stack-closure
+ ;; #F
+ ;; <lambda>
+ ;; #<frame>
+ ;; (lookup cont)
+ ;; ...)
+ ;; ...))
+ ;; (CALL 'make-stack-closure #F ...))
+ (let loop ((rator rator) (cont cont) (rands rands))
+ (if (and (call/%make-stack-closure? cont)
+ (pair? (call/%make-stack-closure/values cont))
+ (call/%make-stack-closure?
+ (first (call/%make-stack-closure/values cont))))
+ (let ((cont-var (new-continuation-variable)))
+ (loop
+ `(LAMBDA (,cont-var)
+ (CALL ,rator
+ (CALL ',%make-stack-closure
+ '#F
+ ,(call/%make-stack-closure/lambda-expression cont)
+ ,(call/%make-stack-closure/vector cont)
+ (LOOKUP ,cont-var)
+ ,@(cdr (call/%make-stack-closure/values cont)))
+ ,@rands))
+ (first (call/%make-stack-closure/values cont))
+ '() ))
+ (receiver-of-rator+cont+rands rator cont rands))))
+
+
+(define (stackopt/expr state expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (stackopt/quote state expr))
+ ((LOOKUP)
+ (stackopt/lookup state expr))
+ ((LAMBDA)
+ (stackopt/lambda state expr))
+ ((LET)
+ (stackopt/let state expr))
+ ((DECLARE)
+ (stackopt/declare state expr))
+ ((CALL)
+ (stackopt/call state expr))
+ ((BEGIN)
+ (stackopt/begin state expr))
+ ((IF)
+ (stackopt/if state expr))
+ ((LETREC)
+ (stackopt/letrec state expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (stackopt/expr* state exprs)
+ (lmap (lambda (expr)
+ (stackopt/expr state expr))
+ exprs))
+
+(define (stackopt/remember new old)
+ (code-rewrite/remember new old))
+\f
+(define stackopt/?lambda-list (->pattern-variable 'LAMBDA-LIST))
+(define stackopt/?frame-name (->pattern-variable 'FRAME-VECTOR-NAME))
+(define stackopt/?frame-vector (->pattern-variable 'FRAME-VECTOR))
+(define stackopt/?call-side-frame-vector (->pattern-variable 'CALL-FRAME))
+(define stackopt/?continuation-side-frame-vector (->pattern-variable 'CONT-FRAME))
+(define stackopt/?body (->pattern-variable 'BODY))
+(define stackopt/?closure-elts (->pattern-variable 'CLOSURE-ELTS))
+(define stackopt/?non-lambda-expression (->pattern-variable 'NON-LAMBDA))
+
+(define stackopt/cont-pattern
+ `(CALL (QUOTE ,%make-stack-closure)
+ (QUOTE #F)
+ (LAMBDA ,stackopt/?lambda-list
+ (LET ((,stackopt/?frame-name
+ (CALL (QUOTE ,%fetch-stack-closure)
+ (QUOTE #F)
+ (QUOTE ,stackopt/?continuation-side-frame-vector))))
+ ,stackopt/?body))
+ (QUOTE ,stackopt/?call-side-frame-vector)
+ ,@stackopt/?closure-elts))
+
+
+(define (stackopt/call/can-see-both-frames state handler match-result)
+
+ (define (first-mismatch v1 v2)
+ (let ((length (min (vector-length v1) (vector-length v2))))
+ (let loop ((i 0))
+ (cond ((= i length) length)
+ ((eq? (vector-ref v1 i) (vector-ref v2 i))
+ (loop (+ i 1)))
+ (else i)))))
+
+ (define (wire-from! model frame from)
+ (let ((end (vector-length frame)))
+ (do ((i from (+ i 1)))
+ ((= i end) 'OK)
+ (let ((var (vector-ref frame i)))
+ (if (not (continuation-variable? var))
+ (stackopt/wire! model `((,var . ,i))))))))
+
+ ;; Handler for "standard" %make-stack-closure (those with a LAMBDA
+ ;; expression)
+ (let ((lambda-list (cadr (assq stackopt/?lambda-list match-result)))
+ (frame-name (cadr (assq stackopt/?frame-name match-result)))
+ (call-frame-vector
+ (cadr (assq stackopt/?call-side-frame-vector match-result)))
+ (cont-frame-vector
+ (cadr (assq stackopt/?continuation-side-frame-vector
+ match-result)))
+ (body (cadr (assq stackopt/?body match-result)))
+ (real-rands (cadr (assq stackopt/?closure-elts match-result))))
+ (let* ((call-model (stackopt/model/make state call-frame-vector #F))
+ (cont-model
+ (if (eq? call-frame-vector cont-frame-vector)
+ call-model
+ (stackopt/model/make call-model cont-frame-vector #F)))
+ ;; See Big Note A at the top of this file.
+ (handler*
+ `(LAMBDA ,lambda-list
+ (LET ((,frame-name (CALL (QUOTE ,%fetch-stack-closure)
+ (QUOTE #F)
+ (QUOTE ,cont-frame-vector))))
+ ,(stackopt/expr cont-model body))))
+ (form*
+ `(CALL (QUOTE ,%make-stack-closure)
+ (QUOTE #F)
+ ,(stackopt/remember handler* handler)
+ (QUOTE ,call-frame-vector)
+ ,@(stackopt/expr* false real-rands))))
+ (if (not (eq? call-model cont-model))
+ (let ((mismatch (first-mismatch call-frame-vector
+ cont-frame-vector)))
+ (wire-from! call-model call-frame-vector mismatch)
+ (wire-from! cont-model cont-frame-vector mismatch)
+ (set-stackopt/model/form! cont-model #F)))
+ (stackopt/%call state call-model form*))))
+
+(define (stackopt/call/terminal state cont)
+ ;; Handler for CONT being the "push" %make-stack-closure (i.e. with
+ ;; anything other than a LAMBDA expression)
+ (let ((frame-vector (quote/text (call/%make-stack-closure/vector cont)))
+ (real-rands (call/%make-stack-closure/values cont))
+ (non-lambda (call/%make-stack-closure/lambda-expression cont)))
+ (let* ((model (stackopt/model/make state frame-vector #T))
+ (form* `(CALL (QUOTE ,%make-stack-closure)
+ (QUOTE #F)
+ ,(stackopt/expr false non-lambda)
+ (QUOTE ,frame-vector)
+ ,@(stackopt/expr* false real-rands))))
+ (stackopt/%call state model form*))))
+\f
+(define (stackopt/%call state model form*)
+ (set-stackopt/model/form! model form*)
+ (if (not state)
+ (stackopt/reorder! model))
+ form*)
+
+;; For now, this is a very simple rearranger.
+;; The problem is really complicated (probably NP-complete),
+;; and it's not clear how to even do a good heuristic.
+;; The problem is simplified if we allow stack frames to have holes,
+;; as C compilers do, since then each preserved variable can have a
+;; home in the stack. The problem is garbage collection:
+;; no-longer-used slots need to be cleared, and this is as costly as
+;; reshuffling.
+
+(define (stackopt/reorder! model)
+ (define (stackopt/model-intersection model)
+ ;; Find the set of variables present in the model and all of its children
+ (define (walk set models)
+ (cond ((null? models) set)
+ ((null? set) set)
+ (else (walk
+ (intersection set
+ (vector->list
+ (stackopt/model/frame
+ (car models))))
+ (append (stackopt/model/children (car models))
+ (cdr models))))))
+ (walk (vector->list (stackopt/model/frame model))
+ (stackopt/model/children model)))
+
+ (stackopt/rearrange! model
+ (stackopt/constrain model
+ (stackopt/model-intersection model)
+ (let min-all ((model model))
+ ;; Calculate the smallest frame size that appears anywhere in
+ ;; the tree of frame extensions
+ (fold-right (lambda (model current-min)
+ (min (min-all model) current-min))
+ (vector-length (stackopt/model/frame model))
+ (stackopt/model/children model)))))
+ (stackopt/rewrite! model))
+
+(define (stackopt/rewrite! model)
+ ;; Rewrite the form for this model and those for all of its children
+ ;; by calculating the new order of names in the frame and reordering
+ ;; the value expressions to match the new order.
+ (for-each stackopt/rewrite! (stackopt/model/children model))
+ (let* ((frame* (stackopt/model/frame model))
+ (frame (vector-copy frame*))
+ (form (stackopt/model/form model)))
+ (stackopt/update-frame! model)
+ (if (and form (not (equal? frame* frame)))
+ (let* ((names&values
+ (map cons
+ (vector->list frame)
+ (call/%make-stack-closure/values form)))
+ (values*
+ (map (lambda (name*)
+ (let ((place (assq name* names&values)))
+ (if (not place)
+ (stackopt/inconsistency model))
+ (cdr place)))
+ (vector->list frame*))))
+ (form/rewrite! form
+ `(CALL ,(call/operator form)
+ ,(call/continuation form)
+ ,(call/%make-stack-closure/lambda-expression form)
+ ,(call/%make-stack-closure/vector form)
+ ,@values*))))))
+\f
+(define (stackopt/rearrange! model wired)
+ (define (arrange-locally! model)
+ ;; Generate the wiring for a model by performing a union of WIRED
+ ;; with the wired elements of the model's frame (WIRED wins if a
+ ;; name is wired in two different places?!)
+ (let* ((wired*
+ (let ((wired* (stackopt/model/wired model)))
+ (if (not wired*)
+ wired
+ (append wired
+ (list-transform-negative wired*
+ (lambda (wired-pair)
+ (assq (car wired-pair) wired)))))))
+ (unwired
+ (list-transform-negative
+ (vector->list (stackopt/model/frame model))
+ (lambda (var)
+ (assq var wired*)))))
+ (set-stackopt/model/wired! model wired*)
+ (set-stackopt/model/unwired! model unwired)
+ (set-stackopt/model/n-unwired! model (length unwired))))
+
+ (define (max-all model)
+ ;; Maximum number of unwired slots in this frame or any
+ ;; [grand*]child frame
+ (fold-right (lambda (model current-max)
+ (max (max-all model) current-max))
+ (stackopt/model/n-unwired model)
+ (stackopt/model/children model)))
+
+ ;; Walk the model's frame and all of its (recursive) children. This
+ ;; will add the WIRED set to all of the wired names of this frame
+ ;; and its children.
+ (let walk ((model model))
+ (arrange-locally! model)
+ (for-each walk (stackopt/model/children model)))
+
+ ;; If this model has children and they aren't all wired down by this
+ ;; time, gyrate around filling in the unfilled slots.
+ (if (not (null? (stackopt/model/children model)))
+ (let ((max-unwired (max-all model)))
+ (if (not (zero? max-unwired))
+ (let ((buckets (make-vector max-unwired '())))
+ (let insert! ((model model))
+ (for-each insert! (stackopt/model/children model))
+ (let ((n-unwired (stackopt/model/n-unwired model)))
+ (if (not (zero? n-unwired))
+ (let ((index (- n-unwired 1)))
+ (vector-set! buckets index
+ (cons model
+ (vector-ref buckets index)))))))
+ (stackopt/rearrange/process! buckets))))))
+\f
+(define (stackopt/rearrange/process! buckets)
+ ;; BUCKETS is a vector long enough to hold an entry for each unwired
+ ;; slot in the largest frame here or in one of the children. It
+ ;; maps from number of open slots to models with that number of open
+ ;; slots (off by one). That is, entry 0 has a list of all models
+ ;; with one unwired slot,etc.
+ (define (propagate model unwired index)
+ ;; Do the assignment in the model itself, and then propagate it as
+ ;; far up and down the tree as possible.
+ (define (wire!? model unwired index)
+ ;; Wire the name UNWIRED to offset INDEX in the MODEL if that slot
+ ;; is available, and return a boolean indicating whether it was
+ ;; done.
+ (and (memq unwired (stackopt/model/unwired model))
+ (stackopt/free-index? model index)
+ (let ((bucket (- (stackopt/model/n-unwired model) 1)))
+ (stackopt/wire! model (list (cons unwired index)))
+ (vector-set! buckets bucket
+ (delq model (vector-ref buckets bucket)))
+ ;; Move this model to a bucket indicating the next
+ ;; available location to be filled.
+ (if (not (zero? bucket))
+ (let ((bucket* (- bucket 1)))
+ (vector-set! buckets bucket*
+ (cons model (vector-ref buckets bucket*)))))
+ true)))
+
+ (define (try-up model unwired index)
+ ;; Try to wire UNWIRED to offset INDEX in this MODEL and all of
+ ;; its parents. Stops when it can't be wired or the top of the
+ ;; frame tree is encountered.
+ (let loop ((model model))
+ (and model
+ (wire!? model unwired index)
+ (loop (stackopt/model/parent model)))))
+
+ (define (try-down model unwired index)
+ ;; Try to wire UNWIRED to offset INDEX in this MODEL and all of
+ ;; its descendents. Stops when it can't be wired any lower in
+ ;; this branch of the frame tree.
+ (let walk ((model model))
+ (and (wire!? model unwired index)
+ (for-each walk (stackopt/model/children model)))))
+
+ (if (not (wire!? model unwired index))
+ (internal-error "STACKOPT/REARRANGE/PROCESS!: Can't wire"
+ model unwired index))
+ (try-up (stackopt/model/parent model) unwired index)
+ (for-each (lambda (model*)
+ (try-down model* unwired index))
+ (stackopt/model/children model)))
+
+ (define (find-wired model models*)
+ ;; Return the first model in MODELS* which has already decided on
+ ;; a binding for one of the unwired variables in MODEL and for
+ ;; which that same binding slot is available in MODEL; otherwise
+ ;; #F.
+ (and (not (null? models*))
+ (let ((model* (car models*)))
+ (or (list-search-positive (stackopt/model/wired model*)
+ (lambda (wired*)
+ (and (memq (car wired*) (stackopt/model/unwired model))
+ (stackopt/free-index? model (cdr wired*)))))
+ (find-wired model (cdr models*))))))
+
+ (define (pick-to-wire model)
+ ;; Assigns an unwired variable to a free index at random.
+ (cons (pick-random (stackopt/model/unwired model))
+ (pick-random (stackopt/free-indices model))))
+
+ (define (phase-2)
+ ;; For all of the frames that have more than one free slot, grab
+ ;; the most highly constrained frame (fewest free slots), assign
+ ;; an unwired variable, propagate, and repeat from phase-1 until
+ ;; there are no models remaining.
+ (let ((bucketlen (vector-length buckets)))
+ (let loop ((i 1))
+ (and (< i bucketlen)
+ (if (null? (vector-ref buckets i))
+ (loop (1+ i))
+ (let* ((model (car (vector-ref buckets i)))
+ (children (stackopt/model/children model))
+ (to-wire
+ (or (find-wired
+ model
+ (if (stackopt/model/parent model)
+ (cons (stackopt/model/parent model)
+ children)
+ children))
+ (pick-to-wire model))))
+ (propagate model (car to-wire) (cdr to-wire))
+ (phase-1)))))))
+\f
+ (define (phase-1)
+ ;; For all of the models that have only one free slot available,
+ ;; wire their first unwired variable to that slot and propagate
+ ;; that choice up and down the tree. This may promote other
+ ;; models to having only one free slot, so the iteration doesn't
+ ;; terminate in the obvious manner. When all remaining models
+ ;; have more than one free slot, go on to phase-2.
+ (let ((bucket0 (vector-ref buckets 0)))
+ (if (null? bucket0)
+ (phase-2)
+ (let* ((model (car bucket0))
+ (unwired (car (stackopt/model/unwired model)))
+ (index (car (stackopt/free-indices model))))
+ (vector-set! buckets 0 (delq model bucket0))
+ (propagate model unwired index)
+ (phase-1)))))
+
+ (phase-1))
+
+(define (stackopt/update-frame! model)
+ ;; Calculate offsets for all elements in this model's frame by first
+ ;; using the wired offsets and then filling in order from the
+ ;; unwired list.
+ (let* ((frame (stackopt/model/frame model))
+ (len (vector-length frame))
+ (frame* (make-vector len false)))
+ (for-each (lambda (wired)
+ (let ((name (car wired))
+ (index (cdr wired)))
+ (if (vector-ref frame* index)
+ (stackopt/inconsistency model)
+ (vector-set! frame* index name))))
+ (stackopt/model/wired model))
+ (let loop ((i (- len 1))
+ (unwired (stackopt/model/unwired model)))
+ (cond ((negative? i)
+ (if (not (null? unwired))
+ (stackopt/inconsistency model)))
+ ((vector-ref frame* i) ; This slot wired
+ (loop (- i 1) unwired))
+ ((null? unwired)
+ (stackopt/inconsistency model))
+ (else
+ (vector-set! frame* i (car unwired))
+ (loop (- i 1) (cdr unwired)))))
+ (stackopt/clobber! frame frame*)))
+
+(define (stackopt/free-index? model index)
+ ;; #T iff the index-th entry in the frame is not in use for a wired
+ ;; value.
+ (let ((len (vector-length (stackopt/model/frame model))))
+ (and (< index len)
+ (not (rassq index (stackopt/model/wired model))))))
+\f
+(define (stackopt/free-indices model)
+ ;; Return a list of all offsets in the frame that aren't currently
+ ;; in use for a wired value.
+ (let* ((len (vector-length (stackopt/model/frame model)))
+ (frame* (make-vector len true)))
+ (for-each (lambda (wired)
+ (vector-set! frame* (cdr wired) false))
+ (stackopt/model/wired model))
+ (let loop ((index 0)
+ (free '()))
+ (cond ((= index len)
+ free)
+ ((vector-ref frame* index)
+ (loop (+ index 1)
+ (cons index free)))
+ (else
+ (loop (+ index 1) free))))))
+
+(define (stackopt/wire! model pairs)
+ ;; Each element of PAIRS is (<var> . <offset>)
+ (let ((wired* (append pairs (stackopt/model/wired model)))
+ (unwired* (delq* (lmap car pairs)
+ (stackopt/model/unwired model))))
+ (set-stackopt/model/wired! model wired*)
+ (set-stackopt/model/unwired! model unwired*)
+ (set-stackopt/model/n-unwired! model (length unwired*))))
+
+(define (stackopt/inconsistency model)
+ (internal-error "Inconsistent wiring" model))
+
+(define (stackopt/clobber! v1 v2)
+ ;; Copy the values from v2 into v1 (sort of like "v1 := v2")
+ (do ((i (- (vector-length v1) 1) (- i 1)))
+ ((< i 0) 'done)
+ (vector-set! v1 i (vector-ref v2 i))))
+
+(define (stackopt/new-name prefix)
+ (new-variable prefix))
+
+(define-structure (stackopt/model
+ (conc-name stackopt/model/)
+ (constructor stackopt/model/%make (parent frame)))
+ (parent false read-only true)
+ (frame false read-only true) ; Vector of variable names
+ (wired '() read-only false) ; List mapping names to offsets
+ (unwired '() read-only false) ; List of names, currently
+ ; without offsets
+ (form false read-only false)
+ (children '() read-only false)
+ (n-unwired false read-only false)
+ (extended? false read-only false))
+
+(define (stackopt/model/make parent frame wire-all?)
+ (let ((new (stackopt/model/%make parent frame)))
+ (if parent
+ (set-stackopt/model/children! parent
+ (cons new
+ (stackopt/model/children parent))))
+ (call-with-values
+ (lambda ()
+ (list-split (vector->list frame) continuation-variable?))
+ (lambda (cont-vars others)
+ (cond ((null? cont-vars) 'OK)
+ ((null? (cdr cont-vars))
+ (set-stackopt/model/wired! new `((,(car cont-vars) . 0))))
+ (else (internal-error
+ "STACKOPT/MODEL/MAKE: multiple continuation variables"
+ frame)))
+ (if wire-all?
+ (let* ((zero-counts (iota (length others)))
+ (counts (if (null? cont-vars)
+ zero-counts
+ (map 1+ zero-counts))))
+ (set-stackopt/model/wired! new
+ (append (stackopt/model/wired new)
+ (map cons others counts)))))))
+ new))
+\f
+;; This is more general than it needs to be, because it accomodates
+;; partially wired frames.
+
+(define (stackopt/constrain model common sup-index)
+ ;; MODEL is a model to be processed
+ ;; COMMON is the list of variables that appears in the model's frame
+ ;; and all of its descendent frames
+ ;; SUP-INDEX is the size of the smallest frame appearing in
+ ;; the tree of frames rooted in this model's frame.
+ ;;
+ ;; Returns a mapping from names in the COMMON set to fixed stack
+ ;; offsets. This might not provide locations for all values,
+ ;; because it treats a wiring in any frame as though it applied to
+ ;; all frames. Later we will generate final assignments that allow
+ ;; assignments in one frame configuration to be wired but will use
+ ;; the same slot for another purpose in a different configuration.
+
+ (define (walk model pairs)
+ ;; Each element of PAIRS is (<name> <possible offsets for this name>)
+ ;; Returns a similar list of pairs, but the possible offsets have
+ ;; been corrected to account for wired down names. The entry for
+ ;; a name may become '() if there's no place to put it (i.e. you
+ ;; lose track of the name if it can't go anywhere).
+ (if (null? pairs)
+ pairs
+ (fold-right
+ walk
+ (let ((wired (stackopt/model/wired model)))
+ (if (not wired)
+ pairs
+ (let ((nogood (lmap cdr wired)))
+ (append-map
+ (lambda (pair)
+ (let* ((name (car pair))
+ (place (assq name wired)))
+ (cond ((not place)
+ (let ((possible (difference (cadr pair) nogood)))
+ (if (null? possible)
+ '() ; Nowhere to go
+ (list (list name possible)))))
+ ; Anywhere but the wired locations
+ ((memq (cdr place) (cadr pair))
+ (list (list name (list (cdr place)))))
+ ; Wired location is free, so
+ ; that's it
+ (else '())))) ; Wired but slot's not free
+ pairs))))
+ (stackopt/model/children model))))
+
+ (call-with-values
+ (lambda ()
+ (list-split (walk model
+ (lmap (lambda (common)
+ (list common (iota sup-index)))
+ common))
+ (lambda (pair)
+ (continuation-variable? (car pair)))))
+ (lambda (cont-variables rest)
+ ;; At least the continuation variable must be shared if there are
+ ;; any children frames, and the continuation must be in slot 0.
+ (cond ((null? cont-variables)
+ ;; This is no longer true. A better test would be that the
+ ;; continuation variables must be shared across non-leaf models
+ ;; (if (not (null? (stackopt/model/children model)))
+ ;; (internal-error "No continuation variables shared"
+ ;; model common))
+ (stackopt/constrain* rest))
+ ((not (null? (cdr cont-variables)))
+ (internal-error "Too many continuation variables"
+ model common))
+ ((not (memq 0 (cadr (car cont-variables))))
+ (internal-error "Unexpected offset for shared continuation"
+ model (car cont-variables)))
+ (else
+ (stackopt/constrain* (cons (list (car (car cont-variables)) '(0))
+ rest)))))))
+\f
+(define (stackopt/constrain* pairs)
+ ;; PAIRS maps names to possible stack offset locations
+ ;; Returns a mapping from names to fixed stack offsets. This may
+ ;; not provide locations for all values originally in PAIRS.
+ (call-with-values
+ (lambda ()
+ (list-split pairs
+ (lambda (pair)
+ (null? (cdr (cadr pair))))))
+ (lambda (wired free)
+ ;; WIRED variables now have no other place they can go
+ (let loop ((wired (lmap (lambda (pair)
+ (cons (car pair) (car (cadr pair))))
+ wired))
+ (free free))
+ (if (null? free)
+ wired
+ ;; This is not necessarily a good choice
+ (let* ((next (car free))
+ (index (list-search-negative (cadr next)
+ (lambda (index)
+ (rassq index wired)))))
+ (loop (if (not index)
+ wired
+ (cons (cons (car next) index)
+ wired))
+ (cdr free))))))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: staticfy.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; Static binding annotator
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+(define (staticfy/top-level program)
+ (staticfy/expr (staticfy/env/make 'STATIC false '()) program))
+
+(define-macro (define-staticfier keyword bindings . body)
+ (let ((proc-name (symbol-append 'STATICFY/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdr bindings) '(handler env) '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler (lambda ,(cons (car bindings) names) ,@body)))
+ (named-lambda (,proc-name env form)
+ (staticfy/remember ,code
+ form))))))))
+
+(define-staticfier LOOKUP (env name)
+ (staticfy/lookup* env name `(LOOKUP ,name)))
+
+(define-staticfier LAMBDA (env lambda-list body)
+ `(LAMBDA ,lambda-list
+ ,(staticfy/expr (staticfy/bind 'DYNAMIC
+ env
+ (lambda-list->names lambda-list))
+ body)))
+
+(define-staticfier LETREC (env bindings body)
+ (let ((env* (staticfy/bind (staticfy/env/context env)
+ env
+ (lmap car bindings))))
+ `(LETREC ,(lmap (lambda (binding)
+ (list (car binding)
+ (staticfy/expr env* (cadr binding))))
+ bindings)
+ ,(staticfy/expr env* body))))
+
+(define-staticfier QUOTE (env object)
+ env ; ignored
+ `(QUOTE ,object))
+
+(define-staticfier DECLARE (env #!rest anything)
+ env ; ignored
+ `(DECLARE ,@anything))
+
+(define-staticfier BEGIN (env #!rest actions)
+ `(BEGIN ,@(staticfy/expr* env actions)))
+
+(define-staticfier IF (env pred conseq alt)
+ `(IF ,(staticfy/expr env pred)
+ ,(staticfy/expr env conseq)
+ ,(staticfy/expr env alt)))
+\f
+(define-staticfier CALL (env cont rator #!rest rands)
+ (if (or (not (pair? rator))
+ (not (eq? (car rator) 'LAMBDA))
+ (eq? (staticfy/env/context env) 'DYNAMIC)
+ (not (equal? cont '(QUOTE #F))))
+ `(CALL ,(staticfy/expr env rator)
+ ,(staticfy/expr env cont)
+ ,@(staticfy/expr* env rands))
+ (staticfy/let* (lambda (bindings* body*)
+ (staticfy/pseudo-letify rator bindings* body*))
+ env
+ (map list (cdr (cadr rator)) rands)
+ (caddr rator))))
+
+(define-staticfier LET (env bindings body)
+ (if (eq? (staticfy/env/context env) 'DYNAMIC)
+ `(LET ,(lmap (lambda (binding)
+ (list (car binding)
+ (staticfy/expr env (cadr binding))))
+ bindings)
+ ,(staticfy/expr (staticfy/bind 'DYNAMIC env (lmap car bindings))
+ body))
+ (staticfy/let* staticfy/letify
+ env
+ bindings
+ body)))
+
+(define (staticfy/letify bindings body)
+ `(LET ,bindings ,body))
+
+(define (staticfy/pseudo-letify rator bindings body)
+ `(CALL ,(staticfy/remember
+ `(LAMBDA (,(car (cadr rator)) ,@(lmap car bindings))
+ ,body)
+ rator)
+ (QUOTE #F)
+ ,@(lmap cadr bindings)))
+\f
+(define (staticfy/let* letify env bindings body)
+ (let* ((bindings* (lmap (lambda (binding)
+ (list (car binding)
+ (staticfy/expr env (cadr binding))))
+ bindings))
+ (env* (staticfy/bind (staticfy/env/context env)
+ env
+ (lmap car bindings)))
+ (body* (staticfy/expr env* body)))
+ (call-with-values
+ (lambda ()
+ (list-split bindings*
+ (lambda (binding*)
+ (staticfy/simple? (cadr binding*)))))
+ (lambda (simple hairy)
+ (if (null? hairy)
+ (letify bindings* body*)
+ (begin
+ (for-each
+ (lambda (hairy)
+ (let* ((name (car hairy))
+ (binding (assq name (staticfy/env/bindings env*))))
+ (for-each
+ (lambda (ref)
+ (form/rewrite!
+ ref
+ `(CALL (QUOTE ,%static-binding-ref)
+ (QUOTE #F)
+ (LOOKUP ,name)
+ (QUOTE ,name))))
+ (cdr binding))))
+ hairy)
+ (letify
+ (lmap (lambda (binding*)
+ (if (memq binding* simple)
+ simple
+ (let ((name (car binding*)))
+ (list name
+ `(CALL (QUOTE ,%make-static-binding)
+ (QUOTE #F)
+ (QUOTE ,%unassigned)
+ (QUOTE ,name))))))
+ bindings*)
+ (beginnify
+ (append
+ (let ((actions*
+ (lmap (lambda (hairy)
+ (let ((name (car hairy)))
+ `(CALL (QUOTE ,%static-binding-set!)
+ (QUOTE #F)
+ (LOOKUP ,name)
+ ,(cadr hairy)
+ (QUOTE ,name))))
+ hairy)))
+ (case *order-of-argument-evaluation*
+ ((ANY LEFT-TO-RIGHT) actions*)
+ ((RIGHT-TO_LEFT) (reverse actions*))
+ (else
+ (configuration-error
+ "Unknown order of argument evaluation"
+ *order-of-argument-evaluation*))))
+ (list body*))))))))))
+\f
+(define (staticfy/expr env expr)
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((QUOTE)
+ (staticfy/quote env expr))
+ ((LOOKUP)
+ (staticfy/lookup env expr))
+ ((LAMBDA)
+ (staticfy/lambda env expr))
+ ((LET)
+ (staticfy/let env expr))
+ ((DECLARE)
+ (staticfy/declare env expr))
+ ((CALL)
+ (staticfy/call env expr))
+ ((BEGIN)
+ (staticfy/begin env expr))
+ ((IF)
+ (staticfy/if env expr))
+ ((LETREC)
+ (staticfy/letrec env expr))
+ ((SET! UNASSIGNED? OR DELAY
+ ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr))
+ (else
+ (illegal expr))))
+
+(define (staticfy/expr* env exprs)
+ (lmap (lambda (expr)
+ (staticfy/expr env expr))
+ exprs))
+
+(define (staticfy/remember new old)
+ (code-rewrite/remember new old))
+
+(define (staticfy/new-name prefix)
+ (new-variable prefix))
+
+(define staticfy/guaranteed-static-operators
+ (list %make-operator-variable-cache
+ %make-remote-operator-variable-cache
+ %make-read-variable-cache
+ %make-write-variable-cache
+ %fetch-environment))
+
+(define (staticfy/simple? form)
+ (and (pair? form)
+ (or (eq? (car form) 'QUOTE)
+ (and (eq? (car form) 'CALL)
+ (pair? (cadr form))
+ (eq? (car (cadr form)) 'QUOTE)
+ (memq (cadr (cadr form))
+ staticfy/guaranteed-static-operators)))))
+\f
+(define-structure (staticfy/env
+ (conc-name staticfy/env/)
+ (constructor staticfy/env/make))
+ (context false read-only true)
+ (parent false read-only true)
+ (bindings '() read-only true))
+
+(define (staticfy/lookup* env name ref)
+ (let loop ((env env))
+ (cond ((not env)
+ (free-var-error name))
+ ((assq name (staticfy/env/bindings env))
+ => (lambda (binding)
+ (set-cdr! binding (cons ref (cdr binding)))))
+ (else
+ (loop (staticfy/env/parent env)))))
+ ref)
+
+(define-integrable (staticfy/bind context env names)
+ (staticfy/env/make context
+ env
+ (lmap list names)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: synutl.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; ??
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+;;; Syntax-time utilities
+
+(define (%matchup lambda-list prefix expr)
+ (if (null? lambda-list)
+ (values '() prefix)
+ (let ((var* (generate-uninterned-symbol "SUBFORM")))
+ (let loop ((ll lambda-list)
+ (names '())
+ (args '())
+ (path var*))
+ (cond ((null? ll)
+ (values (reverse names)
+ `(let ((,var* ,expr))
+ (,@prefix ,@(reverse args)))))
+ ((eq? (car ll) '#!rest)
+ (loop '()
+ (cons (cadr ll) names)
+ (cons path args)
+ false))
+ (else
+ (loop (cdr ll)
+ (cons (car ll) names)
+ (cons `(car ,path) args)
+ `(cdr ,path))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: triveval.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; "Trivial" KMP Scheme evaluator
+;;; package: (compiler midend)
+
+(declare (usual-integrations))
+\f
+;;;; Trivial evaluator's runtime library
+
+;; New special forms handled as procedures
+
+(define (lookup value)
+ value)
+
+(define (call operator cont . operands)
+ (if (eq? operator %invoke-continuation)
+ (apply cont operands)
+ (let ((rator (operator->procedure operator)))
+ (cond ((cps-proc? rator)
+ (cps-proc/apply rator cont operands))
+ ((not cont)
+ (apply rator operands))
+ ((continuation? cont)
+ (within-continuation cont
+ (lambda ()
+ (apply rator operands))))
+ (else
+ (cont (apply rator operands)))))))
+
+(define-structure (cps-proc
+ (conc-name cps-proc/)
+ (constructor %cps-proc/make%))
+ (handler false read-only true))
+
+(define (cps-proc/apply proc cont operands)
+ ;; if cont is false, proc should not need it
+ #|
+ (if (not cont)
+ (apply proc operands)
+ (apply (cps-proc/handler proc) cont operands))
+ |#
+ (apply (cps-proc/handler proc) cont operands))
+
+(define (funcall nargs operator . operands)
+ nargs ; ignored
+ (apply operator operands))
+
+(define *last-env*)
+(define *this-env* (the-environment))
+
+(define (fetch-environment)
+ (let ((env *last-env*))
+ (set! *last-env*)
+ env))
+
+(define (execute expr env)
+ (set! *last-env* env)
+ (eval (cond ((cps-program1? expr)
+ (cps-rewrite (caddr expr)))
+ ((cps-program2? expr)
+ (cps-rewrite expr))
+ ((compatible-program? expr)
+ (compatible-rewrite expr))
+ (else
+ (pre-cps-rewrite expr)))
+ *this-env*))
+\f
+(define (pre-cps-rewrite expr)
+ `(let-syntax ((NON-CPS-LAMBDA
+ (macro (param-list body)
+ (list 'LAMBDA (cdr param-list) body))))
+ ,(form/replace expr '((LAMBDA NON-CPS-LAMBDA)))))
+
+(define triveval/?cont-variable (->pattern-variable 'CONT-VARIABLE))
+(define triveval/?body (->pattern-variable 'BODY))
+(define triveval/?ignore (->pattern-variable 'IGNORE))
+(define triveval/?frame (->pattern-variable 'FRAME))
+(define triveval/?frame-vector (->pattern-variable 'FRAME-VECTOR))
+
+(define triveval/compatible-expr-pattern
+ `(LAMBDA (,triveval/?ignore)
+ (LET ((,triveval/?frame
+ (CALL (QUOTE ,%fetch-stack-closure)
+ (QUOTE #F)
+ (QUOTE ,triveval/?frame-vector))))
+ ,triveval/?body)))
+
+(define (compatible-program? expr)
+ (form/match triveval/compatible-expr-pattern expr))
+
+(define (compatible-rewrite expr)
+ (let ((expr* (%cps-rewrite (caddr expr)))
+ (name (generate-uninterned-symbol 'CONT)))
+ `(call-with-current-continuation
+ (lambda (,name)
+ (set! *stack-closure* (make-stack-closure false '() ,name))
+ ,expr*))))
+
+;;this no longer appears to be the only correct pattern, a (letrec () appears
+;;before this let, so I just make two tests, and do the appropriate thing
+;;JBANK
+
+(define triveval/cps-expr-pattern1
+ `(LETREC ()
+ (LET ((,triveval/?cont-variable
+ (CALL (QUOTE ,%fetch-continuation)
+ (QUOTE #F))))
+ ,triveval/?body)))
+
+(define triveval/cps-expr-pattern1-2
+ `(LET ()
+ (LET ((,triveval/?cont-variable
+ (CALL (QUOTE ,%fetch-continuation)
+ (QUOTE #F))))
+ ,triveval/?body)))
+
+(define triveval/cps-expr-pattern2
+ `(LET ((,triveval/?cont-variable
+ (CALL (QUOTE ,%fetch-continuation)
+ (QUOTE #F))))
+ ,triveval/?body))
+
+(define (cps-program1? expr)
+ (or (form/match triveval/cps-expr-pattern1 expr)
+ (form/match triveval/cps-expr-pattern1-2 expr)))
+
+(define (cps-program2? expr)
+ (form/match triveval/cps-expr-pattern2 expr))
+
+(define (%cps-rewrite expr)
+ `(let-syntax ((cps-lambda
+ (macro (param-list body)
+ (list '%cps-proc/make%
+ (list 'LAMBDA param-list body)))))
+ ,(form/replace expr '((LAMBDA CPS-LAMBDA)))))
+
+(define (cps-rewrite expr)
+ `(call-with-current-continuation
+ (lambda (,(car (car (cadr expr)))) ; cont variable
+ ,(%cps-rewrite (caddr expr)))))
+\f
+(define-structure (variable-cache
+ (conc-name variable-cache/)
+ (constructor variable-cache/make))
+ env name)
+
+(define (make-read-variable-cache env name)
+ (variable-cache/make env name))
+
+(define (make-write-variable-cache env name)
+ (variable-cache/make env name))
+
+(define (variable-cache-ref cache name)
+ name ; ignored
+ (lexical-reference (variable-cache/env cache)
+ (variable-cache/name cache)))
+
+(define (variable-cache-set! cache value name)
+ name ; ignored
+ (lexical-assignment (variable-cache/env cache)
+ (variable-cache/name cache)
+ value))
+
+(define (safe-variable-cache-ref cache name)
+ name ; ignored
+ (let ((env (variable-cache/env cache))
+ (name (variable-cache/name cache)))
+ (if (lexical-unassigned? env name)
+ %unassigned
+ (lexical-reference env name))))
+
+(define (variable-cell-ref cache)
+ (let ((env (variable-cache/env cache))
+ (name (variable-cache/name cache)))
+ (if (lexical-unassigned? env name)
+ %unassigned
+ (lexical-reference env name))))
+
+(define (variable-cell-set! cache value)
+ (lexical-assignment (variable-cache/env cache)
+ (variable-cache/name cache)
+ value))
+
+(define-structure (operator-cache
+ (conc-name operator-cache/)
+ (constructor operator-cache/make))
+ env name arity)
+
+(define (make-operator-variable-cache env name arity)
+ (operator-cache/make env name arity))
+
+(define (make-remote-operator-variable-cache package name arity)
+ (operator-cache/make (->environment package) name arity))
+
+(define (invoke-operator-cache name cache . args)
+ name ; ignored
+ (let ((arity (operator-cache/arity cache)))
+ (if (not (= (length args) arity))
+ (error "Operator cache called with wrong number of arguments"
+ args arity)
+ (apply (lexical-reference (operator-cache/env cache)
+ (operator-cache/name cache))
+ args))))
+\f
+(define (cell/make value name)
+ name ; ignored
+ (make-cell value))
+
+(define (cell-ref cell name)
+ name ; ignored
+ (cell-contents cell))
+
+(define (cell-set! cell value name)
+ name ; ignored
+ (set-cell-contents! cell value))
+
+(define (make-closure proc names . values)
+ names ; ignored
+ (make-entity proc (list->vector values)))
+
+(define (closure-ref closure index name)
+ name ; ignored
+ (vector-ref (entity-extra closure) index))
+
+(define (closure-set! closure index value name)
+ name ; ignored
+ (vector-set! (entity-extra closure) index value))
+
+(define *stack-closure*)
+
+(define (fetch-stack-closure names)
+ names ; ignored
+ (let ((closure *stack-closure*))
+ (set! *stack-closure*) ; clear for gc
+ closure))
+
+(define (make-stack-closure proc names . values)
+ names ; ignored
+ (make-entity (lambda (closure . args)
+ (set! *stack-closure* closure)
+ (apply proc args))
+ (list->vector values)))
+
+(define (stack-closure-ref closure index name)
+ name ; ignored
+ (vector-ref (entity-extra closure) index))
+
+(define (projection/2/0 x y)
+ y ; ignored
+ x)
+
+(define (%unknown . all)
+ all ; ignored
+ (error "Unknown operator"))
+
+;; *** These two do not currently work for #!optional or #!rest! ***
+
+(define (make-closure/compatible proc names . values)
+ (let ((proc (cps-proc/handler proc)))
+ (apply make-closure
+ (lambda (closure . args)
+ (call-with-current-continuation
+ (lambda (cont)
+ (set! *stack-closure*
+ (apply make-stack-closure
+ false
+ '()
+ (cons cont
+ (append (reverse args)
+ (list closure)))))
+ (apply proc (cons* cont closure args)))))
+ names
+ values)))
+
+(define *trivial-closures* ; to preserve eq-ness
+ (make-eq-hash-table))
+
+(define (make-trivial-closure/compatible proc)
+ (let ((proc (cps-proc/handler proc)))
+ (or (hash-table/get *trivial-closures* proc false)
+ (let ((new
+ (lambda args
+ (call-with-current-continuation
+ (lambda (cont)
+ (set! *stack-closure*
+ (apply make-stack-closure
+ false
+ '()
+ (cons cont (reverse args))))
+ (apply proc (cons cont args)))))))
+ (hash-table/put! *trivial-closures* proc new)
+ new))))
+
+(define internal-apply/compatible
+ (%cps-proc/make%
+ (lambda (stack-closure nargs operator)
+ nargs ; ignored
+ (let ((elements (vector->list (entity-extra stack-closure))))
+ (apply call
+ operator
+ (car elements)
+ (reverse (cdr elements)))))))
+
+(define invoke-operator-cache/compatible
+ (%cps-proc/make%
+ (lambda (stack-closure desc cache)
+ (let ((elements (vector->list (entity-extra stack-closure))))
+ (apply call
+ (let ((cache
+ (or cache
+ (make-remote-operator-variable-cache
+ '()
+ (car desc)
+ (cadr desc)))))
+ (lexical-reference (operator-cache/env cache)
+ (operator-cache/name cache)))
+ (car elements)
+ (reverse (cdr elements)))))))
+\f
+(define *operator->procedure*
+ (make-eq-hash-table 311))
+
+(define (operator->procedure rator)
+ (if (not (symbol? rator))
+ rator
+ (hash-table/get *operator->procedure* rator rator)))
+
+(define (init-operators!)
+ (let* ((table *operator->procedure*)
+ (declare-operator
+ (lambda (token handler)
+ (hash-table/put! table token handler))))
+
+ (declare-operator %invoke-operator-cache invoke-operator-cache)
+ (declare-operator %invoke-remote-cache invoke-operator-cache)
+ (declare-operator %variable-cache-ref variable-cache-ref)
+ (declare-operator %variable-cache-set! variable-cache-set!)
+ (declare-operator %safe-variable-cache-ref safe-variable-cache-ref)
+ (declare-operator %unassigned? (lambda (obj) (eq? obj %unassigned)))
+ (declare-operator %make-promise (lambda (proc) (delay (proc))))
+ (declare-operator %make-cell cell/make)
+ (declare-operator %make-static-binding cell/make)
+ (declare-operator %cell-ref cell-ref)
+ (declare-operator %static-binding-ref cell-ref)
+ (declare-operator %cell-set! cell-set!)
+ (declare-operator %static-binding-set! cell-set!)
+ (declare-operator %cons cons)
+ (declare-operator %vector vector)
+ (declare-operator %*lookup
+ (lambda (env name depth offset)
+ depth offset ; ignored
+ (lexical-reference env name)))
+ (declare-operator %*set!
+ (lambda (env name depth offset value)
+ depth offset ; ignored
+ (lexical-assignment env name value)))
+ (declare-operator %*unassigned?
+ (lambda (env name depth offset)
+ depth offset ; ignored
+ (lexical-unassigned? env name)))
+ (declare-operator %*define local-assignment)
+ (declare-operator %*define* define-multiple)
+ (declare-operator %*make-environment *make-environment)
+ (declare-operator %execute execute)
+ (declare-operator %fetch-environment fetch-environment)
+ (declare-operator %fetch-continuation
+ (lambda ()
+ (error "Fetch-continuation executed!")))
+ (declare-operator %make-read-variable-cache make-read-variable-cache)
+ (declare-operator %make-write-variable-cache make-write-variable-cache)
+ (declare-operator %make-operator-variable-cache
+ make-operator-variable-cache)
+ (declare-operator %make-remote-operator-variable-cache
+ make-remote-operator-variable-cache)
+ (declare-operator %copy-program %copy-program)
+ (declare-operator %make-heap-closure make-closure)
+ (declare-operator %make-trivial-closure identity-procedure)
+ (declare-operator %heap-closure-ref closure-ref)
+ (declare-operator %heap-closure-set! closure-set!)
+ (declare-operator %make-stack-closure make-stack-closure)
+ (declare-operator %stack-closure-ref stack-closure-ref)
+ (declare-operator %fetch-stack-closure fetch-stack-closure)
+ (declare-operator %internal-apply funcall)
+ (declare-operator %primitive-apply funcall)
+ ; (declare-operator %invoke-continuation identity-procedure)
+ (declare-operator %vector-index vector-index)
+\f
+ (declare-operator %machine-fixnum? machine-fixnum?)
+ (declare-operator %small-fixnum? small-fixnum?)
+ (declare-operator %+ +)
+ (declare-operator %- -)
+ (declare-operator %* *)
+ (declare-operator %/ /)
+ (declare-operator %quotient quotient)
+ (declare-operator %remainder remainder)
+ (declare-operator %= =)
+ (declare-operator %< <)
+ (declare-operator %> >)
+ (declare-operator %vector-cons make-vector)
+ (declare-operator %string-allocate string-allocate)
+ (declare-operator %floating-vector-cons flo:vector-cons)
+
+ ;; Compatiblity operators:
+
+ (declare-operator %make-return-address
+ (lambda (obj)
+ obj ; ignored
+ (error "make-return-address executed!")))
+
+ (declare-operator %variable-read-cache projection/2/0)
+ (declare-operator %variable-write-cache projection/2/0)
+ (declare-operator %variable-cell-ref variable-cell-ref)
+ (declare-operator %hook-variable-cell-ref variable-cell-ref)
+ (declare-operator %hook-safe-variable-cell-ref variable-cell-ref)
+ (declare-operator %variable-cell-set! variable-cell-set!)
+ (declare-operator %hook-variable-cell-set! variable-cell-set!)
+ (declare-operator %reference-trap? (lambda (obj) (eq? obj %unassigned)))
+ (declare-operator %primitive-apply/compatible internal-apply/compatible)))
+\f
+;; This makes cps procs and ordinary procs intermixable
+
+(set-record-type-application-method!
+ cps-proc
+ (lambda (the-proc . args)
+ (call-with-current-continuation
+ (lambda (cont)
+ (apply (cps-proc/handler the-proc) cont args)))))
+
+(init-operators!)
\ No newline at end of file
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+;;; Compile-time handling of booleans
+
+(define (boolean/discriminate object)
+ (cond ((eq? object #f)
+ 'FALSE)
+ ((eq? object #t)
+ 'TRUE)
+ ((eq? object '())
+ ;; 'UNKNOWN
+ 'TRUE)
+ (else
+ 'TRUE)))
+
+;;; Compile-time handling of numbers (*** For now ***)
+
+(define machine-tag-renames
+ '((floating-point-vector flonum)))
+
+(define (machine-tag tag-name)
+ (let ((place (assq tag-name machine-tag-renames)))
+ (microcode-type
+ (if (not place)
+ tag-name
+ (cadr place)))))
+
+(define (machine-fixnum? value)
+ (fix:fixnum? value))
+
+(define (small-fixnum? value nbits)
+ (and (machine-fixnum? value)
+ (machine-fixnum? (* (expt 2 nbits) value))))
+
+;; Trivial pretty printer
+
+(define kmp/pp-unparser-table
+ (unparser-table/copy system-global-unparser-table))
+
+(define *unparse-string
+ (lexical-reference (->environment '(runtime unparser)) '*unparse-string))
+
+(unparser-table/set-entry!
+ kmp/pp-unparser-table
+ 'UNINTERNED-SYMBOL
+ (lambda (symbol)
+ (let ((name (symbol-name symbol)))
+ (cond ((= 0 (vector-8b-ref name 0))
+ (*unparse-string (substring name 1 (string-length name))))
+ ((new-variable->index symbol)
+ => (lambda (index)
+ (*unparse-string name)
+ (*unparse-string kmp/pp-symbol-glue)
+ (*unparse-string (number->string index))))
+ (else
+ ;;(*unparse-string "#[uninterned-symbol ")
+ (*unparse-string name)
+ ;;(*unparse-string " ")
+ ;;(*unparse-string (number->string (hash symbol)))
+ ;;(*unparse-string "]")
+ )))))
+
+(define kmp/pp-symbol-glue "-")
+
+(define (kmp/pp kmp-code)
+ (fluid-let ((*pp-primitives-by-name* false)
+ (*pp-uninterned-symbols-by-name* false)
+ (*pp-avoid-circularity?* true)
+ (*pp-default-as-code?* true))
+ (pp kmp-code)))
+
+(define (kmp/ppp kmp-code)
+ (kmp/pp (kmp/->ppp kmp-code)))
+
+(define (kmp/->ppp kmp-code)
+ (define (->string x)
+ (cond ((interned-symbol? x) (symbol-name x))
+ ((uninterned-symbol? x)
+ (let ((index (new-variable->index x))
+ (name (symbol-name x)))
+ (cond (index
+ (string-append name kmp/pp-symbol-glue
+ (number->string index)))
+ ((= 0 (vector-8b-ref name 0))
+ (substring name 1 (string-length name)))
+ (else
+ (string-append name "[#@"
+ (number->string (hash x)) "]")))))
+ (else x)))
+ (define (->sym . stuff)
+ (string->uninterned-symbol
+ (apply string-append "\000" (map ->string stuff))))
+ (let walk ((expr kmp-code))
+ (define (format-ref get-closure get-name)
+ (define (gen closure)
+ (->sym closure "." (quote/text (get-name expr))))
+ (let* ((expr (map walk expr))
+ (closure (get-closure expr)))
+ (cond ((symbol? closure) (gen closure))
+ ((LOOKUP/? closure) (gen (lookup/name closure)))
+ (else expr))))
+ (cond ((QUOTE/? expr)
+ expr)
+ ;;((LET/? expr)
+ ;; (let do-let ((names '()) (values '()) (form expr))
+ ;; (cond ((and (LET/? form)
+ ;; (= (length (let/bindings form)) 1))
+ ;; (do-let (cons (first (first (let/bindings form))) names)
+ ;; (cons (second (first (let/bindings form))) values)
+ ;; (let/body form)))
+ ;; ((null? names)
+ ;; (map walk expr))
+ ;; ((= (length names) 1)
+ ;; `(LET (,(car names) ,(walk (car values)))
+ ;; ,(walk form)))
+ ;; (else
+ ;; `(LET* ,(reverse (map (lambda (n v) `(,n ,(walk v)))
+ ;; names values))
+ ;; ,(walk form))))))
+ ((LOOKUP/? expr)
+ (lookup/name expr))
+ ((CALL/%heap-closure-ref? expr)
+ (format-ref CALL/%heap-closure-ref/closure
+ CALL/%heap-closure-ref/name))
+ ((CALL/%stack-closure-ref? expr)
+ (format-ref CALL/%stack-closure-ref/closure
+ CALL/%stack-closure-ref/name))
+ ((pair? expr)
+ (map walk expr))
+ (else expr))))
+\f
+;;; Simple form utilities
+
+(define (bind name value body)
+ `(CALL (LAMBDA (,(new-continuation-variable) ,name)
+ ,body)
+ (QUOTE #F)
+ ,value))
+
+(define (bind* names values body)
+ `(CALL (LAMBDA (,(new-continuation-variable) ,@names)
+ ,body)
+ (QUOTE #F)
+ ,@values))
+
+(define (andify left right)
+ `(IF ,left ,right (QUOTE #F)))
+
+(define (beginnify actions)
+ ;; Flattens the ACTIONS, discarding any in non-tail position that
+ ;; are side-effect free or static (compile-time only). It
+ ;; returns (BEGIN) or (BEGIN <action>+ <expression>) or <expression>
+ (let loop ((actions (reverse actions))
+ (actions* '()))
+ (cond ((null? actions)
+ (if (or (null? actions*)
+ (not (null? (cdr actions*))))
+ `(BEGIN ,@actions*)
+ (car actions*)))
+ ((not (pair? (car actions)))
+ (internal-warning "BEGINNIFY: Non-pair form in BEGIN:" (car actions))
+ (loop (cdr actions)
+ (cons (car actions) actions*)))
+ ((eq? (caar actions) 'BEGIN)
+ (loop (append (reverse (cdar actions)) (cdr actions))
+ actions*))
+ ((and (not (null? actions*))
+ (or (form/satisfies? (car actions) '(SIDE-EFFECT-FREE))
+ (and (form/satisfies? (car actions) '(STATIC))
+ (begin
+ (write-line `(BEGINNIFY ELIDING ,(car actions)))
+ #T))))
+ (loop (cdr actions) actions*))
+ (else
+ (loop (cdr actions)
+ (cons (car actions) actions*))))))
+
+(define (simplify-actions expressions)
+ ;; Takes a list of expressions, as in a BEGIN body, and produces a
+ ;; simplified list of expressions (i.e. removes side-effect-free
+ ;; expressions in non-tail position).
+ (let ((simplified (beginnify expressions)))
+ (if (and (pair? simplified)
+ (eq? (car simplified) 'BEGIN))
+ (cdr simplified)
+ (list simplified))))
+
+(define (pseudo-letify rator bindings body remember)
+ ;; Using pseudo-letify ensures that LET is only inserted for simple,
+ ;; non-continuation bindings.
+ (if (and (for-all? bindings
+ (lambda (binding)
+ (and (form/simple? (cadr binding))
+ (not (continuation-variable? (car binding))))))
+ *after-cps-conversion?*)
+ `(LET ,bindings
+ ,body)
+ (let ((cont-binding
+ (list-search-positive bindings
+ (lambda (binding)
+ (continuation-variable? (car binding)))))
+ (finish
+ (lambda (cont-name cont-expr bindings*)
+ (let ((rator* `(LAMBDA (,cont-name
+ ,@(lmap car bindings*))
+ ,body)))
+ `(CALL ,(remember rator* rator)
+ ,cont-expr
+ ,@(lmap cadr bindings*))))))
+ (if (not cont-binding)
+ (finish (new-continuation-variable)
+ `(QUOTE #F)
+ bindings)
+ (finish (car cont-binding)
+ (cadr cont-binding)
+ (delq cont-binding bindings))))))
+\f
+(define (hash-table/copy table make-hash-table)
+ (let ((new-table (make-hash-table (hash-table/size table))))
+ (hash-table/for-each table
+ (lambda (key datum)
+ (hash-table/put! new-table key datum)))
+ new-table))
+
+(define (make-variable-properties)
+ (make-eq-hash-table))
+
+(define (copy-variable-properties)
+ (let ((var-props *variable-properties*))
+ (and var-props
+ (hash-table/copy var-props make-eq-hash-table))))
+
+(define (get-variable-properties var)
+ (let ((var-props *variable-properties*))
+ (and var-props
+ (hash-table/get var-props var '()))))
+
+(define (set-variable-properties! var alist)
+ (let ((var-props *variable-properties*))
+ (and var-props
+ (hash-table/put! var-props var alist))))
+
+(define (get-variable-property var property)
+ (let ((properties (get-variable-properties var)))
+ (and properties
+ (assq property properties))))
+
+(define (declare-variable-property! var property)
+ (let ((var-props *variable-properties*))
+ (and var-props
+ (hash-table/put!
+ var-props
+ var
+ (let* ((all (hash-table/get var-props var '()))
+ (place (assq (car property) all)))
+ (cons property
+ (if (not place)
+ all
+ (delq place all))))))))
+\f
+;; NEW-VARIABLE
+;;
+;; The only reason for this table is to canonocalize the names to allow
+;; comparison across compilations. If you want to use something like
+;; this for a code rewrite, dont use this table. Use the variable
+;; properties or something else.
+
+(define new-variable-index)
+(define new-variable-table #F)
+
+(define (initialize-new-variable!)
+ (set! new-variable-index 0)
+ (set! new-variable-table (make-eq-hash-table)))
+
+(define (new-variable prefix)
+ ;;(generate-uninterned-symbol prefix)
+ (set! new-variable-index (+ new-variable-index 1))
+ (let ((symbol (string->uninterned-symbol
+ (if (symbol? prefix)
+ (symbol-name prefix)
+ prefix))))
+ (hash-table/put! new-variable-table symbol new-variable-index)
+ symbol))
+
+(define (new-variable->index symbol)
+ (and new-variable-table
+ (hash-table/get new-variable-table symbol #F)))
+
+
+(define (closure-variable? var)
+ (get-variable-property var 'CLOSURE))
+
+(define (new-closure-variable)
+ (let ((name (new-variable 'CLOSURE)))
+ (declare-variable-property! name '(CLOSURE))
+ name))
+
+(define-integrable (new-ignored-variable name)
+ (let ((name (new-variable name)))
+ (declare-variable-property! name '(IGNORED))
+ name))
+
+(define-integrable (ignored-variable? var)
+ (get-variable-property var 'IGNORED))
+
+(define (continuation-variable? var)
+ (get-variable-property var 'CONTINUATION))
+
+(define (ignored-continuation-variable? var)
+ (and (get-variable-property var 'CONTINUATION)
+ (ignored-variable? var)))
+
+(define (referenced-continuation-variable? var)
+ (and (get-variable-property var 'CONTINUATION)
+ (not (ignored-variable? var))))
+
+(define (new-continuation-variable)
+ (let ((name (new-variable 'CONT)))
+ (declare-variable-property! name '(CONTINUATION))
+ name))
+
+(define (new-ignored-continuation-variable)
+ (let ((name (new-ignored-variable 'IGNORED-CONTINUATION)))
+ (declare-variable-property! name '(CONTINUATION))
+ name))
+
+(define (environment-variable? var)
+ (get-variable-property var 'ENVIRONMENT))
+
+(define (new-environment-variable)
+ (let ((name (new-variable 'ENV)))
+ (declare-variable-property! name '(ENVIRONMENT))
+ name))
+
+(define (new-variable-cache-variable name desc)
+ name ; ignored
+ (let ((name* (new-variable 'CACHE)))
+ (declare-variable-property! name* `(CACHE ,desc))
+ name*))
+
+(define (variable-cache-variable? var)
+ (get-variable-property var 'CACHE))
+
+(define (variable/rename var)
+ (let ((new
+ ;;(generate-uninterned-symbol (string-append (symbol-name var) "-"))
+ (new-variable var)
+ )
+ (original-properties (get-variable-properties var)))
+ (if original-properties
+ (set-variable-properties! new (alist-copy original-properties)))
+ (declare-variable-property! new `(ORIGINAL-NAME ,var))
+ new))
+
+(define (variable/original-name var)
+ (let loop ((var var))
+ (let ((place (get-variable-property var 'ORIGINAL-NAME)))
+ (if (not place)
+ var
+ (loop (cadr place))))))
+
+(define (pseudo-static-variable? var)
+ (let ((var-props *variable-properties*))
+ (and var-props
+ (let ((props (hash-table/get var-props var false)))
+ (and props
+ (or (assq 'CONTINUATION props)
+ (assq 'ENVIRONMENT props)))))))
+
+\f
+(define (lifter/letrecify program)
+ ;; Ensure that there is a place to attach lifted stuff,
+ ;; by introducing a LETREC if necessary.
+ (if (LETREC/? program)
+ program
+ `(LETREC () ,program)))
+
+(define (lifter/make find-static-form)
+ (lambda (env lamname form*)
+ (define (clobber-letrec! form)
+ (set-car! (cdr form)
+ (cons (list lamname form*)
+ (cadr form))))
+
+ (let ((form (find-static-form env)))
+ (if (or (not form) (not (pair? form)))
+ (internal-error "Nowhere to insert" form)
+ (case (car form)
+ ((LETREC)
+ (clobber-letrec! form))
+ ((LET LAMBDA)
+ (let ((body (caddr form)))
+ (if (and (pair? body) (eq? (car body) 'LETREC))
+ (clobber-letrec! body)
+ (set-car! (cddr form)
+ `(LETREC ((,lamname ,form*))
+ ,body)))))
+ (else
+ (internal-error "Invalid place to insert" form)))))))
+
+(define (form/rewrite! old new)
+ (set-car! old (car new))
+ (set-cdr! old (cdr new)))
+
+(define (form/preserve form)
+ ;; This makes a copy that won't be affected by later rewriting
+ ;; of the original. Rewritten components will be present in both.
+ (cons (car form) (cdr form)))
+
+(define (form/copy form)
+ (let walk ((form form))
+ (cond ((not (pair? form))
+ form)
+ ((eq? 'QUOTE (car form))
+ `(QUOTE ,(cadr form)))
+ (else
+ (cons (walk (car form))
+ (walk (cdr form)))))))
+
+(define (form/replace form replacements)
+ (let walk ((form form))
+ (cond ((not (pair? form))
+ (let ((place (assq form replacements)))
+ (if (not place)
+ form
+ (cadr place))))
+ ((eq? 'QUOTE (car form))
+ `(QUOTE ,(cadr form)))
+ (else
+ (cons (walk (car form))
+ (walk (cdr form)))))))
+\f
+(define (form/satisfies? form operator-properties)
+ (let walk ((expr form))
+ (and (pair? expr)
+ (case (car expr)
+ ((LOOKUP QUOTE LAMBDA) true)
+ ((IF)
+ (and (walk (cadr expr))
+ (walk (caddr expr))
+ (walk (cadddr expr))))
+ ((CALL)
+ (let ((rator (cadr expr)))
+ (and (pair? rator)
+ (eq? (car rator) 'QUOTE)
+ (operator/satisfies? (cadr rator) operator-properties)
+ (for-all? (cddr expr) walk))))
+ (else false)))))
+
+(define (form/simple&side-effect-free? operand)
+ (form/satisfies? operand '(SIMPLE SIDE-EFFECT-FREE)))
+
+(define (form/simple&side-effect-insensitive? operand)
+ (form/satisfies? operand '(SIMPLE SIDE-EFFECT-INSENSITIVE)))
+
+(define (form/simple? form)
+ (and (pair? form)
+ (case (car form)
+ ((LOOKUP QUOTE LAMBDA) true)
+ ((IF)
+ (and (form/simple&side-effect-free? (cadr form))
+ (form/simple&side-effect-free? (caddr form))
+ (form/simple&side-effect-free? (caddr form))))
+ ((CALL)
+ (let ((rator (cadr form)))
+ (and (QUOTE/? rator)
+ (operator/satisfies? (cadr rator) '(SIMPLE))
+ (for-all? (cddr form) form/simple&side-effect-free?))))
+ (else false))))
+
+(define (pseudo-simple-operator? rator)
+ (or (operator/satisfies? rator '(SIMPLE))
+ (operator/satisfies? rator '(OUT-OF-LINE-HOOK))))
+
+(define (form/pseudo-simple? form)
+ (and (pair? form)
+ (case (car form)
+ ((LOOKUP QUOTE LAMBDA) true)
+ ((IF)
+ (and (form/simple&side-effect-free? (cadr form))
+ (form/simple&side-effect-free? (caddr form))
+ (form/simple&side-effect-free? (caddr form))))
+ ((CALL)
+ (let ((rator (cadr form)))
+ (and (QUOTE/? rator)
+ (pseudo-simple-operator? (cadr rator))
+ (for-all? (cddr form) form/simple&side-effect-free?))))
+ (else false))))
+\f
+(define (binding-context-type keyword context bindings)
+ (if (or (eq? keyword 'LETREC)
+ (eq? context 'DYNAMIC))
+ context
+ (call-with-values
+ (lambda ()
+ (list-split
+ (list-transform-negative bindings
+ (lambda (binding)
+ ;; eliminate any continuation variables. They will not
+ ;; be considered as either dynamic or static (as
+ ;; suggested by Jinx)
+ ;; --JBANK
+ (continuation-variable? (car binding))))
+ (lambda (binding) (form/static? (cadr binding)))))
+ (lambda (static dynamic)
+ (cond ((null? dynamic) 'STATIC)
+ ((null? static) 'DYNAMIC)
+ (else (internal-error
+ "Frame with static and dynamic bindings")))))))
+
+(define (form/static? form)
+ ;; This assumes that the operands are OK.
+ (and (pair? form)
+ (eq? (car form) 'CALL)
+ (let ((rator (cadr form)))
+ (and (pair? rator)
+ (eq? 'QUOTE (car rator))
+ (operator/satisfies? (cadr rator) '(STATIC))))))
+\f
+(define (form/free-vars form)
+ (form/%free-vars form true))
+
+(define (form/%free-vars form inside-lambda?)
+ ;; Only valid after environment conversion.
+ (define (free-vars* exprs bound acc)
+ (let loop ((acc acc)
+ (exprs exprs))
+ (if (null? exprs)
+ acc
+ (loop (free-vars (car exprs) bound acc)
+ (cdr exprs)))))
+
+ (define (maybe-add var bound acc)
+ (if (or (memq var bound) (memq var acc))
+ acc
+ (cons var acc)))
+
+ (define (free-vars expr bound acc)
+ (if (not (pair? expr))
+ (internal-error "form/free-vars: Not a KMP expression" expr))
+ (case (car expr)
+ ((LOOKUP)
+ (maybe-add (cadr expr) bound acc))
+ ((LAMBDA)
+ (if (not inside-lambda?)
+ acc
+ (free-vars (caddr expr)
+ (append (lambda-list->names (cadr expr))
+ bound)
+ acc)))
+ ((LET)
+ (free-vars* (map cadr (cadr expr))
+ bound
+ (free-vars (caddr expr)
+ (map* bound car (cadr expr))
+ acc)))
+ ((CALL BEGIN IF DELAY OR)
+ (free-vars* (cdr expr) bound acc))
+ ((LETREC)
+ (free-vars* (cons (caddr expr) (map cadr (cadr expr)))
+ (map* bound car (cadr expr))
+ acc))
+ ((SET!)
+ (maybe-add (cadr expr)
+ bound
+ (free-vars (caddr expr) bound acc)))
+ ((QUOTE DECLARE)
+ acc)
+ ((ACCESS DEFINE IN-PACKAGE THE-ENVIRONMENT)
+ (no-longer-legal expr 'FORM/FREE-VARS))
+ (else
+ (illegal expr))))
+
+ (free-vars form '() '()))
+\f
+(define-structure (pattern-variable
+ (conc-name pattern-variable/)
+ (constructor ->pattern-variable)
+ (print-procedure
+ (standard-unparser-method 'PATTERN-VARIABLE
+ (lambda (v port)
+ (write-char #\space port)
+ (display (pattern-variable/name v) port)))))
+ (name false read-only true))
+
+(define (form/equal? form1 form2)
+ (define (walk form1 form2)
+ (or (eq? form1 form2)
+ (and (pair? form1)
+ (pair? form2)
+ (walk (car form1) (car form2))
+ (walk (cdr form1) (cdr form2)))))
+
+ (walk form1 form2))
+
+(define (form/match pattern form)
+ (define (walk pattern form dict)
+ (and dict
+ (cond ((pattern-variable? pattern)
+ (let ((place (assq pattern (cdr dict))))
+ (cond ((not place)
+ (cons 'DICT
+ (cons (list pattern form)
+ (cdr dict))))
+ ((form/equal? (cadr place) form)
+ dict)
+ (else
+ false))))
+ ((eq? pattern form)
+ dict)
+ ((pair? pattern)
+ (and (pair? form)
+ (walk (cdr pattern)
+ (cdr form)
+ (walk (car pattern)
+ (car form)
+ dict))))
+ (else
+ false))))
+
+ (let ((result (walk pattern form (list 'DICT))))
+ (and result
+ (or (null? (cdr result))
+ (cdr result)))))
+\f
+;;;; Lambda-list utilities
+
+(define (lambda-list->names lambda-list)
+ (delq* '(#!OPTIONAL #!REST #!AUX) lambda-list))
+
+(define (lambda-list/count-names lambda-list)
+ (let loop ((list lambda-list) (count 0))
+ (cond ((null? list) count)
+ ((memq (car list) '(#!OPTIONAL #!REST #!AUX))
+ (loop (cdr list) count))
+ (else
+ (loop (cdr list) (+ count 1))))))
+
+(define (hairy-lambda-list? lambda-list)
+ (there-exists? lambda-list
+ (lambda (token)
+ (or (eq? token '#!OPTIONAL)
+ (eq? token '#!REST)
+ (eq? token '#!AUX)))))
+
+(define (guarantee-simple-lambda-list lambda-list)
+ (if (hairy-lambda-list? lambda-list)
+ (internal-error "Unexpected lambda list keywords" lambda-list)))
+
+(define (guarantee-argument-list args len)
+ (if (not (= (length args) len))
+ (internal-error "Wrong number of arguments" len args)))
+
+(define (lambda-list/applicate lambda-list args)
+ ;; No #!AUX allowed here
+ (let loop ((ll lambda-list)
+ (ops args)
+ (ops* '()))
+ (cond ((null? ll)
+ (if (not (null? ops))
+ (user-error "Too many arguments" lambda-list args))
+ (reverse! ops*))
+ ((eq? (car ll) '#!OPTIONAL)
+ (loop (if (or (null? (cddr ll))
+ (eq? '#!REST (caddr ll)))
+ (cddr ll)
+ (cons '#!OPTIONAL (cddr ll)))
+ (if (null? ops)
+ ops
+ (cdr ops))
+ (cons (if (null? ops)
+ `(QUOTE ,%unassigned)
+ (car ops))
+ ops*)))
+ ((eq? (car ll) '#!REST)
+ ;; This only works before CPS conversion.
+ ;; By that time, all "lexprs" should have been split.
+ (reverse!
+ (cons (let listify ((ops ops))
+ (if (null? ops)
+ `(QUOTE ())
+ `(CALL (QUOTE ,%cons)
+ (QUOTE #F)
+ ,(car ops)
+ ,(listify (cdr ops)))))
+ ops*)))
+ ((null? ops)
+ (user-error "Too few arguments" lambda-list args))
+ (else
+ (loop (cdr ll) (cdr ops) (cons (car ops) ops*))))))
+\f
+(define (lambda-list/parse lambda-list)
+ ;; (values required optional rest)
+ ;; No #!AUX allowed here
+ (let parse ((ll lambda-list))
+ (cond ((null? ll)
+ (values '() '() false))
+ ((eq? (car ll) '#!OPTIONAL)
+ (call-with-values
+ (lambda () (parse (cdr ll)))
+ (lambda (opt opt* rest)
+ (if (not (null? opt*))
+ (internal-error "Multiple #!OPTIONAL specifiers"
+ lambda-list))
+ (values '() opt rest))))
+ ((eq? (car ll) '#!REST)
+ (if (or (null? (cdr ll))
+ (not (null? (cddr ll))))
+ (internal-error "Parameters follow #!REST" lambda-list))
+ (values '() '() (cdr ll)))
+ (else
+ (call-with-values
+ (lambda () (parse (cdr ll)))
+ (lambda (req opt rest)
+ (values (cons (car ll) req)
+ opt
+ rest)))))))
+
+(define (lambda-list/arity-info lambda-list)
+ ;; This includes the return address, since the
+ ;; current convention includes that.
+ (call-with-values
+ (lambda () (lambda-list/parse lambda-list))
+ (lambda (required optional rest)
+ ;; min includes the continuation, since after CPS!
+ (let* ((min (length required))
+ (max (+ min (length optional))))
+ (list min
+ (if rest
+ (- 0 (+ max 1))
+ max))))))
+\f
+;;;; List & vector utilities
+
+(define (delq* to-remove some-list)
+ (if (null? to-remove)
+ some-list
+ (let loop ((al some-list)
+ (names '()))
+ (cond ((null? al)
+ (reverse! names))
+ ((memq (car al) to-remove)
+ (loop (cdr al) names))
+ (else
+ (loop (cdr al)
+ (cons (car al) names)))))))
+
+(define (list-prefix ol tail)
+ (let loop ((elements '())
+ (l ol))
+ (cond ((eq? l tail)
+ (reverse! elements))
+ ((null? l)
+ (error "list-prefix: not a prefix" ol tail))
+ (else
+ (loop (cons (car l) elements)
+ (cdr l))))))
+
+(define-integrable (lmap proc l)
+ (let loop ((l l) (l* '()))
+ (if (null? l)
+ (reverse! l*)
+ (loop (cdr l)
+ (cons (proc (car l))
+ l*)))))
+
+(define (difference set1 set2)
+ (list-transform-negative set1
+ (lambda (element)
+ (memq element set2))))
+
+(define (intersection set1 set2)
+ (cond ((null? set1)
+ '())
+ ((null? set2)
+ '())
+ (else
+ (list-transform-positive set1
+ (lambda (element)
+ (memq element set2))))))
+
+(define (union set1 set2)
+ (cond ((null? set1)
+ set2)
+ ((null? set2)
+ set1)
+ (else
+ (append (delq* set2 set1) set2))))
+
+(define (union-map* set0 proc l)
+ ;; Apply PROC to each element of L and union the results with SET0
+ (let loop ((set set0)
+ (l l))
+ (if (null? l)
+ set
+ (loop (union (proc (car l)) set)
+ (cdr l)))))
+
+
+(define (remove-duplicates l)
+ (let loop ((l l) (l* '()))
+ (cond ((null? l) (reverse! l*))
+ ((memq (car l) l*) (loop (cdr l) l*))
+ (else (loop (cdr l) (cons (car l) l*))))))
+
+(define (null-intersection? set1 set2)
+ (cond ((null? set1) #T)
+ ((null? set2) #T)
+ ((memq (car set1) set2) #F)
+ (else (null-intersection? (cdr set1) set2))))
+
+\f
+(define (list-split ol predicate)
+ ;; (values yes no)
+ (let loop ((l (reverse ol))
+ (yes '())
+ (no '()))
+ (cond ((null? l)
+ (values yes no))
+ ((predicate (car l))
+ (loop (cdr l) (cons (car l) yes) no))
+ (else
+ (loop (cdr l) yes (cons (car l) no))))))
+
+(define (rassq value alist)
+ (let loop ((alist alist))
+ (and (pair? alist)
+ (pair? (car alist))
+ (if (eq? value (cdar alist))
+ (car alist)
+ (loop (cdr alist))))))
+
+(define (pick-random l)
+ (let ((len (length l)))
+ (list-ref l (if *allow-random-choices?*
+ (random len)
+ (quotient len 2)))))
+
+(define (vector-index vector name)
+ (if (not (vector? vector))
+ (internal-error "vector-index: Not a vector" vector name)
+ (do ((i (- (vector-length vector) 1) (- i 1)))
+ ((eq? name (vector-ref vector i)) i)
+ (if (= i 0)
+ (internal-error "vector-index: component not found"
+ vector name)))))
+
+\f
+(define-structure (queue
+ (conc-name queue/)
+ (constructor queue/%make))
+ (head false read-only true)
+ (tail false read-only false))
+
+(define (queue/make)
+ (let ((pair (cons '*HEAD* '())))
+ (queue/%make pair pair)))
+
+(define (queue/enqueue! queue object)
+ (let ((pair (cons object '())))
+ (set-cdr! (queue/tail queue) pair)
+ (set-queue/tail! queue pair)))
+
+(define (queue/enqueue!* queue objects)
+ (if (not (null? objects))
+ (let ((objects* (list-copy objects)))
+ (set-cdr! (queue/tail queue) objects*)
+ (set-queue/tail! queue (last-pair objects*)))))
+
+(define (queue/drain! queue process)
+ ;; process can cause more queueing
+ (let loop ((pair (queue/head queue)))
+ (if (not (null? (cdr pair)))
+ (begin
+ (process (cadr pair))
+ ;; This can GC by bashing the queue!
+ (loop (cdr pair))))))
+
+(define (queue/contents queue)
+ (cdr (queue/head queue)))
+\f
+;;;; Miscellaneous
+
+(define (eq?-memoize function)
+ (let ((table (make-eq-hash-table))
+ (absent (cons #f #f)))
+ (lambda (arg)
+ (let ((value (hash-table/get table arg absent)))
+ (if (eq? value absent)
+ (let ((value (function arg)))
+ (hash-table/put! table arg value)
+ value)
+ value)))))
+
+;; Missing SCODE utilities for input
+
+(define (the-environment-components tenv receiver)
+ tenv ; ignored
+ (receiver))
+
+(define (scode/absolute-reference? object)
+ (and (access? object)
+ (null? (access-environment object))))
+
+(define (absolute-reference-name reference)
+ (access-name reference))
+
+(define (good-factor? value)
+ (and (machine-fixnum? value)
+ (< (abs value) *sup-good-factor*)))
+
+(define (good-factor->nbits value)
+ (if (not (good-factor? value))
+ (internal-error "constant factors can only be good factors"
+ value)
+ (ceiling->exact (/ (log (abs value)) (log 2)))))
+
+(define (power-of-two? n)
+ (let loop ((power 1) (exponent 0))
+ (cond ((< n power) false)
+ ((= n power) exponent)
+ (else
+ (loop (* 2 power) (1+ exponent))))))
+
+(define (careful/quotient x y)
+ (if (zero? y)
+ (user-error "quotient: Division by zero" x y)
+ (quotient x y)))
+
+(define (careful/remainder x y)
+ (if (zero? y)
+ (user-error "remainder: Division by zero" x y)
+ (remainder x y)))
+
+(define (careful// x y)
+ (if (zero? y)
+ (user-error "/: Division by zero" x y)
+ (/ x y)))
+
+(define (iota n)
+ (do ((i (- n 1) (- i 1))
+ (acc '() (cons i acc)))
+ ((< i 0) acc)))
+\f
+(define code/rewrite-table/make
+ (strong-hash-table/constructor eq-hash-mod eq?))
+
+(define code-rewrite/remember
+ (let ((not-found (list '*NOT-FOUND*)))
+ (lambda (new old)
+ (let ((crt *code-rewrite-table*))
+ (if (and crt (eq? not-found (hash-table/get crt new not-found)))
+ (let* ((pcrt *previous-code-rewrite-table*)
+ (old* (if (not pcrt)
+ not-found
+ (hash-table/get pcrt
+ old
+ not-found))))
+ (cond ((not (eq? old* not-found))
+ (hash-table/put! crt new old*))
+ ((eq? pcrt #t)
+ (hash-table/put! crt new old))))))
+ new)))
+
+(define code-rewrite/remember*
+ (let ((not-found (list '*NOT-FOUND*)))
+ (lambda (new old)
+ (let ((crt *code-rewrite-table*))
+ (if (and crt (eq? not-found (hash-table/get crt new not-found)))
+ (hash-table/put! crt new old)))
+ new)))
+
+(define (code-rewrite/original-form new)
+ (and *code-rewrite-table*
+ (hash-table/get *code-rewrite-table* new false)))
+
+(define code-rewrite/original-form*/previous
+ (let ((not-found (list '*NOT-FOUND*)))
+ (lambda (old)
+ ;; (values available? form)
+ (if (not *previous-code-rewrite-table*)
+ (values false old)
+ (let ((ancient
+ (hash-table/get *previous-code-rewrite-table* old not-found)))
+ (if (eq? not-found ancient)
+ (values false old)
+ (values true ancient)))))))
+
+(define (code-rewrite/original-form/previous old)
+ (and *previous-code-rewrite-table*
+ (hash-table/get *previous-code-rewrite-table* old false)))
+
+(define (code/rewrite-table/copy table)
+ (hash-table/copy table
+ code/rewrite-table/make))
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+;;; Widen parameter lists where a known closure is being passed around, so that
+;;; the component parts can be passed rather than the closure object itself. We
+;;; do this only when the closure can be eliminated entirely; hence, the
+;;; requirement that the closure not escape.
+
+(define (reject-reason closure)
+ ;; Returns the reason a closure can't be considered for widening.
+ ;; This is referred to later as "undeniably-dirty?". Current
+ ;; reasons are:
+ ;; 1. The value ESCAPES.
+ ;; 2. There is some use of the value where other values might also
+ ;; occur. (Could be weakened to sites where other values occur
+ ;; that don't widen the same way.)
+ ;; 3. There is some use of the value that we don't know how to
+ ;; widen. We can widen expressions that create closures,
+ ;; references to closed over variables, operands of
+ ;; applications, bindings of LET or LETREC variables, formal
+ ;; parameters of LAMBDA, and the expressions which fetches a
+ ;; stack closure.
+ (cond ((value/closure/escapes? closure) 'escapes)
+ #| ((eq? 'STACK (value/closure/kind closure)) 'stack-closure) |#
+ (else
+ (let ((reasons '()))
+ (define (new-reason! reason)
+ (set! reasons (cons reason reasons)))
+ (do ((nodes (value/nodes closure) (cdr nodes)))
+ ((null? nodes)
+ (if (null? reasons)
+ (if (eq? 'STACK (value/closure/kind closure))
+ (begin
+ (internal-warning "I want to widen a stack closure"
+ closure)
+ #F)
+ #F)
+ reasons))
+ (let ((node (car nodes)))
+ (cond ((not (node/unique-value node))
+ (new-reason! (list 'not-unique node)))
+ #| ((continuation-invocation-operand? node)
+ (new-reason! (list 'continuation-invocation node)))
+ |#
+ ((not (or #| (not (null? (node/uses/operator node))) |#
+ (closure-constructor-node? node)
+ (closure-slot-node? node)
+ (not (null? (node/uses/operand node)))
+ (let-binding-node? node)
+ (node/formal-parameter? node)
+ (fetch-stack-closure-node? node)))
+ (new-reason! (list 'unusual-use node)))
+ (else 'OK))))))))
+
+(define widen-parameter-lists
+ ;; Generate the data flow graph, separate out the closures that
+ ;; appear to be widenable, then do a more careful analysis to
+ ;; actually choose the ones which will be widened (i.e. converted
+ ;; from single objects into a set of the closed-over values).
+ (make-dataflow-analyzer
+ (lambda (code graph closures)
+ ;;(write-line graph)
+ (rewrite-as-widened graph code
+ (analyze-widenable-closures
+ (list-transform-negative closures
+ reject-reason))))))
+
+(define closure/name
+ (let* ((name (->pattern-variable 'NAME))
+ (pattern
+ `(CALL ',%make-heap-closure '#F
+ (LAMBDA (,(->pattern-variable 'CONTINUE)
+ ,name
+ . ,(->pattern-variable 'FORMALS))
+ ,(->pattern-variable 'BODY))
+ . ,(->pattern-variable 'CRAP))))
+ (lambda (closure)
+ (symbol->string
+ (case (value/closure/kind closure)
+ ((STACK) 'STACK-CLOSURE)
+ ((TRIVIAL) 'TRIVIAL-CLOSURE)
+ ((HEAP) (let ((match (form/match pattern (value/text closure))))
+ (if match
+ (cadr (assq name match))
+ (internal-error "Heap closure naming error"))))
+ (else (internal-error "Unknown closure type")))))))
+
+;; Functions to retrieve the representations (list of variable names
+;; to replace) and name maps (maps from old closed variable name to
+;; list of new variable names) for each of the widenable closures.
+(define value/closure.representation 'LATER)
+(define set-value/closure.representation! 'LATER)
+(define value/closure.name-map 'LATER)
+(define set-value/closure.name-map! 'LATER)
+
+;; Now initialize those functions
+(let ((representations (make-attribute))
+ (name-maps (make-attribute)))
+ ;; For each closure that is widenable, we store the representation
+ ;; we choose for the closure as a list of closed over variables.
+ (set! value/closure.representation
+ (lambda (value/closure) (get-attribute value/closure representations)))
+ (set! set-value/closure.representation!
+ (lambda (value/closure rep)
+ (set-attribute! value/closure representations rep)))
+ (set! value/closure.name-map
+ (lambda (value/closure) (get-attribute value/closure name-maps)))
+ (set! set-value/closure.name-map!
+ (lambda (value/closure rep)
+ (set-attribute! value/closure name-maps rep))))
+
+(define (analyze-widenable-closures widenable-closures)
+ ;; The WIDENABLE-CLOSURES all have the property that whenever they appear as a
+ ;; value somewhere, they are the only possible value, and they appear only in
+ ;; restricted contexts, as defined by REJECT-REASON.
+
+ ;; Returns the list of closures that will actually be widened. As a
+ ;; side-effect, it computes and stores the representations and name maps for
+ ;; these closures.
+
+ (define (transitively-dirty? undeniably-dirty? components adj)
+ ;; Given a set of nodes (COMPONENTS) and an ADJacency function
+ ;; (from nodes to a list of adjacent nodes), return a function on
+ ;; the nodes which is true IFF the node is UNDENIABLY-DIRTY? or is
+ ;; adjacent to a node that is transitively-dirty. The algorithm
+ ;; is simply depth first search.
+ (define dirty? (make-attribute))
+ (define seen? (make-attribute))
+ (define (visit u)
+ (if (not (get-attribute u seen?))
+ (begin
+ (set-attribute! u seen? #T)
+ (if (undeniably-dirty? u)
+ (set-attribute! u dirty? #T)
+ (for-every (adj u)
+ (lambda (v)
+ (if (visit v) (set-attribute! u dirty? #T)))))))
+ (get-attribute u dirty?))
+ (for-each visit components)
+ (lambda (u) (get-attribute u dirty?)))
+
+ (let ((closure.adjacent-closures (make-attribute))
+ (closure.closed-over-non-closures? (make-attribute)))
+
+ ;; A closure C (in WIDENABLE-CLOSURES) is adjacent to other
+ ;; widenable-closures over which it is closed.
+ (define (adj c) (or (get-attribute c closure.adjacent-closures) '()))
+ (define (adj! c1 c2)
+ (set-attribute! c1 closure.adjacent-closures
+ (cons c2 (adj c1))))
+
+ ;; True IFF a closure C (in WIDENABLE-CLOSURES) is closed over
+ ;; anything other than another one of the widenable-closures.
+ (define (external? c)
+ (get-attribute c closure.closed-over-non-closures?))
+ (define (external! c)
+ (set-attribute! c closure.closed-over-non-closures? #T))
+
+ ;; Initialize the ADJ and EXTERNAL? functions
+ (for-every widenable-closures
+ (lambda (c)
+ (let ((values-closed-over
+ (vector->list (value/closure/location-nodes c))))
+ (for-every (map node/unique-value values-closed-over)
+ (lambda (value)
+ (if (memq value widenable-closures)
+ (adj! c value)
+ (external! c)))))))
+
+ (let* ((components (strongly-connected-components widenable-closures adj))
+ (scc-graph (s-c-c->adj components adj)))
+ ;; Identify the strongly connected components of the graph of
+ ;; widenable closures closed over one another. All of the
+ ;; closures in a given component either widen or don't widen.
+ ;; When they widen, they widen into an odd kind of union of
+ ;; their closed over components.
+
+ (define (cyclic? component)
+ ;; By their nature, strongly-connected-components that have
+ ;; more than one element are cyclic.
+ (or (not (null? (cdr component)))
+ (let ((closure (car component)))
+ (there-exists? (adj closure)
+ (lambda (adjacent) (eq? closure adjacent))))))
+
+ (define (primordially-dirty? component)
+ ;; A strongly connected component can't be widened if it is
+ ;; cyclic and any component is closed over something outside
+ ;; itself, since this would lead to an infinite number of
+ ;; items in its widened representation.
+ (and (cyclic? component)
+ (there-exists? component external?)))
+
+ (define (generate-reps-and-name-maps! closures)
+ (define seen? (make-attribute))
+ (define (visit u)
+ ;; Returns the representation of this closure and calculates
+ ;; the name map.
+ (if (get-attribute u seen?)
+ (value/closure.representation u)
+ (begin
+ (set-attribute! u seen? #T)
+ (set-value/closure.representation! u '())
+ (let ((values-closed-over
+ (vector->list (value/closure/location-nodes u)))
+ (names-closed-over
+ (vector->list (value/closure/location-names u)))
+ (closure-name (closure/name u))
+ (the-map '()))
+ (define (new! old-name new-names)
+ (define (new-name name)
+ (dataflow/new-name (string-append
+ closure-name "."
+ (symbol-name old-name) "/"
+ (symbol-name name) "+")))
+ (set! the-map
+ `((,old-name . ,(map new-name new-names))
+ . ,the-map))
+ 'OK)
+ (for-each
+ (lambda (value-node name)
+ (let ((neighbor (node/unique-value value-node)))
+ (new! name
+ (if (memq neighbor closures)
+ (visit neighbor)
+ (list name)))))
+ values-closed-over names-closed-over)
+ (set-value/closure.name-map! u the-map)
+ (let ((rep (apply append (reverse (map cdr the-map)))))
+ ;; The choice of representation is not freely made
+ ;; here. The actual order must match the order of
+ ;; the value-computing expressions that appear where
+ ;; the closure is created, and we don't want to have
+ ;; to permute those expressions.
+ (set-value/closure.representation! u rep)
+ rep)))))
+ (for-each visit closures))
+
+ (let* ((is-dirty-because-of-kids?
+ (transitively-dirty? primordially-dirty? components scc-graph))
+ (finally-widenable-closures
+ (apply append
+ (list-transform-negative components
+ (lambda (component)
+ (and (cyclic? component)
+ (is-dirty-because-of-kids? component)))))))
+ (if (not (null? finally-widenable-closures))
+ (pp (list 'finally (length finally-widenable-closures) 'widened)))
+ (generate-reps-and-name-maps! finally-widenable-closures)
+ finally-widenable-closures))))
+\f
+(define-macro (define-widen-handler keyword bindings . body)
+ (let ((proc-name (symbol-append 'WIDEN/ keyword)))
+ (call-with-values
+ (lambda () (%matchup (cdddr bindings)
+ '(handler graph name-map form)
+ '(cdr form)))
+ (lambda (names code)
+ `(define ,proc-name
+ (let ((handler
+ (lambda ,(cons* (first bindings) (second bindings)
+ (third bindings) names)
+ ,@body)))
+ (named-lambda (,proc-name graph name-map form)
+ ;; These handlers return a list of forms, to account for the fact
+ ;; that widening turns single expressions into multiple ones
+ ,code)))))))
+
+(define (widen/expr graph name-map expr)
+ ;; Maps a single expression to a list of (zero or more) expressions
+ (if (not (pair? expr))
+ (illegal expr))
+ (case (car expr)
+ ((ACCESS) (widen/access graph name-map expr))
+ ((BEGIN) (widen/begin graph name-map expr))
+ ((CALL) (widen/call graph name-map expr))
+ ((DECLARE) (widen/declare graph name-map expr))
+ ((DEFINE) (widen/define graph name-map expr))
+ ((DELAY) (widen/delay graph name-map expr))
+ ((IF) (widen/if graph name-map expr))
+ ((IN-PACKAGE) (widen/in-package graph name-map expr))
+ ((LAMBDA) (widen/lambda graph name-map expr))
+ ((LET) (widen/let graph name-map expr))
+ ((LETREC) (widen/letrec graph name-map expr))
+ ((LOOKUP) (widen/lookup graph name-map expr))
+ ((OR) (widen/or graph name-map expr))
+ ((QUOTE) (widen/quote graph name-map expr))
+ ((SET!) (widen/set! graph name-map expr))
+ ((THE-ENVIRONMENT) (widen/the-environment graph name-map expr))
+ ((UNASSIGNED?) (widen/unassigned? graph name-map expr))
+ (else (illegal expr))))
+
+
+(define (widen->expr graph name-map expr)
+ ;; Requires that the widened version be exactly one expression, and
+ ;; returns that expression
+ (let ((result (widen/expr graph name-map expr)))
+ (if (not (singleton-list? result))
+ (internal-error "Did not widen to ONE expression" expr result))
+ (car result)))
+
+(define (widen/expr* graph name-map exprs)
+ ;; Returns a list of lists of expressions
+ (map (lambda (exp) (widen/expr graph name-map exp)) exprs))
+
+(define (widen/flatten-expr* graph name-map exprs)
+ ;; Maps a list of expressions to a list of expressions (not
+ ;; necessarily length preserving, of course)
+ (apply append (widen/expr* graph name-map exprs)))
+
+(define-widen-handler LOOKUP (graph name-map LOOKUP-form name)
+ ;; If the name being looked up is one to widen, return lookups of
+ ;; the names to which it expands; otherwise just return the original
+ ;; lookup
+ graph ; Not used
+ (cond ((assq name name-map)
+ => (lambda (entry)
+ (map (lambda (name) `(LOOKUP ,name)) (cdr entry))))
+ (else (list LOOKUP-form))))
+
+(define (widen/rewrite-bindings name-map names value-nodes continue)
+ ;; Calls CONTINUE with a (possibly) new name-map and names.
+ (define (rename formal closure)
+ ;; Return a list of new names to reference the widened form of a
+ ;; given FORMAL whose value will be the value represented by CLOSURE
+ (map (lambda (closed-over)
+ (dataflow/new-name
+ (string-append (symbol->string formal) "."
+ (symbol->string closed-over)
+ "-")))
+ (value/closure.representation closure)))
+ (let loop ((name-map name-map)
+ (new-names '())
+ (names names)
+ (nodes value-nodes))
+ (cond ((null? nodes)
+ (continue name-map (reverse new-names)))
+ ((memq (car names) '(#!REST #!OPTIONAL #!AUX))
+ (loop name-map (cons (car names) new-names) (cdr names) nodes))
+ ((widen/rewrite? (car nodes))
+ (let* ((this (car nodes))
+ (formal (car names))
+ (closure (node/unique-value this))
+ (rep (rename formal closure)))
+ (loop `((,formal . ,rep) . ,name-map)
+ `(,@(reverse rep) . ,new-names)
+ (cdr names)
+ (cdr nodes))))
+ (else (loop name-map
+ `(,(car names) . ,new-names)
+ (cdr names)
+ (cdr nodes))))))
+
+(define-widen-handler LAMBDA (graph name-map LAMBDA-form lambda-list body)
+ ;; The body needs to be rewritten. If the parameter list needs widening it
+ ;; will require that the body be rewritten with additional local variables
+ ;; alpha-renamed. Widening happens after CPS conversion, so the body
+ ;; shouldn't need widening.
+
+ (define (graph->parameter-nodes graph lambda-expr)
+ (value/procedure/input-nodes
+ (node/the-procedure-value
+ (graph/text->node graph lambda-expr))))
+
+ (no-widening-allowed graph LAMBDA-form)
+ (widen/rewrite-bindings
+ name-map
+ lambda-list
+ (graph->parameter-nodes graph LAMBDA-form)
+ (lambda (name-map lambda-list)
+ `((LAMBDA ,lambda-list ,(widen->expr graph name-map body))))))
+
+(define (widen/let-like graph name-map let-or-letrec bindings body)
+ (let ((bound-names (map car bindings))
+ (binding-exprs (map cadr bindings)))
+ (widen/rewrite-bindings
+ name-map
+ bound-names
+ (map (lambda (expr) (graph/text->node graph expr)) binding-exprs)
+ (lambda (new-name-map names)
+ (let* ((which-map (if (eq? let-or-letrec 'LET) name-map new-name-map))
+ (value-exprs
+ (widen/flatten-expr* graph which-map binding-exprs)))
+ (if (not (= (length value-exprs) (length names)))
+ (internal-error "LET expansion error" (list names value-exprs)))
+ `((,let-or-letrec ,(map list names value-exprs)
+ ,(widen->expr graph new-name-map body))))))))
+
+(define-widen-handler LET (graph name-map LET-form bindings body)
+ (no-widening-allowed graph LET-form)
+ (widen/let-like graph name-map 'LET bindings body))
+
+(define-widen-handler LETREC (graph name-map LETREC-form bindings body)
+ (no-widening-allowed graph LETREC-form)
+ (widen/let-like graph name-map 'LETREC bindings body))
+
+;;; CONTAINERS: When a non-widenable closure is closed over a
+;;; widenable closure, we choose to pack and unpack the elements of
+;;; the widened closure in the single slot provided by the unwidened
+;;; one. An alternate (preferable?) choice would be to alter the
+;;; representation of the non-widenable closure to have extra slots,
+;;; but that would require transitively rewriting all references to
+;;; those closures.
+
+(define (widen/create-container exprs)
+ ;; We choose to use #F ('deleted-container just for now so we can see it)
+ ;; where it expands to 0 values, the value itself where it expands
+ ;; to one value, a pair for 2 values, and a vector for any other
+ ;; case.
+ (pp `("Creating container" ,(length exprs)))
+ (case (length exprs)
+ ;;((0) `'#F)
+ ((0) `'deleted-container)
+ ((1) (car exprs))
+ ((2) `(CALL ',%cons '#F ,(car exprs) ,(cadr exprs)))
+ (else `(CALL ',%vector '#F . ,exprs))))
+
+(define (widen/unwrap-container n expr)
+ ;; N is the number of items in the container, and EXPR is the
+ ;; expression that generates the container's value.
+ ;; NOTE: We expect RTL CSE to remove the redundant evaluations of EXPR.
+ ;;(pp `("Unwrapping containter (form below)" ,n))
+ ;;(kmp/pp expr)
+ (case n
+ ((0) '())
+ ((1) (list expr))
+ ((2) `((CALL ',car '#F ,expr)
+ (CALL ',cdr '#F ,expr)))
+ (else (let loop ((m (- n 1))
+ (result '()))
+ (if (negative? m)
+ result
+ (loop (- m 1)
+ `((CALL ',vector-ref '#F ,expr ',m) . ,result)))))))
+
+(define (no-CONT-allowed cont)
+ (if (not (equal? CONT ''#F))
+ (internal-error "No continuation allowed" cont)))
+
+(define (no-widening-allowed graph form)
+ (if (widen/rewrite? (graph/text->node graph form))
+ (internal-error "Widening non-widenable form" form)))
+
+(define (widen/handler/make-closure graph name-map form rator cont rands)
+ ;; (CALL ',%make-????-closure '#F <lambda-expr> 'VECTOR <value>*)
+ ;; -------- rator ----- cont ------------ rands ------------
+
+ (define (containerize exprs node)
+ ;; EXPRS are the expressions corresponding to the value for this NODE.
+ (if (widen/rewrite? node)
+ (if (not (= (length exprs)
+ (length (value/closure.representation node))))
+ (internal-error
+ "Representation mismatch of widened closed value" exprs node)
+ (widen/create-container exprs))
+ (if (not (singleton-list? exprs))
+ (internal-error
+ "Representation mismatch of non-widened closed value"
+ exprs node)
+ (car exprs))))
+
+ ;; If a closure is being widened, it is converted to just
+ ;; the rewritten <value>* expressions. Otherwise, any closed-over
+ ;; widenable closures must be converted to containers (see
+ ;; WIDEN/CREATE-CONTAINER, above).
+
+ (no-CONT-allowed cont)
+ (let ((value-exprs (cddr rands))
+ (the-closure-node (graph/text->node graph form)))
+ (let ((closure (node/unique-value the-closure-node))
+ (exprs (widen/expr* graph name-map value-exprs)))
+ (if (widen/rewrite? the-closure-node)
+ (let ((values (apply append exprs)))
+ (if (not (= (length values)
+ (length (value/closure.representation closure))))
+ (internal-error
+ "Representation mismatch of make-heap-closure"
+ rator rands values)
+ values))
+ `((CALL ,rator ,cont
+ ,(widen->expr graph name-map (car rands))
+ ,(cadr rands)
+ . ,(map containerize
+ exprs
+ (map node/unique-value
+ (vector->list (value/closure/location-nodes closure))))))))))
+
+(define (widen/handler/%make-heap-closure graph name-map form rator cont rands)
+ ;; (CALL ',%make-heap-closure '#F <lambda-expr> 'VECTOR <value>*)
+ ;; -------- rator ----- cont ------------ rands ------------
+ (no-CONT-allowed cont)
+ (widen/handler/make-closure graph name-map form rator cont rands))
+
+(define (widen/handler/%make-stack-closure
+ graph name-map form rator cont rands)
+ ;; (CALL ',%make-stack-closure '#F <lambda-expr or '#F> 'VECTOR <value>*)
+ ;; -------- rator ------ cont --------------- rands --------------
+ (no-CONT-allowed cont)
+ (widen/handler/make-closure graph name-map form rator cont rands))
+
+(define (widen/handler/%make-trivial-closure graph name-map form rator cont rands)
+ ;; (CALL ',%make-trivial-closure '#F <lambda-expression or LOOKUP>)
+ ;; --------- rator ------- cont ----------- rands ----------
+ (no-CONT-allowed cont)
+ (let ((the-closure-node (graph/text->node graph form)))
+ (if (widen/rewrite? the-closure-node)
+ '() ; Vanishes entirely!
+ `((CALL ,rator ,cont ,(widen->expr graph name-map (car rands)))))))
+
+(define (widen/closure-ref graph name-map form rator cont rands)
+ ;; (CALL ',%????-closure-ref '#F <closure> <offset> 'NAME)
+ ;; ------ rator ------ cont ------- rands ---------
+ ;; NOTE: <offset> is assumed not to require examination (i.e. it
+ ;; doesn't contain names that are remapped by the NAME-MAP)
+ (define (widen-closure-ref closure closure-exprs name)
+ (let ((rep-vector (list->vector (value/closure.representation closure)))
+ (name-map (value/closure.name-map closure)))
+ (if (not (= (vector-length rep-vector) (length closure-exprs)))
+ (internal-error "Closure didn't widen as expected"
+ closure closure-exprs rep-vector))
+ (let ((entry (assq name name-map)))
+ (if (not entry)
+ (internal-error "Closure doesn't have desired slot"
+ closure rep-vector name))
+ (map (lambda (name)
+ (list-ref closure-exprs (vector-index rep-vector name)))
+ (cdr entry)))))
+ (let ((my-value (graph/text->node graph form))
+ (closure-node (graph/text->node graph (car rands)))
+ (closure-exprs (widen/expr graph name-map (car rands))))
+ (if (widen/rewrite? closure-node)
+ (widen-closure-ref
+ (node/unique-value closure-node) closure-exprs (cadr (third rands)))
+ (if (not (singleton-list? closure-exprs))
+ (internal-error
+ "Unexpected widening of closure being dereferenced"
+ my-value closure-exprs)
+ (let ((slot-extractor `(CALL ,rator ,cont ,(car closure-exprs)
+ ,(second rands) ,(third rands))))
+ (if (widen/rewrite? my-value)
+ (let* ((result-closure (node/unique-value my-value))
+ (rep (value/closure.representation result-closure)))
+ (widen/unwrap-container (length rep) slot-extractor))
+ (list slot-extractor)))))))
+
+(define (widen/handler/%heap-closure-ref graph name-map form rator cont rands)
+ ;; (CALL ',%heap-closure-ref '#F <closure> <offset> 'NAME)
+ ;; ------ rator ------ cont ------- rands ---------
+ (no-CONT-allowed cont)
+ (widen/closure-ref graph name-map form rator cont rands))
+
+(define (widen/handler/%stack-closure-ref graph name-map form rator cont rands)
+ ;; (CALL ',%stack-closure-ref '#F <closure> <offset> 'NAME)
+ (no-CONT-allowed cont)
+ (widen/closure-ref graph name-map form rator cont rands))
+
+(define (widen/handler/%internal-apply
+ graph name-map form rator cont rands)
+ ;; (CALL ',%internal-apply <continuation> 'NARGS <procedure> <value>*)
+ ;; ------ rator ---- ------cont --- --------- rands -----------
+ form ; Not used
+ (let ((widened-operands
+ (widen/flatten-expr* graph name-map (cddr rands))))
+ `((CALL ,rator ,(widen->expr graph name-map cont)
+ ',(length widened-operands)
+ ,(widen->expr graph name-map (second rands))
+ . ,widened-operands))))
+
+(define (widen/handler/%fetch-stack-closure
+ graph name-map form rator cont rands)
+ ;; (CALL ',%fetch-stack-closure '#F 'VECTOR)
+ name-map rator rands ; Not used
+ (no-widening-allowed graph form)
+ (no-CONT-allowed cont)
+ (list form))
+
+;;;;;;;;;;;;;;;;;;;;; STEPHEN CHECK TO HERE
+
+(define (widen/handler/%fetch-continuation
+ graph name-map form rator cont rands)
+ ;; (CALL ',%fetch-continuation '#F)
+ name-map rator ; Not used
+ (no-CONT-allowed cont)
+ (no-widening-allowed graph form)
+ (if (not (null? rands))
+ (internal-error "FETCH-CONTINUATION with operands" form rands))
+ (list form))
+
+(define (widen/handler/%invoke-continuation
+ graph name-map form rator cont rands)
+ ;; (CALL ',%invoke-continuation <continuation> <value>*)
+ form ; Not used
+ `((CALL ,rator ,(widen->expr graph name-map cont)
+ . ,(widen/flatten-expr* graph name-map rands))))
+
+(define (widen/handler/default graph name-map form rator cont rands)
+ form ; Not used
+ `((CALL ,(widen->expr graph name-map rator)
+ ,(widen->expr graph name-map cont)
+ . ,(widen/flatten-expr* graph name-map rands))))
+
+(define-widen-handler CALL (graph name-map CALL-form rator cont #!rest rands)
+ (define (use method)
+ (method graph name-map CALL-form rator cont rands))
+ (if (QUOTE/? rator)
+ (let ((operator (QUOTE/text rator)))
+ (cond ((eq? operator %make-heap-closure)
+ (use widen/handler/%make-heap-closure))
+ ((eq? operator %make-stack-closure)
+ (use widen/handler/%make-stack-closure))
+ ((eq? operator %make-trivial-closure)
+ (use widen/handler/%make-trivial-closure))
+ ((eq? operator %heap-closure-ref)
+ (use widen/handler/%heap-closure-ref))
+ ((eq? operator %stack-closure-ref)
+ (use widen/handler/%stack-closure-ref))
+ ((eq? operator %internal-apply)
+ (use widen/handler/%internal-apply))
+ ((eq? operator %fetch-stack-closure)
+ (use widen/handler/%fetch-stack-closure))
+ ((eq? operator %fetch-continuation)
+ (use widen/handler/%fetch-continuation))
+ ((eq? operator %invoke-continuation)
+ (use widen/handler/%invoke-continuation))
+ (else (use widen/handler/default))))
+ (use widen/handler/default)))
+
+(define-widen-handler QUOTE (graph name-map QUOTE-form object)
+ graph name-map ; ignored
+ (no-widening-allowed graph QUOTE-form)
+ `((QUOTE ,object)))
+
+(define-widen-handler DECLARE (graph name-map DECLARE-form #!rest anything)
+ graph name-map
+ (no-widening-allowed graph DECLARE-form)
+ `((DECLARE ,@anything)))
+
+(define-widen-handler BEGIN (graph name-map BEGIN-form #!rest actions)
+ (define (separate l cont)
+ (if (null? l)
+ (cont '() '())
+ (let loop ((before '())
+ (after l))
+ (if (null? (cdr after))
+ (cont (reverse before) after)
+ (loop (cons (car after) before) (cdr after))))))
+ BEGIN-form ; Unused
+ (separate actions
+ (lambda (for-effect value)
+ (let ((for-effect-exprs (widen/flatten-expr* graph name-map for-effect))
+ (value-exprs (widen/flatten-expr* graph name-map value)))
+ (if (null? value-exprs)
+ (if (null? for-effect-exprs)
+ '() ; Vanishes entirely
+ (internal-error "BEGIN with effects and vanishing value"))
+ `((BEGIN ,@for-effect-exprs ,(car value-exprs))
+ ,@(cdr value-exprs)))))))
+
+(define-widen-handler IF (graph name-map IF-form pred conseq alt)
+ (no-widening-allowed graph IF-form)
+ `((IF ,(widen->expr graph name-map pred)
+ ,(widen->expr graph name-map conseq)
+ ,(widen->expr graph name-map alt))))
+
+(define-widen-handler SET! (graph name-map SET!-form name value)
+ (no-widening-allowed graph SET!-form)
+ (if (assq name name-map)
+ (internal-error "Widening SET! variable" name))
+ `((SET! ,name ,(widen->expr graph name-map value))))
+
+(define-widen-handler ACCESS (graph name-map ACCESS-form name env-expr)
+ (no-widening-allowed graph ACCESS-form)
+ (if (assq name name-map)
+ (internal-error "Widening ACCESS variable" name))
+ `((ACCESS ,name ,(widen->expr graph name-map env-expr))))
+
+(define-widen-handler UNASSIGNED? (graph name-map UNASSIGNED?-form name)
+ graph name-map ; ignored
+ (no-widening-allowed graph UNASSIGNED?-form)
+ (if (assq name name-map)
+ (internal-error "Widening UNASSIGNED? variable" name)
+ `((UNASSIGNED? ,name))))
+
+(define-widen-handler OR (graph name-map OR-form pred alt)
+ (no-widening-allowed graph OR-form)
+ `((OR ,(widen->expr graph name-map pred)
+ ,(widen->expr graph name-map alt))))
+
+(define-widen-handler DELAY (graph name-map DELAY-form expr)
+ (no-widening-allowed graph DELAY-form)
+ `((DELAY ,(widen->expr graph name-map expr))))
+
+(define-widen-handler DEFINE (graph name-map DEFINE-form name value)
+ (no-widening-allowed graph DEFINE-form)
+ `((DEFINE ,name ,(widen->expr graph name-map value))))
+
+(define-widen-handler IN-PACKAGE (graph name-map IN-PACKAGE-form envexpr bodyexpr)
+ (no-widening-allowed graph IN-PACKAGE-form)
+ `((IN-PACKAGE ,(widen->expr graph name-map envexpr)
+ ,(widen->expr graph name-map bodyexpr))))
+
+(define-widen-handler THE-ENVIRONMENT (graph name-map THE-ENVIRONMENT-form)
+ graph name-map ; Ignored
+ (no-widening-allowed graph THE-ENVIRONMENT-form)
+ `((THE-ENVIRONMENT)))
+\f
+(define widen/rewrite! 'LATER)
+(define widen/rewrite? 'LATER)
+(let ((*nodes-to-rewrite* (make-attribute)))
+ (set! widen/rewrite!
+ (lambda (node) (set-attribute! node *nodes-to-rewrite* #T)))
+ (set! widen/rewrite?
+ (lambda (node) (get-attribute node *nodes-to-rewrite*))))
+
+(define (rewrite-as-widened graph code widenable)
+ ;; Rewrite CODE after widening all references to the WIDENABLE closures. The
+ ;; widening is done by side-effecting CODE, and the rewritten CODE is
+ ;; returned.
+ (for-every widenable
+ (lambda (closure)
+ ;; Mark the closures and all nodes at which the value arrives as
+ ;; rewritable.
+ (widen/rewrite! closure)
+ (for-every (value/nodes closure) widen/rewrite!)))
+ (form/rewrite! code (widen->expr graph '() code))
+ code)
+
+(define (closure/closed-over-names closure)
+ (vector->list (value/closure/location-names closure)))
+
+(define (closure-constructor-text? text)
+ (or (CALL/%make-heap-closure? text)
+ (CALL/%make-trivial-closure? text)
+ (CALL/%make-stack-closure? text)))
+
+(define (closure-constructor-node? node)
+ (and (closure-constructor-text? (node/text node))
+ (string? (node/name node))))
+
+(define (closure-constructor-node/closed-expressions node)
+ (if (eq? 'TRIVIAL (value/closure/kind (node/unique-value node)))
+ '()
+ (cdr (cddddr (node/text node)))))
+
+(define (fetch-stack-closure-node? node)
+ (CALL/%fetch-stack-closure? (node/text node)))
+
+(define let-binding-node?
+ (let ((pattern `(LET ,(->pattern-variable 'BINDINGS)
+ ,(->pattern-variable 'BODY))))
+ (lambda (node)
+ (and
+ (form/match pattern (node/text node))
+ #T))))
+
+(define (closure-slot-node? node)
+ (and (closure-constructor-text? (node/text node))
+ (pair? (node/name node))))
+
+(define-integrable (singleton-list? x)
+ (and (pair? x)
+ (null? (cdr x))))
+
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/rtlbase/regset.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1988, 1990 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. |#
+
+;;;; RTL Register Sets
+
+(declare (usual-integrations))
+\f
+(define-integrable (make-regset n-registers)
+ (make-bit-string n-registers false))
+
+(define (for-each-regset-member regset procedure)
+ (let ((end (bit-string-length regset)))
+ (let loop ((start 0))
+ (let ((register (bit-substring-find-next-set-bit regset start end)))
+ (if register
+ (begin
+ (procedure register)
+ (loop (1+ register))))))))
+
+(define (regset->list regset)
+ (let ((end (bit-string-length regset)))
+ (let loop ((start 0))
+ (let ((register (bit-substring-find-next-set-bit regset start end)))
+ (if register
+ (cons register (loop (1+ register)))
+ '())))))
+
+(define-integrable (regset-clear! regset)
+ (bit-string-fill! regset false))
+
+(define-integrable (regset-disjoint? x y)
+ (regset-null? (regset-intersection x y)))
+
+(define-integrable regset-allocate bit-string-allocate)
+(define-integrable regset-adjoin! bit-string-set!)
+(define-integrable regset-delete! bit-string-clear!)
+(define-integrable regset-member? bit-string-ref)
+(define-integrable regset=? bit-string=?)
+(define-integrable regset-null? bit-string-zero?)
+
+(define-integrable regset-copy! bit-string-move!)
+(define-integrable regset-union! bit-string-or!)
+(define-integrable regset-difference! bit-string-andc!)
+(define-integrable regset-intersection! bit-string-and!)
+
+(define-integrable regset-copy bit-string-copy)
+(define-integrable regset-union bit-string-or)
+(define-integrable regset-difference bit-string-andc)
+(define-integrable regset-intersection bit-string-and)
+\f
+#| Alternate representation.
+
+(define-integrable (make-regset n-registers)
+ n-registers
+ (list 'REGSET))
+
+(define-integrable (regset-allocate n-registers)
+ n-registers
+ (list 'REGSET))
+
+(define-integrable (for-each-regset-member regset procedure)
+ (for-each procedure (cdr regset)))
+
+(define-integrable (regset->list regset)
+ (list-copy (cdr regset)))
+
+(define-integrable (regset-clear! regset)
+ (set-cdr! regset '()))
+
+(define-integrable (regset-disjoint? x y)
+ (eq-set-disjoint? (cdr x) (cdr y)))
+
+(define (regset-adjoin! regset register)
+ (if (not (memq register (cdr regset)))
+ (set-cdr! regset (cons register (cdr regset)))))
+
+(define (regset-delete! regset register)
+ (set-cdr! regset (delq register (cdr regset))))
+
+(define-integrable (regset-member? regset register)
+ (memq register (cdr regset)))
+
+(define-integrable (regset=? x y)
+ (eq-set-same-set? (cdr x) (cdr y)))
+
+(define-integrable (regset-null? regset)
+ (null? (cdr regset)))
+
+(define-integrable (regset-copy! destination source)
+ (set-cdr! destination (cdr source)))
+
+(define (regset-union! destination source)
+ (set-cdr! destination (eq-set-union (cdr source) (cdr destination))))
+
+(define (regset-difference! destination source)
+ (set-cdr! destination (eq-set-difference (cdr destination) (cdr source))))
+
+(define (regset-intersection! destination source)
+ (set-cdr! destination (eq-set-intersection (cdr source) (cdr destination))))
+
+(define-integrable regset-copy list-copy)
+
+(define-integrable (regset-union x y)
+ (cons 'REGSET (eq-set-union (cdr x) (cdr y))))
+
+(define-integrable (regset-difference x y)
+ (cons 'REGSET (eq-set-difference (cdr x) (cdr y))))
+
+(define-integrable (regset-intersection x y)
+ (cons 'REGSET (eq-set-intersection (cdr x) (cdr y))))
+
+|#
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rgraph.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; Program Graph Abstraction
+
+(declare (usual-integrations))
+\f
+(define-structure (rgraph (type vector)
+ (copier false)
+ (constructor make-rgraph (n-registers)))
+ n-registers
+ (entry-edges '())
+ (bblocks '())
+ register-bblock
+ register-n-refs
+ register-n-deaths
+ register-live-length
+ register-crosses-call?
+ register-value-classes
+ register-known-values
+ register-known-expressions)
+
+(define (add-rgraph-bblock! rgraph bblock)
+ (set-rgraph-bblocks! rgraph (cons bblock (rgraph-bblocks rgraph))))
+
+(define (delete-rgraph-bblock! rgraph bblock)
+ (set-rgraph-bblocks! rgraph (delq! bblock (rgraph-bblocks rgraph))))
+
+(define (add-rgraph-entry-edge! rgraph edge)
+ (set-rgraph-entry-edges! rgraph (cons edge (rgraph-entry-edges rgraph))))
+
+(define-integrable rgraph-register-renumber rgraph-register-bblock)
+(define-integrable set-rgraph-register-renumber! set-rgraph-register-bblock!)
+
+(define *rgraphs*)
+(define *current-rgraph*)
+
+(define (rgraph-initial-edges rgraph)
+ (list-transform-positive (rgraph-entry-edges rgraph)
+ (lambda (edge)
+ (node-previous=0? (edge-right-node edge)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlcfg.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; RTL CFG Nodes
+
+(declare (usual-integrations))
+\f
+(define-snode sblock)
+(define-pnode pblock)
+
+(define-vector-slots bblock 6
+ instructions
+ live-at-entry
+ live-at-exit
+ (new-live-at-exit register-map)
+ label
+ continuations)
+
+(define-vector-slots sblock 12
+ continuation)
+
+(define (make-sblock instructions)
+ (make-pnode sblock-tag instructions false false false false '() false))
+
+(define-vector-slots pblock 12
+ consequent-lap-generator
+ alternative-lap-generator)
+
+(define (make-pblock instructions)
+ (make-pnode pblock-tag instructions false false false false '() false false))
+
+(define-integrable (statement->srtl statement)
+ (snode->scfg (make-sblock (make-rtl-instruction statement))))
+
+(define-integrable (predicate->prtl predicate)
+ (pnode->pcfg (make-pblock (make-rtl-instruction predicate))))
+
+(let ((bblock-describe
+ (lambda (bblock)
+ (descriptor-list bblock
+ instructions
+ live-at-entry
+ live-at-exit
+ register-map
+ label
+ continuations))))
+ (set-vector-tag-description!
+ sblock-tag
+ (lambda (sblock)
+ (append! ((vector-tag-description snode-tag) sblock)
+ (bblock-describe sblock)
+ (descriptor-list sblock
+ continuation))))
+ (set-vector-tag-description!
+ pblock-tag
+ (lambda (pblock)
+ (append! ((vector-tag-description pnode-tag) pblock)
+ (bblock-describe pblock)
+ (descriptor-list pblock
+ consequent-lap-generator
+ alternative-lap-generator)))))
+\f
+(define-integrable (bblock-reversed-instructions bblock)
+ (rinst-reversed (bblock-instructions bblock)))
+
+(define (bblock-compress! bblock limit-predicate)
+ (let ((walk-next?
+ (if limit-predicate
+ (lambda (next) (and next (not (limit-predicate next))))
+ (lambda (next) next))))
+ (let walk-bblock ((bblock bblock))
+ (if (not (node-marked? bblock))
+ (begin
+ (node-mark! bblock)
+ (if (sblock? bblock)
+ (let ((next (snode-next bblock)))
+ (if (walk-next? next)
+ (begin
+ (if (null? (cdr (node-previous-edges next)))
+ (begin
+ (set-rinst-next!
+ (rinst-last (bblock-instructions bblock))
+ (bblock-instructions next))
+ (set-bblock-instructions!
+ next
+ (bblock-instructions bblock))
+ (snode-delete! bblock)))
+ (walk-bblock next))))
+ (begin
+ (let ((consequent (pnode-consequent bblock)))
+ (if (walk-next? consequent)
+ (walk-bblock consequent)))
+ (let ((alternative (pnode-alternative bblock)))
+ (if (walk-next? alternative)
+ (walk-bblock alternative))))))))))
+
+(define (bblock-walk-forward bblock procedure)
+ (let loop ((rinst (bblock-instructions bblock)))
+ (procedure rinst)
+ (if (rinst-next rinst) (loop (rinst-next rinst)))))
+
+(define (bblock-walk-backward bblock procedure)
+ (let loop ((rinst (bblock-instructions bblock)))
+ (if (rinst-next rinst) (loop (rinst-next rinst)))
+ (procedure rinst)))
+
+(define (bblock-label! bblock)
+ (or (bblock-label bblock)
+ (let ((label (generate-label)))
+ (set-bblock-label! bblock label)
+ label)))
+
+(define (bblock-perform-deletions! bblock)
+ (define (loop rinst)
+ (let ((next
+ (and (rinst-next rinst)
+ (loop (rinst-next rinst)))))
+ (if (rinst-rtl rinst)
+ (begin (set-rinst-next! rinst next)
+ rinst)
+ next)))
+ (let ((instructions (loop (bblock-instructions bblock))))
+ (if instructions
+ (set-bblock-instructions! bblock instructions)
+ (begin
+ (snode-delete! bblock)
+ (set-rgraph-bblocks! *current-rgraph*
+ (delq! bblock
+ (rgraph-bblocks *current-rgraph*)))))))
+\f
+(define-integrable (pcfg/prefer-consequent! pcfg)
+ (pcfg/prefer-branch! 'CONSEQUENT pcfg))
+
+(define-integrable (pcfg/prefer-alternative! pcfg)
+ (pcfg/prefer-branch! 'ALTERNATIVE pcfg))
+
+(define (pcfg/prefer-branch! branch pcfg)
+ (let loop ((bblock (cfg-entry-node pcfg)))
+ (cond ((pblock? bblock)
+ (pnode/prefer-branch! bblock branch))
+ ((sblock? bblock)
+ (loop (snode-next bblock)))
+ (else
+ (error "PCFG/PREFER-BRANCH!: Unknown bblock type" bblock))))
+ pcfg)
+
+(define (pnode/prefer-branch! pnode branch)
+ (if (not (eq? branch 'NEITHER))
+ (cfg-node-put! pnode cfg/prefer-branch/tag branch))
+ pnode)
+
+(define-integrable (pnode/preferred-branch pnode)
+ (cfg-node-get pnode cfg/prefer-branch/tag))
+
+(define cfg/prefer-branch/tag
+ (intern "#[(compiler)cfg/prefer-branch]"))
+
+;;;; RTL Instructions
+
+(define-vector-slots rinst 0
+ rtl
+ dead-registers
+ next)
+
+(define-integrable (make-rtl-instruction rtl)
+ (vector rtl '() false))
+
+(define-integrable (make-rtl-instruction* rtl next)
+ (vector rtl '() next))
+
+(define-integrable (rinst-dead-register? rinst register)
+ (memq register (rinst-dead-registers rinst)))
+
+(define (rinst-last rinst)
+ (if (rinst-next rinst)
+ (rinst-last (rinst-next rinst))
+ rinst))
+
+(define (rinst-disconnect-previous! bblock rinst)
+ (let loop ((rinst* (bblock-instructions bblock)))
+ (if (eq? rinst (rinst-next rinst*))
+ (set-rinst-next! rinst* false)
+ (loop (rinst-next rinst*)))))
+
+(define (rinst-length rinst)
+ (let loop ((rinst rinst) (length 0))
+ (if rinst
+ (loop (rinst-next rinst) (1+ length))
+ length)))
+
+(define (rinst-reversed rinst)
+ (let loop ((rinst rinst) (result '()))
+ (if rinst
+ (loop (rinst-next rinst) (cons rinst result))
+ result)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlcon.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1988-1993 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. |#
+
+;;;; Register Transfer Language: Complex Constructors
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;;; Statements
+
+(define (rtl:make-assignment locative expression)
+ (locative-dereference-for-statement locative
+ (lambda (locative)
+ (let ((receiver
+ (lambda (expression)
+ (rtl:make-assignment-internal locative expression))))
+ (if (rtl:pseudo-register-expression? locative)
+ (expression-simplify-for-pseudo-assignment expression receiver)
+ (expression-simplify-for-statement expression receiver))))))
+
+(define (rtl:make-assignment-internal locative expression)
+ (cond ((and (or (rtl:register? locative) (rtl:offset? locative))
+ (equal? locative expression))
+ (make-null-cfg))
+ ((or (rtl:register? locative) (rtl:register? expression))
+ (%make-assign locative expression))
+ (else
+ (let ((register (rtl:make-pseudo-register)))
+ (scfg*scfg->scfg! (%make-assign register expression)
+ (%make-assign locative register))))))
+
+(define (rtl:make-pop locative)
+ (locative-dereference-for-statement locative
+ (lambda (locative)
+ (rtl:make-assignment-internal locative (stack-pop-address)))))
+
+(define (rtl:make-push expression)
+ (expression-simplify-for-statement expression
+ (lambda (expression)
+ (rtl:make-assignment-internal (stack-push-address) expression))))
+
+(define (rtl:make-eq-test expression-1 expression-2)
+ (expression-simplify-for-predicate expression-1
+ (lambda (expression-1)
+ (expression-simplify-for-predicate expression-2
+ (lambda (expression-2)
+ (%make-eq-test expression-1 expression-2))))))
+
+;;(define (rtl:make-false-test expression)
+;; (rtl:make-eq-test expression (rtl:make-constant false)))
+(define (rtl:make-false-test expression)
+ (rtl:make-pred-1-arg 'FALSE? expression))
+
+(define (rtl:make-true-test expression)
+ (pcfg-invert (rtl:make-false-test expression)))
+
+(define (rtl:make-type-test expression type)
+ (expression-simplify-for-predicate expression
+ (lambda (expression)
+ (%make-type-test expression type))))
+
+(define (rtl:make-pred-1-arg predicate operand)
+ (expression-simplify-for-predicate operand
+ (lambda (operand)
+ (%make-pred-1-arg predicate operand))))
+
+(define (rtl:make-pred-2-args predicate operand1 operand2)
+ (expression-simplify-for-predicate operand1
+ (lambda (operand1)
+ (expression-simplify-for-predicate operand2
+ (lambda (operand2)
+ (%make-pred-2-args predicate operand1 operand2))))))
+
+(define (rtl:make-unassigned-test expression)
+ (rtl:make-eq-test
+ expression
+ (rtl:make-cons-non-pointer
+ (rtl:make-machine-constant (ucode-type unassigned))
+ (rtl:make-machine-constant 0))))
+\f
+
+(define (rtl:make-fixnum-pred-1-arg predicate operand)
+ (expression-simplify-for-predicate operand
+ (lambda (operand)
+ (%make-fixnum-pred-1-arg predicate operand))))
+
+(define (rtl:make-fixnum-pred-2-args predicate operand1 operand2)
+ (expression-simplify-for-predicate operand1
+ (lambda (operand1)
+ (expression-simplify-for-predicate operand2
+ (lambda (operand2)
+ (%make-fixnum-pred-2-args predicate operand1 operand2))))))
+
+(define (rtl:make-flonum-pred-1-arg predicate operand)
+ (expression-simplify-for-predicate operand
+ (lambda (operand)
+ (%make-flonum-pred-1-arg predicate operand))))
+
+(define (rtl:make-flonum-pred-2-args predicate operand1 operand2)
+ (expression-simplify-for-predicate operand1
+ (lambda (operand1)
+ (expression-simplify-for-predicate operand2
+ (lambda (operand2)
+ (%make-flonum-pred-2-args predicate operand1 operand2))))))
+
+(define (rtl:make-push-return continuation)
+ (rtl:make-push
+ (rtl:make-cons-pointer (rtl:make-machine-constant type-code:compiled-entry)
+ (rtl:make-entry:continuation continuation))))
+
+(define (rtl:make-push-link)
+ (rtl:make-push
+ (rtl:make-environment (rtl:make-fetch register:dynamic-link))))
+
+(define (rtl:make-pop-link)
+ (rtl:make-assignment register:dynamic-link
+ (rtl:make-object->address (stack-pop-address))))
+
+(define (rtl:make-stack-pointer->link)
+ (rtl:make-assignment register:dynamic-link
+ (rtl:make-fetch register:stack-pointer)))
+
+(define (rtl:make-link->stack-pointer)
+ (rtl:make-assignment register:stack-pointer
+ (rtl:make-fetch register:dynamic-link)))
+
+(define (rtl:make-constant value)
+ (if (unassigned-reference-trap? value)
+ (rtl:make-cons-non-pointer
+ (rtl:make-machine-constant type-code:unassigned)
+ (rtl:make-machine-constant 0))
+ (%make-constant value)))
+
+\f
+;;; Interpreter Calls
+
+(define rtl:make-interpreter-call:access)
+(define rtl:make-interpreter-call:unassigned?)
+(define rtl:make-interpreter-call:unbound?)
+(let ((interpreter-lookup-maker
+ (lambda (%make)
+ (lambda (cont environment name)
+ (expression-simplify-for-statement environment
+ (lambda (environment)
+ (%make cont environment name)))))))
+ (set! rtl:make-interpreter-call:access
+ (interpreter-lookup-maker %make-interpreter-call:access))
+ (set! rtl:make-interpreter-call:unassigned?
+ (interpreter-lookup-maker %make-interpreter-call:unassigned?))
+ (set! rtl:make-interpreter-call:unbound?
+ (interpreter-lookup-maker %make-interpreter-call:unbound?)))
+
+(define rtl:make-interpreter-call:define)
+(define rtl:make-interpreter-call:set!)
+(let ((interpreter-assignment-maker
+ (lambda (%make)
+ (lambda (cont environment name value)
+ (expression-simplify-for-statement value
+ (lambda (value)
+ (expression-simplify-for-statement environment
+ (lambda (environment)
+ (%make cont environment name value)))))))))
+ (set! rtl:make-interpreter-call:define
+ (interpreter-assignment-maker %make-interpreter-call:define))
+ (set! rtl:make-interpreter-call:set!
+ (interpreter-assignment-maker %make-interpreter-call:set!)))
+
+(define (rtl:make-interpreter-call:lookup cont environment name safe?)
+ (expression-simplify-for-statement environment
+ (lambda (environment)
+ (%make-interpreter-call:lookup cont environment name safe?))))
+
+(define (rtl:make-interpreter-call:cache-assignment cont name value)
+ (expression-simplify-for-statement name
+ (lambda (name)
+ (expression-simplify-for-statement value
+ (lambda (value)
+ (%make-interpreter-call:cache-assignment cont name value))))))
+
+(define (rtl:make-interpreter-call:cache-reference cont name safe?)
+ (expression-simplify-for-statement name
+ (lambda (name)
+ (%make-interpreter-call:cache-reference cont name safe?))))
+
+(define (rtl:make-interpreter-call:cache-unassigned? cont name)
+ (expression-simplify-for-statement name
+ (lambda (name)
+ (%make-interpreter-call:cache-unassigned? cont name))))
+\f
+;;;; Expression Simplification
+
+(package (locative-dereference-for-statement
+ expression-simplify-for-statement
+ expression-simplify-for-predicate
+ expression-simplify-for-pseudo-assignment)
+
+(define-export (locative-dereference-for-statement locative receiver)
+ (locative-dereference locative scfg*scfg->scfg!
+ receiver
+ (lambda (register offset granularity)
+ (receiver (make-offset register offset granularity)))))
+
+(define-export (expression-simplify-for-statement expression receiver)
+ (expression-simplify expression scfg*scfg->scfg! receiver))
+
+(define-export (expression-simplify-for-predicate expression receiver)
+ (expression-simplify expression scfg*pcfg->pcfg! receiver))
+
+(define-export (expression-simplify-for-pseudo-assignment expression receiver)
+ (let ((entry (assq (car expression) expression-methods)))
+ (if entry
+ (apply (cdr entry) receiver scfg*scfg->scfg! (cdr expression))
+ (receiver expression))))
+
+(define (expression-simplify expression scfg-append! receiver)
+ (if (rtl:register? expression)
+ (receiver expression)
+ (let ((entry (assq (car expression) expression-methods)))
+ (if entry
+ (apply (cdr entry)
+ (lambda (expression)
+ (if (rtl:register? expression)
+ (receiver expression)
+ (assign-to-temporary expression
+ scfg-append!
+ receiver)))
+ scfg-append!
+ (cdr expression))
+ (assign-to-temporary expression scfg-append! receiver)))))
+
+(define (simplify-expressions expressions scfg-append! generator)
+ (let loop ((expressions* expressions) (simplified-expressions '()))
+ (if (null? expressions*)
+ (generator (reverse! simplified-expressions))
+ (expression-simplify (car expressions*) scfg-append!
+ (lambda (expression)
+ (loop (cdr expressions*)
+ (cons expression simplified-expressions)))))))
+
+(define (assign-to-temporary expression scfg-append! receiver)
+ (let ((pseudo (rtl:make-pseudo-register)))
+ (scfg-append! (rtl:make-assignment-internal pseudo expression)
+ (receiver pseudo))))
+
+(define (make-offset register offset granularity)
+ (case granularity
+ ((OBJECT)
+ (rtl:make-offset register (rtl:make-machine-constant offset)))
+ ((BYTE)
+ (rtl:make-byte-offset register (rtl:make-machine-constant offset)))
+ ((FLOAT)
+ (rtl:make-float-offset register (rtl:make-machine-constant offset)))
+ (else
+ (error "unknown offset granularity" granularity))))
+
+(define (make-offset-address register offset granularity)
+ (case granularity
+ ((OBJECT)
+ (rtl:make-offset-address register offset))
+ ((BYTE)
+ (rtl:make-byte-offset-address register offset))
+ ((FLOAT)
+ (rtl:make-float-offset-address register offset))
+ (else
+ (error "unknown offset granularity" granularity))))
+\f
+(define (locative-dereference locative scfg-append! if-register if-memory)
+ (let ((dereference-fetch
+ (lambda (locative offset granularity)
+ (let ((if-address
+ (lambda (address)
+ (if-memory address offset granularity))))
+ (let ((if-not-address
+ (lambda (register)
+ (assign-to-address-temporary register
+ scfg-append!
+ if-address))))
+ (locative-dereference (cadr locative) scfg-append!
+ (lambda (expression)
+ (let ((register (rtl:register-number expression)))
+ (if (and (machine-register? register)
+ (register-value-class=address? register))
+ (if-address expression)
+ (if-not-address expression))))
+ (lambda (register offset granularity)
+ (assign-to-temporary
+ (make-offset register offset granularity)
+ scfg-append!
+ if-not-address)))))))
+ (dereference-constant
+ (lambda (locative offset granularity)
+ (assign-to-temporary locative scfg-append!
+ (lambda (register)
+ (assign-to-address-temporary register scfg-append!
+ (lambda (register)
+ (if-memory register offset granularity))))))))
+ (cond ((symbol? locative)
+ (let ((register (rtl:machine-register? locative)))
+ (if register
+ (if-register register)
+ (if-memory (interpreter-regs-pointer)
+ (rtl:interpreter-register->offset locative)
+ 'OBJECT))))
+ ((pair? locative)
+ (case (car locative)
+ ((REGISTER)
+ (if-register locative))
+ ((FETCH)
+ (dereference-fetch locative 0 'OBJECT))
+ ((OFFSET)
+ (let ((base (rtl:locative-offset-base locative))
+ (offset (rtl:locative-offset-offset locative))
+ (granularity (rtl:locative-offset-granularity locative)))
+ (if (not (pair? base))
+ (error "offset base not pair" locative))
+ (case (car base)
+ ((FETCH)
+ (dereference-fetch base offset granularity))
+ ((CONSTANT)
+ (dereference-constant base offset granularity))
+ ((INDEX)
+ (locative-dereference
+ base
+ scfg-append!
+ (lambda (reg)
+ (error "Can't be a reg" locative reg))
+ (lambda (base* zero granularity*)
+ zero granularity* ; ignored
+ (if-memory base* offset granularity))))
+ ((OFFSET)
+ (locative-dereference
+ base
+ scfg-append!
+ (lambda (reg)
+ (error "Can't be a reg" locative reg))
+ (lambda (base* offset* granularity*)
+ (assign-to-temporary
+ (make-offset-address
+ base*
+ (rtl:make-machine-constant offset*)
+ granularity*)
+ scfg-append!
+ (lambda (base-reg)
+ (if-memory base-reg offset granularity))))))
+ (else
+ (error "illegal offset base" locative)))))
+ ((INDEX)
+ (let ((base (rtl:locative-index-base locative))
+ (offset (rtl:locative-index-offset locative))
+ (granularity (rtl:locative-index-granularity locative)))
+ (define (finish base-reg-expr offset-expr)
+ (assign-to-temporary
+ (make-offset-address base-reg-expr offset-expr granularity)
+ scfg-append!
+ (lambda (loc-reg-expr)
+ ;; granularity ok?
+ (if-memory loc-reg-expr 0 granularity))))
+ (expression-simplify
+ offset
+ scfg-append!
+ (lambda (offset-expr)
+ (locative-dereference
+ base
+ scfg-append!
+ (lambda (base-reg-expr)
+ (finish base-reg-expr offset-expr))
+ (lambda (base*-reg-expr offset* granularity*)
+ (if (zero? offset*)
+ (finish base*-reg-expr offset-expr)
+ (assign-to-temporary
+ (make-offset-address
+ base*-reg-expr
+ (rtl:make-machine-constant offset*)
+ granularity*)
+ scfg-append!
+ (lambda (loc-reg-expr)
+ (finish loc-reg-expr offset-expr))))))))))
+ ((CONSTANT)
+ (dereference-constant locative 0 'OBJECT))
+ (else
+ (error "unknown keyword" locative))))
+ (else
+ (error "illegal locative" locative)))))
+
+(define (assign-to-address-temporary expression scfg-append! receiver)
+ (let ((pseudo (rtl:make-pseudo-register)))
+ (scfg-append!
+ (rtl:make-assignment-internal pseudo
+ (rtl:make-object->address expression))
+ (receiver pseudo))))
+\f
+(define (define-expression-method name method)
+ (let ((entry (assq name expression-methods)))
+ (if entry
+ (set-cdr! entry method)
+ (set! expression-methods
+ (cons (cons name method) expression-methods))))
+ name)
+
+(define expression-methods
+ '())
+
+(define-expression-method 'FETCH
+ (lambda (receiver scfg-append! locative)
+ (locative-dereference locative scfg-append!
+ receiver
+ (lambda (register offset granularity)
+ (receiver (make-offset register offset granularity))))))
+
+(define (address-method generator)
+ (lambda (receiver scfg-append! locative)
+ (locative-dereference locative scfg-append!
+ (lambda (register)
+ register
+ (error "Can't take ADDRESS of a register" locative))
+ (generator receiver scfg-append!))))
+
+(define-expression-method 'ADDRESS
+ (address-method
+ (lambda (receiver scfg-append!)
+ scfg-append! ;ignore
+ (lambda (address offset granularity)
+ (receiver
+ (case granularity
+ ((OBJECT)
+ (if (zero? offset)
+ address
+ (rtl:make-offset-address address
+ (rtl:make-machine-constant offset))))
+ ((BYTE)
+ (rtl:make-byte-offset-address address
+ (rtl:make-machine-constant offset)))
+ ((FLOAT)
+ (rtl:make-float-offset-address address
+ (rtl:make-machine-constant offset)))
+ (else
+ (error "ADDRESS: Unknown granularity" granularity))))))))
+
+(define-expression-method 'ENVIRONMENT
+ (address-method
+ (lambda (receiver scfg-append!)
+ (lambda (address offset granularity)
+ (if (not (eq? granularity 'OBJECT))
+ (error "can't take address of non-object offset" granularity))
+ (let ((receiver
+ (lambda (address)
+ (expression-simplify
+ (rtl:make-cons-pointer
+ (rtl:make-machine-constant (ucode-type stack-environment))
+ address)
+ scfg-append!
+ receiver))))
+ (if (zero? offset)
+ (receiver address)
+ (assign-to-temporary
+ (rtl:make-offset-address address
+ (rtl:make-machine-constant offset))
+ scfg-append!
+ receiver)))))))
+
+(define-expression-method 'CONS-POINTER
+ (lambda (receiver scfg-append! type datum)
+ (expression-simplify type scfg-append!
+ (lambda (type)
+ (expression-simplify datum scfg-append!
+ (lambda (datum)
+ (receiver (rtl:make-cons-pointer type datum))))))))
+
+(define-expression-method 'CONS-NON-POINTER
+ (lambda (receiver scfg-append! type datum)
+ (expression-simplify type scfg-append!
+ (lambda (type)
+ (expression-simplify datum scfg-append!
+ (lambda (datum)
+ (receiver (rtl:make-cons-non-pointer type datum))))))))
+\f
+;;
+;; The two allocation schemes are:
+;;
+;; *free++ = r1
+;; ...
+;; *free++ = rk
+;; rx = (offset-address free -k)
+;; result = (cons-pointer type rx)
+;;
+;; and
+;;
+;; free[0] = r1
+;; ...
+;; free[k-1] = rk
+;; result = (cons-pointer type free)
+;; free = (offset-address free k)
+
+
+(define (store-element! free element offset)
+ (if use-pre/post-increment?
+ (rtl:make-assignment-internal
+ (rtl:make-post-increment free 1)
+ element)
+ (rtl:make-assignment-internal
+ (rtl:make-offset free (rtl:make-machine-constant offset))
+ element)))
+
+(define (finish-allocation free type words receiver)
+ (expression-simplify type scfg-append!
+ (lambda (type)
+ (if use-pre/post-increment?
+ (assign-to-temporary
+ (rtl:make-offset-address free (rtl:make-machine-constant (- words)))
+ scfg-append!
+ (lambda (temporary)
+ (assign-to-temporary
+ (rtl:make-cons-pointer type temporary)
+ scfg-append!
+ receiver)))
+ (scfg-append!
+ (assign-to-temporary
+ (rtl:make-cons-pointer type free)
+ scfg-append!
+ (lambda (the-new-object)
+ (scfg-append!
+ (rtl:make-assignment-internal
+ free
+ (rtl:make-offset-address free
+ (rtl:make-machine-constant words)))
+ (receiver the-new-object)))))))))
+
+
+(define-expression-method 'CELL-CONS
+ (lambda (receiver scfg-append! expression)
+ (expression-simplify expression scfg-append!
+ (lambda (expression)
+ (let ((free (interpreter-free-pointer)))
+ (scfg-append!
+ (store-element! free expression 0)
+ (finish-allocation free
+ (rtl:make-machine-constant type-code:cell)
+ 1 receiver)))))))
+
+
+(define-expression-method 'TYPED-CONS:PAIR
+ (lambda (receiver scfg-append! type car cdr)
+ (let ((free (interpreter-free-pointer)))
+ (expression-simplify car scfg-append!
+ (lambda (car)
+ (expression-simplify cdr scfg-append!
+ (lambda (cdr)
+ (scfg-append!
+ (store-element! free car 0)
+ (scfg-append!
+ (store-element! free cdr 1)
+ (finish-allocation free type 2 receiver))))))))))
+
+\f
+(define-expression-method 'TYPED-CONS:VECTOR
+ (lambda (receiver scfg-append! type . elements)
+ (let ((nelements (length elements)))
+ (if (> nelements (-1+ (number-of-available-word-registers)))
+ (simplify-cons-long-vector nelements receiver
+ scfg-append! type elements)
+ (let* ((free (interpreter-free-pointer)))
+ (simplify-expressions elements scfg-append!
+ (lambda (elements)
+ (expression-simplify
+ (rtl:make-cons-non-pointer
+ (rtl:make-machine-constant
+ (ucode-type manifest-vector))
+ (rtl:make-machine-constant (length elements)))
+ scfg-append!
+ (lambda (header)
+ (assign-to-temporary header scfg-append!
+ (lambda (header-temporary)
+ (scfg-append!
+ (store-element! free header-temporary 0)
+ (let loop ((elements elements) (offset 1))
+ (if (null? elements)
+ (finish-allocation free type offset receiver)
+ (scfg-append!
+ (store-element! free (car elements) offset)
+ (loop (cdr elements)
+ (+ offset 1)))))))))))))))))
+\f
+(define (simplify-cons-long-vector nelements receiver
+ scfg-append! type elements)
+ (let* ((chunk-size (-1+ (number-of-available-word-registers)))
+ (free (interpreter-free-pointer))
+ (nchunks (quotient (+ nelements (-1+ chunk-size)) chunk-size)))
+
+ (define (do-chunk elements offset tail)
+ (simplify-expressions elements scfg-append!
+ (lambda (elements)
+ (let loop ((elements elements) (offset offset))
+ (if (null? elements)
+ tail
+ (scfg-append! (store-element! free (car elements) offset)
+ (loop (cdr elements)
+ (1+ offset))))))))
+
+ (expression-simplify
+ (rtl:make-cons-non-pointer
+ (rtl:make-machine-constant
+ (ucode-type manifest-vector))
+ (rtl:make-machine-constant (length elements)))
+ scfg-append!
+ (lambda (header)
+ (scfg-append!
+ (store-element! free header 0)
+ (let process ((elements elements)
+ (offset 1)
+ (chunk 1))
+ (if (= chunk nchunks)
+ (do-chunk elements
+ offset
+ (finish-allocation
+ free type (1+ nelements) receiver))
+ (do-chunk (list-head elements chunk-size)
+ offset
+ (process (list-tail elements chunk-size)
+ (+ offset chunk-size)
+ (1+ chunk))))))))))
+\f
+;; This re-caches and re-computes if we change the number of registers
+
+(define number-of-available-word-registers
+ (let ((reg-list false)
+ (value false))
+ (lambda ()
+ (if (and value
+ (eq? reg-list available-machine-registers))
+ value
+ (begin
+ (set! reg-list available-machine-registers)
+ (set! value
+ (length (list-transform-positive reg-list
+ (lambda (reg)
+ (value-class=word?
+ (machine-register-value-class reg))))))
+ value)))))
+
+(define-expression-method 'TYPED-CONS:PROCEDURE
+ (lambda (receiver scfg-append! entry)
+ (expression-simplify
+ entry scfg-append!
+ (lambda (entry)
+ (receiver (rtl:make-cons-pointer
+ (rtl:make-machine-constant type-code:compiled-entry)
+ entry))))))
+
+(define-expression-method 'BYTE-OFFSET-ADDRESS
+ (lambda (receiver scfg-append! base offset)
+ (expression-simplify
+ base scfg-append!
+ (lambda (base)
+ (expression-simplify
+ offset scfg-append!
+ (lambda (offset)
+ (receiver (rtl:make-byte-offset-address base offset))))))))
+
+(define-expression-method 'FLOAT-OFFSET-ADDRESS
+ (lambda (receiver scfg-append! base offset)
+ (expression-simplify
+ base scfg-append!
+ (lambda (base)
+ (expression-simplify
+ offset scfg-append!
+ (lambda (offset)
+ (receiver (rtl:make-float-offset-address base offset))))))))
+
+;; NOPs for simplification
+
+(define-expression-method 'ENTRY:CONTINUATION
+ (lambda (receiver scfg-append! label)
+ scfg-append! ; unused
+ (receiver (rtl:make-entry:continuation label))))
+
+(define-expression-method 'ENTRY:PROCEDURE
+ (lambda (receiver scfg-append! label)
+ scfg-append! ; unused
+ (receiver (rtl:make-entry:procedure label))))
+
+(define-expression-method 'CONS-CLOSURE
+ (lambda (receiver scfg-append! entry min max size)
+ scfg-append! ; unused
+ (receiver (rtl:make-cons-closure entry min max size))))
+
+(define-expression-method 'CONS-MULTICLOSURE
+ (lambda (receiver scfg-append! nentries size entries)
+ scfg-append! ; unused
+ (receiver (rtl:make-cons-multiclosure nentries size entries))))
+\f
+(define (object-selector make-object-selector)
+ (lambda (receiver scfg-append! expression)
+ (expression-simplify expression scfg-append!
+ (lambda (expression)
+ (receiver (make-object-selector expression))))))
+
+(define-expression-method 'OBJECT->TYPE
+ (object-selector rtl:make-object->type))
+
+(define-expression-method 'CHAR->ASCII
+ (object-selector rtl:make-char->ascii))
+
+(define-expression-method 'OBJECT->DATUM
+ (object-selector rtl:make-object->datum))
+
+(define-expression-method 'OBJECT->ADDRESS
+ (object-selector rtl:make-object->address))
+
+(define-expression-method 'FIXNUM->OBJECT
+ (object-selector rtl:make-fixnum->object))
+
+(define-expression-method 'FIXNUM->ADDRESS
+ (object-selector rtl:make-fixnum->address))
+
+(define-expression-method 'ADDRESS->FIXNUM
+ (object-selector rtl:make-address->fixnum))
+
+(define-expression-method 'OBJECT->FIXNUM
+ (object-selector rtl:make-object->fixnum))
+
+(define-expression-method 'OBJECT->UNSIGNED-FIXNUM
+ (object-selector rtl:make-object->unsigned-fixnum))
+
+(define-expression-method 'FLOAT->OBJECT
+ (object-selector rtl:make-float->object))
+
+(define-expression-method 'OBJECT->FLOAT
+ (object-selector rtl:make-object->float))
+
+(define-expression-method 'FIXNUM-2-ARGS
+ (lambda (receiver scfg-append! operator operand1 operand2 overflow?)
+ (expression-simplify operand1 scfg-append!
+ (lambda (operand1)
+ (expression-simplify operand2 scfg-append!
+ (lambda (operand2)
+ (receiver
+ (rtl:make-fixnum-2-args operator
+ operand1
+ operand2
+ overflow?))))))))
+
+(define-expression-method 'FIXNUM-1-ARG
+ (lambda (receiver scfg-append! operator operand overflow?)
+ (expression-simplify operand scfg-append!
+ (lambda (operand)
+ (receiver (rtl:make-fixnum-1-arg operator operand overflow?))))))
+
+(define-expression-method 'FLONUM-1-ARG
+ (lambda (receiver scfg-append! operator operand overflow?)
+ (expression-simplify operand scfg-append!
+ (lambda (s-operand)
+ (receiver (rtl:make-flonum-1-arg
+ operator
+ s-operand
+ overflow?))))))
+
+(define-expression-method 'FLONUM-2-ARGS
+ (lambda (receiver scfg-append! operator operand1 operand2 overflow?)
+ (expression-simplify operand1 scfg-append!
+ (lambda (s-operand1)
+ (expression-simplify operand2 scfg-append!
+ (lambda (s-operand2)
+ (receiver (rtl:make-flonum-2-args
+ operator
+ s-operand1
+ s-operand2
+ overflow?))))))))
+
+;;; end EXPRESSION-SIMPLIFY package
+)
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlexp.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; Register Transfer Language: Expression Operations
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+(define (rtl:invocation? rtl)
+ (memq (rtl:expression-type rtl)
+ '(INVOCATION:APPLY
+ INVOCATION:JUMP
+ INVOCATION:COMPUTED-JUMP
+ INVOCATION:LEXPR
+ INVOCATION:COMPUTED-LEXPR
+ INVOCATION:PRIMITIVE
+ INVOCATION:SPECIAL-PRIMITIVE
+ INVOCATION:UUO-LINK
+ INVOCATION:GLOBAL-LINK
+ INVOCATION:CACHE-REFERENCE
+ INVOCATION:LOOKUP
+ INVOCATION:REGISTER
+ INVOCATION:PROCEDURE
+ INVOCATION:NEW-APPLY)))
+
+(define (rtl:invocation-prefix? rtl)
+ (memq (rtl:expression-type rtl)
+ '(INVOCATION-PREFIX:DYNAMIC-LINK
+ INVOCATION-PREFIX:MOVE-FRAME-UP)))
+
+(define (rtl:expression-value-class expression)
+ (case (rtl:expression-type expression)
+ ((REGISTER)
+ (register-value-class (rtl:register-number expression)))
+ ((CONS-NON-POINTER CONS-POINTER CONSTANT FIXNUM->OBJECT FLOAT->OBJECT
+ GENERIC-BINARY GENERIC-UNARY OFFSET POST-INCREMENT
+ PRE-INCREMENT)
+ value-class=object)
+ ((FIXNUM->ADDRESS OBJECT->ADDRESS
+ ASSIGNMENT-CACHE VARIABLE-CACHE
+ OFFSET-ADDRESS
+ FLOAT-OFFSET-ADDRESS
+ BYTE-OFFSET-ADDRESS
+ STATIC-CELL ALIGN-FLOAT)
+ value-class=address)
+ ((CONS-CLOSURE CONS-MULTICLOSURE ENTRY:CONTINUATION ENTRY:PROCEDURE)
+ (if untagged-entries?
+ value-class=object
+ value-class=address))
+ ((MACHINE-CONSTANT)
+ value-class=immediate)
+ ((BYTE-OFFSET CHAR->ASCII)
+ value-class=ascii)
+ ((OBJECT->DATUM)
+ value-class=datum)
+ ((ADDRESS->FIXNUM FIXNUM-1-ARG FIXNUM-2-ARGS OBJECT->FIXNUM
+ OBJECT->UNSIGNED-FIXNUM)
+ value-class=fixnum)
+ ((OBJECT->TYPE)
+ value-class=type)
+ ((OBJECT->FLOAT FLONUM-1-ARG FLONUM-2-ARGS FLOAT-OFFSET)
+ value-class=float)
+ ((COERCE-VALUE-CLASS)
+ (case (rtl:coerce-value-class-class expression)
+ ((ADDRESS) value-class=address)
+ (else (error "Unknown value class coercion:" expression))))
+ (else
+ (error "Unknown RTL expression type:" expression))))
+
+(define (rtl:object-valued-expression? expression)
+ (value-class=object? (rtl:expression-value-class expression)))
+
+(define (rtl:volatile-expression? expression)
+ (memq (rtl:expression-type expression) '(POST-INCREMENT PRE-INCREMENT)))
+
+(define (rtl:machine-register-expression? expression)
+ (and (rtl:register? expression)
+ (machine-register? (rtl:register-number expression))))
+
+(define (rtl:pseudo-register-expression? expression)
+ (and (rtl:register? expression)
+ (pseudo-register? (rtl:register-number expression))))
+
+(define (rtl:stack-reference-expression? expression)
+ (and (rtl:offset? expression)
+ (interpreter-stack-pointer? (rtl:offset-base expression))))
+
+(define (rtl:register-assignment? rtl)
+ (and (rtl:assign? rtl)
+ (rtl:register? (rtl:assign-address rtl))))
+\f
+(define (rtl:expression-cost expression)
+ (if (rtl:register? expression)
+ 1
+ (or (rtl:constant-cost expression)
+ (let loop ((parts (cdr expression)) (cost 2))
+ (if (null? parts)
+ cost
+ (loop (cdr parts)
+ (if (pair? (car parts))
+ (+ cost (rtl:expression-cost (car parts)))
+ cost)))))))
+
+(define (rtl:map-subexpressions expression procedure)
+ (if (rtl:constant? expression)
+ expression
+ (cons (car expression)
+ (map (lambda (x)
+ (if (pair? x)
+ (procedure x)
+ x))
+ (cdr expression)))))
+
+(define (rtl:for-each-subexpression expression procedure)
+ (if (not (rtl:constant? expression))
+ (for-each (lambda (x)
+ (if (pair? x)
+ (procedure x)))
+ (cdr expression))))
+
+(define (rtl:any-subexpression? expression predicate)
+ (and (not (rtl:constant? expression))
+ (there-exists? (cdr expression)
+ (lambda (x)
+ (and (pair? x)
+ (predicate x))))))
+
+(define (rtl:expression-contains? expression predicate)
+ (let loop ((expression expression))
+ (or (predicate expression)
+ (rtl:any-subexpression? expression loop))))
+
+(define (rtl:all-subexpressions? expression predicate)
+ (or (rtl:constant? expression)
+ (for-all? (cdr expression)
+ (lambda (x)
+ (or (not (pair? x))
+ (predicate x))))))
+
+(define (rtl:reduce-subparts expression operator initial if-expression if-not)
+ (let ((remap
+ (if (rtl:constant? expression)
+ if-not
+ (lambda (x)
+ (if (pair? x)
+ (if-expression x)
+ (if-not x))))))
+ (let loop ((parts (cdr expression)) (accum initial))
+ (if (null? parts)
+ accum
+ (loop (cdr parts)
+ (operator accum (remap (car parts))))))))
+
+(define (rtl:expression=? x y)
+ (let ((type (car x)))
+ (and (eq? type (car y))
+ (if (eq? type 'CONSTANT)
+ (eqv? (cadr x) (cadr y))
+ (let loop ((x (cdr x)) (y (cdr y)))
+ ;; Because of fixed format, all expressions of same
+ ;; type have the same length, and each entry is either
+ ;; a subexpression or a non-expression.
+ (or (null? x)
+ (and (if (pair? (car x))
+ (rtl:expression=? (car x) (car y))
+ (eqv? (car x) (car y)))
+ (loop (cdr x) (cdr y)))))))))
+\f
+(define (rtl:match-subexpressions x y predicate)
+ (let ((type (car x)))
+ (and (eq? type (car y))
+ (if (eq? type 'CONSTANT)
+ (eqv? (cadr x) (cadr y))
+ (let loop ((x (cdr x)) (y (cdr y)))
+ (or (null? x)
+ (and (if (pair? (car x))
+ (predicate (car x) (car y))
+ (eqv? (car x) (car y)))
+ (loop (cdr x) (cdr y)))))))))
+
+(define (rtl:refers-to-register? rtl register)
+ (let loop
+ ((expression
+ (if (rtl:register-assignment? rtl) (rtl:assign-expression rtl) rtl)))
+ (cond ((not (pair? expression)) false)
+ ((rtl:register? expression)
+ (= (rtl:register-number expression) register))
+ ((rtl:contains-no-substitutable-registers? expression) false)
+ (else (there-exists? (cdr expression) loop)))))
+
+(define (rtl:subst-register rtl register substitute)
+ (letrec
+ ((loop
+ (lambda (expression)
+ (cond ((not (pair? expression)) expression)
+ ((rtl:register? expression)
+ (if (= (rtl:register-number expression) register)
+ substitute
+ expression))
+ ((rtl:contains-no-substitutable-registers? expression)
+ expression)
+ (else (cons (car expression) (map loop (cdr expression))))))))
+ (if (rtl:register-assignment? rtl)
+ (list (rtl:expression-type rtl)
+ (rtl:assign-address rtl)
+ (loop (rtl:assign-expression rtl)))
+ (loop rtl))))
+
+(define (rtl:substitutable-registers rtl)
+ (if (rtl:register-assignment? rtl)
+ (rtl:substitutable-registers (rtl:assign-expression rtl))
+ (let outer ((expression rtl) (registers '()))
+ (cond ((not (pair? expression)) registers)
+ ((rtl:register? expression)
+ (let ((register (rtl:register-number expression)))
+ (if (memq register registers)
+ registers
+ (cons register registers))))
+ ((rtl:contains-no-substitutable-registers? expression) registers)
+ (else
+ (let inner
+ ((subexpressions (cdr expression)) (registers registers))
+ (if (null? subexpressions)
+ registers
+ (inner (cdr subexpressions)
+ (outer (car subexpressions) registers)))))))))
+
+(define (rtl:contains-no-substitutable-registers? expression)
+ ;; True for all expressions that cannot possibly contain registers.
+ ;; In addition, this is also true of expressions that do contain
+ ;; registers but are not candidates for substitution (e.g.
+ ;; `pre-increment').
+ (memq (rtl:expression-type expression)
+ '(ASSIGNMENT-CACHE
+ CONS-CLOSURE
+ CONS-MULTICLOSURE
+ CONSTANT
+ ENTRY:CONTINUATION
+ ENTRY:PROCEDURE
+ MACHINE-CONSTANT
+ POST-INCREMENT
+ PRE-INCREMENT
+ VARIABLE-CACHE
+ STATIC-CELL)))
+\f
+(define (rtl:constant-expression? expression)
+ (case (rtl:expression-type expression)
+ ((ASSIGNMENT-CACHE
+ CONSTANT
+ ENTRY:CONTINUATION
+ ENTRY:PROCEDURE
+ MACHINE-CONSTANT
+ VARIABLE-CACHE
+ STATIC-CELL)
+ true)
+ ((BYTE-OFFSET-ADDRESS
+ CHAR->ASCII
+ CONS-NON-POINTER
+ CONS-POINTER
+ FIXNUM-1-ARG
+ FIXNUM-2-ARGS
+ FIXNUM->ADDRESS
+ FIXNUM->OBJECT
+ FLOAT-OFFSET-ADDRESS
+ FLONUM-1-ARG
+ FLONUM-2-ARGS
+ GENERIC-BINARY
+ GENERIC-UNARY
+ OBJECT->ADDRESS
+ OBJECT->DATUM
+ OBJECT->FIXNUM
+ OBJECT->TYPE
+ OBJECT->UNSIGNED-FIXNUM
+ OFFSET-ADDRESS)
+ (let loop ((subexpressions (cdr expression)))
+ (or (null? subexpressions)
+ (and (let ((expression (car subexpressions)))
+ (or (not (pair? expression))
+ (rtl:constant-expression? expression)))
+ (loop (cdr subexpressions))))))
+ (else
+ false)))
+
+(define (rtx-set/union* set sets)
+ (let loop ((set set) (sets sets) (accum '()))
+ (let ((set (rtx-set/union set accum)))
+ (if (null? sets)
+ set
+ (loop (car sets) (cdr sets) set)))))
+
+(define (rtx-set/union x y)
+ (if (null? y)
+ x
+ (let loop ((x x) (y y))
+ (if (null? x)
+ y
+ (loop (cdr x)
+ (let ((x (car x)))
+ (if (there-exists? y
+ (lambda (y)
+ (rtl:expression=? x y)))
+ y
+ (cons x y))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtline.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; RTL linearizer
+;; package: (compiler rtl-generator)
+
+(declare (usual-integrations))
+\f
+(define ((make-linearizer bblock-linearize
+ initial-value
+ instruction-append!
+ final-value)
+ root procedures continuations conts-linked?)
+ (with-new-node-marks
+ (lambda ()
+ (let ((input-queue (make-queue))
+ (output (initial-value)))
+ (let* ((queue-continuations!
+ (lambda (bblock)
+ (for-each (lambda (bblock)
+ (if (not (node-marked? bblock))
+ (enqueue!/unsafe input-queue bblock)))
+ (bblock-continuations bblock))))
+ (process-bblock!
+ (lambda (bblock)
+ (if (not (node-marked? bblock))
+ (set! output
+ (instruction-append!
+ output
+ (bblock-linearize bblock
+ queue-continuations!)))))))
+ (if (pair? root)
+ (for-each (lambda (rgraph)
+ (for-each
+ (lambda (edge)
+ (process-bblock! (edge-right-node edge)))
+ (rgraph-entry-edges rgraph)))
+ root)
+ (process-bblock!
+ (cond ((rtl-expr? root) (rtl-expr/entry-node root))
+ ((rtl-procedure? root) (rtl-procedure/entry-node root))
+ (else (error "Illegal linearization root" root)))))
+ (queue-map!/unsafe input-queue process-bblock!)
+ (for-each (lambda (procedure)
+ (process-bblock! (rtl-procedure/entry-node procedure))
+ (queue-map!/unsafe input-queue process-bblock!))
+ procedures)
+ (if (not conts-linked?)
+ (for-each
+ (lambda (cont)
+ (process-bblock! (rtl-continuation/entry-node cont))
+ (queue-map!/unsafe input-queue process-bblock!))
+ continuations))
+ (final-value output))))))
+\f
+(define (setup-bblock-continuations! rgraphs)
+ (for-each
+ (lambda (rgraph)
+ (for-each
+ (lambda (bblock)
+ (let ((continuations '()))
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (let loop ((expression (cdr (rinst-rtl rinst))))
+ (if (pair? expression)
+ (cond ((eq? (car expression) 'ENTRY:CONTINUATION)
+ ;; Because the average number of
+ ;; continuations per basic block is usually
+ ;; less than one, we optimize this case to
+ ;; speed up the accumulation.
+ (cond ((null? continuations)
+ (set! continuations
+ (list (cadr expression))))
+ ((not (memq (cadr expression) continuations))
+ (set! continuations
+ (cons (cadr expression)
+ continuations)))))
+ ((not (eq? (car expression) 'CONSTANT))
+ (for-each loop (cdr expression))))))))
+ (set-bblock-continuations!
+ bblock
+ (map (lambda (label)
+ (rtl-continuation/entry-node (label->object label)))
+ continuations)))
+ (if (sblock? bblock)
+ (let ((rtl (rinst-rtl (rinst-last (bblock-instructions bblock)))))
+ (if (rtl:invocation? rtl)
+ (let ((continuation (rtl:invocation-continuation rtl)))
+ (if continuation
+ (set-sblock-continuation!
+ bblock
+ (rtl-continuation/entry-node
+ (label->object continuation)))))))))
+ (rgraph-bblocks rgraph)))
+ rgraphs))
+\f
+;;; The linearizer attaches labels to nodes under two conditions. The
+;;; first is that the node in question has more than one previous
+;;; neighboring node. The other is when a conditional branch requires
+;;; such a label. It is assumed that if one encounters a node that
+;;; has already been linearized, that it has a label, since this
+;;; implies that it has more than one previous neighbor.
+
+(define (bblock-linearize-rtl bblock queue-continuations!)
+ (define (linearize-bblock bblock)
+ (node-mark! bblock)
+ (queue-continuations! bblock)
+ (if (and (not (bblock-label bblock))
+ (node-previous>1? bblock))
+ (bblock-label! bblock))
+ (let ((kernel
+ (lambda ()
+ (let loop ((rinst (bblock-instructions bblock)))
+ (cond ((rinst-next rinst)
+ (cons (rinst-rtl rinst) (loop (rinst-next rinst))))
+ ((sblock? bblock)
+ (cons (rinst-rtl rinst)
+ (let ((next (snode-next bblock)))
+ (if next
+ (linearize-sblock-next next)
+ (let ((bblock (sblock-continuation bblock)))
+ (if (and bblock
+ (not (node-marked? bblock)))
+ (linearize-bblock bblock)
+ '()))))))
+ (else
+ (linearize-pblock bblock
+ (rinst-rtl rinst)
+ (pnode-consequent bblock)
+ (pnode-alternative bblock))))))))
+ (if (bblock-label bblock)
+ `(,(rtl:make-label-statement (bblock-label bblock)) ,@(kernel))
+ (kernel))))
+
+ (define (linearize-sblock-next bblock)
+ (if (node-marked? bblock)
+ `(,(rtl:make-jump-statement (bblock-label bblock)))
+ (linearize-bblock bblock)))
+
+ (define (linearize-pblock pblock predicate cn an)
+ (let ((heed-preference
+ (lambda (finish)
+ (if (eq? 'CONSEQUENT (pnode/preferred-branch pblock))
+ (finish (rtl:negate-predicate predicate) an cn)
+ (finish predicate cn an)))))
+ (if (node-marked? cn)
+ (if (node-marked? an)
+ (heed-preference
+ (lambda (predicate cn an)
+ `(,(rtl:make-jumpc-statement predicate (bblock-label cn))
+ ,(rtl:make-jump-statement (bblock-label an)))))
+ `(,(rtl:make-jumpc-statement predicate (bblock-label cn))
+ ,@(linearize-bblock an)))
+ (if (node-marked? an)
+ `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate)
+ (bblock-label an))
+ ,@(linearize-bblock cn))
+ (heed-preference
+ (lambda (predicate cn an)
+ (let ((clabel (bblock-label! cn))
+ (alternative (linearize-bblock an)))
+ `(,(rtl:make-jumpc-statement predicate clabel)
+ ,@alternative
+ ,@(if (node-marked? cn) '() (linearize-bblock cn))))))))))
+
+ (linearize-bblock bblock))
+
+(define linearize-rtl
+ (make-linearizer bblock-linearize-rtl
+ (lambda () (let ((value (list false))) (cons value value)))
+ (lambda (accumulator instructions)
+ (set-cdr! (cdr accumulator) instructions)
+ (set-cdr! accumulator (last-pair instructions))
+ accumulator)
+ cdar))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlobj.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1988-92 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. |#
+
+;;;; Register Transfer Language: Object Datatypes
+
+(declare (usual-integrations))
+\f
+(define-structure (rtl-expr
+ (conc-name rtl-expr/)
+ (constructor make-rtl-expr
+ (rgraph label entry-edge debugging-info))
+ (print-procedure
+ (standard-unparser (symbol->string 'RTL-EXPR)
+ (lambda (state expression)
+ (unparse-object state (rtl-expr/label expression))))))
+ (rgraph false read-only true)
+ (label false read-only true)
+ (entry-edge false read-only true)
+ (debugging-info false read-only true))
+
+(define-integrable (rtl-expr/entry-node expression)
+ (edge-right-node (rtl-expr/entry-edge expression)))
+
+(define-structure (rtl-procedure
+ (conc-name rtl-procedure/)
+ (constructor make-rtl-procedure
+ (rgraph label entry-edge name n-required
+ n-optional rest? closure?
+ dynamic-link? type
+ debugging-info
+ next-continuation-offset stack-leaf?))
+ (print-procedure
+ (standard-unparser (symbol->string 'RTL-PROCEDURE)
+ (lambda (state procedure)
+ (unparse-object state
+ (rtl-procedure/label procedure))))))
+ (rgraph false read-only true)
+ (label false read-only true)
+ (entry-edge false read-only true)
+ (name false read-only true)
+ (n-required false read-only true)
+ (n-optional false read-only true)
+ (rest? false read-only true)
+ (closure? false read-only true)
+ (dynamic-link? false read-only true)
+ (type false read-only true)
+ (%external-label false)
+ (debugging-info false read-only true)
+ (next-continuation-offset false read-only true)
+ (stack-leaf? false read-only true))
+
+(define-integrable (rtl-procedure/entry-node procedure)
+ (edge-right-node (rtl-procedure/entry-edge procedure)))
+
+(define (rtl-procedure/external-label procedure)
+ (or (rtl-procedure/%external-label procedure)
+ (let ((label (generate-label (rtl-procedure/name procedure))))
+ (set-rtl-procedure/%external-label! procedure label)
+ label)))
+
+(define-structure (rtl-continuation
+ (conc-name rtl-continuation/)
+ (constructor make-rtl-continuation
+ (rgraph label entry-edge
+ next-continuation-offset
+ debugging-info))
+ (print-procedure
+ (standard-unparser (symbol->string 'RTL-CONTINUATION)
+ (lambda (state continuation)
+ (unparse-object
+ state
+ (rtl-continuation/label continuation))))))
+ (rgraph false read-only true)
+ (label false read-only true)
+ (entry-edge false read-only true)
+ (next-continuation-offset false read-only true)
+ (debugging-info false read-only true))
+
+(define-integrable (rtl-continuation/entry-node continuation)
+ (edge-right-node (rtl-continuation/entry-edge continuation)))
+\f
+(define (make/label->object expression procedures continuations)
+ (let ((hash-table
+ (make-eq-hash-table
+ (+ (if expression 1 0)
+ (length procedures)
+ (length continuations)))))
+ (if expression
+ (hash-table/put! hash-table
+ (rtl-expr/label expression)
+ expression))
+ (for-each (lambda (procedure)
+ (hash-table/put! hash-table
+ (rtl-procedure/label procedure)
+ procedure))
+ procedures)
+ (for-each (lambda (continuation)
+ (hash-table/put! hash-table
+ (rtl-continuation/label continuation)
+ continuation))
+ continuations)
+ (lambda (label)
+ (let ((datum (hash-table/get hash-table label #f)))
+ (if (not datum)
+ (error "Undefined label:" label))
+ datum))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlpars.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; RTL parser
+;;; package: (compiler rtl-parser)
+
+(declare (usual-integrations))
+\f
+(define label-like-statements
+ '(LABEL RETURN-ADDRESS PROCEDURE TRIVIAL-CLOSURE CLOSURE EXPRESSION))
+
+(define jump-like-statements
+ ;; JUMPC is special.
+ ;; Also missing some other INVOCATION:s and INTERPRETER-CALL:s
+ ;; but the new compiler never uses them.
+ '(JUMP
+ POP-RETURN INVOCATION:NEW-APPLY
+ INVOCATION:REGISTER INVOCATION:PROCEDURE
+ INVOCATION:UUO-LINK INVOCATION:GLOBAL-LINK
+ INVOCATION:PRIMITIVE INVOCATION:APPLY
+ INVOCATION:SPECIAL-PRIMITIVE
+ INTERPRETER-CALL:CACHE-REFERENCE
+ INTERPRETER-CALL:CACHE-ASSIGNMENT))
+
+(define (internal-error message . more)
+ (apply error "rtl->rtl-graph internal error:" message more))
+
+(define *rgraphs*)
+(define *expressions*)
+(define *procedures*)
+(define *continuations*)
+
+(define (rtl->rtl-graph rtl-program)
+ ;; (values expression procedures continuations rgraphs)
+ (fluid-let ((*rgraphs* '())
+ (*expressions* '())
+ (*procedures* '())
+ (*continuations* '()))
+ (let ((labels->segments (parse-rtl rtl-program)))
+ (hash-table/for-each labels->segments reformat!)
+ (hash-table/for-each labels->segments
+ (lambda (label slot)
+ label ; ignored
+ (link-up! slot labels->segments)))
+ (hash-table/for-each labels->segments rgraphify!/1)
+ (hash-table/for-each labels->segments rgraphify!/2)
+ (hash-table/for-each labels->segments rgraphify!/3)
+ (values (cond ((null? *expressions*)
+ (if *procedure-result?*
+ false
+ (internal-error "No expression found")))
+ ((not (null? (cdr *expressions*)))
+ (internal-error "Too many expressions found"))
+ (else
+ (car *expressions*)))
+ *procedures*
+ *continuations*
+ *rgraphs*))))
+\f
+;;; The following procedures solve a union/find problem.
+;;; They use the bblock-live-at-entry field temporarily to associate
+;;; a bblock with its set. The field is cleared at the end.
+
+(define (rgraphify!/1 label slot)
+ label ; ignored
+ (if (not (eq? (car slot) 'EMPTY))
+ (let ((bblock (caddr slot)))
+ (set-bblock-live-at-entry! bblock (list false bblock)))))
+
+(define (rgraphify!/2 label slot)
+ label ; ignored
+ (if (not (eq? (car slot) 'EMPTY))
+ (let* ((bblock (caddr slot))
+ (set (bblock-live-at-entry bblock))
+ (to-bash set)
+ (unify!
+ (lambda (bblock*)
+ (let ((set* (bblock-live-at-entry bblock*)))
+ (if (not (eq? set* set))
+ (let ((set** (cdr set*)))
+ (for-each (lambda (bblock**)
+ (set-bblock-live-at-entry! bblock** set))
+ set**)
+ (append! to-bash set**)
+ (set! to-bash set**)))))))
+ (for-each (lambda (edge)
+ (unify! (edge-left-node edge)))
+ (node-previous-edges bblock)))))
+
+(define (rgraphify!/3 label slot)
+ label ; ignored
+ (if (not (eq? (car slot) 'EMPTY))
+ (let* ((bblock (caddr slot))
+ (set (bblock-live-at-entry bblock)))
+ (if (not (car set))
+ (set-car! set (->rgraph (cdr set))))
+ (classify! bblock (car set))
+ (set-bblock-live-at-entry! bblock false))))
+
+(define (->rgraph bblocks)
+ (let* ((max-reg
+ (fold-right (lambda (bblock max-reg)
+ (max (bblock->max-reg bblock)
+ max-reg))
+ (- number-of-machine-registers 1)
+ bblocks))
+ (rgraph (make-rgraph (+ max-reg 1))))
+ (set-rgraph-bblocks! rgraph bblocks)
+ (set! *rgraphs* (cons rgraph *rgraphs*))
+ rgraph))
+
+(define (bblock->max-reg bblock)
+ (let loop ((insts (bblock-instructions bblock))
+ (max-reg -1))
+ (if (not insts)
+ max-reg
+ (loop (rinst-next insts)
+ (max max-reg
+ (let walk ((rtl (rinst-rtl insts)))
+ (cond ((not (pair? rtl))
+ max-reg)
+ ((eq? (car rtl) 'REGISTER)
+ (cadr rtl))
+ ((eq? (car rtl) 'CONSTANT)
+ max-reg)
+ (else
+ (max (walk (car rtl)) (walk (cdr rtl)))))))))))
+\f
+(define (reformat! label slot)
+ (define (->rinsts stmts)
+ (let loop ((stmts stmts)
+ (next false))
+ (if (null? stmts)
+ next
+ (loop (cdr stmts)
+ (make-rtl-instruction* (car stmts) next)))))
+
+ (let* ((stmts (cadr slot))
+ (result
+ (cond ((null? stmts)
+ (internal-error "Null segment" label))
+ ((not (eq? (caar stmts) 'JUMP))
+ (list (let ((stmt (car stmts)))
+ (cond ((eq? (car stmt) 'INVOCATION:SPECIAL-PRIMITIVE)
+ (caddr stmt))
+ ((memq (car stmt)
+ '(INTERPRETER-CALL:CACHE-REFERENCE
+ INTERPRETER-CALL:CACHE-ASSIGNMENT))
+ (cadr stmt))
+ (else
+ false)))
+ (make-sblock (->rinsts stmts))))
+ ((and (not (null? (cdr stmts)))
+ (eq? (car (cadr stmts)) 'JUMPC))
+ (let ((jump-inst (car stmts))
+ (jumpc-inst (cadr stmts)))
+ (let ((jump-label (cadr jump-inst))
+ (jumpc-label (caddr jumpc-inst))
+ (predicate (cadr jumpc-inst))
+ (finish
+ (lambda (predicate preference trueb falseb)
+ (list (list trueb falseb)
+ (pnode/prefer-branch!
+ (make-pblock
+ (->rinsts (cons predicate (cddr stmts))))
+ preference)))))
+ (cond ((not (pair? predicate))
+ (finish predicate
+ 'NEITHER
+ jumpc-label
+ jump-label))
+ ((eq? 'UNPREDICTABLE (car predicate))
+ (finish (cadr predicate)
+ 'NEITHER
+ jumpc-label
+ jump-label))
+ ((eq? 'NOT (car predicate))
+ (finish (cadr predicate)
+ 'ALTERNATIVE
+ jump-label
+ jumpc-label))
+ (else
+ (finish predicate
+ 'CONSEQUENT
+ jumpc-label
+ jump-label))))))
+ (else
+ (list (cadr (car stmts))
+ (make-sblock (->rinsts (cdr stmts))))))))
+ (set-car! slot
+ (if (bblock-instructions (cadr result))
+ 'BBLOCK
+ 'EMPTY))
+ (set-cdr! slot result)
+ #| (set-bblock-label! (cadr result) label) |#
+ unspecific))
+\f
+(define (link-up! slot labels->segments)
+ (define (find-bblock label)
+ (let ((desc (hash-table/get labels->segments label false)))
+ (if (not desc)
+ (internal-error "Missing label" label))
+ (if (eq? (car desc) 'EMPTY)
+ (find-bblock (cadr desc))
+ (caddr desc))))
+
+ (if (not (eq? (car slot) 'EMPTY))
+ (let ((next (cadr slot))
+ (bblock (caddr slot)))
+ (cond ((not next))
+ ((not (pair? next))
+ (create-edge! bblock
+ set-snode-next-edge!
+ (find-bblock next)))
+ (else
+ (create-edge! bblock
+ set-pnode-consequent-edge!
+ (find-bblock (car next)))
+ (create-edge! bblock
+ set-pnode-alternative-edge!
+ (find-bblock (cadr next))))))))
+\f
+(define-macro (%push! object collection)
+ `(begin (set! ,collection (cons ,object ,collection))
+ unspecific))
+
+(define (classify! bblock rgraph)
+ ;; Most of the fields are meaningless for the new headers
+ ;; since the information is explicit in the RTL (e.g. INTERRUPT-CHECK:)
+ (let* ((gen-edge
+ (lambda ()
+ (let ((edge (create-edge! false false bblock)))
+ (add-rgraph-entry-edge! rgraph edge)
+ edge)))
+ (insts (bblock-instructions bblock))
+ (rtl (rinst-rtl insts)))
+ (case (car rtl)
+ ((RETURN-ADDRESS)
+ (%push!
+ (make-rtl-continuation
+ rgraph ; rgraph
+ (cadr rtl) ; label
+ (gen-edge) ; entry edge
+ false ; next continuation offset
+ false ; debugging info
+ )
+ *continuations*))
+ ((PROCEDURE CLOSURE TRIVIAL-CLOSURE)
+ (let ((proc
+ (make-rtl-procedure
+ rgraph ; rgraph
+ (cadr rtl) ; label
+ (gen-edge) ; entry edge
+ (cadr rtl) ; name
+ false ; nrequired
+ false ; noptional
+ false ; rest
+ (not (eq? (car rtl) 'PROCEDURE)) ; closure?
+ false ; dynamic link?
+ (car rtl) ; type
+ false ; debugging info
+ false ; next continuation offset
+ false ; stack leaf?
+ )))
+ (set-rtl-procedure/%external-label! proc (cadr rtl))
+ (%push! proc *procedures*)))
+ ((EXPRESSION)
+ (%push!
+ (make-rtl-expr
+ rgraph ; rgraph
+ (cadr rtl) ; label
+ (gen-edge) ; entry edge
+ false ; debugging info
+ )
+ *expressions*)))))
+\f
+(define (parse-rtl rtl-program)
+ (cond ((null? rtl-program)
+ (internal-error "Empty program"))
+ ((not (memq (caar rtl-program) label-like-statements))
+ (internal-error "Program does not start with label" rtl-program)))
+ (let ((labels->segments (make-eq-hash-table)))
+ (define (found-one label stmts)
+ (hash-table/put! labels->segments
+ label
+ (list 'STATEMENTS stmts)))
+
+ (let loop ((program (cdr rtl-program))
+ (label (cadr (car rtl-program)))
+ (segment (if (eq? (caar rtl-program) 'LABEL)
+ '()
+ (list (car rtl-program)))))
+ (if (null? program)
+ (begin
+ (if (not (null? segment))
+ (internal-error "Last segment falls through"
+ (reverse segment))))
+ (let ((stmt (car program)))
+ (cond ((memq (car stmt) jump-like-statements)
+ (found-one label (cons stmt segment))
+ (if (not (null? (cdr program)))
+ (let ((next (cadr program)))
+ (if (not (memq (car next) label-like-statements))
+ (internal-error "No label following jump"
+ program))
+ (loop (cddr program)
+ (cadr next)
+ (if (eq? (car next) 'LABEL)
+ '()
+ (list next))))))
+ ((eq? (car stmt) 'JUMPC)
+ (if (null? (cdr program))
+ (internal-error "Last segment falls through when false"
+ (reverse (cons stmt segment))))
+ (let ((next (cadr program)))
+ (if (eq? 'JUMP (car next))
+ (loop (cdr program)
+ label
+ (cons stmt segment))
+ (let ((label (generate-label)))
+ (loop (cons `(LABEL ,label) (cdr program))
+ label
+ (cons stmt segment))))))
+ ((memq (car stmt) label-like-statements)
+ (if (not (eq? (car stmt) 'LABEL))
+ (internal-error "Falling through to non-label label"
+ (car stmt)))
+ (found-one label (cons `(JUMP ,(cadr stmt)) segment))
+ (loop (cdr program)
+ (cadr stmt)
+ '()))
+ (else
+ (loop (cdr program)
+ label
+ (cons stmt segment)))))))
+ labels->segments))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlreg.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; RTL Registers
+
+(declare (usual-integrations))
+\f
+(define *machine-register-map*)
+
+(define (initialize-machine-register-map!)
+ (set! *machine-register-map*
+ (let ((map (make-vector number-of-machine-registers)))
+ (let loop ((n 0))
+ (if (< n number-of-machine-registers)
+ (begin (vector-set! map n (%make-register n))
+ (loop (1+ n)))))
+ map)))
+
+(define-integrable (rtl:make-machine-register n)
+ (vector-ref *machine-register-map* n))
+
+(define-integrable (machine-register? register)
+ (< register number-of-machine-registers))
+
+(define (for-each-machine-register procedure)
+ (let ((limit number-of-machine-registers))
+ (define (loop register)
+ (if (< register limit)
+ (begin (procedure register)
+ (loop (1+ register)))))
+ (loop 0)))
+
+(define (rtl:make-pseudo-register)
+ (let ((n (rgraph-n-registers *current-rgraph*)))
+ (set-rgraph-n-registers! *current-rgraph* (1+ n))
+ (%make-register n)))
+
+(define-integrable (pseudo-register? register)
+ (>= register number-of-machine-registers))
+
+(define (for-each-pseudo-register procedure)
+ (let ((n-registers (rgraph-n-registers *current-rgraph*)))
+ (define (loop register)
+ (if (< register n-registers)
+ (begin (procedure register)
+ (loop (1+ register)))))
+ (loop number-of-machine-registers)))
+\f
+(let-syntax
+ ((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))))))))
+ (define-register-references bblock)
+ (define-register-references n-refs)
+ (define-register-references n-deaths)
+ (define-register-references live-length)
+ (define-register-references renumber))
+
+(define-integrable (reset-register-n-refs! register)
+ (set-register-n-refs! register 0))
+
+(define (increment-register-n-refs! register)
+ (set-register-n-refs! register (1+ (register-n-refs register))))
+
+(define-integrable (reset-register-n-deaths! register)
+ (set-register-n-deaths! register 0))
+
+(define (increment-register-n-deaths! register)
+ (set-register-n-deaths! register (1+ (register-n-deaths register))))
+
+(define-integrable (reset-register-live-length! register)
+ (set-register-live-length! register 0))
+
+(define (increment-register-live-length! register)
+ (set-register-live-length! register (1+ (register-live-length register))))
+
+(define (decrement-register-live-length! register)
+ (set-register-live-length! register (-1+ (register-live-length register))))
+
+(define (register-crosses-call? register)
+ (bit-string-ref (rgraph-register-crosses-call? *current-rgraph*) register))
+
+(define (register-crosses-call! register)
+ (bit-string-set! (rgraph-register-crosses-call? *current-rgraph*) register))
+
+(define (pseudo-register-value-class register)
+ (vector-ref (rgraph-register-value-classes *current-rgraph*) register))
+
+(define (pseudo-register-known-value register)
+ (vector-ref (rgraph-register-known-values *current-rgraph*) register))
+
+(define (pseudo-register-known-expression register)
+ (vector-ref (rgraph-register-known-expressions *current-rgraph*) register))
+
+(define (register-value-class register)
+ (if (machine-register? register)
+ (machine-register-value-class register)
+ (pseudo-register-value-class register)))
+
+(define (register-known-value register)
+ (if (machine-register? register)
+ (machine-register-known-value register)
+ (pseudo-register-known-value register)))
+
+(define (register-known-expression register)
+ (if (machine-register? register)
+ #F
+ (pseudo-register-known-expression register)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlty1.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; Register Transfer Language Type Definitions
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;;; These three lists will be filled in by the type definitions that
+;;; follow. See those macros for details.
+(define rtl:expression-types '())
+(define rtl:statement-types '())
+(define rtl:predicate-types '())
+
+(define-rtl-expression register % number)
+
+;;; Scheme object
+(define-rtl-expression constant % value)
+
+;;; Memory references that return Scheme objects
+(define-rtl-expression offset rtl: base offset)
+(define-rtl-expression pre-increment rtl: register number)
+(define-rtl-expression post-increment rtl: register number)
+
+;;; Memory reference that returns ASCII integer
+(define-rtl-expression byte-offset rtl: base offset)
+;;; Memory reference that returns a floating-point number
+(define-rtl-expression float-offset rtl: base offset)
+
+;;; Generic arithmetic operations on Scheme number objects
+;;; (define-rtl-expression generic-unary rtl: operator operand)
+;;; (define-rtl-expression generic-binary rtl: operator operand-1 operand-2)
+
+;;; Code addresses
+(define-rtl-expression entry:continuation rtl: continuation)
+(define-rtl-expression entry:procedure rtl: procedure)
+
+;;; Allocating a closure object (returns its address)
+(define-rtl-expression cons-closure rtl: entry min max size)
+;;; Allocating a multi-closure object
+;;; (returns the address of first entry point)
+(define-rtl-expression cons-multiclosure rtl: nentries size entries)
+
+;;; Cache addresses
+(define-rtl-expression assignment-cache rtl: name)
+(define-rtl-expression variable-cache rtl: name)
+
+;;; Get the address of a Scheme object
+(define-rtl-expression object->address rtl: expression)
+
+;;; Convert between a datum and an address
+;;; (define-rtl-expression datum->address rtl: expression)
+;;; (define-rtl-expression address->datum rtl: expression)
+
+;;; Add a constant offset to an address
+(define-rtl-expression offset-address rtl: base offset)
+(define-rtl-expression byte-offset-address rtl: base offset)
+(define-rtl-expression float-offset-address rtl: base offset)
+
+;;; A machine constant (an integer, usually unsigned)
+(define-rtl-expression machine-constant rtl: value)
+
+;;; Destructuring Scheme objects
+(define-rtl-expression object->datum rtl: expression)
+(define-rtl-expression object->type rtl: expression)
+(define-rtl-expression cons-pointer rtl: type datum)
+(define-rtl-expression cons-non-pointer rtl: type datum)
+
+;;; Convert a character object to an ASCII machine integer
+(define-rtl-expression char->ascii rtl: expression)
+
+;;; Conversion between fixnum objects and machine integers
+(define-rtl-expression object->fixnum rtl: expression)
+(define-rtl-expression object->unsigned-fixnum rtl: expression)
+(define-rtl-expression fixnum->object rtl: expression)
+
+;;; Conversion between machine integers and addresses
+(define-rtl-expression fixnum->address rtl: expression)
+(define-rtl-expression address->fixnum rtl: expression)
+
+;;; Machine integer arithmetic operations
+(define-rtl-expression fixnum-1-arg rtl:
+ operator operand overflow?)
+(define-rtl-expression fixnum-2-args rtl:
+ operator operand-1 operand-2 overflow?)
+\f
+;;; Conversion between flonums and machine floats
+(define-rtl-expression float->object rtl: expression)
+(define-rtl-expression object->float rtl: expression)
+
+;;; Floating-point arithmetic operations
+(define-rtl-expression flonum-1-arg rtl:
+ operator operand overflow?)
+(define-rtl-expression flonum-2-args rtl:
+ operator operand-1 operand-2 overflow?)
+
+;; Predicates whose inputs are fixnums
+(define-rtl-predicate fixnum-pred-1-arg %
+ predicate operand)
+(define-rtl-predicate fixnum-pred-2-args %
+ predicate operand-1 operand-2)
+
+;; Predicates whose inputs are flonums
+(define-rtl-predicate flonum-pred-1-arg %
+ predicate operand)
+(define-rtl-predicate flonum-pred-2-args %
+ predicate operand-1 operand-2)
+
+(define-rtl-predicate eq-test % expression-1 expression-2)
+
+;; Type tests compare an extracted type field with a constant type
+(define-rtl-predicate type-test % expression type)
+
+;; General predicates
+(define-rtl-predicate pred-1-arg % predicate operand)
+(define-rtl-predicate pred-2-args % predicate operand-1 operand-2)
+
+(define-rtl-predicate overflow-test rtl:)
+
+(define-rtl-statement assign % address expression)
+
+(define-rtl-statement pop-return rtl:)
+
+(define-rtl-statement continuation-entry rtl: continuation)
+(define-rtl-statement continuation-header rtl: continuation)
+(define-rtl-statement ic-procedure-header rtl: procedure)
+(define-rtl-statement open-procedure-header rtl: procedure)
+(define-rtl-statement procedure-header rtl: procedure min max)
+(define-rtl-statement closure-header rtl: procedure nentries entry)
+
+(define-rtl-statement interpreter-call:access %
+ continuation environment name)
+(define-rtl-statement interpreter-call:define %
+ continuation environment name value)
+(define-rtl-statement interpreter-call:lookup %
+ continuation environment name safe?)
+(define-rtl-statement interpreter-call:set! %
+ continuation environment name value)
+(define-rtl-statement interpreter-call:unassigned? %
+ continuation environment name)
+(define-rtl-statement interpreter-call:unbound? %
+ continuation environment name)
+
+(define-rtl-statement interpreter-call:cache-assignment %
+ continuation name value)
+(define-rtl-statement interpreter-call:cache-reference %
+ continuation name safe?)
+(define-rtl-statement interpreter-call:cache-unassigned? %
+ continuation name)
+
+(define-rtl-statement invocation:apply rtl:
+ pushed continuation)
+(define-rtl-statement invocation:jump rtl:
+ pushed continuation procedure)
+(define-rtl-statement invocation:computed-jump rtl:
+ pushed continuation)
+(define-rtl-statement invocation:lexpr rtl:
+ pushed continuation procedure)
+(define-rtl-statement invocation:computed-lexpr rtl:
+ pushed continuation)
+(define-rtl-statement invocation:uuo-link rtl:
+ pushed continuation name)
+(define-rtl-statement invocation:global-link rtl:
+ pushed continuation name)
+(define-rtl-statement invocation:primitive rtl:
+ pushed continuation procedure)
+(define-rtl-statement invocation:special-primitive rtl:
+ pushed continuation procedure)
+(define-rtl-statement invocation:cache-reference rtl:
+ pushed continuation name)
+(define-rtl-statement invocation:lookup rtl:
+ pushed continuation environment name)
+
+(define-rtl-statement invocation-prefix:move-frame-up rtl:
+ frame-size locative)
+(define-rtl-statement invocation-prefix:dynamic-link rtl:
+ frame-size locative register)
+\f
+;;;; New RTL
+
+(define-rtl-statement invocation:register rtl:
+ pushed continuation destination cont-defined? nregs)
+(define-rtl-statement invocation:procedure rtl:
+ pushed continuation procedure nregs)
+(define-rtl-statement invocation:new-apply rtl:
+ pushed continuation destination nregs)
+
+(define-rtl-statement return-address rtl: label frame-size nregs)
+(define-rtl-statement procedure rtl: label frame-size)
+(define-rtl-statement trivial-closure rtl: label min max)
+(define-rtl-statement closure rtl: label frame-size)
+(define-rtl-statement expression rtl: label)
+
+(define-rtl-statement interrupt-check:procedure rtl:
+ intrpt? heap? stack? label nregs)
+(define-rtl-statement interrupt-check:continuation rtl:
+ intrpt? heap? stack? label nregs)
+(define-rtl-statement interrupt-check:closure rtl:
+ intrpt? heap? stack? nregs)
+(define-rtl-statement interrupt-check:simple-loop rtl:
+ intrpt? heap? stack? loop-label header-label nregs)
+
+(define-rtl-statement preserve rtl: register how)
+(define-rtl-statement restore rtl: register value)
+
+(define-rtl-expression static-cell rtl: name)
+(define-rtl-expression align-float rtl: expression)
+
+(define-rtl-expression coerce-value-class rtl: expression class)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlty2.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1988-1993 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. |#
+
+;;;; Register Transfer Language Type Definitions
+;;; package: (compiler)
+
+(declare (usual-integrations))
+\f
+;; clash with new rtl:
+;;(define-integrable rtl:expression? pair?)
+
+(define-integrable rtl:expression-type car)
+(define-integrable rtl:address-register cadr)
+(define-integrable rtl:address-number caddr)
+(define-integrable rtl:test-expression cadr)
+(define-integrable rtl:invocation-pushed cadr)
+(define-integrable rtl:invocation-continuation caddr)
+
+(define-integrable (rtl:set-invocation-continuation! rtl continuation)
+ (set-car! (cddr rtl) continuation))
+
+;;;; Locatives
+
+;;; Locatives are used as an intermediate form by the code generator
+;;; to build expressions. Later, when the expressions are inserted
+;;; into statements, any locatives they contain are eliminated by
+;;; "simplifying" them into sequential instructions using pseudo
+;;; registers.
+
+(define-integrable register:environment
+ 'ENVIRONMENT)
+
+(define-integrable register:stack-pointer
+ 'STACK-POINTER)
+
+(define-integrable register:dynamic-link
+ 'DYNAMIC-LINK)
+
+(define-integrable register:value
+ 'VALUE)
+
+(define-integrable register:int-mask
+ 'INT-MASK)
+
+(define-integrable register:memory-top
+ 'MEMORY-TOP)
+
+(define-integrable register:free
+ 'FREE)
+
+(define-integrable (rtl:interpreter-call-result:access)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:ACCESS))
+
+(define-integrable (rtl:interpreter-call-result:cache-reference)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:CACHE-REFERENCE))
+
+(define-integrable (rtl:interpreter-call-result:cache-unassigned?)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:CACHE-UNASSIGNED?))
+
+(define-integrable (rtl:interpreter-call-result:lookup)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:LOOKUP))
+
+(define-integrable (rtl:interpreter-call-result:unassigned?)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNASSIGNED?))
+
+(define-integrable (rtl:interpreter-call-result:unbound?)
+ (rtl:make-fetch 'INTERPRETER-CALL-RESULT:UNBOUND?))
+\f
+;;; "Pre-simplification" locative offsets
+
+(define (rtl:locative-offset? locative)
+ (and (pair? locative) (eq? (car locative) 'OFFSET)))
+
+(define-integrable rtl:locative-offset-base cadr)
+(define-integrable rtl:locative-offset-offset caddr)
+
+#|
+(define (rtl:locative-offset-granularity locative)
+ ;; This is kludged up for backward compatibility
+ (if (rtl:locative-offset? locative)
+ (if (pair? (cdddr locative))
+ (cadddr locative)
+ 'OBJECT)
+ (error "Not a locative offset" locative)))
+|#
+(define-integrable rtl:locative-offset-granularity cadddr)
+
+(define-integrable (rtl:locative-byte-offset? locative)
+ (eq? (rtl:locative-offset-granularity locative) 'BYTE))
+
+(define-integrable (rtl:locative-float-offset? locative)
+ (eq? (rtl:locative-offset-granularity locative) 'FLOAT))
+
+(define-integrable (rtl:locative-object-offset? locative)
+ (eq? (rtl:locative-offset-granularity locative) 'OBJECT))
+
+(define-integrable (rtl:locative-offset locative offset)
+ (rtl:locative-object-offset locative offset))
+
+(define (rtl:locative-byte-offset locative byte-offset)
+ (cond ((rtl:locative-offset? locative)
+ `(OFFSET ,(rtl:locative-offset-base locative)
+ ,(back-end:+
+ byte-offset
+ (cond ((rtl:locative-byte-offset? locative)
+ (rtl:locative-offset-offset locative))
+ ((rtl:locative-object-offset? locative)
+ (back-end:*
+ (rtl:locative-offset-offset locative)
+ address-units-per-object))
+ (else
+ (back-end:*
+ (rtl:locative-offset-offset locative)
+ address-units-per-float))))
+ BYTE))
+ ((back-end:= byte-offset 0)
+ locative)
+ (else
+ `(OFFSET ,locative ,byte-offset BYTE))))
+
+(define (rtl:locative-float-offset locative float-offset)
+ (let ((default
+ (lambda ()
+ `(OFFSET ,locative ,float-offset FLOAT))))
+ (cond ((rtl:locative-offset? locative)
+ (if (rtl:locative-float-offset? locative)
+ `(OFFSET ,(rtl:locative-offset-base locative)
+ ,(back-end:+ (rtl:locative-offset-offset locative)
+ float-offset)
+ FLOAT)
+ (default)))
+ (else
+ (default)))))
+
+(define (rtl:locative-object-offset locative offset)
+ (cond ((back-end:= offset 0) locative)
+ ((rtl:locative-offset? locative)
+ (if (not (rtl:locative-object-offset? locative))
+ (error "Can't add object offset to non-object offset"
+ locative offset)
+ `(OFFSET ,(rtl:locative-offset-base locative)
+ ,(back-end:+ (rtl:locative-offset-offset locative)
+ offset)
+ OBJECT)))
+ (else
+ `(OFFSET ,locative ,offset OBJECT))))
+\f
+(define (rtl:locative-index? locative)
+ (and (pair? locative) (eq? (car locative) 'INDEX)))
+
+(define-integrable rtl:locative-index-base cadr)
+(define-integrable rtl:locative-index-offset caddr)
+(define-integrable rtl:locative-index-granularity cadddr)
+
+(define-integrable (rtl:locative-byte-index? locative)
+ (eq? (rtl:locative-index-granularity locative) 'BYTE))
+
+(define-integrable (rtl:locative-float-index? locative)
+ (eq? (rtl:locative-index-granularity locative) 'FLOAT))
+
+(define-integrable (rtl:locative-object-index? locative)
+ (eq? (rtl:locative-index-granularity locative) 'OBJECT))
+
+(define (rtl:locative-byte-index locative offset)
+ `(INDEX ,locative ,offset BYTE))
+
+(define (rtl:locative-float-index locative offset)
+ `(INDEX ,locative ,offset FLOAT))
+
+(define (rtl:locative-object-index locative offset)
+ `(INDEX ,locative ,offset OBJECT))
+\f
+;;; Expressions that are used in the intermediate form.
+
+(define-integrable (rtl:make-address locative)
+ `(ADDRESS ,locative))
+
+(define-integrable (rtl:make-environment locative)
+ `(ENVIRONMENT ,locative))
+
+(define-integrable (rtl:make-cell-cons expression)
+ `(CELL-CONS ,expression))
+
+(define-integrable (rtl:make-fetch locative)
+ `(FETCH ,locative))
+
+(define-integrable (rtl:make-typed-cons:pair type car cdr)
+ `(TYPED-CONS:PAIR ,type ,car ,cdr))
+
+(define-integrable (rtl:make-typed-cons:vector type elements)
+ `(TYPED-CONS:VECTOR ,type ,@elements))
+
+(define-integrable (rtl:make-typed-cons:procedure entry)
+ `(TYPED-CONS:PROCEDURE ,entry))
+
+;;; Linearizer Support
+
+(define-integrable (rtl:make-jump-statement label)
+ `(JUMP ,label))
+
+(define-integrable (rtl:make-jumpc-statement predicate label)
+ `(JUMPC ,predicate ,label))
+
+(define-integrable (rtl:make-label-statement label)
+ `(LABEL ,label))
+
+(define-integrable (rtl:negate-predicate expression)
+ `(NOT ,expression))
+
+;;; Stack
+
+(define-integrable (stack-locative-offset locative offset)
+ (rtl:locative-offset locative (stack->memory-offset offset)))
+
+(define-integrable (stack-push-address)
+ (rtl:make-pre-increment (interpreter-stack-pointer)
+ (stack->memory-offset -1)))
+
+(define-integrable (stack-pop-address)
+ (rtl:make-post-increment (interpreter-stack-pointer)
+ (stack->memory-offset 1)))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/rtlbase/valclass.scm,v 1.1 1994/11/19 02:05:54 adams Exp $
+
+Copyright (c) 1989, 1990 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. |#
+
+;;;; RTL Value Classes
+
+(declare (usual-integrations))
+\f
+(define-structure (value-class
+ (conc-name value-class/)
+ (constructor %make-value-class (name parent))
+ (print-procedure
+ (unparser/standard-method 'VALUE-CLASS
+ (lambda (state class)
+ (unparse-object state (value-class/name class))))))
+ (name false read-only true)
+ (parent false read-only true)
+ (children '())
+ (properties (make-1d-table) read-only true))
+
+(define (make-value-class name parent)
+ (let ((class (%make-value-class name parent)))
+ (if parent
+ (set-value-class/children!
+ parent
+ (cons class (value-class/children parent))))
+ class))
+
+(define (value-class/ancestor-or-self? class ancestor)
+ (or (eq? class ancestor)
+ (let loop ((class (value-class/parent class)))
+ (and class
+ (or (eq? class ancestor)
+ (loop (value-class/parent class)))))))
+
+(define (value-class/ancestry class)
+ (value-class/partial-ancestry class value-class=value))
+
+(define (value-class/partial-ancestry class ancestor)
+ (let loop ((class* class) (ancestry '()))
+ (if (not class*)
+ (error "value-class not an ancestor" class ancestor))
+ (let ((ancestry (cons class* ancestry)))
+ (if (eq? class* ancestor)
+ ancestry
+ (loop (value-class/parent class*) ancestry)))))
+
+(define (value-class/nearest-common-ancestor x y)
+ (let loop
+ ((join false)
+ (x (value-class/ancestry x))
+ (y (value-class/ancestry y)))
+ (if (and (not (null? x))
+ (not (null? y))
+ (eq? (car x) (car y)))
+ (loop (car x) (cdr x) (cdr y))
+ join)))
+\f
+(let-syntax
+ ((define-value-class
+ (lambda (name parent-name)
+ (let* ((name->variable
+ (lambda (name) (symbol-append 'VALUE-CLASS= name)))
+ (variable (name->variable name)))
+ `(BEGIN
+ (DEFINE ,variable
+ (MAKE-VALUE-CLASS ',name
+ ,(cond ((symbol? parent-name)
+ (name->variable parent-name))
+ ((pair? parent-name)
+ parent-name)
+ (else `#F))))
+ (DEFINE (,(symbol-append variable '?) CLASS)
+ (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable))
+ (DEFINE
+ (,(symbol-append 'REGISTER- variable '?) REGISTER)
+ (VALUE-CLASS/ANCESTOR-OR-SELF? (REGISTER-VALUE-CLASS REGISTER)
+ ,variable)))))))
+
+
+(define-value-class value #f)
+(define-value-class float value)
+(define-value-class word value)
+(define-value-class object word)
+(define-value-class unboxed word)
+(define-value-class address unboxed)
+
+;; If we are using tags 0000... and 1111... for fixnums then immedaite
+;; values are valid objects. Otherwise they are unboxed values
+(define-value-class immediate (if untagged-fixnums?
+ VALUE-CLASS=object
+ VALUE-CLASS=unboxed))
+(define-value-class ascii immediate)
+(define-value-class datum immediate)
+(define-value-class fixnum immediate)
+(define-value-class type immediate)
+
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: ralloc.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1988-93 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. |#
+
+;;;; Register Allocation
+;;; Based on the GNU C Compiler
+
+(declare (usual-integrations))
+\f
+(package (register-allocation)
+
+(define-export (register-allocation rgraphs)
+ (for-each (lambda (rgraph)
+ (let ((n-temporaries (walk-rgraph rgraph)))
+ (if (> n-temporaries number-of-temporary-registers)
+ (error "Too many temporary quantities" n-temporaries))))
+ rgraphs))
+
+(define (walk-rgraph rgraph)
+ (let ((n-registers (rgraph-n-registers rgraph)))
+ (set-rgraph-register-renumber!
+ rgraph
+ (make-vector n-registers false))
+ (fluid-let ((*current-rgraph* rgraph))
+ (walk-bblocks n-registers (rgraph-bblocks rgraph)))))
+
+(define (walk-bblocks n-registers bblocks)
+ ;; First, renumber all the registers remaining to be allocated.
+ (let ((next-renumber 0)
+ (register->renumber (make-vector n-registers false)))
+ (define (renumbered-registers n)
+ (if (< n n-registers)
+ (if (vector-ref register->renumber n)
+ (cons n (renumbered-registers (1+ n)))
+ (renumbered-registers (1+ n)))
+ '()))
+ (for-each-pseudo-register
+ (lambda (register)
+ (if (positive? (register-n-refs register))
+ (begin (vector-set! register->renumber register next-renumber)
+ (set! next-renumber (1+ next-renumber))))))
+ ;; Now create a conflict matrix for those registers and fill it.
+ (let ((conflict-matrix
+ (make-initialized-vector next-renumber
+ (lambda (i)
+ i
+ (make-regset next-renumber)))))
+ (for-each (lambda (bblock)
+ (let ((live (make-regset next-renumber)))
+ (for-each-regset-member (bblock-live-at-entry bblock)
+ (lambda (register)
+ (let ((renumber
+ (vector-ref register->renumber register)))
+ (if renumber
+ (regset-adjoin! live renumber)))))
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (for-each-regset-member live
+ (lambda (renumber)
+ (regset-union! (vector-ref conflict-matrix
+ renumber)
+ live)))
+ (for-each (lambda (register)
+ (let ((renumber
+ (vector-ref register->renumber
+ register)))
+ (if renumber
+ (regset-delete! live renumber))))
+ (rinst-dead-registers rinst))
+ (mark-births! live
+ (rinst-rtl rinst)
+ register->renumber)))))
+ bblocks)
+\f
+ ;; Finally, sort the renumbered registers into an allocation
+ ;; order, and then allocate them into registers one at a time.
+ ;; Return the number of required real registers as a value.
+ (let ((next-allocation 0)
+ (allocated (make-vector next-renumber 0)))
+ (for-each (lambda (register)
+ (let ((renumber (vector-ref register->renumber register)))
+ (define (loop allocation)
+ (if (< allocation next-allocation)
+ (if (regset-disjoint?
+ (vector-ref conflict-matrix renumber)
+ (vector-ref allocated allocation))
+ allocation
+ (loop (1+ allocation)))
+ (let ((allocation next-allocation))
+ (set! next-allocation (1+ next-allocation))
+ (vector-set! allocated allocation
+ (make-regset next-renumber))
+ allocation)))
+ (let ((allocation (loop 0)))
+ (set-register-renumber! register allocation)
+ (regset-adjoin! (vector-ref allocated allocation)
+ renumber))))
+ (sort (renumbered-registers number-of-machine-registers)
+ allocate<?))
+ next-allocation))))
+
+(define (allocate<? x y)
+ (and (not (= (register-live-length x) 0))
+ (or (= (register-live-length y) 0)
+ (< (/ (register-n-refs x) (register-live-length x))
+ (/ (register-n-refs y) (register-live-length y))))))
+
+(define (mark-births! live rtl register->renumber)
+ (if (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl)))
+ (if (rtl:register? address)
+ (let ((register (rtl:register-number address)))
+ (if (pseudo-register? register)
+ (regset-adjoin! live
+ (vector-ref register->renumber
+ register))))))))
+
+)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rcompr.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; RTL Compression
+;;; Based on the GNU C Compiler
+;;; package: (compiler rtl-optimizer code-compression)
+
+(declare (usual-integrations))
+\f
+(define (code-compression rgraphs)
+ (for-each (lambda (rgraph)
+ (fluid-let ((*current-rgraph* rgraph))
+ (for-each walk-bblock (rgraph-bblocks rgraph))))
+ rgraphs))
+
+(define (walk-bblock bblock)
+ (if (rinst-next (bblock-instructions bblock))
+ (begin
+ (let ((live (regset-copy (bblock-live-at-entry bblock)))
+ (births (make-regset (rgraph-n-registers *current-rgraph*))))
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (if (rinst-next rinst)
+ (let ((rtl (rinst-rtl rinst)))
+ (optimize-rtl bblock live rinst rtl)
+ (regset-clear! births)
+ (mark-set-registers! live births rtl false)
+ (for-each (lambda (register)
+ (regset-delete! live register))
+ (rinst-dead-registers rinst))
+ (regset-union! live births))))))
+ (bblock-perform-deletions! bblock))))
+
+(define (optimize-rtl bblock live rinst rtl)
+ ;; Look for assignments whose address is a pseudo register. If that
+ ;; register has exactly one reference that is known to be in this
+ ;; basic block, it is a candidate for expression folding.
+ (let ((register
+ (and (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl)))
+ (and (rtl:register? address)
+ (rtl:register-number address))))))
+ (if (and register
+ (pseudo-register? register)
+ (eq? (register-bblock register) bblock)
+ (= 2 (register-n-refs register)))
+ (let ((expression (rtl:assign-expression rtl)))
+ (if (not (or (rtl:expression-contains? expression
+ rtl:volatile-expression?)
+ (and (rtl:register? expression)
+ (machine-register? (rtl:register-number expression)))))
+ (with-values
+ (lambda ()
+ (let ((next (rinst-next rinst)))
+ (if (rinst-dead-register? next register)
+ (values next expression)
+ (find-reference-instruction next
+ register
+ expression))))
+ (lambda (next expression)
+ (if next
+ (fold-instructions! live
+ rinst
+ next
+ register
+ expression)))))))))
+\f
+(define (find-reference-instruction next register expression)
+ ;; Find the instruction that contains the single reference to
+ ;; `register', and determine if it is possible to fold `expression'
+ ;; into that instruction in `register's place.
+ (let loop ((expression expression))
+ (let ((search-stopping-at
+ (lambda (expression predicate)
+ (define (phi-1 next)
+ (if (predicate (rinst-rtl next))
+ (values false false)
+ (phi-2 (rinst-next next))))
+ (define (phi-2 next)
+ (if (rinst-dead-register? next register)
+ (values next expression)
+ (phi-1 next)))
+ (phi-1 next)))
+ (recursion
+ (lambda (unwrap wrap)
+ (with-values
+ (lambda ()
+ (loop (unwrap expression)))
+ (lambda (next expression)
+ (if next
+ (values next (wrap expression))
+ (values false false)))))))
+ (let ((recurse-and-search
+ (lambda (unwrap wrap)
+ (with-values (lambda ()
+ (recursion unwrap wrap))
+ (lambda (next expression*)
+ (if next
+ (values next expression*)
+ (search-stopping-at expression
+ (lambda (rtl)
+ rtl ; ignored
+ false))))))))
+
+ (cond ((interpreter-value-register? expression)
+ (search-stopping-at expression
+ (lambda (rtl)
+ (and (rtl:assign? rtl)
+ (interpreter-value-register?
+ (rtl:assign-address rtl))))))
+ ((and (rtl:offset? expression)
+ (interpreter-stack-pointer? (rtl:offset-base expression))
+ (rtl:machine-constant? (rtl:offset-offset expression)))
+ (let ()
+ (define (phi-1 next offset)
+ (let ((rtl (rinst-rtl next)))
+ (cond ((expression-is-stack-push? rtl)
+ (phi-2 (rinst-next next) (1+ offset)))
+ ((or (and (rtl:assign? rtl)
+ (rtl:expression=? (rtl:assign-address rtl)
+ expression))
+ (expression-clobbers-stack-pointer? rtl))
+ (values false false))
+ (else
+ (phi-2 (rinst-next next) offset)))))
+ (define (phi-2 next offset)
+ (if (rinst-dead-register? next register)
+ (values next
+ (rtl:make-offset (rtl:offset-base expression)
+ (rtl:make-machine-constant
+ offset)))
+ (phi-1 next offset)))
+ (phi-1 next
+ (rtl:machine-constant-value
+ (rtl:offset-offset expression)))))
+ ((and (rtl:offset-address? expression)
+ (interpreter-stack-pointer?
+ (rtl:offset-address-base expression)))
+ (search-stopping-at expression
+ expression-clobbers-stack-pointer?))
+ ((rtl:constant-expression? expression)
+ (let loop ((next (rinst-next next)))
+ (if (rinst-dead-register? next register)
+ (values next expression)
+ (loop (rinst-next next)))))
+ ((or (rtl:offset? expression)
+ (rtl:byte-offset? expression)
+ (rtl:float-offset? expression))
+ (search-stopping-at
+ expression
+ (lambda (rtl)
+ (or (and (rtl:assign? rtl)
+ (memq (rtl:expression-type
+ (rtl:assign-address rtl))
+ '(OFFSET POST-INCREMENT PRE-INCREMENT)))
+ (expression-clobbers-stack-pointer? rtl)))))
+ ((and (rtl:cons-pointer? expression)
+ (rtl:machine-constant? (rtl:cons-pointer-type expression)))
+ (recursion rtl:cons-pointer-datum
+ (lambda (datum)
+ (rtl:make-cons-pointer
+ (rtl:cons-pointer-type expression)
+ datum))))
+ ((and (rtl:cons-non-pointer? expression)
+ (rtl:machine-constant?
+ (rtl:cons-non-pointer-type expression)))
+ (recursion rtl:cons-non-pointer-datum
+ (lambda (datum)
+ (rtl:make-cons-non-pointer
+ (rtl:cons-non-pointer-type expression)
+ datum))))
+ ((rtl:object->address? expression)
+ (recursion rtl:object->address-expression
+ rtl:make-object->address))
+ ((rtl:object->datum? expression)
+ (recurse-and-search rtl:object->datum-expression
+ rtl:make-object->datum))
+ ((rtl:object->fixnum? expression)
+ (recurse-and-search rtl:object->fixnum-expression
+ rtl:make-object->fixnum))
+ ((rtl:object->type? expression)
+ (recursion rtl:object->type-expression rtl:make-object->type))
+ ((rtl:object->unsigned-fixnum? expression)
+ (recursion rtl:object->unsigned-fixnum-expression
+ rtl:make-object->unsigned-fixnum))
+ (else
+ (values false false)))))))
+\f
+(define (expression-clobbers-stack-pointer? rtl)
+ (or (and (rtl:assign? rtl)
+ (rtl:register? (rtl:assign-address rtl))
+ (interpreter-stack-pointer? (rtl:assign-address rtl)))
+ (rtl:invocation? rtl)
+ (rtl:invocation-prefix? rtl)
+ (let loop ((expression rtl))
+ (rtl:any-subexpression? expression
+ (lambda (expression)
+ (cond ((rtl:pre-increment? expression)
+ (interpreter-stack-pointer?
+ (rtl:pre-increment-register expression)))
+ ((rtl:post-increment? expression)
+ (interpreter-stack-pointer?
+ (rtl:post-increment-register expression)))
+ (else
+ (loop expression))))))))
+
+(define (expression-is-stack-push? rtl)
+ (and (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl)))
+ (and (rtl:pre-increment? address)
+ (interpreter-stack-pointer?
+ (rtl:pre-increment-register address))
+ (= -1 (rtl:pre-increment-number address))))))
+
+(define (fold-instructions! live rinst next register expression)
+ ;; Attempt to fold `expression' into the place of `register' in the
+ ;; RTL instruction `next'. If the resulting instruction is
+ ;; reasonable (i.e. if the LAP generator informs us that it has a
+ ;; pattern for generating that instruction), the folding is
+ ;; performed.
+ (let ((rtl (rinst-rtl next)))
+ (if (rtl:refers-to-register? rtl register)
+ (let ((rtl (rtl:subst-register rtl register expression)))
+ (if (lap-generator/match-rtl-instruction rtl)
+ (begin
+ (set-rinst-rtl! rinst false)
+ (set-rinst-rtl! next rtl)
+ (for-each-regset-member live decrement-register-live-length!)
+ (let ((dead
+ (new-dead-registers
+ (rinst-next rinst)
+ next
+ (rinst-dead-registers rinst)
+ (rtl:expression-register-references expression))))
+ (set-rinst-dead-registers!
+ next
+ (eqv-set-union dead
+ (delv! register
+ (rinst-dead-registers next)))))
+ (reset-register-n-refs! register)
+ (reset-register-n-deaths! register)
+ (reset-register-live-length! register)
+ (set-register-bblock! register false)))))))
+
+(define (new-dead-registers rinst next old-dead registers)
+ (let loop ((rinst rinst) (new-dead old-dead))
+ (for-each increment-register-live-length! new-dead)
+ (if (eq? rinst next)
+ new-dead
+ (let* ((dead (rinst-dead-registers rinst))
+ (dead* (eqv-set-intersection dead registers)))
+ (if (not (null? dead*))
+ (begin
+ (set-rinst-dead-registers!
+ rinst
+ (eqv-set-difference dead dead*))
+ (loop (rinst-next rinst) (eqv-set-union dead* new-dead)))
+ (loop (rinst-next rinst) new-dead))))))
+
+(define (rtl:expression-register-references expression)
+ (let ((registers '()))
+ (let loop ((expression expression))
+ (if (rtl:pseudo-register-expression? expression)
+ (let ((register (rtl:register-number expression)))
+ (if (not (memv register registers))
+ (set! registers (cons register registers))))
+ (rtl:for-each-subexpression expression loop)))
+ registers))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rcse1.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; RTL Common Subexpression Elimination: Codewalker
+;;; Based on the GNU C Compiler
+;;; package: (compiler rtl-cse)
+
+(declare (usual-integrations))
+\f
+(define (common-subexpression-elimination rgraphs)
+ (with-new-node-marks (lambda () (for-each cse-rgraph rgraphs))))
+
+(define-structure (state (type vector) (conc-name state/))
+ (register-tables false read-only true)
+ (hash-table false read-only true)
+ (stack-offset false read-only true)
+ (stack-reference-quantities false read-only true))
+
+#|
+;;(define *initial-queue*)
+;;(define *branch-queue*)
+;;
+;;(define (cse-rgraph rgraph)
+;; (fluid-let ((*current-rgraph* rgraph)
+;; (*next-quantity-number* 0)
+;; (*initial-queue* (make-queue))
+;; (*branch-queue* '()))
+;; (for-each (lambda (edge)
+;; (enqueue!/unsafe *initial-queue* (edge-right-node edge)))
+;; (rgraph-initial-edges rgraph))
+;; (fluid-let ((*register-tables*
+;; (register-tables/make (rgraph-n-registers rgraph)))
+;; (*hash-table*)
+;; (*stack-offset*)
+;; (*stack-reference-quantities*))
+;; (continue-walk))))
+;;
+;;(define (continue-walk)
+;; (cond ((not (null? *branch-queue*))
+;; (let ((entry (car *branch-queue*)))
+;; (set! *branch-queue* (cdr *branch-queue*))
+;; (let ((state (car entry)))
+;; (set! *register-tables* (state/register-tables state))
+;; (set! *hash-table* (state/hash-table state))
+;; (set! *stack-offset* (state/stack-offset state))
+;; (set! *stack-reference-quantities*
+;; (state/stack-reference-quantities state)))
+;; (walk-bblock (cdr entry))))
+;; ((not (queue-empty? *initial-queue*))
+;; (state/reset!)
+;; (walk-bblock (dequeue!/unsafe *initial-queue*)))))
+;;\f
+;;(define (walk-bblock bblock)
+;; (let loop ((rinst (bblock-instructions bblock)))
+;; (let ((rtl (rinst-rtl rinst)))
+;; ((if (eq? (rtl:expression-type rtl) 'ASSIGN)
+;; cse/assign
+;; (let ((entry (assq (rtl:expression-type rtl) cse-methods)))
+;; (if (not entry)
+;; (error "Missing CSE method" (rtl:expression-type rtl)))
+;; (cdr entry)))
+;; rtl))
+;; (if (rinst-next rinst)
+;; (loop (rinst-next rinst))))
+;; (node-mark! bblock)
+;; (if (sblock? bblock)
+;; (let ((next (snode-next bblock)))
+;; (if (walk-next? next)
+;; (walk-next next)
+;; (continue-walk)))
+;; (let ((consequent (pnode-consequent bblock))
+;; (alternative (pnode-alternative bblock)))
+;; (if (walk-next? consequent)
+;; (if (walk-next? alternative)
+;; (if (node-previous>1? consequent)
+;; (begin (enqueue!/unsafe *initial-queue* consequent)
+;; (walk-next alternative))
+;; (begin (if (node-previous>1? alternative)
+;; (enqueue!/unsafe *initial-queue* alternative)
+;; (set! *branch-queue*
+;; (cons (cons (state/get) alternative)
+;; *branch-queue*)))
+;; (walk-bblock consequent)))
+;; (walk-next consequent))
+;; (if (walk-next? alternative)
+;; (walk-next alternative)
+;; (continue-walk))))))
+;;
+;;(define-integrable (walk-next? bblock)
+;; (and bblock (not (node-marked? bblock))))
+;;
+;;(define-integrable (walk-next bblock)
+;; (if (node-previous>1? bblock) (state/reset!))
+;; (walk-bblock bblock))
+;;
+;;(define (state/get)
+;; (make-state (register-tables/copy *register-tables*)
+;; (hash-table-copy *hash-table*)
+;; *stack-offset*
+;; (map (lambda (entry)
+;; (cons (car entry) (quantity-copy (cdr entry))))
+;; *stack-reference-quantities*)))
+;;
+;;(define (state/reset!)
+;; (register-tables/reset! *register-tables*)
+;; (set! *hash-table* (make-hash-table))
+;; (set! *stack-offset* 0)
+;; (set! *stack-reference-quantities* '())
+;; unspecific)
+|#
+\f
+;;;; New rgraph walker
+
+(define *any-preserved?*)
+
+(define (cse-rgraph rgraph)
+ (fluid-let ((*current-rgraph* rgraph)
+ (*next-quantity-number* 0)
+ (*register-tables*)
+ (*hash-table*)
+ (*stack-offset*)
+ (*stack-reference-quantities*)
+ (*any-preserved?*))
+ (state/set! (state/make-empty))
+ (let loop ((bblocks (sort-bblocks-topologically (rgraph-bblocks rgraph)))
+ (bblock-info '()))
+ (if (not (null? bblocks))
+ (let ((bblock (car bblocks)))
+ (restore-state! bblock bblock-info)
+ (walk-bblock bblock)
+ (loop (cdr bblocks)
+ (if (or (pblock? bblock)
+ (snode-next bblock))
+ (cons (list bblock
+ (state/get)
+ *any-preserved?*
+ (not (pblock? bblock)))
+ bblock-info)
+ ;; No successors, let the state be GC'd
+ bblock-info)))))))
+\f
+(define (restore-state! bblock bblock-info)
+ (define (do-single-predecessor info)
+ (cond ((not info) ; loop in graph
+ (state/make-empty))
+ ((or (sblock? (car info))
+ (cadddr info))
+ (cadr info))
+ (else
+ ;; This branch copies the state.
+ ;; Remember that the other branch need not.
+ (set-car! (cdddr info) true)
+ (state/copy (cadr info)))))
+
+ (define (try-to-restore bblock*)
+ (let ((info (assq bblock* bblock-info)))
+ (do-single-predecessor (and info
+ (caddr info)
+ info))))
+
+ (set! *any-preserved?* false)
+ (state/restore!
+ (let ((previous (node-previous-edges bblock)))
+ (cond ((null? previous)
+ (let ((state (state/make-empty)))
+ (state/set! state)
+ state))
+ ((not (for-all? previous edge-left-node))
+ (cond ((or (null? (cdr previous))
+ (not (null? (cddr previous))))
+ (state/make-empty))
+ ((edge-left-node (car previous))
+ => try-to-restore)
+ ((edge-left-node (cadr previous))
+ => try-to-restore)
+ (else
+ (state/make-empty))))
+ ((null? (cdr previous))
+ (do-single-predecessor (assq (edge-left-node (car previous))
+ bblock-info)))
+ (else
+ (state/merge* (map (lambda (edge)
+ (let ((bblock* (edge-left-node edge)))
+ (assq bblock* bblock-info)))
+ previous)))))))
+
+(define (preserve-register! regno)
+ (set! *any-preserved?* true)
+ (set-register-preserved?! regno true))
+
+(define (walk-bblock bblock)
+ (let loop ((rinst (bblock-instructions bblock)))
+ (let ((rtl (rinst-rtl rinst)))
+ (case (rtl:expression-type rtl)
+ ((ASSIGN)
+ (cse/assign rtl))
+ ((PRESERVE)
+ (preserve-register!
+ (rtl:register-number (rtl:preserve-register rtl))))
+ ((RESTORE)
+ ;; ignore completely
+ unspecific)
+ (else
+ (let ((entry (assq (rtl:expression-type rtl)
+ cse-methods)))
+ (if (not entry)
+ (error "Missing CSE method"
+ (rtl:expression-type rtl)))
+ ((cdr entry) rtl)))))
+ (if (rinst-next rinst)
+ (loop (rinst-next rinst)))))
+\f
+(define (sort-bblocks-topologically bblocks)
+ (let ((pairs (map (lambda (bblock)
+ (cons bblock (topo-node/make bblock)))
+ bblocks)))
+ (for-each
+ (lambda (pair)
+ (let ((bblock (car pair))
+ (node (cdr pair)))
+ (for-each (lambda (edge)
+ (let ((bblock* (edge-left-node edge)))
+ (if bblock*
+ (let ((node* (cdr (assq bblock* pairs))))
+ (set-topo-node/before!
+ node
+ (cons node* (topo-node/before node)))
+ (set-topo-node/after!
+ node*
+ (cons node (topo-node/after node*)))))))
+ (node-previous-edges bblock))))
+ pairs)
+ (map topo-node/contents (sort-topologically (map cdr pairs)))))
+
+(define (state/get)
+ (make-state *register-tables*
+ *hash-table*
+ *stack-offset*
+ *stack-reference-quantities*))
+
+(define (state/copy state)
+ (make-state (register-tables/copy (state/register-tables state))
+ (hash-table-copy (state/hash-table state))
+ (state/stack-offset state)
+ (map (lambda (entry)
+ (cons (car entry) (quantity-copy (cdr entry))))
+ (state/stack-reference-quantities state))))
+
+(define (state/set! state)
+ (set! *register-tables* (state/register-tables state))
+ (set! *hash-table* (state/hash-table state))
+ (set! *stack-offset* (state/stack-offset state))
+ (set! *stack-reference-quantities* (state/stack-reference-quantities state))
+ unspecific)
+
+(define (state/restore! state)
+ (state/set! state)
+ (register-tables/restore! *register-tables*))
+
+(define (state/make-empty)
+ (let ((reg-tables
+ (register-tables/make (rgraph-n-registers *current-rgraph*))))
+ (register-tables/reset! reg-tables)
+ (make-state reg-tables
+ (make-hash-table)
+ 0
+ '())))
+\f
+(define (define-cse-method type method)
+ (let ((entry (assq type cse-methods)))
+ (if entry
+ (set-cdr! entry method)
+ (set! cse-methods (cons (cons type method) cse-methods))))
+ type)
+
+(define cse-methods
+ '())
+
+(define (cse/assign statement)
+ (expression-replace! rtl:assign-expression rtl:set-assign-expression!
+ statement
+ (lambda (volatile? insert-source!)
+ ((let ((address (rtl:assign-address statement)))
+ (if volatile? (notice-pop! (rtl:assign-expression statement)))
+ (cond ((rtl:register? address) cse/assign/register)
+ ((stack-reference? address) cse/assign/stack-reference)
+ ((and (rtl:pre-increment? address)
+ (interpreter-stack-pointer?
+ (rtl:address-register address)))
+ cse/assign/stack-push)
+ ((interpreter-register-reference? address)
+ cse/assign/interpreter-register)
+ (else
+ (let ((address (expression-canonicalize address)))
+ (rtl:set-assign-address! statement address)
+ cse/assign/general))))
+ (rtl:assign-address statement)
+ (rtl:assign-expression statement)
+ volatile?
+ insert-source!))))
+
+(define (cse/assign/register address expression volatile? insert-source!)
+ (if (interpreter-stack-pointer? address)
+ (if (and (rtl:offset? expression)
+ (interpreter-stack-pointer? (rtl:offset-base expression))
+ (rtl:machine-constant? (rtl:offset-offset expression)))
+ (stack-pointer-adjust!
+ (rtl:machine-constant-value (rtl:offset-offset expression)))
+ (begin
+ (stack-invalidate!)
+ (stack-pointer-invalidate!)))
+ (register-expression-invalidate! address))
+ (if (and (not volatile?)
+ (pseudo-register? (rtl:register-number address)))
+ (insert-register-destination! address (insert-source!))))
+
+(define (cse/assign/stack-reference address expression volatile?
+ insert-source!)
+ expression
+ (stack-reference-invalidate! address)
+ (if (not volatile?)
+ (insert-stack-destination! address (insert-source!))))
+
+(define (cse/assign/stack-push address expression volatile? insert-source!)
+ expression
+ (let ((adjust!
+ (lambda ()
+ (stack-pointer-adjust! (rtl:address-number address)))))
+ (if (not volatile?)
+ (let ((element (insert-source!)))
+ (adjust!)
+ (insert-stack-destination!
+ (rtl:make-offset (interpreter-stack-pointer)
+ (rtl:make-machine-constant 0))
+ element))
+ (adjust!))))
+\f
+(define (cse/assign/interpreter-register address expression volatile?
+ insert-source!)
+ expression
+ (let ((hash (expression-hash address)))
+ (let ((memory-invalidate!
+ (lambda ()
+ (hash-table-delete! hash (hash-table-lookup hash address)))))
+ (if volatile?
+ (memory-invalidate!)
+ (assignment-memory-insertion address
+ hash
+ insert-source!
+ memory-invalidate!)))))
+
+(define (cse/assign/general address expression volatile? insert-source!)
+ expression
+ (full-expression-hash address
+ (lambda (hash volatile?* in-memory?)
+ in-memory?
+ (let ((memory-invalidate!
+ (cond ((stack-pop? address)
+ (lambda () unspecific))
+ ((and (memq (rtl:expression-type address)
+ '(PRE-INCREMENT POST-INCREMENT))
+ (interpreter-free-pointer?
+ (rtl:address-register address)))
+ (lambda ()
+ (register-expression-invalidate!
+ (rtl:address-register address))))
+ ((expression-address-varies? address)
+ (lambda ()
+ (hash-table-delete-class! element-in-memory?)))
+ (else
+ (lambda ()
+ (hash-table-delete! hash
+ (hash-table-lookup hash address))
+ (varying-address-invalidate!))))))
+ (if (or volatile? volatile?*)
+ (memory-invalidate!)
+ (assignment-memory-insertion address
+ hash
+ insert-source!
+ memory-invalidate!)))))
+ (notice-pop! address))
+
+(define (notice-pop! expression)
+ ;; **** Kludge. Works only because stack-pointer
+ ;; gets used in very fixed way by code generator.
+ (if (stack-pop? expression)
+ (stack-pointer-adjust! (rtl:address-number expression))))
+\f
+(define (assignment-memory-insertion address hash insert-source!
+ memory-invalidate!)
+ #|
+ ;; This does not cause bugs (false hash number passed to
+ ;; insert-memory-destination! fixed one), but does not do anything
+ ;; useful. The idea of doing optimization on the address of a
+ ;; memory assignment does not work since the RTL does not
+ ;; distinguish addresses from references. When the RTL is changed,
+ ;; we can do CSE on the memory address.
+ (let ((address (find-cheapest-expression address hash false)))
+ (let ((element (insert-source!)))
+ (memory-invalidate!)
+ (insert-memory-destination! address element false)))
+ |#
+ hash
+ (insert-source!)
+ (memory-invalidate!)
+ (mention-registers! address))
+
+(define (trivial-action volatile? insert-source!)
+ (if (not volatile?)
+ (insert-source!)))
+
+(define (define-trivial-one-arg-method type get set)
+ (define-cse-method type
+ (lambda (statement)
+ (expression-replace! get set statement trivial-action))))
+
+(define (define-trivial-two-arg-method type get-1 set-1 get-2 set-2)
+ (define-cse-method type
+ (lambda (statement)
+ (expression-replace! get-1 set-1 statement trivial-action)
+ (expression-replace! get-2 set-2 statement trivial-action))))
+
+(define-trivial-two-arg-method 'EQ-TEST
+ rtl:eq-test-expression-1 rtl:set-eq-test-expression-1!
+ rtl:eq-test-expression-2 rtl:set-eq-test-expression-2!)
+
+(define-trivial-one-arg-method 'PRED-1-ARG
+ rtl:pred-1-arg-operand rtl:set-pred-1-arg-operand!)
+
+(define-trivial-two-arg-method 'PRED-2-ARGS
+ rtl:pred-2-args-operand-1 rtl:set-pred-2-args-operand-1!
+ rtl:pred-2-args-operand-2 rtl:set-pred-2-args-operand-2!)
+
+(define-trivial-one-arg-method 'FIXNUM-PRED-1-ARG
+ rtl:fixnum-pred-1-arg-operand rtl:set-fixnum-pred-1-arg-operand!)
+
+(define-trivial-two-arg-method 'FIXNUM-PRED-2-ARGS
+ rtl:fixnum-pred-2-args-operand-1 rtl:set-fixnum-pred-2-args-operand-1!
+ rtl:fixnum-pred-2-args-operand-2 rtl:set-fixnum-pred-2-args-operand-2!)
+
+(define-trivial-one-arg-method 'FLONUM-PRED-1-ARG
+ rtl:flonum-pred-1-arg-operand rtl:set-flonum-pred-1-arg-operand!)
+
+(define-trivial-two-arg-method 'FLONUM-PRED-2-ARGS
+ rtl:flonum-pred-2-args-operand-1 rtl:set-flonum-pred-2-args-operand-1!
+ rtl:flonum-pred-2-args-operand-2 rtl:set-flonum-pred-2-args-operand-2!)
+
+(define-trivial-one-arg-method 'TYPE-TEST
+ rtl:type-test-expression rtl:set-type-test-expression!)
+\f
+(define (method/noop statement)
+ statement
+ unspecific)
+
+(define-cse-method 'OVERFLOW-TEST method/noop)
+(define-cse-method 'POP-RETURN method/noop)
+(define-cse-method 'CONTINUATION-ENTRY method/noop)
+(define-cse-method 'CONTINUATION-HEADER method/noop)
+(define-cse-method 'IC-PROCEDURE-HEADER method/noop)
+(define-cse-method 'OPEN-PROCEDURE-HEADER method/noop)
+(define-cse-method 'PROCEDURE-HEADER method/noop)
+(define-cse-method 'CLOSURE-HEADER method/noop)
+(define-cse-method 'INVOCATION:JUMP method/noop)
+(define-cse-method 'INVOCATION:LEXPR method/noop)
+
+(define (invalidate-pseudo-registers! n-pushed)
+ (for-each-pseudo-register
+ (lambda (register)
+ (if (not (register-preserved? register))
+ (let ((expression (register-expression register)))
+ (if expression
+ (register-expression-invalidate! expression))))))
+ (stack-pointer-adjust! (stack->memory-offset n-pushed))
+ (expression-invalidate! (interpreter-value-register))
+ (expression-invalidate! (interpreter-free-pointer)))
+
+(define (method/unknown-invocation statement)
+ (invalidate-pseudo-registers! (rtl:invocation-pushed statement)))
+
+(define-cse-method 'INVOCATION:APPLY method/unknown-invocation)
+(define-cse-method 'INVOCATION:COMPUTED-JUMP method/unknown-invocation)
+(define-cse-method 'INVOCATION:COMPUTED-LEXPR method/unknown-invocation)
+(define-cse-method 'INVOCATION:UUO-LINK method/unknown-invocation)
+(define-cse-method 'INVOCATION:GLOBAL-LINK method/unknown-invocation)
+(define-cse-method 'INVOCATION:PRIMITIVE method/unknown-invocation)
+(define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/unknown-invocation)
+
+(define-cse-method 'INVOCATION:CACHE-REFERENCE
+ (lambda (statement)
+ (expression-replace! rtl:invocation:cache-reference-name
+ rtl:set-invocation:cache-reference-name!
+ statement
+ trivial-action)
+ (method/unknown-invocation statement)))
+
+(define-cse-method 'INVOCATION:LOOKUP
+ (lambda (statement)
+ (expression-replace! rtl:invocation:lookup-environment
+ rtl:set-invocation:lookup-environment!
+ statement
+ trivial-action)
+ (method/unknown-invocation statement)))
+
+(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP
+ (lambda (statement)
+ (expression-replace! rtl:invocation-prefix:move-frame-up-locative
+ rtl:set-invocation-prefix:move-frame-up-locative!
+ statement
+ trivial-action)
+ (stack-invalidate!)
+ (stack-pointer-invalidate!)))
+
+(define-cse-method 'INVOCATION-PREFIX:DYNAMIC-LINK
+ (lambda (statement)
+ (expression-replace! rtl:invocation-prefix:dynamic-link-locative
+ rtl:set-invocation-prefix:dynamic-link-locative!
+ statement
+ trivial-action)
+ (expression-replace! rtl:invocation-prefix:dynamic-link-register
+ rtl:set-invocation-prefix:dynamic-link-register!
+ statement
+ trivial-action)
+ (stack-invalidate!)
+ (stack-pointer-invalidate!)))
+\f
+(define (define-lookup-method type get-environment set-environment! register)
+ (define-cse-method type
+ (lambda (statement)
+ (expression-replace! get-environment set-environment! statement
+ (lambda (volatile? insert-source!)
+ (expression-invalidate! (register))
+ #|
+ (non-object-invalidate!)
+ |#
+ (invalidate-pseudo-registers! 0)
+ (if (not volatile?) (insert-source!)))))))
+
+(define-lookup-method 'INTERPRETER-CALL:ACCESS
+ rtl:interpreter-call:access-environment
+ rtl:set-interpreter-call:access-environment!
+ interpreter-register:access)
+
+(define-lookup-method 'INTERPRETER-CALL:CACHE-REFERENCE
+ rtl:interpreter-call:cache-reference-name
+ rtl:set-interpreter-call:cache-reference-name!
+ interpreter-register:cache-reference)
+
+(define-lookup-method 'INTERPRETER-CALL:CACHE-UNASSIGNED?
+ rtl:interpreter-call:cache-unassigned?-name
+ rtl:set-interpreter-call:cache-unassigned?-name!
+ interpreter-register:cache-unassigned?)
+
+(define-lookup-method 'INTERPRETER-CALL:LOOKUP
+ rtl:interpreter-call:lookup-environment
+ rtl:set-interpreter-call:lookup-environment!
+ interpreter-register:lookup)
+
+(define-lookup-method 'INTERPRETER-CALL:UNASSIGNED?
+ rtl:interpreter-call:unassigned?-environment
+ rtl:set-interpreter-call:unassigned?-environment!
+ interpreter-register:unassigned?)
+
+(define-lookup-method 'INTERPRETER-CALL:UNBOUND?
+ rtl:interpreter-call:unbound?-environment
+ rtl:set-interpreter-call:unbound?-environment!
+ interpreter-register:unbound?)
+
+(define (define-assignment-method type
+ get-environment set-environment!
+ get-value set-value!)
+ (define-cse-method type
+ (lambda (statement)
+ (expression-replace! get-value set-value! statement trivial-action)
+ (expression-replace! get-environment set-environment! statement
+ (lambda (volatile? insert-source!)
+ (varying-address-invalidate!)
+ (non-object-invalidate!)
+ (if (not volatile?) (insert-source!)))))))
+
+(define-assignment-method 'INTERPRETER-CALL:CACHE-ASSIGNMENT
+ rtl:interpreter-call:cache-assignment-name
+ rtl:set-interpreter-call:cache-assignment-name!
+ rtl:interpreter-call:cache-assignment-value
+ rtl:set-interpreter-call:cache-assignment-value!)
+
+(define-assignment-method 'INTERPRETER-CALL:DEFINE
+ rtl:interpreter-call:define-environment
+ rtl:set-interpreter-call:define-environment!
+ rtl:interpreter-call:define-value
+ rtl:set-interpreter-call:define-value!)
+
+(define-assignment-method 'INTERPRETER-CALL:SET!
+ rtl:interpreter-call:set!-environment
+ rtl:set-interpreter-call:set!-environment!
+ rtl:interpreter-call:set!-value
+ rtl:set-interpreter-call:set!-value!)
+\f
+;; New stuff
+
+(define-cse-method 'INVOCATION:PROCEDURE method/unknown-invocation)
+(define-cse-method 'INTERRUPT-CHECK:PROCEDURE method/noop)
+(define-cse-method 'INTERRUPT-CHECK:CONTINUATION method/noop)
+(define-cse-method 'INTERRUPT-CHECK:CLOSURE method/noop)
+(define-cse-method 'INTERRUPT-CHECK:SIMPLE-LOOP method/noop)
+(define-cse-method 'PROCEDURE method/noop)
+(define-cse-method 'TRIVIAL-CLOSURE method/noop)
+(define-cse-method 'CLOSURE method/noop)
+(define-cse-method 'EXPRESSION method/noop)
+(define-cse-method 'RETURN-ADDRESS method/noop)
+#|
+;; Handled specially
+(define-cse-method 'PRESERVE method/noop)
+(define-cse-method 'RESTORE method/noop)
+|#
+
+(define-cse-method 'INVOCATION:REGISTER
+ (lambda (statement)
+ (expression-replace! rtl:invocation:register-destination
+ rtl:set-invocation:register-destination!
+ statement
+ trivial-action)
+ (method/unknown-invocation statement)))
+
+(define-cse-method 'INVOCATION:NEW-APPLY
+ (lambda (statement)
+ (expression-replace! rtl:invocation:new-apply-destination
+ rtl:set-invocation:new-apply-destination!
+ statement
+ trivial-action)
+ (method/unknown-invocation statement)))
+
+;; End of new stuff
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rcse2.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; RTL Common Subexpression Elimination
+;;; Based on the GNU C Compiler
+;; package: (compiler rtl-cse)
+
+(declare (usual-integrations))
+\f
+;;;; Canonicalization
+
+(define (expression-replace! statement-expression set-statement-expression!
+ statement receiver)
+ ;; Replace the expression by its cheapest equivalent. Returns two
+ ;; values: (1) a flag which is true iff the expression is volatile;
+ ;; and (2) a thunk which, when called, will insert the expression in
+ ;; the hash table, returning the element. Do not call the thunk if
+ ;; the expression is volatile.
+ (let ((expression (statement-expression statement)))
+ (if (and (rtl:register? expression)
+ (machine-register? (rtl:register-number expression)))
+ (begin
+ (set-statement-expression! statement expression)
+ (receiver true (lambda () (error "Insert source invoked"))))
+ (expression-replace!/1 expression set-statement-expression!
+ statement receiver))))
+
+(define (expression-replace!/1 expression* set-statement-expression!
+ statement receiver)
+ (let ((expression (expression-canonicalize expression*)))
+ (full-expression-hash expression
+ (lambda (hash volatile? in-memory?)
+ (let ((element
+ (find-cheapest-valid-element expression hash volatile?)))
+ (let ((finish
+ (lambda (expression hash volatile? in-memory?)
+ (set-statement-expression! statement expression)
+ (receiver volatile?
+ (expression-inserter expression
+ element
+ hash
+ in-memory?)))))
+ (if element
+ (let ((expression (element-expression element)))
+ (full-expression-hash expression
+ (lambda (hash volatile? in-memory?)
+ (finish expression hash volatile? in-memory?))))
+ (finish expression hash volatile? in-memory?))))))))
+
+(define ((expression-inserter expression element hash in-memory?))
+ (or element
+ (begin
+ (if (rtl:register? expression)
+ (set-register-expression! (rtl:register-number expression)
+ expression)
+ (mention-registers! expression))
+ (let ((element* (hash-table-insert! hash expression false)))
+ (set-element-in-memory?! element* in-memory?)
+ (element-first-value element*)))))
+
+(define (expression-canonicalize expression)
+ (cond ((rtl:register? expression)
+ (or (register-expression
+ (quantity-first-register
+ (get-register-quantity (rtl:register-number expression))))
+ expression))
+ ((stack-reference? expression)
+ (let ((register
+ (quantity-first-register
+ (stack-reference-quantity expression))))
+ (or (and register (register-expression register))
+ expression)))
+ (else
+ (rtl:map-subexpressions expression expression-canonicalize))))
+\f
+;;;; Hash
+
+(define (expression-hash expression)
+ (full-expression-hash expression
+ (lambda (hash do-not-record? hash-arg-in-memory?)
+ do-not-record? hash-arg-in-memory?
+ hash)))
+
+(define (full-expression-hash expression receiver)
+ (let ((do-not-record? false)
+ (hash-arg-in-memory? false))
+ (define (loop expression)
+ (let ((type (rtl:expression-type expression)))
+ (+ (symbol-hash type)
+ (case type
+ ((REGISTER)
+ (quantity-number
+ (get-register-quantity (rtl:register-number expression))))
+ ((OFFSET)
+ ;; Note that stack-references do not get treated as
+ ;; memory for purposes of invalidation. This is because
+ ;; (supposedly) no one ever accesses the stack directly
+ ;; except the compiler's output, which is explicit.
+ (if (interpreter-stack-pointer? (rtl:offset-base expression))
+ (quantity-number (stack-reference-quantity expression))
+ (begin
+ (set! hash-arg-in-memory? true)
+ (continue expression))))
+ ((BYTE-OFFSET FLOAT-OFFSET)
+ (set! hash-arg-in-memory? true)
+ (continue expression))
+ ((PRE-INCREMENT POST-INCREMENT)
+ (set! hash-arg-in-memory? true)
+ (set! do-not-record? true)
+ 0)
+ (else
+ (continue expression))))))
+
+ (define (continue expression)
+ (rtl:reduce-subparts expression + 0 loop
+ (lambda (object)
+ (cond ((integer? object) (inexact->exact object))
+ ((symbol? object) (symbol-hash object))
+ ((string? object) (string-hash object))
+ (else (hash object))))))
+
+ (let ((hash (loop expression)))
+ (receiver (modulo hash (hash-table-size))
+ do-not-record?
+ hash-arg-in-memory?))))
+\f
+;;;; Table Search
+
+(define (find-cheapest-expression expression hash volatile?)
+ ;; Find the cheapest equivalent expression for EXPRESSION.
+ (let ((element (find-cheapest-valid-element expression hash volatile?)))
+ (if element
+ (element-expression element)
+ expression)))
+
+(define (find-cheapest-valid-element expression hash volatile?)
+ ;; Find the cheapest valid hash table element for EXPRESSION.
+ ;; Returns false if no such element exists or if EXPRESSION is
+ ;; VOLATILE?.
+ (and (not volatile?)
+ (let ((element (hash-table-lookup hash expression)))
+ (and element
+ (let ((element* (element-first-value element)))
+ (if (eq? element element*)
+ element
+ (let loop ((element element*))
+ (and element
+ (let ((expression (element-expression element)))
+ (if (or (rtl:register? expression)
+ (expression-valid? expression))
+ element
+ (loop (element-next-value element))))))))))))
+
+(define (expression-valid? expression)
+ ;; True iff all registers mentioned in EXPRESSION have valid values
+ ;; in the hash table.
+ (if (rtl:register? expression)
+ (let ((register (rtl:register-number expression)))
+ (= (register-in-table register) (register-tick register)))
+ (rtl:all-subexpressions? expression expression-valid?)))
+
+(define (element->class element)
+ ;; Return the cheapest element in the hash table which has the same
+ ;; value as `element'. This is necessary because `element' may have
+ ;; been deleted due to register or memory invalidation.
+ (and element
+ ;; If `element' has been deleted from the hash table,
+ ;; `element-first-value' will be false. [ref crock-1]
+ (or (element-first-value element)
+ (element->class (element-next-value element)))))
+\f
+;;;; Insertion
+
+(define (insert-register-destination! expression element)
+ ;; Insert EXPRESSION, which should be a register expression, into
+ ;; the hash table as the destination of an assignment. ELEMENT is
+ ;; the hash table element for the value being assigned to
+ ;; EXPRESSION.
+ (let ((register (rtl:register-number expression)))
+ (set-register-expression! register expression)
+ (let ((quantity (get-element-quantity element)))
+ (if quantity
+ (begin
+ (set-register-quantity! register quantity)
+ (let ((last (quantity-last-register quantity)))
+ (cond ((not last)
+ (set-quantity-first-register! quantity register)
+ (set-register-next-equivalent! register false))
+ (else
+ (set-register-next-equivalent! last register)
+ (set-register-previous-equivalent! register last))))
+ (set-quantity-last-register! quantity register)))))
+ (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
+ expression
+ (element->class element))
+ false))
+
+(define (insert-stack-destination! expression element)
+ (let ((quantity (get-element-quantity element)))
+ (if quantity
+ (set-stack-reference-quantity! expression quantity)))
+ (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
+ expression
+ (element->class element))
+ false))
+
+(define (get-element-quantity element)
+ (let loop ((element (element->class element)))
+ (and element
+ (let ((expression (element-expression element)))
+ (cond ((rtl:register? expression)
+ (get-register-quantity (rtl:register-number expression)))
+ ((stack-reference? expression)
+ (stack-reference-quantity expression))
+ (else
+ (loop (element-next-value element))))))))
+\f
+(define (insert-memory-destination! expression element hash)
+ (let ((class (element->class element)))
+ (mention-registers! expression)
+ ;; Optimization: if class and hash are both false, hash-table-insert!
+ ;; makes an element which is not connected to the rest of the table.
+ ;; In that case, there is no need to make an element at all.
+ (if (or class hash)
+ (set-element-in-memory?! (hash-table-insert! hash expression class)
+ true))))
+
+(define (mention-registers! expression)
+ (if (rtl:register? expression)
+ (let ((register (rtl:register-number expression)))
+ (remove-invalid-references! register)
+ (set-register-in-table! register (register-tick register)))
+ (rtl:for-each-subexpression expression mention-registers!)))
+
+(define (remove-invalid-references! register)
+ ;; If REGISTER is invalid, delete from the hash table all
+ ;; expressions which refer to it.
+ (if (let ((in-table (register-in-table register)))
+ (and (not (negative? in-table))
+ (not (= in-table (register-tick register)))))
+ (let ((expression (register-expression register)))
+ (hash-table-delete-class!
+ (lambda (element)
+ (let ((expression* (element-expression element)))
+ (and (not (rtl:register? expression*))
+ (expression-refers-to? expression* expression)))))))
+ unspecific)
+\f
+;;;; Invalidation
+
+(define (non-object-invalidate!)
+ (hash-table-delete-class!
+ (lambda (element)
+ (not (rtl:object-valued-expression? (element-expression element))))))
+
+(define (varying-address-invalidate!)
+ (hash-table-delete-class!
+ (lambda (element)
+ (and (element-in-memory? element)
+ (expression-address-varies? (element-expression element))))))
+
+(define (expression-invalidate! expression)
+ ;; Delete from the table any expression which refers to this
+ ;; expression.
+ (if (rtl:register? expression)
+ (register-expression-invalidate! expression)
+ (hash-table-delete-class!
+ (lambda (element)
+ (expression-refers-to? (element-expression element) expression)))))
+
+(define (register-expression-invalidate! expression)
+ ;; Invalidate a register expression. These expressions are handled
+ ;; specially for efficiency -- the register is marked invalid but we
+ ;; delay searching the hash table for relevant expressions.
+ (let ((register (rtl:register-number expression))
+ (hash (expression-hash expression)))
+ (register-invalidate! register)
+ ;; If we're invalidating the stack pointer, delete its entries
+ ;; immediately.
+ (if (interpreter-stack-pointer? expression)
+ (mention-registers! expression)
+ (hash-table-delete! hash (hash-table-lookup hash expression)))))
+
+(define (register-invalidate! register)
+ (let ((next (register-next-equivalent register))
+ (previous (register-previous-equivalent register))
+ (quantity (get-register-quantity register)))
+ (set-register-tick! register (1+ (register-tick register)))
+ (if next
+ (set-register-previous-equivalent! next previous)
+ (set-quantity-last-register! quantity previous))
+ (if previous
+ (set-register-next-equivalent! previous next)
+ (set-quantity-first-register! quantity next))
+ (set-register-quantity! register (new-quantity register))
+ (set-register-next-equivalent! register false)
+ (set-register-previous-equivalent! register false))
+ unspecific)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rcseep.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; RTL Common Subexpression Elimination: Expression Predicates
+;;; Based on the GNU C Compiler
+
+(declare (usual-integrations))
+\f
+(define (expression-equivalent? x y validate?)
+ ;; If VALIDATE? is true, assume that Y comes from the hash table and
+ ;; should have its register references validated.
+ (define (loop x y)
+ (let ((type (rtl:expression-type x)))
+ (and (eq? type (rtl:expression-type y))
+ (cond ((eq? type 'REGISTER)
+ (register-equivalent? x y))
+ ((and (memq type '(OFFSET BYTE-OFFSET))
+ (interpreter-stack-pointer? (rtl:offset-base x)))
+ (and (interpreter-stack-pointer? (rtl:offset-base y))
+ (eq? (stack-reference-quantity x)
+ (stack-reference-quantity y))))
+ (else
+ (rtl:match-subexpressions x y loop))))))
+
+ (define (register-equivalent? x y)
+ (let ((x (rtl:register-number x))
+ (y (rtl:register-number y)))
+ (and (eq? (get-register-quantity x) (get-register-quantity y))
+ (or (not validate?)
+ (= (register-in-table y) (register-tick y))))))
+
+ (loop x y))
+
+(define (expression-refers-to? x y)
+ ;; True iff any subexpression of X matches Y.
+ (define (loop x)
+ (or (eq? x y)
+ (if (eq? (rtl:expression-type x) (rtl:expression-type y))
+ (expression-equivalent? x y false)
+ (rtl:any-subexpression? x loop))))
+ (loop x))
+
+(define (interpreter-register-reference? expression)
+ (and (rtl:offset? expression)
+ (interpreter-regs-pointer? (rtl:offset-base expression))))
+
+(define (expression-address-varies? expression)
+ (and (not (interpreter-register-reference? expression))
+ (or (memq (rtl:expression-type expression)
+ '(OFFSET BYTE-OFFSET PRE-INCREMENT POST-INCREMENT))
+ (rtl:any-subexpression? expression expression-address-varies?))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rcseht.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; RTL Common Subexpression Elimination: Hash Table Abstraction
+;;; Based on the GNU C Compiler
+;;; package: (compiler rtl-cse)
+
+(declare (usual-integrations))
+\f
+(define (make-hash-table)
+ (make-vector 31 false))
+
+(define *hash-table*)
+
+(define-integrable (hash-table-size)
+ (vector-length *hash-table*))
+
+(define-integrable (hash-table-ref hash)
+ (vector-ref *hash-table* hash))
+
+(define-integrable (hash-table-set! hash element)
+ (vector-set! *hash-table* hash element))
+
+(define-structure (element
+ (constructor %make-element)
+ (constructor make-element (expression))
+ (print-procedure
+ (standard-unparser (symbol->string 'ELEMENT) false)))
+ (expression false read-only true)
+ (cost false)
+ (in-memory? false)
+ (next-hash false)
+ (previous-hash false)
+ (next-value false)
+ (previous-value false)
+ (first-value false))
+
+(define (hash-table-lookup hash expression)
+ (let loop ((element (hash-table-ref hash)))
+ (and element
+ (if (let ((expression* (element-expression element)))
+ (or (eq? expression expression*)
+ (expression-equivalent? expression expression* true)))
+ element
+ (loop (element-next-hash element))))))
+
+(define (hash-table-insert! hash expression class)
+ (let ((element (make-element expression))
+ (cost (rtl:expression-cost expression)))
+ (set-element-cost! element cost)
+ (if hash
+ (begin
+ (let ((next (hash-table-ref hash)))
+ (set-element-next-hash! element next)
+ (if next (set-element-previous-hash! next element)))
+ (hash-table-set! hash element)))
+ (cond ((not class)
+ (set-element-first-value! element element))
+ ((or (< cost (element-cost class))
+ (and (= cost (element-cost class))
+ (rtl:register? expression)
+ (not (rtl:register? (element-expression class)))))
+ (set-element-next-value! element class)
+ (set-element-previous-value! class element)
+ (let loop ((x element))
+ (if x
+ (begin
+ (set-element-first-value! x element)
+ (loop (element-next-value x))))))
+ (else
+ (set-element-first-value! element class)
+ (let loop ((previous class) (next (element-next-value class)))
+ (cond ((not next)
+ (set-element-next-value! element false)
+ (set-element-next-value! previous element)
+ (set-element-previous-value! element previous))
+ ((or (< cost (element-cost next))
+ (and (= cost (element-cost next))
+ (or (rtl:register? expression)
+ (not (rtl:register?
+ (element-expression next))))))
+ (set-element-next-value! element next)
+ (set-element-previous-value! next element)
+ (set-element-next-value! previous element)
+ (set-element-previous-value! element previous))
+ (else
+ (loop next (element-next-value next)))))))
+ element))
+\f
+(define (hash-table-delete! hash element)
+ (if element
+ (begin
+ ;; **** Mark this element as removed. [ref crock-1]
+ (set-element-first-value! element false)
+ (let ((next (element-next-value element))
+ (previous (element-previous-value element)))
+ (if next (set-element-previous-value! next previous))
+ (if previous
+ (set-element-next-value! previous next)
+ (let loop ((element next))
+ (if element
+ (begin
+ (set-element-first-value! element next)
+ (loop (element-next-value element)))))))
+ (let ((next (element-next-hash element))
+ (previous (element-previous-hash element)))
+ (if next (set-element-previous-hash! next previous))
+ (if previous
+ (set-element-next-hash! previous next)
+ (hash-table-set! hash next))))))
+
+(define (hash-table-delete-class! predicate)
+ (let table-loop ((i 0))
+ (if (< i (hash-table-size))
+ (let bucket-loop ((element (hash-table-ref i)))
+ (if element
+ (begin
+ (if (predicate element) (hash-table-delete! i element))
+ (bucket-loop (element-next-hash element)))
+ (table-loop (1+ i)))))))
+\f
+(define (hash-table-copy table)
+ ;; During this procedure, the `element-cost' slots of `table' are
+ ;; reused as "broken hearts".
+ (let ((elements (vector->list table)))
+ (let ((elements*
+ (map (lambda (element)
+ (let per-element ((element element) (previous false))
+ (and element
+ (let ((element*
+ (%make-element
+ (element-expression element)
+ (element-cost element)
+ (element-in-memory? element)
+ false
+ previous
+ (element-next-value element)
+ (element-previous-value element)
+ (element-first-value element))))
+ (set-element-cost! element element*)
+ (set-element-next-hash!
+ element*
+ (per-element (element-next-hash element)
+ element*))
+ element*))))
+ elements)))
+ (letrec ((per-element
+ (lambda (element)
+ (if element
+ (begin
+ (if (element-first-value element)
+ (set-element-first-value!
+ element
+ (element-cost (element-first-value element))))
+ (if (element-previous-value element)
+ (set-element-previous-value!
+ element
+ (element-cost (element-previous-value element))))
+ (if (element-next-value element)
+ (set-element-next-value!
+ element
+ (element-cost (element-next-value element))))
+ (per-element (element-next-hash element)))))))
+ (for-each per-element elements*))
+ (letrec ((per-element
+ (lambda (element)
+ (if element
+ (begin
+ (set-element-cost!
+ element
+ (element-cost (element-cost element)))
+ (per-element (element-next-hash element)))))))
+ (for-each per-element elements))
+ (list->vector elements*))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rcsemrg.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1994 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. |#
+
+;;;; RTL CSE merge
+;;; package: (compiler rtl-cse)
+\f
+(declare (usual-integrations))
+
+;;; For now, this is really dumb.
+;;; It takes the intersection of the states.
+;;; A better solution is to check whether a subexpression is redundant
+;;; with one of the predecessors, and if so, insert it into the other
+;;; predecessors. In order to avoid code blow-up a distinguished predecessor
+;;; can be chosen, and the rest can be intersected in the usual way.
+;;; Then there is no net code growth (except for perhaps one branch instr.)
+;;; because the expression would have been computed anyway after the merge.
+
+(define (state/merge* infos)
+ ;; each info is either #F (predecessor not yet processed),
+ ;; or a list of a bblock a state, and a flag signalling whether
+ ;; there are preserved registers in the bblock.
+ ;; #F only occurs when a predecessor has not been processed,
+ ;; which can only occur when there is a loop in the flow graph.
+ (if (there-exists? infos (lambda (pair) (not (pair? pair))))
+ ;; Loop in flow graph. For now, flush everything.
+ (state/make-empty)
+ (let ((states (map cadr infos)))
+ (state/set! (state/copy (car states)))
+ (let loop ((states (cdr states)))
+ (if (null? states)
+ (state/get)
+ (begin
+ (state/merge! (car states))
+ (loop (cdr states))))))))
+
+(define (state/merge! state)
+ (register-tables/merge! *register-tables*
+ (state/register-tables state))
+ ;; For now, drop all stack references
+ (set! *stack-offset* 0)
+ (set! *stack-reference-quantities* '())
+ unspecific)
+\f
+(define (register-tables/merge! tables tables*)
+ (define (%register-invalidate! reg)
+ (let ((expression (register-expression reg)))
+ (if expression
+ (register-expression-invalidate! expression))))
+
+ (define (quantity-registers tables quantity)
+ (let loop ((reg (quantity-first-register quantity))
+ (all '()))
+ (if (not reg)
+ all
+ (loop (%register-next-equivalent tables reg)
+ (cons reg all)))))
+
+ (let ((n-registers (vector-length (vector-ref tables 0)))
+ (quantities (vector-ref tables 0))
+ (quantities* (vector-copy (vector-ref tables* 0))))
+ (do ((reg 0 (+ reg 1)))
+ ((>= reg n-registers))
+ (let ((quantity (vector-ref quantities reg))
+ (quantity* (vector-ref quantities* reg)))
+ (cond ((or (not quantity)
+ ;; Already merged
+ (eq? quantity quantity*)))
+ ((or (not quantity*)
+ ;; This could check if the expressions happened
+ ;; to be the same!
+ (not (= (quantity-number quantity)
+ (quantity-number quantity*))))
+ (%register-invalidate! reg))
+ (else
+ ;; Merge the quantities
+ (let ((regs (quantity-registers tables quantity))
+ (regs* (quantity-registers tables* quantity*)))
+ (for-each %register-invalidate!
+ (eq-set-difference regs regs*))
+ (for-each (lambda (reg)
+ (vector-set! quantities* reg quantity))
+ regs*))))))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rcserq.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1988-1994 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. |#
+
+;;;; RTL Common Subexpression Elimination: Register/Quantity Abstractions
+;;; Based on the GNU C Compiler
+;;; package: (compiler rtl-cse)
+
+(declare (usual-integrations))
+\f
+(define-structure (quantity
+ (copier quantity-copy)
+ (print-procedure
+ (standard-unparser (symbol->string 'QUANTITY) false)))
+ (number false read-only true)
+ (first-register false)
+ (last-register false))
+
+(define (get-register-quantity register)
+ (or (register-quantity register)
+ (let ((quantity (new-quantity register)))
+ (set-register-quantity! register quantity)
+ quantity)))
+
+(define (new-quantity register)
+ (make-quantity (let ((n *next-quantity-number*))
+ (set! *next-quantity-number* (1+ *next-quantity-number*))
+ n)
+ register
+ register))
+
+(define *next-quantity-number*)
+\f
+(define (register-tables/make n-registers)
+ (vector (make-vector n-registers) ; quantity
+ (make-vector n-registers) ; next equivalent
+ (make-vector n-registers) ; previous equivalent
+ (make-vector n-registers) ; expression
+ (make-vector n-registers) ; tick
+ (make-vector n-registers) ; in table
+ (make-vector n-registers) ; preserved?
+ ))
+
+(define (register-tables/reset! register-tables)
+ (vector-fill! (vector-ref register-tables 0) false)
+ (vector-fill! (vector-ref register-tables 1) false)
+ (vector-fill! (vector-ref register-tables 2) false)
+ (let ((expressions (vector-ref register-tables 3)))
+ (vector-fill! expressions false)
+ (for-each-machine-register
+ (lambda (register)
+ (vector-set! expressions
+ register
+ (rtl:make-machine-register register)))))
+ (vector-fill! (vector-ref register-tables 4) 0)
+ (vector-fill! (vector-ref register-tables 5) -1)
+ (vector-fill! (vector-ref register-tables 6) false))
+
+(define (register-tables/copy register-tables)
+ (vector (vector-map (vector-ref register-tables 0)
+ (lambda (quantity)
+ (and quantity
+ (quantity-copy quantity))))
+ (vector-copy (vector-ref register-tables 1))
+ (vector-copy (vector-ref register-tables 2))
+ (vector-copy (vector-ref register-tables 3))
+ (vector-copy (vector-ref register-tables 4))
+ (vector-copy (vector-ref register-tables 5))
+ (vector-copy (vector-ref register-tables 6))))
+
+(define (register-tables/restore! register-tables)
+ ;; Nothing is preserved.
+ (vector-fill! (vector-ref register-tables 6) false))
+
+(define-integrable (%register-quantity tables register)
+ (vector-ref (vector-ref tables 0) register))
+
+(define-integrable (%set-register-quantity! tables register quantity)
+ (vector-set! (vector-ref tables 0) register quantity))
+
+(define-integrable (%register-next-equivalent tables register)
+ (vector-ref (vector-ref tables 1) register))
+
+(define-integrable
+ (%set-register-next-equivalent! tables register next-equivalent)
+ (vector-set! (vector-ref tables 1) register next-equivalent))
+
+(define-integrable (%register-previous-equivalent tables register)
+ (vector-ref (vector-ref tables 2) register))
+
+(define-integrable
+ (%set-register-previous-equivalent! tables register previous-equivalent)
+ (vector-set! (vector-ref tables 2) register previous-equivalent))
+
+(define-integrable (%register-expression tables register)
+ (vector-ref (vector-ref tables 3) register))
+
+(define-integrable (%set-register-expression! tables register expression)
+ (vector-set! (vector-ref tables 3) register expression))
+
+(define-integrable (%register-tick tables register)
+ (vector-ref (vector-ref tables 4) register))
+
+(define-integrable (%set-register-tick! tables register tick)
+ (vector-set! (vector-ref tables 4) register tick))
+
+(define-integrable (%register-in-table tables register)
+ (vector-ref (vector-ref tables 5) register))
+
+(define-integrable (%set-register-in-table! tables register in-table)
+ (vector-set! (vector-ref tables 5) register in-table))
+
+(define-integrable (%register-preserved? tables register)
+ (vector-ref (vector-ref tables 6) register))
+
+(define-integrable (%set-register-preserved?! tables register state)
+ (vector-set! (vector-ref tables 6) register state))
+\f
+(define *register-tables*)
+
+(define-integrable (register-quantity register)
+ (%register-quantity *register-tables* register))
+
+(define-integrable (set-register-quantity! register quantity)
+ (%set-register-quantity! *register-tables* register quantity))
+
+(define-integrable (register-next-equivalent register)
+ (%register-next-equivalent *register-tables* register))
+
+(define-integrable (set-register-next-equivalent! register next-equivalent)
+ (%set-register-next-equivalent! *register-tables* register next-equivalent))
+
+(define-integrable (register-previous-equivalent register)
+ (%register-previous-equivalent *register-tables* register))
+
+(define-integrable
+ (set-register-previous-equivalent! register previous-equivalent)
+ (%set-register-previous-equivalent! *register-tables*
+ register previous-equivalent))
+
+(define-integrable (register-expression register)
+ (%register-expression *register-tables* register))
+
+(define-integrable (set-register-expression! register expression)
+ (%set-register-expression! *register-tables* register expression))
+
+(define-integrable (register-tick register)
+ (%register-tick *register-tables* register))
+
+(define-integrable (set-register-tick! register tick)
+ (%set-register-tick! *register-tables* register tick))
+
+(define-integrable (register-in-table register)
+ (%register-in-table *register-tables* register))
+
+(define-integrable (set-register-in-table! register in-table)
+ (%set-register-in-table! *register-tables* register in-table))
+
+(define (register-preserved? register)
+ (%register-preserved? *register-tables* register))
+
+(define (set-register-preserved?! register state)
+ (%set-register-preserved?! *register-tables* register state))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rcsesr.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1987-1993 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. |#
+
+;;;; RTL Common Subexpression Elimination: Stack References
+
+(declare (usual-integrations))
+\f
+(define *stack-offset*)
+(define *stack-reference-quantities*)
+
+(define-integrable (memory->stack-offset offset)
+ ;; Assume this operation is a self-inverse.
+ (stack->memory-offset offset))
+
+(define (stack-push? expression)
+ (and (rtl:pre-increment? expression)
+ (interpreter-stack-pointer? (rtl:address-register expression))
+ (= -1 (memory->stack-offset (rtl:address-number expression)))))
+
+(define (stack-pop? expression)
+ (and (rtl:post-increment? expression)
+ (interpreter-stack-pointer? (rtl:address-register expression))
+ (= 1 (memory->stack-offset (rtl:address-number expression)))))
+
+(define (stack-reference? expression)
+ (and (rtl:offset? expression)
+ (interpreter-stack-pointer? (rtl:address-register expression))))
+
+(define (stack-reference-quantity expression)
+ (let ((n (+ *stack-offset*
+ (rtl:machine-constant-value (rtl:offset-offset expression)))))
+ (let ((entry (ass= n *stack-reference-quantities*)))
+ (if entry
+ (cdr entry)
+ (let ((quantity (new-quantity false)))
+ (set! *stack-reference-quantities*
+ (cons (cons n quantity)
+ *stack-reference-quantities*))
+ quantity)))))
+
+(define (set-stack-reference-quantity! expression quantity)
+ (let ((n (+ *stack-offset*
+ (rtl:machine-constant-value (rtl:offset-offset expression)))))
+ (let ((entry (ass= n *stack-reference-quantities*)))
+ (if entry
+ (set-cdr! entry quantity)
+ (set! *stack-reference-quantities*
+ (cons (cons n quantity)
+ *stack-reference-quantities*)))))
+ unspecific)
+
+(define (stack-pointer-adjust! offset)
+ (let ((offset (memory->stack-offset offset)))
+ (if (positive? offset) ;i.e. if a pop
+ (stack-region-invalidate! 0 offset)))
+ (set! *stack-offset* (+ *stack-offset* offset))
+ (stack-pointer-invalidate!))
+
+(define-integrable (stack-pointer-invalidate!)
+ (register-expression-invalidate! (interpreter-stack-pointer)))
+
+(define-integrable (stack-invalidate!)
+ (set! *stack-reference-quantities* '()))
+
+(define (stack-region-invalidate! start end)
+ (let loop ((i start) (quantities *stack-reference-quantities*))
+ (if (< i end)
+ (loop (1+ i)
+ (del-ass=! (+ *stack-offset* (stack->memory-offset i))
+ quantities))
+ (set! *stack-reference-quantities* quantities))))
+
+(define (stack-reference-invalidate! expression)
+ (expression-invalidate! expression)
+ (set! *stack-reference-quantities*
+ (del-ass=! (+ *stack-offset*
+ (rtl:machine-constant-value
+ (rtl:offset-offset expression)))
+ *stack-reference-quantities*)))
+
+(define ass= (association-procedure = car))
+(define del-ass=! (delete-association-procedure list-deletor! = car))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rdebug.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; RTL Optimizer Debugging Output
+
+(declare (usual-integrations))
+\f
+(define (dump-register-info rgraph)
+ (fluid-let ((*current-rgraph* rgraph))
+ (for-each-pseudo-register
+ (lambda (register)
+ (if (positive? (register-n-refs register))
+ (begin (newline)
+ (write register)
+ (write-string ": renumber ")
+ (write (register-renumber register))
+ (write-string "; nrefs ")
+ (write (register-n-refs register))
+ (write-string "; length ")
+ (write (register-live-length register))
+ (write-string "; ndeaths ")
+ (write (register-n-deaths register))
+ (let ((bblock (register-bblock register)))
+ (cond ((eq? bblock 'NON-LOCAL)
+ (if (register-crosses-call? register)
+ (write-string "; crosses calls")
+ (write-string "; multiple blocks")))
+ (bblock
+ (write-string "; block ")
+ (write (unhash bblock)))
+ (else
+ (write-string "; no block!"))))))))))
+
+(define (dump-block-info rgraph)
+ (fluid-let ((*current-rgraph* rgraph))
+ (let ((machine-regs (make-regset (rgraph-n-registers rgraph))))
+ (for-each-machine-register
+ (lambda (register)
+ (regset-adjoin! machine-regs register)))
+ (for-each (lambda (bblock)
+ (newline)
+ (newline)
+ (write bblock)
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (pp (rinst-rtl rinst))))
+ (let ((live-at-exit (bblock-live-at-exit bblock)))
+ (regset-difference! live-at-exit machine-regs)
+ (if (not (regset-null? live-at-exit))
+ (begin (newline)
+ (write-string "Registers live at end:")
+ (for-each-regset-member live-at-exit
+ (lambda (register)
+ (write-string " ")
+ (write register)))))))
+ (rgraph-bblocks rgraph)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rdflow.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1990-1994 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. |#
+
+;;;; RTL Dataflow Analysis
+;;; package: (compiler rtl-optimizer rtl-dataflow-analysis)
+
+(declare (usual-integrations))
+\f
+(define (rtl-dataflow-analysis rgraphs)
+ (for-each (lambda (rgraph)
+ (let ((rnodes (generate-dataflow-graph rgraph)))
+ (set-rgraph-register-value-classes!
+ rgraph
+ (vector-map rnodes
+ (lambda (rnode)
+ (and rnode
+ (rnode/value-class rnode)))))
+ (generate-known-values! rnodes)
+ (set-rgraph-register-known-values!
+ rgraph
+ (vector-map rnodes
+ (lambda (rnode)
+ (and rnode
+ (rnode/known-value rnode)))))
+ (set-rgraph-register-known-expressions!
+ rgraph
+ (vector-map rnodes
+ (lambda (rnode)
+ (and rnode
+ (rnode/values rnode)
+ (null? (cdr (rnode/values rnode)))
+ (car (rnode/values rnode))))))))
+ rgraphs))
+
+;; New stuff. *** Temporary kludge ***
+
+(define (argument-register-type value)
+ (and (rtl:register? value)
+ (let ((reg-number (rtl:register-number value)))
+ (and (machine-register? reg-number)
+ (memq reg-number *argument-registers*)
+ (let ((class (machine-register-value-class reg-number)))
+ (if (eq? class value-class=float)
+ class
+ value-class=object))))))
+
+(define (rnode/value-class rnode)
+ (let ((union
+ (let ((values (rnode/values rnode)))
+ (or (and (not (null? values))
+ (null? (cdr values))
+ (argument-register-type (car values)))
+ (reduce value-class/nearest-common-ancestor
+ false
+ ;; Here we assume that no member of
+ ;; `rnode/values' is a register expression.
+ (map rtl:expression-value-class values))))))
+ ;; Really this test should look for non-leaf value
+ ;; classes, except that the "immediate" class (which is
+ ;; the only other non-leaf class) is generated by the
+ ;; `machine-constant' expression. The `machine-constant'
+ ;; expression should be typed so that its class could be
+ ;; more precisely determined.
+ (if (and (pseudo-register? (rnode/register rnode))
+ (or (eq? union value-class=value)
+ (eq? union value-class=word)
+ (eq? union value-class=unboxed)))
+ (error "mixed-class register" rnode union))
+ union))
+
+;; End of new stuff
+
+(define-structure (rnode
+ (conc-name rnode/)
+ (constructor make-rnode (register))
+ (print-procedure
+ (unparser/standard-method 'RNODE
+ (lambda (state rnode)
+ (unparse-object state (rnode/register rnode))))))
+ (register false read-only true)
+ (forward-links '())
+ (backward-links '())
+ (initial-values '())
+ (values '())
+ (known-value false)
+ (classified-values))
+\f
+(define (generate-dataflow-graph rgraph)
+ (let ((rnodes (make-vector (rgraph-n-registers rgraph) false)))
+ (for-each (lambda (bblock)
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (walk-rtl rnodes (rinst-rtl rinst)))))
+ (rgraph-bblocks rgraph))
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (set-rnode/values!
+ rnode
+ (rtx-set/union* (rnode/initial-values rnode)
+ (map rnode/initial-values
+ (rnode/backward-links rnode))))))
+ rnodes))
+
+(define (for-each-rnode rnodes procedure)
+ (for-each-vector-element rnodes
+ (lambda (rnode)
+ (if rnode
+ (procedure rnode)))))
+
+(define (walk-rtl rnodes rtl)
+ (let ((get-rnode
+ (lambda (expression)
+ (let ((register (rtl:register-number expression)))
+ (or (vector-ref rnodes register)
+ (let ((rnode (make-rnode register)))
+ (vector-set! rnodes register rnode)
+ rnode))))))
+ (if (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl))
+ (expression (rtl:assign-expression rtl)))
+ (if (rtl:pseudo-register-expression? address)
+ (let ((target (get-rnode address)))
+ (if (rtl:pseudo-register-expression? expression)
+ (rnode/connect! target (get-rnode expression))
+ (add-rnode/initial-value! target expression))))))
+ (let loop ((rtl rtl))
+ (rtl:for-each-subexpression rtl
+ (lambda (expression)
+ (if (rtl:volatile-expression? expression)
+ (if (or (rtl:post-increment? expression)
+ (rtl:pre-increment? expression))
+ (add-rnode/initial-value!
+ (get-rnode (rtl:address-register expression))
+ expression)
+ (error "Unknown volatile expression" expression))
+ (loop expression)))))))
+
+(define (add-rnode/initial-value! target expression)
+ (let ((values (rnode/initial-values target)))
+ (if (not (there-exists? values
+ (lambda (value)
+ (rtl:expression=? expression value))))
+ (set-rnode/initial-values! target
+ (cons expression values)))))
+
+(define (rnode/connect! target source)
+ (if (not (memq source (rnode/backward-links target)))
+ (begin
+ (set-rnode/backward-links! target
+ (cons source (rnode/backward-links target)))
+ (set-rnode/forward-links! source
+ (cons target (rnode/forward-links source)))
+ (for-each (lambda (source) (rnode/connect! target source))
+ (rnode/backward-links source))
+ (for-each (lambda (target) (rnode/connect! target source))
+ (rnode/forward-links target)))))
+\f
+(define (generate-known-values! rnodes)
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (set-rnode/classified-values! rnode
+ (map expression->classified-value
+ (rnode/values rnode)))))
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (let ((expression (initial-known-value (rnode/classified-values rnode))))
+ (set-rnode/known-value! rnode expression)
+ (if (not (memq expression '(UNDETERMINED #F)))
+ (set-rnode/classified-values! rnode '())))))
+ (let loop ()
+ (let ((new-constant? false))
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (if (eq? (rnode/known-value rnode) 'UNDETERMINED)
+ (let ((values
+ (values-substitution-step
+ rnodes
+ (rnode/classified-values rnode))))
+ (if (there-exists? values
+ (lambda (value)
+ (eq? (car value) 'SUBSTITUTABLE-REGISTERS)))
+ (set-rnode/classified-values! rnode values)
+ (let ((expression (values-unique-expression values)))
+ (if expression (set! new-constant? true))
+ (set-rnode/known-value! rnode expression)
+ (set-rnode/classified-values! rnode '())))))))
+ (if new-constant? (loop))))
+ (for-each-rnode rnodes
+ (lambda (rnode)
+ (if (eq? (rnode/known-value rnode) 'UNDETERMINED)
+ (begin
+ (set-rnode/known-value!
+ rnode
+ (values-unique-expression (rnode/classified-values rnode)))
+ (set-rnode/classified-values! rnode '()))))))
+
+(define (expression->classified-value expression)
+ (cons (cond ((rtl:constant-expression? expression)
+ 'CONSTANT)
+ ((rtl:contains-no-substitutable-registers? expression)
+ 'NO-SUBSTITUTABLE-REGISTERS)
+ (else
+ 'SUBSTITUTABLE-REGISTERS))
+ expression))
+\f
+(define (initial-known-value values)
+ (and (not (null? values))
+ (not (there-exists? values
+ (lambda (value)
+ (rtl:volatile-expression? (cdr value)))))
+ (let loop ((value (car values)) (rest (cdr values)))
+ (cond ((eq? (car value) 'SUBSTITUTABLE-REGISTERS) 'UNDETERMINED)
+ ((null? rest) (values-unique-expression values))
+ (else (loop (car rest) (cdr rest)))))))
+
+(define (values-unique-expression values)
+ (let ((class (caar values))
+ (expression (cdar values)))
+ (and (for-all? (cdr values)
+ (lambda (value)
+ (and (eq? class (car value))
+ (rtl:expression=? expression (cdr value)))))
+ expression)))
+
+(define (values-substitution-step rnodes values)
+ (map (lambda (value)
+ (if (eq? (car value) 'SUBSTITUTABLE-REGISTERS)
+ (let ((substitution? false))
+ (let ((expression
+ (let loop ((expression (cdr value)))
+ (if (rtl:register? expression)
+ (let ((value
+ (register-known-value rnodes expression)))
+ (if value
+ (begin (set! substitution? true) value)
+ expression))
+ (rtl:map-subexpressions expression loop)))))
+ (if substitution?
+ (expression->classified-value expression)
+ value)))
+ value))
+ values))
+
+(define (register-known-value rnodes expression)
+ (let ((rnode (vector-ref rnodes (rtl:register-number expression))))
+ (and rnode
+ (let ((value (rnode/known-value rnode)))
+ (and (not (eq? value 'UNDETERMINED))
+ value)))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rerite.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1990-1993 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. |#
+
+;;;; RTL Rewriting
+;;; package: (compiler rtl-optimizer rtl-rewriting)
+
+(declare (usual-integrations))
+\f
+(define-structure (rewriting-rules
+ (conc-name rewriting-rules/)
+ (constructor make-rewriting-rules ()))
+ (assignment '())
+ (statement '())
+ (register '())
+ (expression '())
+ (generic '()))
+
+(define rules:pre-cse (make-rewriting-rules))
+(define rules:post-cse (make-rewriting-rules))
+
+(define (rtl-rewriting:pre-cse rgraphs)
+ (walk-rgraphs rules:pre-cse rgraphs))
+
+(define (rtl-rewriting:post-cse rgraphs)
+ (walk-rgraphs rules:post-cse rgraphs))
+
+(define (add-rewriting-rule! pattern result-procedure)
+ (new-rewriting-rule! rules:post-cse pattern result-procedure))
+
+(define (add-pre-cse-rewriting-rule! pattern result-procedure)
+ (new-rewriting-rule! rules:pre-cse pattern result-procedure))
+
+(define (walk-rgraphs rules rgraphs)
+ (if (not (and (null? (rewriting-rules/assignment rules))
+ (null? (rewriting-rules/statement rules))
+ (null? (rewriting-rules/register rules))
+ (null? (rewriting-rules/expression rules))
+ (null? (rewriting-rules/generic rules))))
+ (for-each (lambda (rgraph)
+ (walk-rgraph rules rgraph))
+ rgraphs)))
+
+(define (walk-rgraph rules rgraph)
+ (fluid-let ((*current-rgraph* rgraph))
+ (for-each (lambda (bblock) (walk-bblock rules bblock))
+ (rgraph-bblocks rgraph))))
+
+(define (walk-bblock rules bblock)
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (walk-rinst rules rinst))))
+
+(define (walk-rinst rules rinst)
+ (let ((rtl (rinst-rtl rinst)))
+ ;; Typically there will be few rules, and few instructions that
+ ;; match, so it is worth checking before rewriting anything.
+ (if (or (match-rtl-statement rules rtl)
+ (rtl:any-subexpression? rtl
+ (letrec ((loop
+ (lambda (expression)
+ (or (match-rtl-expression rules expression)
+ (rtl:any-subexpression? expression loop)))))
+ loop)))
+ (set-rinst-rtl!
+ rinst
+ (let loop
+ ((rtl
+ (rtl:map-subexpressions rtl
+ (letrec ((loop
+ (lambda (expression)
+ (let ((match-result
+ (match-rtl-expression rules expression)))
+ (if match-result
+ (loop (match-result))
+ expression)))))
+ loop))))
+ (let ((match-result (match-rtl-statement rules rtl)))
+ (if match-result
+ (loop (match-result))
+ rtl)))))))
+\f
+(define (match-rtl-statement rules rtl)
+ (or (if (rtl:assign? rtl)
+ (pattern-lookup (rewriting-rules/assignment rules) rtl)
+ (let ((entries
+ (assq (rtl:expression-type rtl)
+ (rewriting-rules/statement rules))))
+ (and entries
+ (pattern-lookup (cdr entries) rtl))))
+ (pattern-lookup (rewriting-rules/generic rules) rtl)))
+
+(define (match-rtl-expression rules expression)
+ (or (if (rtl:register? expression)
+ (pattern-lookup (rewriting-rules/register rules) expression)
+ (let ((entries
+ (assq (rtl:expression-type expression)
+ (rewriting-rules/expression rules))))
+ (and entries
+ (pattern-lookup (cdr entries) expression))))
+ (pattern-lookup (rewriting-rules/generic rules) expression)))
+
+(define (new-rewriting-rule! rules pattern result-procedure)
+ (let ((entry (cons pattern result-procedure)))
+ (if (not (and (pair? pattern) (symbol? (car pattern))))
+ (set-rewriting-rules/generic! rules
+ (cons entry
+ (rewriting-rules/generic rules)))
+ (let ((keyword (car pattern)))
+ (cond ((eq? keyword 'ASSIGN)
+ (set-rewriting-rules/assignment!
+ rules
+ (cons entry (rewriting-rules/assignment rules))))
+ ((eq? keyword 'REGISTER)
+ (set-rewriting-rules/register!
+ rules
+ (cons entry (rewriting-rules/register rules))))
+ ((memq keyword rtl:expression-types)
+ (let ((entries
+ (assq keyword (rewriting-rules/expression rules))))
+ (if entries
+ (set-cdr! entries (cons entry (cdr entries)))
+ (set-rewriting-rules/expression!
+ rules
+ (cons (list keyword entry)
+ (rewriting-rules/expression rules))))))
+ ((or (memq keyword rtl:statement-types)
+ (memq keyword rtl:predicate-types))
+ (let ((entries
+ (assq keyword (rewriting-rules/statement rules))))
+ (if entries
+ (set-cdr! entries (cons entry (cdr entries)))
+ (set-rewriting-rules/statement!
+ rules
+ (cons (list keyword entry)
+ (rewriting-rules/statement rules))))))
+ (else
+ (error "illegal RTL type" keyword))))))
+ pattern)
+
+(define-rule add-pre-cse-rewriting-rule!
+ (OBJECT->ADDRESS (? source))
+ (QUALIFIER (value-class=address? (rtl:expression-value-class source)))
+ source)
+
+;; KLUDGE! This is unsafe, but currently works.
+;; Probably closure bumping should not use byte-offset-address, and use
+;; a new rtl type, but...
+
+(define-rule add-pre-cse-rewriting-rule!
+ (CONS-POINTER (MACHINE-CONSTANT (? type))
+ (REGISTER (? datum register-known-value)))
+ (QUALIFIER
+ (and (= (ucode-type compiled-entry) type)
+ (rtl:byte-offset-address? datum)
+ (let ((v (let ((v (rtl:byte-offset-address-base datum)))
+ (if (rtl:register? v)
+ (register-known-value (rtl:register-number v))
+ v))))
+ (and v
+ (rtl:object->address? v)))))
+ (rtl:make-byte-offset-address
+ (rtl:object->address-expression
+ (let ((v (rtl:byte-offset-address-base datum)))
+ (if (rtl:register? v)
+ (register-known-value (rtl:register-number v))
+ v)))
+ (rtl:byte-offset-address-offset datum)))
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rinvex.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1989-1994 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. |#
+
+;;;; RTL Invertible Expression Elimination
+;;; package: (compiler rtl-optimizer invertible-expression-elimination)
+
+(declare (usual-integrations))
+\f
+(define *initial-queue*)
+(define *branch-queue*)
+(define *register-values*)
+
+(define (invertible-expression-elimination rgraphs)
+ (with-new-node-marks (lambda () (for-each walk-rgraph rgraphs))))
+
+(define (walk-rgraph rgraph)
+ (fluid-let ((*current-rgraph* rgraph)
+ (*initial-queue* (make-queue))
+ (*branch-queue* '())
+ (*register-values*
+ (make-vector (rgraph-n-registers rgraph) false)))
+ (for-each (lambda (edge)
+ (enqueue!/unsafe *initial-queue* (edge-right-node edge)))
+ (rgraph-initial-edges rgraph))
+ (continue-walk)))
+
+(define (continue-walk)
+ (cond ((not (null? *branch-queue*))
+ (let ((entry (car *branch-queue*)))
+ (set! *branch-queue* (cdr *branch-queue*))
+ (set! *register-values* (car entry))
+ (walk-bblock (cdr entry))))
+ ((not (queue-empty? *initial-queue*))
+ (vector-fill! *register-values* false)
+ (walk-bblock (dequeue!/unsafe *initial-queue*)))))
+
+(define (walk-bblock bblock)
+ (let loop ((rinst (bblock-instructions bblock)))
+ (let ((rtl (rinst-rtl rinst)))
+ ((lookup-method (rtl:expression-type rtl)) rtl))
+ (if (rinst-next rinst)
+ (loop (rinst-next rinst))))
+ (node-mark! bblock)
+ (if (sblock? bblock)
+ (let ((next (snode-next bblock)))
+ (if (walk-next? next)
+ (walk-next next)
+ (continue-walk)))
+ (let ((consequent (pnode-consequent bblock))
+ (alternative (pnode-alternative bblock)))
+ (if (walk-next? consequent)
+ (if (walk-next? alternative)
+ (if (node-previous>1? consequent)
+ (begin
+ (enqueue!/unsafe *initial-queue* consequent)
+ (walk-next alternative))
+ (begin
+ (if (node-previous>1? alternative)
+ (enqueue!/unsafe *initial-queue* alternative)
+ (set! *branch-queue*
+ (cons (cons (vector-copy *register-values*)
+ alternative)
+ *branch-queue*)))
+ (walk-bblock consequent)))
+ (walk-next consequent))
+ (if (walk-next? alternative)
+ (walk-next alternative)
+ (continue-walk))))))
+
+(define-integrable (walk-next? bblock)
+ (and bblock (not (node-marked? bblock))))
+
+(define-integrable (walk-next bblock)
+ (if (node-previous>1? bblock) (vector-fill! *register-values* false))
+ (walk-bblock bblock))
+
+(define-integrable (register-value register)
+ (vector-ref *register-values* register))
+
+(define-integrable (set-register-value! register value)
+ (vector-set! *register-values* register value)
+ unspecific)
+\f
+(define (expression-update! get-expression set-expression! object)
+ ;; Note: The following code may cause pseudo-register copies to be
+ ;; generated since it would have to propagate some of the
+ ;; simplifications, and then delete the now unused registers. This
+ ;; is not worthwhile since the previous register is likely to be
+ ;; dead at this point, so the lap-level register allocator will
+ ;; reuse the alias achieving the effect of the deletion. Ultimately
+ ;; the expression invertibility code should be integrated into the
+ ;; CSE and this register deletion would happen there.
+ (set-expression!
+ object
+ (let loop ((expression (get-expression object)))
+ (if (rtl:register? expression)
+ expression
+ (optimize-expression (rtl:map-subexpressions expression loop))))))
+
+(define (optimize-expression expression)
+ (let loop
+ ((identities
+ (list-transform-positive identities
+ (let ((type (rtl:expression-type expression)))
+ (lambda (identity)
+ (eq? type (car (cadr identity))))))))
+ (cond ((null? identities)
+ expression)
+ ((let ((identity (car identities)))
+ (let ((in-domain? (car identity))
+ (matching-operation (cadr identity)))
+ (let loop
+ ((operations (cddr identity))
+ (subexpression ((cadr matching-operation) expression)))
+ (if (null? operations)
+ (and (valid-subexpression? subexpression)
+ (in-domain?
+ (rtl:expression-value-class subexpression))
+ subexpression)
+ (let ((subexpression
+ (canonicalize-subexpression subexpression)))
+ (and (eq? (caar operations)
+ (rtl:expression-type subexpression))
+ (loop (cdr operations)
+ ((cadar operations) subexpression))))))))
+ => optimize-expression)
+ (else
+ (loop (cdr identities))))))
+
+(define identities
+ ;; Each entry is composed of a value class and a sequence of
+ ;; operations whose composition is the identity for that value
+ ;; class. Each operation is described by the operator and the
+ ;; selector for the relevant operand.
+ `(
+ (,value-class=value? (OBJECT->FIXNUM ,rtl:object->fixnum-expression)
+ (FIXNUM->OBJECT ,rtl:fixnum->object-expression))
+ (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression)
+ (OBJECT->FIXNUM ,rtl:object->fixnum-expression))
+ (,value-class=value? (OBJECT->UNSIGNED-FIXNUM
+ ,rtl:object->unsigned-fixnum-expression)
+ (FIXNUM->OBJECT ,rtl:fixnum->object-expression))
+ (,value-class=value? (FIXNUM->OBJECT ,rtl:fixnum->object-expression)
+ (OBJECT->UNSIGNED-FIXNUM
+ ,rtl:object->unsigned-fixnum-expression))
+ (,value-class=value? (FIXNUM->ADDRESS ,rtl:fixnum->address-expression)
+ (ADDRESS->FIXNUM ,rtl:address->fixnum-expression))
+ (,value-class=value? (ADDRESS->FIXNUM ,rtl:address->fixnum-expression)
+ (FIXNUM->ADDRESS ,rtl:fixnum->address-expression))
+ (,value-class=value? (OBJECT->FLOAT ,rtl:object->float-expression)
+ (FLOAT->OBJECT ,rtl:float->object-expression))
+ (,value-class=value? (FLOAT->OBJECT ,rtl:float->object-expression)
+ (OBJECT->FLOAT ,rtl:object->float-expression))
+ (,value-class=address? (OBJECT->ADDRESS ,rtl:object->address-expression)
+ (CONS-POINTER ,rtl:cons-pointer-datum))
+ ;; The following are not value-class=datum? and value-class=type?
+ ;; because they are slightly more general.
+ (,value-class=immediate? (OBJECT->DATUM ,rtl:object->datum-expression)
+ (CONS-NON-POINTER ,rtl:cons-non-pointer-datum))
+
+ (,value-class=ascii? (CHAR->ASCII ,rtl:char->ascii-expression)
+ (CONS-POINTER ,rtl:cons-pointer-datum))
+ (,value-class=ascii? (CHAR->ASCII ,rtl:char->ascii-expression)
+ (CONS-NON-POINTER ,rtl:cons-non-pointer-datum))
+
+ (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression)
+ (CONS-POINTER ,rtl:cons-pointer-type))
+ (,value-class=immediate? (OBJECT->TYPE ,rtl:object->type-expression)
+ (CONS-NON-POINTER ,rtl:cons-non-pointer-type))))
+\f
+(define (valid-subexpression? expression)
+ ;; Machine registers not allowed because they are volatile.
+ ;; Ideally at this point we could introduce a copy to the
+ ;; value of the machine register required, but it is too late
+ ;; to do this. Perhaps always copying machine registers out
+ ;; before using them would make this win.
+ (or (not (rtl:register? expression))
+ (rtl:pseudo-register-expression? expression)))
+
+(define (canonicalize-subexpression expression)
+ (or (and (rtl:pseudo-register-expression? expression)
+ (register-value (rtl:register-number expression)))
+ expression))
+
+(define (define-method type method)
+ (let ((entry (assq type methods)))
+ (if entry
+ (set-cdr! entry method)
+ (set! methods (cons (cons type method) methods))))
+ type)
+
+(define (lookup-method type)
+ (if (eq? type 'ASSIGN)
+ walk/assign
+ (let ((entry (assq type methods)))
+ (if (not entry)
+ (error "Missing method" type))
+ (cdr entry))))
+
+(define methods
+ '())
+
+(define (walk/assign statement)
+ (expression-update! rtl:assign-expression
+ rtl:set-assign-expression!
+ statement)
+ (let ((address (rtl:assign-address statement)))
+ (if (rtl:pseudo-register-expression? address)
+ (set-register-value! (rtl:register-number address)
+ (rtl:assign-expression statement)))))
+
+(define-method 'INVOCATION:SPECIAL-PRIMITIVE
+ (lambda (statement)
+ statement
+ (for-each-pseudo-register
+ (lambda (register)
+ (set-register-value! register false)))))
+\f
+(for-each (lambda (type)
+ (define-method type (lambda (statement) statement unspecific)))
+ '(CLOSURE-HEADER
+ CONTINUATION-ENTRY
+ CONTINUATION-HEADER
+ IC-PROCEDURE-HEADER
+ INVOCATION:APPLY
+ INVOCATION:COMPUTED-JUMP
+ INVOCATION:COMPUTED-LEXPR
+ INVOCATION:JUMP
+ INVOCATION:LEXPR
+ INVOCATION:PRIMITIVE
+ INVOCATION:UUO-LINK
+ INVOCATION:GLOBAL-LINK
+ OPEN-PROCEDURE-HEADER
+ OVERFLOW-TEST
+ POP-RETURN
+ PROCEDURE-HEADER
+ INVOCATION:PROCEDURE
+ INVOCATION:REGISTER
+ INVOCATION:NEW-APPLY
+ RETURN-ADDRESS
+ PROCEDURE
+ TRIVIAL-CLOSURE
+ CLOSURE
+ EXPRESSION
+ INTERRUPT-CHECK:PROCEDURE
+ INTERRUPT-CHECK:CONTINUATION
+ INTERRUPT-CHECK:CLOSURE
+ INTERRUPT-CHECK:SIMPLE-LOOP
+ PRESERVE
+ RESTORE))
+
+(define (define-one-arg-method type get set)
+ (define-method type
+ (lambda (statement)
+ (expression-update! get set statement))))
+
+(define-one-arg-method 'FIXNUM-PRED-1-ARG
+ rtl:fixnum-pred-1-arg-operand
+ rtl:set-fixnum-pred-1-arg-operand!)
+
+(define-one-arg-method 'FLONUM-PRED-1-ARG
+ rtl:flonum-pred-1-arg-operand
+ rtl:set-flonum-pred-1-arg-operand!)
+
+(define-one-arg-method 'TYPE-TEST
+ rtl:type-test-expression
+ rtl:set-type-test-expression!)
+
+(define-one-arg-method 'PRED-1-ARG
+ rtl:pred-1-arg-operand
+ rtl:set-pred-1-arg-operand!)
+
+(define-one-arg-method 'INVOCATION:CACHE-REFERENCE
+ rtl:invocation:cache-reference-name
+ rtl:set-invocation:cache-reference-name!)
+
+(define-one-arg-method 'INVOCATION:LOOKUP
+ rtl:invocation:lookup-environment
+ rtl:set-invocation:lookup-environment!)
+
+(define-one-arg-method 'INVOCATION-PREFIX:MOVE-FRAME-UP
+ rtl:invocation-prefix:move-frame-up-locative
+ rtl:set-invocation-prefix:move-frame-up-locative!)
+
+(define-one-arg-method 'INTERPRETER-CALL:ACCESS
+ rtl:interpreter-call:access-environment
+ rtl:set-interpreter-call:access-environment!)
+
+(define-one-arg-method 'INTERPRETER-CALL:CACHE-REFERENCE
+ rtl:interpreter-call:cache-reference-name
+ rtl:set-interpreter-call:cache-reference-name!)
+
+(define-one-arg-method 'INTERPRETER-CALL:CACHE-UNASSIGNED?
+ rtl:interpreter-call:cache-unassigned?-name
+ rtl:set-interpreter-call:cache-unassigned?-name!)
+
+(define-one-arg-method 'INTERPRETER-CALL:LOOKUP
+ rtl:interpreter-call:lookup-environment
+ rtl:set-interpreter-call:lookup-environment!)
+
+(define-one-arg-method 'INTERPRETER-CALL:UNASSIGNED?
+ rtl:interpreter-call:unassigned?-environment
+ rtl:set-interpreter-call:unassigned?-environment!)
+
+(define-one-arg-method 'INTERPRETER-CALL:UNBOUND?
+ rtl:interpreter-call:unbound?-environment
+ rtl:set-interpreter-call:unbound?-environment!)
+\f
+(define (define-two-arg-method type get-1 set-1 get-2 set-2)
+ (define-method type
+ (lambda (statement)
+ (expression-update! get-1 set-1 statement)
+ (expression-update! get-2 set-2 statement))))
+
+(define-two-arg-method 'EQ-TEST
+ rtl:eq-test-expression-1
+ rtl:set-eq-test-expression-1!
+ rtl:eq-test-expression-2
+ rtl:set-eq-test-expression-2!)
+
+(define-two-arg-method 'PRED-2-ARGS
+ rtl:pred-2-args-operand-1
+ rtl:set-pred-2-args-operand-1!
+ rtl:pred-2-args-operand-2
+ rtl:set-pred-2-args-operand-2!)
+
+(define-two-arg-method 'FIXNUM-PRED-2-ARGS
+ rtl:fixnum-pred-2-args-operand-1
+ rtl:set-fixnum-pred-2-args-operand-1!
+ rtl:fixnum-pred-2-args-operand-2
+ rtl:set-fixnum-pred-2-args-operand-2!)
+
+(define-two-arg-method 'FLONUM-PRED-2-ARGS
+ rtl:flonum-pred-2-args-operand-1
+ rtl:set-flonum-pred-2-args-operand-1!
+ rtl:flonum-pred-2-args-operand-2
+ rtl:set-flonum-pred-2-args-operand-2!)
+
+(define-two-arg-method 'INVOCATION-PREFIX:DYNAMIC-LINK
+ rtl:invocation-prefix:dynamic-link-locative
+ rtl:set-invocation-prefix:dynamic-link-locative!
+ rtl:invocation-prefix:dynamic-link-register
+ rtl:set-invocation-prefix:dynamic-link-register!)
+
+(define-two-arg-method 'INTERPRETER-CALL:CACHE-ASSIGNMENT
+ rtl:interpreter-call:cache-assignment-name
+ rtl:set-interpreter-call:cache-assignment-name!
+ rtl:interpreter-call:cache-assignment-value
+ rtl:set-interpreter-call:cache-assignment-value!)
+
+(define-two-arg-method 'INTERPRETER-CALL:DEFINE
+ rtl:interpreter-call:define-environment
+ rtl:set-interpreter-call:define-environment!
+ rtl:interpreter-call:define-value
+ rtl:set-interpreter-call:define-value!)
+
+(define-two-arg-method 'INTERPRETER-CALL:SET!
+ rtl:interpreter-call:set!-environment
+ rtl:set-interpreter-call:set!-environment!
+ rtl:interpreter-call:set!-value
+ rtl:set-interpreter-call:set!-value!)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rlife.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1987-1994 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. |#
+
+;;;; RTL Register Lifetime Analysis
+;;; Based on the GNU C Compiler
+;; package: (compiler rtl-optimizer lifetime-analysis)
+
+(declare (usual-integrations))
+\f
+(define (lifetime-analysis rgraphs)
+ (for-each walk-rgraph rgraphs))
+
+(define (walk-rgraph rgraph)
+ (let ((n-registers (rgraph-n-registers rgraph))
+ (bblocks (rgraph-bblocks rgraph)))
+ (set-rgraph-register-bblock! rgraph (make-vector n-registers false))
+ (set-rgraph-register-n-refs! rgraph (make-vector n-registers 0))
+ (set-rgraph-register-n-deaths! rgraph (make-vector n-registers 0))
+ (set-rgraph-register-live-length! rgraph (make-vector n-registers 0))
+ (set-rgraph-register-crosses-call?! rgraph
+ (make-bit-string n-registers false))
+ (for-each (lambda (bblock)
+ (set-bblock-live-at-entry! bblock (make-regset n-registers))
+ (set-bblock-live-at-exit! bblock (make-regset n-registers))
+ (set-bblock-new-live-at-exit! bblock
+ (make-regset n-registers)))
+ bblocks)
+ (fluid-let ((*current-rgraph* rgraph))
+ (walk-bblocks bblocks))
+ (for-each (lambda (bblock)
+ (set-bblock-new-live-at-exit! bblock false))
+ (rgraph-bblocks rgraph))))
+\f
+(define (walk-bblocks bblocks)
+ (let ((changed? false))
+ (define (loop first-pass?)
+ (for-each (lambda (bblock)
+ (if (or first-pass?
+ (not (regset=? (bblock-live-at-exit bblock)
+ (bblock-new-live-at-exit bblock))))
+ (begin (set! changed? true)
+ (regset-copy! (bblock-live-at-exit bblock)
+ (bblock-new-live-at-exit bblock))
+ (regset-copy! (bblock-live-at-entry bblock)
+ (bblock-live-at-exit bblock))
+ (propagate-block bblock)
+ (for-each-previous-node
+ bblock
+ (lambda (bblock*)
+ (regset-union!
+ (bblock-new-live-at-exit bblock*)
+ (bblock-live-at-entry bblock)))))))
+ bblocks)
+ (if changed?
+ (begin (set! changed? false)
+ (loop false))
+ (for-each (lambda (bblock)
+ (regset-copy! (bblock-live-at-entry bblock)
+ (bblock-live-at-exit bblock))
+ (propagate-block&delete! bblock))
+ bblocks)))
+ (loop true)))
+
+(define (regset-population-count regset)
+ (let ((result 0))
+ (for-each-regset-member regset
+ (lambda (index)
+ (set! result (+ result 1))
+ index))
+ result))
+\f
+(define (propagate-block bblock)
+ (propagation-loop bblock
+ (lambda (dead live rinst)
+ (update-live-registers! (bblock-live-at-entry bblock)
+ dead
+ live
+ (rinst-rtl rinst)
+ false false))))
+
+(define (propagate-block&delete! bblock)
+ (for-each-regset-member (bblock-live-at-entry bblock)
+ (lambda (register)
+ (set-register-bblock! register 'NON-LOCAL)))
+ (propagation-loop bblock
+ (lambda (dead live rinst)
+ (let ((rtl (rinst-rtl rinst))
+ (old (bblock-live-at-entry bblock))
+ (new (bblock-live-at-exit bblock)))
+ (if (rtl:invocation? rtl)
+ (for-each-regset-member old register-crosses-call!))
+ (if (instruction-dead? rtl old new)
+ (set-rinst-rtl! rinst false)
+ (begin
+ (update-live-registers! old dead live rtl bblock rinst)
+ (for-each-regset-member old increment-register-live-length!))))))
+ (bblock-perform-deletions! bblock))
+
+(define (propagation-loop bblock procedure)
+ (let ((dead (regset-allocate (rgraph-n-registers *current-rgraph*)))
+ (live (regset-allocate (rgraph-n-registers *current-rgraph*))))
+ (bblock-walk-backward bblock
+ (lambda (rinst)
+ (regset-clear! dead)
+ (regset-clear! live)
+ (procedure dead live rinst)))))
+
+(define (update-live-registers! old dead live rtl bblock rinst)
+ (mark-set-registers! old dead rtl bblock)
+ (mark-used-registers! old live rtl bblock rinst)
+ (regset-difference! old dead)
+ (regset-union! old live))
+\f
+(define (mark-set-registers! needed dead rtl bblock)
+ ;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT
+ ;; modes, since they are only used on the stack pointer.
+ needed
+ (if (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl)))
+ (if (interesting-register? address)
+ (let ((register (rtl:register-number address)))
+ (regset-adjoin! dead register)
+ (if bblock (record-register-reference register bblock)))))))
+
+(define (mark-used-registers! needed live rtl bblock rinst)
+ (define (loop expression)
+ (if (interesting-register? expression)
+ (let ((register (rtl:register-number expression)))
+ (regset-adjoin! live register)
+ (if bblock
+ (begin (record-register-reference register bblock)
+ (if (and (not (regset-member? needed register))
+ (not (rinst-dead-register? rinst register)))
+ (begin (set-rinst-dead-registers!
+ rinst
+ (cons register
+ (rinst-dead-registers rinst)))
+ (increment-register-n-deaths! register))))))
+ (rtl:for-each-subexpression expression loop)))
+
+ (define (register-assignment register expr)
+ (if (let ((register-number (rtl:register-number register)))
+ (or (machine-register? register-number)
+ (regset-member? needed register-number)))
+ (and (not (rtl:restore? expr))
+ (loop expr))))
+
+ (cond ((and (rtl:assign? rtl)
+ (rtl:register? (rtl:assign-address rtl)))
+ (register-assignment (rtl:assign-address rtl)
+ (rtl:assign-expression rtl)))
+ ((rtl:preserve? rtl)
+ ;; ignored at this stage
+ unspecific)
+ ((rtl:restore? rtl)
+ (if (not (rtl:register? (rtl:restore-value rtl)))
+ (register-assignment (rtl:restore-register rtl)
+ (rtl:restore-value rtl)))
+ unspecific)
+ (else
+ (rtl:for-each-subexpression rtl loop))))
+
+(define (record-register-reference register bblock)
+ (let ((bblock* (register-bblock register)))
+ (cond ((not bblock*)
+ (set-register-bblock! register bblock))
+ ((not (eq? bblock bblock*))
+ (set-register-bblock! register 'NON-LOCAL)))
+ (increment-register-n-refs! register)))
+
+(define (instruction-dead? rtl needed computed)
+ (cond ((rtl:assign? rtl)
+ (and (let ((address (rtl:assign-address rtl)))
+ (and (rtl:register? address)
+ (let ((register (rtl:register-number address)))
+ (and (pseudo-register? register)
+ (not (regset-member? needed register))))))
+ (not (rtl:expression-contains? (rtl:assign-expression rtl)
+ rtl:volatile-expression?))))
+ ((rtl:preserve? rtl)
+ (let ((reg (rtl:register-number (rtl:preserve-register rtl))))
+ (and (pseudo-register? reg)
+ (not (regset-member? computed reg)))))
+ ((rtl:restore? rtl)
+ (let ((reg (rtl:register-number (rtl:restore-register rtl))))
+ (not (regset-member? needed reg))))
+ (else
+ false)))
+
+(define (interesting-register? expression)
+ (and (rtl:register? expression)
+ (pseudo-register? (rtl:register-number expression))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Id: rtlcsm.scm,v 1.1 1994/11/19 02:06:38 adams Exp $
+
+Copyright (c) 1989-1994 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. |#
+
+;;;; RTL Common Suffix Merging
+;; Package: (compiler rtl-optimizer common-suffix-merging)
+
+(declare (usual-integrations))
+\f
+(define (merge-common-suffixes! rgraphs)
+ (for-each merge-suffixes-of-rgraph! rgraphs))
+
+(define (merge-suffixes-of-rgraph! rgraph)
+ (let loop ()
+ (let ((suffix-classes (rgraph-matching-suffixes rgraph)))
+ (if (not (null? suffix-classes))
+ (begin
+ ;; Because many of the original bblocks can be discarded
+ ;; by the merging process, processing of one suffix class
+ ;; can make the information in the subsequent suffix
+ ;; classes incorrect. However, reanalysis will still
+ ;; reproduce the remaining suffix classes. So, process
+ ;; one class and reanalyze before continuing.
+ (merge-suffixes! rgraph (car suffix-classes))
+ (loop))))))
+
+(define (merge-suffixes! rgraph suffixes)
+ (with-values
+ (lambda ()
+ (discriminate-items suffixes
+ (lambda (suffix)
+ (eq? (cdr suffix) (bblock-instructions (car suffix))))))
+ (lambda (total-suffixes partial-suffixes)
+ (if (not (null? total-suffixes))
+ (let ((new-bblock (caar total-suffixes)))
+ (for-each (lambda (suffix)
+ (replace-suffix-block! rgraph suffix new-bblock))
+ (cdr total-suffixes))
+ (replace-suffixes! rgraph new-bblock partial-suffixes))
+ (let ((suffix (car partial-suffixes)))
+ (split-suffix-block! rgraph suffix)
+ (replace-suffixes! rgraph (car suffix) (cdr partial-suffixes)))))))
+
+(define (replace-suffixes! rgraph new-bblock partial-suffixes)
+ (for-each (lambda (suffix)
+ (split-suffix-block! rgraph suffix)
+ (replace-suffix-block! rgraph suffix new-bblock))
+ partial-suffixes))
+
+(define (split-suffix-block! rgraph suffix)
+ (let ((old-bblock (car suffix))
+ (instructions (cdr suffix)))
+ (rinst-disconnect-previous! old-bblock instructions)
+ (let ((sblock (make-sblock (bblock-instructions old-bblock))))
+ (node-insert-snode! old-bblock sblock)
+ (add-rgraph-bblock! rgraph sblock))
+ (set-bblock-instructions! old-bblock instructions)))
+
+(define (replace-suffix-block! rgraph suffix new-bblock)
+ (let ((old-bblock (car suffix)))
+ (node-replace-on-right! old-bblock new-bblock)
+ (node-disconnect-on-left! old-bblock)
+ (delete-rgraph-bblock! rgraph old-bblock)))
+\f
+(define (rgraph-matching-suffixes rgraph)
+ (append-map (lambda (bblock-class)
+ (suffix-classes (initial-bblock-matches bblock-class)))
+ (rgraph/bblock-classes rgraph)))
+
+(define (rgraph/bblock-classes rgraph)
+ (let ((sblock-classes (list false))
+ (pblock-classes (list false)))
+ (for-each (lambda (bblock)
+ (if (sblock? bblock)
+ (add-sblock-to-classes! sblock-classes bblock)
+ (add-pblock-to-classes! pblock-classes bblock)))
+ (rgraph-bblocks rgraph))
+ (let ((singleton? (lambda (x) (null? (cdr x)))))
+ (append! (list-transform-negative (cdr sblock-classes) singleton?)
+ (list-transform-negative (cdr pblock-classes) singleton?)))))
+
+(define (add-sblock-to-classes! classes sblock)
+ (let ((next (snode-next sblock)))
+ (let loop ((previous classes) (classes (cdr classes)))
+ (if (null? classes)
+ (set-cdr! previous (list (list sblock)))
+ (if (eq? next (snode-next (caar classes)))
+ (set-car! classes (cons sblock (car classes)))
+ (loop classes (cdr classes)))))))
+
+(define (add-pblock-to-classes! classes pblock)
+ (let ((consequent (pnode-consequent pblock))
+ (alternative (pnode-alternative pblock)))
+ (let loop ((previous classes) (classes (cdr classes)))
+ (if (null? classes)
+ (set-cdr! previous (list (list pblock)))
+ (if (let ((pblock* (caar classes)))
+ (and (eq? consequent (pnode-consequent pblock*))
+ (eq? alternative (pnode-alternative pblock*))))
+ (set-car! classes (cons pblock (car classes)))
+ (loop classes (cdr classes)))))))
+
+(define (initial-bblock-matches bblocks)
+ (let loop ((bblocks bblocks))
+ (if (null? bblocks)
+ '()
+ (let ((entries (find-matching-bblocks (car bblocks) (cdr bblocks))))
+ (if (null? entries)
+ (loop (cdr bblocks))
+ (append! entries (loop (cdr bblocks))))))))
+
+(define (suffix-classes entries)
+ (let ((classes '())
+ (class-member?
+ (lambda (class suffix)
+ (list-search-positive class
+ (lambda (suffix*)
+ (and (eq? (car suffix) (car suffix*))
+ (eq? (cdr suffix) (cdr suffix*))))))))
+ (for-each (lambda (entry)
+ (let ((class
+ (list-search-positive classes
+ (lambda (class)
+ (class-member? class (car entry))))))
+ (if class
+ (if (not (class-member? class (cdr entry)))
+ (set-cdr! class (cons (cdr entry) (cdr class))))
+ (let ((class
+ (list-search-positive classes
+ (lambda (class)
+ (class-member? class (cdr entry))))))
+ (if class
+ (set-cdr! class (cons (car entry) (cdr class)))
+ (set! classes
+ (cons (list (car entry) (cdr entry))
+ classes))))))
+ unspecific)
+ entries)
+ (map cdr
+ (sort (map (lambda (class) (cons (rinst-length (cdar class)) class))
+ classes)
+ (lambda (x y)
+ (< (car x) (car y)))))))
+\f
+;;;; Basic Block Matching
+
+(define (find-matching-bblocks bblock bblocks)
+ (let loop ((bblocks bblocks))
+ (if (null? bblocks)
+ '()
+ (with-values (lambda () (matching-suffixes bblock (car bblocks)))
+ (lambda (sx sy adjustments)
+ (if (or (interesting-suffix? bblock sx)
+ (interesting-suffix? (car bblocks) sy))
+ (begin
+ (for-each (lambda (adjustment) (adjustment)) adjustments)
+ (cons (cons (cons bblock sx) (cons (car bblocks) sy))
+ (loop (cdr bblocks))))
+ (loop (cdr bblocks))))))))
+
+(define (interesting-suffix? bblock rinst)
+ (and rinst
+ (or (rinst-next rinst)
+ (eq? rinst (bblock-instructions bblock))
+ (and (sblock? bblock)
+ (snode-next bblock))
+ (let ((rtl (rinst-rtl rinst)))
+ (let ((type (rtl:expression-type rtl)))
+ (if (eq? type 'INVOCATION:PRIMITIVE)
+ (let ((procedure (rtl:invocation:primitive-procedure rtl)))
+ (and (not (eq? compiled-error-procedure procedure))
+ (negative? (primitive-procedure-arity procedure))))
+ (memq type
+ '(INTERPRETER-CALL:ACCESS
+ INTERPRETER-CALL:DEFINE
+ INTERPRETER-CALL:LOOKUP
+ INTERPRETER-CALL:SET!
+ INTERPRETER-CALL:UNASSIGNED?
+ INTERPRETER-CALL:UNBOUND
+ INTERPRETER-CALL:CACHE-ASSIGNMENT
+ INTERPRETER-CALL:CACHE-REFERENCE
+ INTERPRETER-CALL:CACHE-UNASSIGNED?
+ INVOCATION:COMPUTED-LEXPR
+ INVOCATION:CACHE-REFERENCE
+ INVOCATION:LOOKUP))))))))
+
+(define (matching-suffixes x y)
+ (let loop
+ ((rx (bblock-reversed-instructions x))
+ (ry (bblock-reversed-instructions y))
+ (wx false)
+ (wy false)
+ (e '())
+ (adjustments '()))
+ (if (or (null? rx) (null? ry))
+ (values wx wy adjustments)
+ (with-values
+ (lambda ()
+ (match-rtl (rinst-rtl (car rx)) (rinst-rtl (car ry)) e))
+ (lambda (e adjustment)
+ (if (eq? e 'FAILURE)
+ (values wx wy adjustments)
+ (let ((adjustments
+ (if adjustment
+ (cons adjustment adjustments)
+ adjustments)))
+ (if (for-all? e (lambda (b) (eqv? (car b) (cdr b))))
+ (loop (cdr rx) (cdr ry)
+ (car rx) (car ry)
+ e adjustments)
+ (loop (cdr rx) (cdr ry)
+ wx wy
+ e adjustments)))))))))
+\f
+;;;; RTL Instruction Matching
+
+(define (match-rtl x y e)
+ (cond ((not (eq? (rtl:expression-type x) (rtl:expression-type y)))
+ (values 'FAILURE false))
+ ((rtl:assign? x)
+ (values
+ (let ((ax (rtl:assign-address x)))
+ (let ((e (match ax (rtl:assign-address y) e)))
+ (if (eq? e 'FAILURE)
+ 'FAILURE
+ (match (rtl:assign-expression x)
+ (rtl:assign-expression y)
+ (remove-from-environment!
+ e
+ (if (rtl:pseudo-register-expression? ax)
+ (list (rtl:register-number ax))
+ '()))))))
+ false))
+ ((and (rtl:invocation? x)
+ (rtl:invocation:continuation-unimportant? x)
+ (not (eqv? (rtl:invocation-continuation x)
+ (rtl:invocation-continuation y))))
+ (let ((x* (rtl:map-subexpressions x identity-procedure))
+ (y* (rtl:map-subexpressions y identity-procedure)))
+ (rtl:set-invocation-continuation! x* false)
+ (rtl:set-invocation-continuation! y* false)
+ (values (match x* y* e)
+ (lambda ()
+ (rtl:set-invocation-continuation! x false)
+ (rtl:set-invocation-continuation! y false)))))
+ (else
+ (values (match x y e) false))))
+
+(define (rtl:invocation:continuation-unimportant? expression)
+ ;; This should probably be in the back-end where we decide on a
+ ;; case-by-case basis whether or not to generate code referencing
+ ;; the continuation label.
+ (not (memq (rtl:expression-type expression)
+ '(INVOCATION:PROCEDURE
+ INVOCATION:NEW-APPLY
+ INVOCATION:UUO-LINK
+ INVOCATION:GLOBAL-LINK))))
+
+(define (remove-from-environment! e keys)
+ (if (null? keys)
+ e
+ (remove-from-environment! (del-assv! (car keys) e) (cdr keys))))
+
+(define (match x y e)
+ (cond ((pair? x)
+ (let ((type (car x)))
+ (if (and (pair? y) (eq? type (car y)))
+ (case type
+ ((CONSTANT)
+ (if (eqv? (cadr x) (cadr y))
+ e
+ 'FAILURE))
+ ((REGISTER)
+ (let ((rx (cadr x))
+ (ry (cadr y)))
+ (if (pseudo-register? rx)
+ (if (pseudo-register? ry)
+ (let ((entry (assv rx e)))
+ (cond ((not entry) (cons (cons rx ry) e))
+ ((eqv? (cdr entry) ry) e)
+ (else 'FAILURE)))
+ 'FAILURE)
+ (if (pseudo-register? ry)
+ 'FAILURE
+ (if (eqv? rx ry)
+ e
+ 'FAILURE)))))
+ (else
+ (let loop ((x (cdr x)) (y (cdr y)) (e e))
+ (cond ((pair? x)
+ (if (pair? y)
+ (let ((e (match (car x) (car y) e)))
+ (if (eq? e 'FAILURE)
+ 'FAILURE
+ (loop (cdr x) (cdr y) e)))
+ 'FAILURE))
+ ((eqv? x y) e)
+ (else 'FAILURE)))))
+ 'FAILURE)))
+ ((eqv? x y) e)
+ (else 'FAILURE)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff