--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 Code Generation
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+(define *code-object-label*)
+
+(define (generate-lap quotations procedures continuations receiver)
+ (fluid-let ((*generation* (make-generation))
+ (*next-constant* 0)
+ (*interned-constants* '())
+ (*block-start-label* (generate-label))
+ (*code-object-label*))
+ (for-each (lambda (continuation)
+ (set! *code-object-label*
+ (code-object-label-initialize continuation))
+ (let ((rnode (cfg-entry-node (continuation-rtl continuation))))
+ (hooks-disconnect! (node-previous rnode) rnode)
+ (cgen-rnode rnode)))
+ continuations)
+ (for-each (lambda (quotation)
+ (set! *code-object-label*
+ (code-object-label-initialize quotation))
+ (cgen-rnode (cfg-entry-node (quotation-rtl quotation))))
+ quotations)
+ (for-each (lambda (procedure)
+ (set! *code-object-label*
+ (code-object-label-initialize procedure))
+ (cgen-rnode (cfg-entry-node (procedure-rtl procedure))))
+ procedures)
+ (receiver *interned-constants* *block-start-label*)))
+\f
+(define *current-rnode*)
+(define *dead-registers*)
+
+(define (cgen-rnode rnode)
+ (define (cgen-right-node next)
+ (if (and next (not (eq? (node-generation next) *generation*)))
+ (begin (if (not (null? (cdr (node-previous next))))
+ (let ((hook (find-hook rnode next))
+ (snode (statement->snode '(NOOP))))
+ (set-rnode-lap! snode
+ (clear-map-instructions
+ (rnode-register-map rnode)))
+ (hook-disconnect! hook next)
+ (hook-connect! hook snode)
+ (snode-next-connect! snode next)))
+ (cgen-rnode next))))
+ (set-node-generation! rnode *generation*)
+ ;; LOOP is for easy restart while debugging.
+ (let loop ()
+ (let ((match-result (pattern-lookup *cgen-rules* (rnode-rtl rnode))))
+ (if match-result
+ (fluid-let ((*current-rnode* rnode)
+ (*dead-registers* (rnode-dead-registers rnode))
+ (*register-map* (rnode-input-register-map rnode))
+ (*prefix-instructions* '())
+ (*needed-registers* '()))
+ (let ((instructions (match-result)))
+ (set-rnode-lap! rnode
+ (append! *prefix-instructions*
+ instructions)))
+ (delete-dead-registers!)
+ (set-rnode-register-map! rnode *register-map*))
+ (begin (error "CGEN-RNODE: No matching rules" (rnode-rtl rnode))
+ (loop)))))
+ ;; **** Works because of kludge in definition of RTL-SNODE.
+ (cgen-right-node (pnode-consequent rnode))
+ (cgen-right-node (pnode-alternative rnode)))
+
+(define (rnode-input-register-map node)
+ (let ((previous (node-previous node)))
+ (if (and (not (null? previous))
+ (null? (cdr previous))
+ (not (entry-holder? (hook-node (car previous)))))
+ (rnode-register-map (hook-node (car previous)))
+ (empty-register-map))))
+
+(define *cgen-rules*
+ '())
+
+(define (add-statement-rule! pattern result-procedure)
+ (set! *cgen-rules*
+ (cons (cons pattern result-procedure)
+ *cgen-rules*))
+ pattern)
+\f
+;;;; Machine independent stuff
+
+(define *register-map*)
+(define *prefix-instructions*)
+(define *needed-registers*)
+
+(define-integrable (prefix-instructions! instructions)
+ (set! *prefix-instructions* (append! *prefix-instructions* instructions)))
+
+(define-integrable (need-register! register)
+ (set! *needed-registers* (cons register *needed-registers*)))
+
+(define (maybe-need-register! register)
+ (if register (need-register! register))
+ register)
+
+(define-integrable (register-alias register type)
+ (maybe-need-register! (pseudo-register-alias *register-map* type register)))
+
+(define-integrable (register-alias-alternate register type)
+ (maybe-need-register! (machine-register-alias *register-map* type register)))
+
+(define-integrable (register-type? register type)
+ (or (not type)
+ (eq? (register-type register) type)))
+
+(define ((register-type-predicate type) register)
+ (register-type? register type))
+
+(define (guarantee-machine-register! register type receiver)
+ (if (and (machine-register? register)
+ (register-type? register type))
+ (receiver register)
+ (with-alias-register! register type receiver)))
+
+(define (with-alias-register! register type receiver)
+ (bind-allocator-values (load-alias-register *register-map* type
+ *needed-registers* register)
+ (lambda (alias map instructions)
+ (set! *register-map* map)
+ (need-register! alias)
+ (append! instructions (receiver alias)))))
+
+(define (allocate-register-for-assignment! register type receiver)
+ (bind-allocator-values (allocate-alias-register *register-map* type
+ *needed-registers* register)
+ (lambda (alias map instructions)
+ (set! *register-map* (delete-other-locations map alias))
+ (need-register! alias)
+ (append! instructions (receiver alias)))))
+
+(define (with-temporary-register! type receiver)
+ (bind-allocator-values (allocate-temporary-register *register-map* type
+ *needed-registers*)
+ (lambda (alias map instructions)
+ (set! *register-map* map)
+ (need-register! alias)
+ (append! instructions (receiver alias)))))
+\f
+(define (clear-map!)
+ (let ((instructions (clear-map)))
+ (set! *register-map* (empty-register-map))
+ (set! *needed-registers* '())
+ instructions))
+
+(define-integrable (clear-map)
+ (clear-map-instructions *register-map*))
+
+(define (clear-registers! . registers)
+ (if (null? registers)
+ '()
+ (let loop ((map *register-map*)
+ (registers registers))
+ (save-machine-register map (car registers)
+ (lambda (map instructions)
+ (let ((map (delete-machine-register map (car registers))))
+ (if (null? (cdr registers))
+ (begin (set! *register-map* map)
+ instructions)
+ (append! instructions (loop map (cdr registers))))))))))
+
+(define (save-machine-register! register)
+ (let ((contents (machine-register-contents *register-map* register)))
+ (if contents
+ (save-pseudo-register! contents))))
+
+(define (save-pseudo-register! register)
+ (if (not (dead-register? register))
+ (save-pseudo-register *register-map* register
+ (lambda (map instructions)
+ (set! *register-map* map)
+ (prefix-instructions! instructions)))))
+
+(define (delete-machine-register! register)
+ (set! *register-map* (delete-machine-register *register-map* register))
+ (set! *needed-registers* (set-delete *needed-registers* register)))
+
+(package (delete-pseudo-register!
+ delete-dead-registers!)
+ (define-export (delete-pseudo-register! register)
+ (delete-pseudo-register *register-map* register delete-registers!))
+ (define-export (delete-dead-registers!)
+ (delete-pseudo-registers *register-map* *dead-registers* delete-registers!)
+ (set! *dead-registers* '()))
+ (define (delete-registers! map aliases)
+ (set! *register-map* map)
+ (set! *needed-registers* (set-difference *needed-registers* aliases))))
+
+(define-integrable (dead-register? register)
+ (memv register *dead-registers*))
+\f
+(define *next-constant*)
+(define *interned-constants*)
+
+(define (constant->label constant)
+ (let ((entry (assv constant *interned-constants*)))
+ (if entry
+ (cdr entry)
+ (let ((label
+ (string->symbol
+ (string-append "CONSTANT-"
+ (write-to-string *next-constant*)))))
+ (set! *next-constant* (1+ *next-constant*))
+ (set! *interned-constants*
+ (cons (cons constant label)
+ *interned-constants*))
+ label))))
+
+(define-integrable (set-current-branches! consequent alternative)
+ (set-rtl-pnode-consequent-lap-generator! *current-rnode* consequent)
+ (set-rtl-pnode-alternative-lap-generator! *current-rnode* alternative))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-generator-package compiler-package)
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ pattern)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 Allocator
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+#|
+
+The register allocator provides a mechanism for allocating and
+deallocating machine registers. It manages the available machine
+registers as a cache, by maintaining a ``map'' which records two kinds
+of information: (1) a list of the machine registers which are not in
+use; and (2) a mapping which is the association between the allocated
+machine registers and the ``pseudo registers'' which they represent.
+
+An ``alias'' is a machine register which also holds the contents of a
+pseudo register. Usually an alias is used for a short period of time,
+as a store-in cache, and then eventually the contents of the alias is
+written back out to the home it is associated with. Because of the
+lifetime analysis, it is possible to identify those registers which
+will no longer be referenced; these are deleted from the map when they
+die, and thus do not need to be saved.
+
+A ``temporary'' is a machine register with no associated home. It
+is used during the code generation of a single RTL instruction to
+hold intermediate results.
+
+Each pseudo register that has at least one alias has an entry in the
+map. While a home is entered in the map, it may have one or more
+aliases added or deleted to its entry, but if the number of aliases
+ever drops to zero, the entry is removed from the map.
+
+Each temporary has an entry in the map, with the difference being
+that the entry has no pseudo register associated with it. Thus it
+need never be written out.
+
+All registers, both machine and pseudo, are represented by
+non-negative integers. Machine registers start at zero (inclusive)
+and stop at NUMBER-OF-MACHINE-REGISTERS (exclusive). All others are
+pseudo registers. Because they are integers, we can use MEMV on lists
+of registers.
+
+AVAILABLE-MACHINE-REGISTERS should be a list of the registers which
+the allocator is allowed to allocate, in the preferred order of
+allocation.
+
+(SORT-MACHINE-REGISTERS REGISTERS) should reorder a list of machine
+registers into some interesting sorting order if that is desired.
+
+(PSEUDO-REGISTER=? X Y) is true iff X and Y are the ``same'' register.
+Normally, two pseudo registers are the same if their
+REGISTER-RENUMBERs are equal.
+
+|#
+\f
+(define empty-register-map)
+(define bind-allocator-values)
+
+(define load-alias-register)
+(define allocate-alias-register)
+(define allocate-temporary-register)
+
+(define machine-register-contents)
+(define pseudo-register-aliases)
+
+(define machine-register-alias)
+(define pseudo-register-alias)
+
+(define save-machine-register)
+(define save-pseudo-register)
+
+(define delete-machine-register)
+(define delete-pseudo-register)
+
+(define delete-pseudo-registers)
+(define delete-other-locations)
+
+(define coerce-map-instructions)
+(define clear-map-instructions)
+
+(define register-allocator-package
+ (make-environment
+\f
+;;;; Register Map
+
+(define-integrable make-register-map cons)
+(define-integrable map-entries car)
+(define-integrable map-registers cdr)
+
+(define-export (empty-register-map)
+ (make-register-map '() available-machine-registers))
+
+(define-integrable (map-entries:search map procedure)
+ (set-search (map-entries map) procedure))
+
+(define (map-entries:find-home map pseudo-register)
+ (map-entries:search map
+ (lambda (entry)
+ (let ((home (map-entry-home entry)))
+ (and home
+ (pseudo-register=? home pseudo-register)
+ entry)))))
+
+(define (map-entries:find-alias map register)
+ (map-entries:search map
+ (lambda (entry)
+ ;; **** Kludge -- depends on fact that machine registers are
+ ;; fixnums, and thus EQ? works on them.
+ (and (memq register (map-entry-aliases entry))
+ entry))))
+
+(define-integrable (map-entries:add map entry)
+ (cons entry (map-entries map)))
+
+(define-integrable (map-entries:delete map entry)
+ (set-delete (map-entries map) entry))
+
+(define-integrable (map-entries:delete* map entries)
+ (set-difference (map-entries map) entries))
+
+(define-integrable (map-entries:replace map old new)
+ (set-substitute (map-entries map) old new))
+
+(define-integrable (map-registers:add map register)
+ (sort-machine-registers (cons register (map-registers map))))
+
+(define-integrable (map-registers:add* map registers)
+ (sort-machine-registers (append registers (map-registers map))))
+
+(define-integrable (map-registers:delete map register)
+ (set-delete (map-registers map) register))
+\f
+;;;; Map Entry
+
+(define-integrable (make-map-entry home saved-into-home? aliases)
+ ;; HOME may be false, indicating that this is a temporary register.
+ ;; SAVED-INTO-HOME? must be true when HOME is false. ALIASES must
+ ;; be a non-null list of registers.
+ (vector home saved-into-home? aliases))
+
+(define-integrable (map-entry-home entry)
+ (vector-ref entry 0))
+
+(define-integrable (map-entry-saved-into-home? entry)
+ (vector-ref entry 1))
+
+(define-integrable (map-entry-aliases entry)
+ (vector-ref entry 2))
+
+(define-integrable (map-entry:any-alias entry)
+ (car (map-entry-aliases entry)))
+
+(define (map-entry:add-alias entry alias)
+ (make-map-entry (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (cons alias (map-entry-aliases entry))))
+
+(define (map-entry:delete-alias entry alias)
+ (make-map-entry (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (set-delete (map-entry-aliases entry) alias)))
+
+(define (map-entry=? entry entry*)
+ (and (map-entry-home entry)
+ (map-entry-home entry*)
+ (pseudo-register=? (map-entry-home entry)
+ (map-entry-home entry*))))
+\f
+;;;; Map Constructors
+
+;;; These constructors are responsible for maintaining consistency
+;;; between the map entries and available registers.
+
+(define (register-map:add-home map home alias)
+ (make-register-map (map-entries:add map
+ (make-map-entry home true (list alias)))
+ (map-registers:delete map alias)))
+
+(define (register-map:add-alias map entry alias)
+ (make-register-map (map-entries:replace map entry
+ (map-entry:add-alias entry alias))
+ (map-registers:delete map alias)))
+
+(define (register-map:save-entry map entry)
+ (make-register-map
+ (map-entries:replace map entry
+ (make-map-entry (map-entry-home entry)
+ true
+ (map-entry-aliases entry)))
+ (map-registers map)))
+
+(define (register-map:delete-entry map entry)
+ (make-register-map (map-entries:delete map entry)
+ (map-registers:add* map (map-entry-aliases entry))))
+
+(define (register-map:delete-entries regmap entries)
+ (make-register-map (map-entries:delete* regmap entries)
+ (map-registers:add* regmap
+ (apply append
+ (map map-entry-aliases
+ entries)))))
+
+(define (register-map:delete-alias map entry alias)
+ (make-register-map (if (null? (cdr (map-entry-aliases entry)))
+ (map-entries:delete map entry)
+ (map-entries:replace map entry
+ (map-entry:delete-alias entry
+ alias)))
+ (map-registers:add map alias)))
+
+(define (register-map:delete-other-aliases map entry alias)
+ (make-register-map (map-entries:replace map entry
+ (let ((home (map-entry-home entry)))
+ (make-map-entry home (not home)
+ (list alias))))
+ (map-registers:add* map
+ ;; **** Kludge -- again, EQ? is
+ ;; assumed to work on machine regs.
+ (delq alias
+ (map-entry-aliases entry)))))
+\f
+;;;; Register Allocator
+
+(define (make-free-register map type needed-registers)
+ (define (reallocate-alias entry)
+ (let ((alias (find-alias entry)))
+ (and alias
+ (delete-alias entry alias '()))))
+
+ (define (find-alias entry)
+ (list-search-positive (map-entry-aliases entry)
+ (lambda (alias)
+ (and (register-type? alias type)
+ (not (memv alias needed-registers))))))
+
+ (define (delete-alias entry alias instructions)
+ (allocator-values alias
+ (register-map:delete-alias map entry alias)
+ instructions))
+
+ (or
+ ;; First see if there is an unused register of the given type.
+ (let ((register (list-search-positive (map-registers map)
+ (register-type-predicate type))))
+ (and register
+ (allocator-values register map '())))
+ ;; There are no free registers available, so must reallocate one.
+ ;; First look for a temporary register that is no longer needed.
+ (map-entries:search map
+ (lambda (entry)
+ (and (not (map-entry-home entry))
+ (reallocate-alias entry))))
+ ;; Then look for a register which contains the same thing as
+ ;; another register.
+ (map-entries:search map
+ (lambda (entry)
+ (and (not (null? (cdr (map-entry-aliases entry))))
+ (reallocate-alias entry))))
+ ;; Look for a non-temporary which has been saved into its home.
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry-home entry)
+ (map-entry-saved-into-home? entry)
+ (reallocate-alias entry))))
+ ;; Finally, save out a non-temporary and reallocate its register.
+ (map-entries:search map
+ (lambda (entry)
+ (and (map-entry-home entry)
+ (not (map-entry-saved-into-home? entry))
+ (let ((alias (find-alias entry)))
+ (and alias
+ (delete-alias entry alias
+ (save-into-home-instruction entry)))))))
+ ;; Reaching this point indicates all registers are allocated.
+ (error "MAKE-FREE-REGISTER: Unable to allocate register")))
+\f
+;;;; Allocator Operations
+
+(let ()
+
+(define-export (load-alias-register map type needed-registers home)
+ ;; Finds or makes an alias register for HOME, and loads HOME's
+ ;; contents into that register.
+ (let ((entry (map-entries:find-home map home)))
+ (or (use-existing-alias map entry type)
+ (bind-allocator-values (make-free-register map type needed-registers)
+ (lambda (alias map instructions)
+ (if entry
+ ;; MAKE-FREE-REGISTER will not flush ENTRY because it
+ ;; has no aliases of the appropriate TYPE.
+ (allocator-values
+ alias
+ (register-map:add-alias map entry alias)
+ (append! instructions
+ (register->register-transfer
+ (map-entry:any-alias entry)
+ alias)))
+ (allocator-values
+ alias
+ (register-map:add-home map home alias)
+ (append! instructions
+ (home->register-transfer home alias)))))))))
+
+(define-export (allocate-alias-register map type needed-registers home)
+ ;; Finds or makes an alias register for HOME. Used when about to
+ ;; modify HOME's contents.
+ (let ((entry (map-entries:find-home map home)))
+ (or (use-existing-alias map entry type)
+ (bind-allocator-values (make-free-register map type needed-registers)
+ (lambda (alias map instructions)
+ (allocator-values alias
+ (if entry
+ ;; MAKE-FREE-REGISTER will not flush
+ ;; ENTRY because it has no aliases
+ ;; of the appropriate TYPE.
+ (register-map:add-alias map entry alias)
+ (register-map:add-home map home alias))
+ instructions))))))
+
+(define (use-existing-alias map entry type)
+ (and entry
+ (let ((alias (list-search-positive (map-entry-aliases entry)
+ (register-type-predicate type))))
+ (and alias
+ (allocator-values alias map '())))))
+
+)
+\f
+(define-export (allocate-temporary-register map type needed-registers)
+ (bind-allocator-values (make-free-register map type needed-registers)
+ (lambda (alias map instructions)
+ (allocator-values alias
+ (register-map:add-home map false alias)
+ instructions))))
+
+(define-export (machine-register-contents map register)
+ (let ((entry (map-entries:find-alias map register)))
+ (and entry
+ (map-entry-home entry))))
+
+(define-export (pseudo-register-aliases map register)
+ (let ((entry (map-entries:find-home map register)))
+ (and entry
+ (map-entry-aliases entry))))
+
+(define-export (machine-register-alias map type register)
+ (let ((entry (map-entries:find-alias map register)))
+ (and entry
+ (list-search-positive (map-entry-aliases entry)
+ (lambda (register*)
+ (and (not (eq? register register*))
+ (register-type? type register*)))))))
+
+(define-export (pseudo-register-alias map type register)
+ (let ((entry (map-entries:find-home map register)))
+ (and entry
+ (list-search-positive (map-entry-aliases entry)
+ (register-type-predicate type)))))
+
+(define-export (save-machine-register map register receiver)
+ (let ((entry (map-entries:find-alias map register)))
+ (if (and entry
+ (not (map-entry-saved-into-home? entry))
+ (null? (cdr (map-entry-aliases entry))))
+ (receiver (register-map:save-entry map entry)
+ (save-into-home-instruction entry))
+ (receiver map '()))))
+
+(define-export (save-pseudo-register map register receiver)
+ (let ((entry (map-entries:find-home map register)))
+ (if (and entry
+ (not (map-entry-saved-into-home? entry)))
+ (receiver (register-map:save-entry map entry)
+ (save-into-home-instruction entry))
+ (receiver map '()))))
+\f
+(define-export (delete-machine-register map register)
+ (let ((entry (map-entries:find-alias map register)))
+ (if entry
+ (register-map:delete-alias map entry register)
+ map)))
+
+(define-export (delete-pseudo-register map register receiver)
+ (let ((entry (map-entries:find-home map register)))
+ (if entry
+ (receiver (register-map:delete-entry map entry)
+ (map-entry-aliases entry))
+ (receiver map '()))))
+
+(define-export (delete-pseudo-registers map registers receiver)
+ ;; Used to remove dead registers from the map.
+ (let loop ((registers registers)
+ (receiver
+ (lambda (entries aliases)
+ (receiver (register-map:delete-entries map entries)
+ aliases))))
+ (if (null? registers)
+ (receiver '() '())
+ (loop (cdr registers)
+ (let ((entry (map-entries:find-home map (car registers))))
+ (if entry
+ (lambda (entries aliases)
+ (receiver (cons entry entries) aliases))
+ receiver))))))
+
+(define-export (delete-other-locations map register)
+ ;; Used in assignments to indicate that other locations containing
+ ;; the same value no longer contain the value for a given home.
+ (register-map:delete-other-aliases
+ map
+ (or (map-entries:find-alias map register)
+ (error "DELETE-OTHER-LOCATIONS: Missing entry" register))
+ register))
+
+(define-integrable (allocator-values alias map instructions)
+ (vector alias map instructions))
+
+(define-export (bind-allocator-values values receiver)
+ (receiver (vector-ref values 0)
+ (vector-ref values 1)
+ (vector-ref values 2)))
+
+(define (save-into-home-instruction entry)
+ (register->home-transfer (map-entry:any-alias entry)
+ (map-entry-home entry)))
+\f
+;;;; Map Coercion
+
+;;; These operations generate the instructions to coerce one map into
+;;; another. They are used when joining two branches of a control
+;;; flow graph which have different maps (e.g. in a loop.)
+
+(let ()
+
+(define-export (coerce-map-instructions input-map output-map)
+ (three-way-sort map-entry=?
+ (map-entries input-map)
+ (map-entries output-map)
+ (lambda (input-entries shared-entries output-entries)
+ ((input-loop input-map
+ ((shared-loop (output-loop (empty-register-map)
+ output-entries))
+ shared-entries))
+ input-entries))))
+
+(define-export (clear-map-instructions input-map)
+ ((input-loop input-map '()) (map-entries input-map)))
+
+(define (input-loop map tail)
+ (define (loop entries)
+ (if (null? entries)
+ tail
+ (let ((instructions (loop (cdr entries))))
+ (if (map-entry-saved-into-home? (car entries))
+ instructions
+ (append! (save-into-home-instruction (car entries))
+ instructions)))))
+ loop)
+
+(define (shared-loop tail)
+ (define (loop entries)
+ (if (null? entries)
+ tail
+ (let ((input-aliases (map-entry-aliases (caar entries))))
+ (define (loop output-aliases)
+ (if (null? output-aliases)
+ (shared-loop (cdr entries))
+ (append! (register->register-transfer (car input-aliases)
+ (car output-aliases))
+ (loop (cdr output-aliases)))))
+ (loop (set-difference (map-entry-aliases (cdar entries))
+ input-aliases)))))
+ loop)
+\f
+(define (output-loop map entries)
+ (if (null? entries)
+ '()
+ (let ((instructions (output-loop map (cdr entries)))
+ (home (map-entry-home (car entries))))
+ (if home
+ (let ((aliases (map-entry-aliases (car entries))))
+ (define (loop registers)
+ (if (null? registers)
+ instructions
+ (append! (register->register-transfer (car aliases)
+ (car registers))
+ (loop (cdr registers)))))
+ (append! (home->register-transfer home (car aliases))
+ (loop (cdr aliases))))
+ instructions))))
+
+)
+
+;;; end REGISTER-ALLOCATOR-PACKAGE
+))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access register-allocator-package lap-generator-package compiler-package)
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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.
+;;;
+
+;;;; Symbol Tables
+
+(declare (usual-integrations))
+\f
+(define (make-symbol-table)
+ (cons "Symbol Table" '()))
+
+(define (symbol-table-define! table key value)
+ (let ((entry (assq key (cdr table))))
+ (if entry
+ (set-binding-value! (cdr entry) value)
+ (set-cdr! table (cons (cons key (vector value '())) (cdr table))))))
+
+(define (symbol-table-binding table key)
+ (let ((entry (assq key (cdr table))))
+ (if entry
+ (cdr entry)
+ (let ((nothing (vector #!FALSE '())))
+ (set-cdr! table (cons (cons key nothing) (cdr table)))
+ nothing))))
+
+(define (symbol-table-value table key)
+ (let ((entry (assq key (cdr table))))
+ (or (and entry (vector-ref (cdr entry) 0))
+ (error "SYMBOL-TABLE-VALUE: Undefined key" key))))
+
+(define (binding-value binding)
+ (vector-ref binding 0))
+
+(define (set-binding-value! binding value)
+ (if (vector-ref binding 0)
+ (error "Attempt to redefine variable" binding))
+ (vector-set! binding 0 value)
+ (for-each (lambda (daemon) (daemon binding))
+ (vector-ref binding 1)))
+
+(define (add-binding-daemon! binding daemon)
+ (vector-set! binding 1 (cons daemon (vector-ref binding 1))))
+
+(define (remove-binding-daemon! binding daemon)
+ (vector-set! binding 1 (delq! daemon (vector-ref binding 1))))
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-package compiler-package)
+;;; End:
+ (vector-set! binding 1 (delq! daemon (vector-ref binding 1))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 Syntaxer
+
+(declare (usual-integrations))
+\f
+(define (syntax-instructions instructions)
+ (convert-output
+ (let loop ((instructions instructions))
+ (if (null? instructions)
+ '()
+ (append-syntax! (syntax-instruction (car instructions))
+ (loop (cdr instructions)))))))
+
+(define (convert-output directives)
+ (map (lambda (directive)
+ (cond ((bit-string? directive) (vector 'CONSTANT directive))
+ ((pair? directive)
+ (if (eq? (car directive) 'GROUP)
+ (vector 'GROUP (convert-output (cdr directive)))
+ (list->vector directive)))
+ ((vector? directive) directive)
+ (else
+ (error "SYNTAX-INSTRUCTIONS: Unknown directive" directive))))
+ directives))
+
+(define (syntax-instruction instruction)
+ (if (memq (car instruction) '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL))
+ (list instruction)
+ (let ((match-result (instruction-lookup instruction)))
+ (or (and match-result (match-result))
+ (error "SYNTAX-INSTRUCTION: Badly formed instruction"
+ instruction)))))
+
+(define (instruction-lookup instruction)
+ (pattern-lookup
+ (cdr (or (assq (car instruction) instructions)
+ (error "INSTRUCTION-LOOKUP: Unknown keyword" (car instruction))))
+ (cdr instruction)))
+
+(define (add-instruction! keyword lookup)
+ (let ((entry (assq keyword instructions)))
+ (if entry
+ (set-cdr! entry lookup)
+ (set! instructions (cons (cons keyword lookup) instructions))))
+ keyword)
+
+(define instructions
+ '())
+
+(define (integer-syntaxer expression coercion-type size)
+ (let ((coercion (make-coercion-name coercion-type size)))
+ (if (integer? expression)
+ `',((lexical-reference coercion-environment coercion) expression)
+ `(SYNTAX-EVALUATION ,expression ,coercion))))
+\f
+(define (syntax-evaluation expression coercion)
+ (if (integer? expression)
+ (coercion expression)
+ (vector 'EVALUATION expression (coercion-size coercion) coercion)))
+
+(define (cons-syntax directive directives)
+ (if (and (bit-string? directive)
+ (not (null? directives))
+ (bit-string? (car directives)))
+ (begin (set-car! directives
+ (bit-string-append (car directives) directive))
+ directives)
+ (cons directive directives)))
+
+(define (append-syntax! directives directives*)
+ (cond ((null? directives) directives*)
+ ((null? directives*) directives)
+ (else
+ (let ((pair (last-pair directives)))
+ (if (and (bit-string? (car pair))
+ (bit-string? (car directives*)))
+ (begin (set-car! pair
+ (bit-string-append (car directives*)
+ (car pair)))
+ (set-cdr! pair (cdr directives*)))
+ (set-cdr! pair directives*)))
+ directives)))
+
+(define optimize-group
+ (let ()
+ (define (loop1 components)
+ (cond ((null? components) '())
+ ((bit-string? (car components))
+ (loop2 (car components) (cdr components)))
+ (else
+ (cons (car components)
+ (loop1 (cdr components))))))
+
+ (define (loop2 bit-string components)
+ (cond ((null? components)
+ (list bit-string))
+ ((bit-string? (car components))
+ (loop2 (bit-string-append (car components) bit-string)
+ (cdr components)))
+ (else
+ (cons bit-string
+ (cons (car components)
+ (loop1 (cdr components)))))))
+
+ (lambda components
+ (let ((components (loop1 components)))
+ (cond ((null? components) (error "OPTIMIZE-GROUP: No components"))
+ ((null? (cdr components)) (car components))
+ (else `(GROUP ,@components)))))))
+\f
+;;;; Coercion Machinery
+
+(define (make-coercion-name coercion-type size)
+ (string->symbol
+ (string-append "COERCE-"
+ (write-to-string size)
+ "-BIT-"
+ (write-to-string coercion-type))))
+
+(define coercion-property-tag
+ "Coercion")
+
+(define ((coercion-maker coercion-types) coercion-type size)
+ (let ((coercion
+ ((cdr (or (assq coercion-type coercion-types)
+ (error "Unknown coercion type" coercion-type)))
+ size)))
+ (2D-put! coercion coercion-property-tag (list coercion-type size))
+ coercion))
+
+(define (coercion-size coercion)
+ (cadr (coercion-properties coercion)))
+
+(define (unmake-coercion coercion receiver)
+ (apply receiver (coercion-properties coercion)))
+
+(define (coercion-properties coercion)
+ (or (2D-get coercion coercion-property-tag)
+ (error "COERCION-PROPERTIES: Not a known coercion" coercion)))
+
+(define coercion-environment
+ (the-environment))
+
+(define (define-coercion coercion-type size)
+ (local-assignment coercion-environment
+ (make-coercion-name coercion-type size)
+ (make-coercion coercion-type size)))
+
+(define (lookup-coercion name)
+ (lexical-reference coercion-environment name))
+\f
+(define ((coerce-unsigned-integer nbits) n)
+ (unsigned-integer->bit-string nbits n))
+
+(define (coerce-signed-integer nbits)
+ (let ((offset (expt 2 nbits)))
+ (lambda (n)
+ (unsigned-integer->bit-string nbits
+ (if (negative? n)
+ (+ n offset)
+ n)))))
+
+(define (standard-coercion kernel)
+ (lambda (nbits)
+ (lambda (n)
+ (unsigned-integer->bit-string nbits (kernel n)))))
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-syntaxer-package compiler-package)
+;;; End:
+ (unsigned-integer->bit-string nbits (kernel n)))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+;;;; Node Types
+
+(define cfg-node-tag (make-vector-tag false 'CFG-NODE))
+(define cfg-node? (tagged-vector-subclass-predicate cfg-node-tag))
+(define-vector-slots node 1 previous alist generation)
+
+(define (cfg-node-describe node)
+ `((NODE-PREVIOUS ,(node-previous node))
+ (NODE-ALIST ,(node-alist node))
+ (NODE-GENERATION ,(node-generation node))))
+
+(define-vector-method cfg-node-tag ':DESCRIBE
+ cfg-node-describe)
+
+(define snode-tag (make-vector-tag cfg-node-tag 'SNODE))
+(define snode? (tagged-vector-subclass-predicate snode-tag))
+(define-vector-slots snode 4 &next)
+
+(define (make-snode tag . extra)
+ (list->vector (cons* tag '() '() false false extra)))
+
+(define (snode-describe snode)
+ (append! (cfg-node-describe snode)
+ `((SNODE-&NEXT ,(snode-&next snode)))))
+
+(define-vector-method snode-tag ':DESCRIBE
+ snode-describe)
+
+(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE))
+(define pnode? (tagged-vector-subclass-predicate pnode-tag))
+(define-vector-slots pnode 4 &consequent &alternative)
+
+(define (make-pnode tag . extra)
+ (list->vector (cons* tag '() '() false false false extra)))
+
+(define (pnode-describe pnode)
+ (append! (cfg-node-describe pnode)
+ `((PNODE-&CONSEQUENT ,(pnode-&consequent pnode))
+ (PNODE-&ALTERNATIVE ,(pnode-&alternative pnode)))))
+
+(define-vector-method pnode-tag ':DESCRIBE
+ pnode-describe)
+\f
+;;;; Special Nodes
+
+;;; Entry/Exit holder nodes are used to hold onto the edges of a
+;;; graph. Entry holders need only a next connection, and exit
+;;; holders need only a previous connection.
+
+(define entry-holder-tag (make-vector-tag cfg-node-tag 'ENTRY-HOLDER))
+(define-vector-slots entry-holder 1 &next)
+
+(define (entry-holder? node)
+ (eq? (vector-ref node 0) entry-holder-tag))
+
+(define-integrable (make-entry-holder)
+ (vector entry-holder-tag false))
+
+(define exit-holder-tag (make-vector-tag cfg-node-tag 'EXIT-HOLDER))
+
+(define (exit-holder? node)
+ (eq? (vector-ref node 0) exit-holder-tag))
+
+(define-integrable (make-exit-holder)
+ (vector exit-holder-tag '()))
+
+(define (next-reference node)
+ (and node (not (exit-holder? node)) node))
+
+(define-integrable (snode-next snode)
+ (next-reference (snode-&next snode)))
+
+(define-integrable (pnode-consequent pnode)
+ (next-reference (pnode-&consequent pnode)))
+
+(define-integrable (pnode-alternative pnode)
+ (next-reference (pnode-&alternative pnode)))
+
+(define-integrable (entry-holder-next entry)
+ (next-reference (entry-holder-&next entry)))
+\f
+(define noop-node-tag (make-vector-tag cfg-node-tag 'NOOP))
+(define-vector-slots noop-node 1 previous next)
+(define *noop-nodes*)
+
+(define-integrable (make-noop-node)
+ (let ((node (vector noop-node-tag '() false)))
+ (set! *noop-nodes* (cons node *noop-nodes*))
+ node))
+
+(define (delete-noop-nodes!)
+ (for-each noop-node-delete! *noop-nodes*)
+ (set! *noop-nodes* '()))
+
+(define (noop-node-delete! noop-node)
+ (hooks-replace! (let ((previous (noop-node-previous noop-node)))
+ (hooks-disconnect! previous noop-node)
+ previous)
+ noop-node noop-node-next))
+
+(define (make-false-pcfg)
+ (let ((node (make-noop-node)))
+ (make-pcfg node
+ '()
+ (list (make-hook node set-noop-node-next!)))))
+
+(define (make-true-pcfg)
+ (let ((node (make-noop-node)))
+ (make-pcfg node
+ (list (make-hook node set-noop-node-next!))
+ '())))
+
+(define (constant->pcfg value)
+ ((if value make-true-pcfg make-false-pcfg)))
+\f
+;;;; Simple Construction
+
+(define ((node-connector set-node-next!) node next)
+ (hook-connect! (make-hook node set-node-next!) next))
+
+(define snode-next-connect! (node-connector set-snode-&next!))
+(define pnode-consequent-connect! (node-connector set-pnode-&consequent!))
+(define pnode-alternative-connect! (node-connector set-pnode-&alternative!))
+(define entry-holder-connect! (node-connector set-entry-holder-&next!))
+
+(define ((node-disconnector node-next) node)
+ (let ((next (node-next node)))
+ (if next (node-disconnect! node next))
+ next))
+
+(define (node-disconnect! node next)
+ (hook-disconnect! (find-hook node next) next))
+
+(define snode-next-disconnect! (node-disconnector snode-&next))
+(define pnode-consequent-disconnect! (node-disconnector pnode-&consequent))
+(define pnode-alternative-disconnect! (node-disconnector pnode-&alternative))
+(define entry-holder-disconnect! (node-disconnector entry-holder-next))
+
+(define (node-previous-disconnect! node)
+ (let ((hooks (node-previous node)))
+ (hooks-disconnect! hooks node)
+ hooks))
+
+(define (node-get node key)
+ (let ((entry (assq key (node-alist node))))
+ (and entry (cdr entry))))
+
+(define (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-integrable (node-previous-node node)
+ (hook-node (car (node-previous node))))
+
+(define (for-each-previous-node node procedure)
+ (for-each (lambda (hook)
+ (let ((node (hook-node hook)))
+ (if (not (entry-holder? node))
+ (procedure node))))
+ (node-previous node)))
+
+(define *generation*)
+
+(define make-generation
+ (let ((generation 0))
+ (named-lambda (make-generation)
+ (let ((value generation))
+ (set! generation (1+ generation))
+ value))))
+\f
+;;;; CFG Objects
+
+;;; 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 (node->scfg node set-node-next!)
+ (make-scfg node
+ (list (make-hook node set-node-next!))))
+
+(define-integrable (snode->scfg snode)
+ (node->scfg snode set-snode-&next!))
+
+(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-integrable (pnode->pcfg pnode)
+ (node->pcfg pnode
+ set-pnode-&consequent!
+ set-pnode-&alternative!))
+
+(define-integrable (make-null-cfg)
+ false)
+
+(define-integrable (cfg-null? cfg)
+ (false? cfg))
+\f
+;;;; Hooks
+
+;;; There are several different types of node, each of which has
+;;; different types of "next" connections, for example, the predicate
+;;; node has a consequent and an alternative connection. Any kind of
+;;; node can be connected to either of these connections. Since it is
+;;; desirable to be able to splice nodes in and out of the graph, we
+;;; would like to be able to dis/connect a node from its previous node
+;;; without knowing anything about that node. Hooks provide this
+;;; capability by providing an operation for setting the previous
+;;; node's appropriate "next" connection to any value.
+
+(define-integrable make-hook cons)
+(define-integrable hook-node car)
+(define-integrable hook-basher cdr)
+(define-integrable hooks-union append!)
+
+(define-integrable (find-hook node next)
+ (assq node (node-previous next)))
+
+(define (hook-connect! hook node)
+ (set-node-previous! node (cons hook (node-previous node)))
+ ((hook-basher hook) (hook-node hook) node))
+
+(define (hooks-connect! hooks node)
+ (define (loop hooks)
+ (if (not (null? hooks))
+ (begin (hook-connect! (car hooks) node)
+ (loop (cdr hooks)))))
+ (loop hooks))
+
+(define (hook-disconnect! hook node)
+ (set-node-previous! node (delq! hook (node-previous node)))
+ ((hook-basher hook) (hook-node hook) false))
+
+(define (hooks-disconnect! hooks node)
+ (define (loop hooks)
+ (if (not (null? hooks))
+ (begin (hook-disconnect! (car hooks) node)
+ (loop (cdr hooks)))))
+ (loop hooks))
+\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)))
+
+(package (scfg-append! scfg*->scfg!)
+
+(define (scfg-append! . scfgs)
+ (scfg*->scfg! scfgs))
+
+(define (scfg*->scfg! scfgs)
+ (let ((first (find-non-null scfgs)))
+ (and (not (null? first))
+ (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))))))))))
+
+(define (loop first second third)
+ (scfg-next-connect! first second)
+ (if (null? third)
+ second
+ (loop second (car third) (find-non-null (cdr third)))))
+
+(define (find-non-null scfgs)
+ (if (or (null? scfgs)
+ (car scfgs))
+ scfgs
+ (find-non-null (cdr scfgs))))
+
+)
+
+(define (scfg*scfg->scfg! scfg scfg*)
+ (cond ((not scfg) scfg*)
+ ((not scfg*) scfg)
+ (else (scfg-next-connect! scfg scfg*)
+ (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*)))))
+\f
+(define (pcfg->scfg! pcfg)
+ (make-scfg* (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks pcfg)
+ (pcfg-alternative-hooks pcfg)))
+
+(package (scfg*pcfg->pcfg! scfg*pcfg->scfg!)
+
+(define ((scfg*pcfg->cfg! transformer constructor) scfg pcfg)
+ (cond ((not pcfg) (error "SCFG*PCFG->CFG!: Can't have null predicate"))
+ ((not scfg) (transformer pcfg))
+ (else
+ (scfg-next-connect! scfg pcfg)
+ (constructor (cfg-entry-node scfg)
+ (pcfg-consequent-hooks pcfg)
+ (pcfg-alternative-hooks pcfg)))))
+
+(define scfg*pcfg->pcfg!
+ (scfg*pcfg->cfg! identity-procedure make-pcfg))
+
+(define scfg*pcfg->scfg!
+ (scfg*pcfg->cfg! pcfg->scfg! make-scfg*))
+
+)
+
+(package (pcfg*scfg->pcfg! pcfg*scfg->scfg!)
+
+(define ((pcfg*scfg->cfg! transformer constructor) pcfg consequent alternative)
+ (cond ((not pcfg) (error "PCFG*SCFG->CFG!: Can't have null predicate"))
+ ((not consequent)
+ (if (not alternative)
+ (transformer pcfg)
+ (begin (pcfg-alternative-connect! pcfg alternative)
+ (constructor (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks pcfg)
+ (scfg-next-hooks alternative)))))
+ ((not alternative)
+ (pcfg-consequent-connect! pcfg consequent)
+ (constructor (cfg-entry-node pcfg)
+ (scfg-next-hooks consequent)
+ (pcfg-alternative-hooks pcfg)))
+ (else
+ (pcfg-consequent-connect! pcfg consequent)
+ (pcfg-alternative-connect! pcfg alternative)
+ (constructor (cfg-entry-node pcfg)
+ (scfg-next-hooks consequent)
+ (scfg-next-hooks alternative)))))
+
+(define pcfg*scfg->pcfg!
+ (pcfg*scfg->cfg! identity-procedure make-pcfg))
+
+(define pcfg*scfg->scfg!
+ (pcfg*scfg->cfg! pcfg->scfg! make-scfg*))
+
+)
+\f
+(package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!)
+
+(define ((pcfg*pcfg->cfg! transformer constructor) pcfg consequent alternative)
+ (cond ((not pcfg)
+ (error "PCFG*PCFG->CFG!: Can't have null predicate"))
+ ((not consequent)
+ (if (not alternative)
+ (transformer pcfg)
+ (begin (pcfg-alternative-connect! pcfg alternative)
+ (constructor
+ (cfg-entry-node pcfg)
+ (hooks-union (pcfg-consequent-hooks pcfg)
+ (pcfg-consequent-hooks alternative))
+ (pcfg-alternative-hooks alternative)))))
+ ((not alternative)
+ (pcfg-consequent-connect! pcfg consequent)
+ (constructor (cfg-entry-node pcfg)
+ (pcfg-consequent-hooks consequent)
+ (hooks-union (pcfg-alternative-hooks consequent)
+ (pcfg-alternative-hooks pcfg))))
+ (else
+ (pcfg-consequent-connect! pcfg consequent)
+ (pcfg-alternative-connect! pcfg alternative)
+ (constructor (cfg-entry-node pcfg)
+ (hooks-union (pcfg-consequent-hooks consequent)
+ (pcfg-consequent-hooks alternative))
+ (hooks-union (pcfg-alternative-hooks consequent)
+ (pcfg-alternative-hooks alternative))))))
+
+(define pcfg*pcfg->pcfg!
+ (pcfg*pcfg->cfg! identity-procedure make-pcfg))
+
+(define pcfg*pcfg->scfg!
+ (pcfg*pcfg->cfg! pcfg->scfg! make-scfg*))
+
+)
+\f
+;;;; CFG Editing Support
+
+(define node-edit!
+ (let ((tail
+ (lambda (procedure entry)
+ (procedure (entry-holder-next entry))
+ (entry-holder-disconnect! entry))))
+ (lambda (node procedure)
+ (let ((entry (make-entry-holder)))
+ (entry-holder-connect! entry node)
+ (tail procedure entry)))))
+
+(define scfg-edit!
+ (let ((tail
+ (lambda (procedure entry exit)
+ (procedure (entry-holder-next entry))
+ (let ((node (entry-holder-disconnect! entry)))
+ (if node
+ (make-scfg node
+ (node-previous-disconnect! exit))
+ (make-null-cfg))))))
+ (lambda (scfg procedure)
+ (and (not (cfg-null? scfg))
+ (let ((entry (make-entry-holder))
+ (exit (make-exit-holder)))
+ (entry-holder-connect! entry (cfg-entry-node scfg))
+ (hooks-connect! (scfg-next-hooks scfg) exit)
+ (tail procedure entry exit))))))
+
+(define pcfg-edit!
+ (let ((tail
+ (lambda (procedure entry consequent alternative)
+ (procedure (entry-holder-next entry))
+ (make-pcfg (entry-holder-disconnect! entry)
+ (node-previous-disconnect! consequent)
+ (node-previous-disconnect! alternative)))))
+ (lambda (pcfg procedure)
+ (and (not (cfg-null? pcfg))
+ (let ((entry (make-entry-holder))
+ (exit (make-exit-holder)))
+ (entry-holder-connect! entry (cfg-entry-node pcfg))
+ (hooks-connect! (pcfg-consequent-hooks pcfg) consequent)
+ (hooks-connect! (pcfg-alternative-hooks pcfg) alternative)
+ (tail procedure entry consequent alternative))))))
+\f
+(define (node-replace! node cfg)
+ ((vector-method node node-replace!) node cfg))
+
+(define (snode-replace! snode scfg)
+ (hooks-replace! (let ((previous (node-previous snode)))
+ (hooks-disconnect! previous snode)
+ (if (not scfg)
+ previous
+ (begin (hooks-connect! previous (cfg-entry-node scfg))
+ (scfg-next-hooks scfg))))
+ snode snode-&next))
+
+(define (pnode-replace! pnode pcfg)
+ (if (not pcfg)
+ (error "PNODE-REPLACE!: Cannot delete pnode"))
+ (let ((previous (node-previous pnode))
+ (consequent (pnode-&consequent pnode))
+ (alternative (pnode-&alternative pnode)))
+ (hooks-disconnect! previous pnode)
+ (hooks-connect! previous (cfg-entry-node pcfg))
+ (hooks-replace! (pcfg-consequent-hooks pcfg) pnode pnode-&consequent)
+ (hooks-replace! (pcfg-alternative-hooks pcfg) pnode pnode-&alternative)))
+
+(define-vector-method snode-tag node-replace! snode-replace!)
+(define-vector-method pnode-tag node-replace! pnode-replace!)
+
+(define (snode-delete! snode)
+ (hooks-replace! (let ((previous (node-previous snode)))
+ (hooks-disconnect! previous snode)
+ previous)
+ snode snode-&next))
+
+(define (hooks-replace! hooks node next)
+ (let ((next (next node)))
+ (if next
+ (begin (node-disconnect! node next)
+ (hooks-connect! hooks next)))))
+
+(define (hook-insert-scfg! hook next scfg)
+ (if scfg
+ (begin (hook-disconnect! hook next)
+ (hook-connect! hook (cfg-entry-node scfg))
+ (hooks-connect! (scfg-next-hooks scfg) next))))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: compiler-package
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ (for-each edge-disconnect-right! edges))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 CFG Datatypes
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+(define-snode assignment block lvalue rvalue)
+
+(define (make-assignment block lvalue rvalue)
+ (vnode-connect! lvalue rvalue)
+ (snode->scfg (make-snode assignment-tag block lvalue rvalue)))
+
+(define-snode definition block lvalue rvalue)
+
+(define (make-definition block lvalue rvalue)
+ (vnode-connect! lvalue rvalue)
+ (snode->scfg (make-snode definition-tag block lvalue rvalue)))
+
+(define-snode combination block compilation-type value operator operands
+ procedures known-operator)
+(define *combinations*)
+
+(define (make-combination block compilation-type value operator operands)
+ (let ((combination
+ (make-snode combination-tag block compilation-type value operator
+ operands '() false)))
+ (set! *combinations* (cons combination *combinations*))
+ (set-block-combinations! block
+ (cons combination (block-combinations block)))
+ (set-vnode-combinations! value
+ (cons combination (vnode-combinations value)))
+ (snode->scfg combination)))
+
+(define-snode rtl-quote generator)
+
+(define-integrable (make-rtl-quote generator)
+ (snode->scfg (make-snode rtl-quote-tag generator)))
+
+(define-snode continuation block entry delta generator rtl label)
+(define *continuations*)
+
+(define-integrable (make-continuation block entry delta generator)
+ (let ((continuation
+ (make-snode continuation-tag block entry delta generator false
+ (generate-label 'CONTINUATION))))
+ (set! *continuations* (cons continuation *continuations*))
+ continuation))
+
+(define-unparser continuation-tag
+ (lambda (continuation)
+ (write (continuation-label continuation))))
+
+(define-snode invocation number-pushed continuation procedure generator)
+
+(define-integrable (make-invocation number-pushed continuation procedure
+ generator)
+ (snode->scfg (make-snode invocation-tag number-pushed continuation procedure
+ generator)))
+\f
+(define-pnode true-test rvalue)
+
+(define-integrable (make-true-test rvalue)
+ (pnode->pcfg (make-pnode true-test-tag rvalue)))
+
+(define-pnode type-test rvalue type)
+
+(define (make-type-test rvalue type)
+ (pnode->pcfg (make-pnode type-test-tag rvalue type)))
+
+(define-pnode unassigned-test block variable)
+
+(define-integrable (make-unassigned-test block variable)
+ (pnode->pcfg (make-pnode unassigned-test-tag block variable)))
+
+(define-pnode unbound-test block variable)
+
+(define-integrable (make-unbound-test block variable)
+ (pnode->pcfg (make-pnode unbound-test-tag block variable)))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: compiler-package
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ (symbol-hash-table/lookup *label->object* label))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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
+
+(declare (usual-integrations))
+\f
+(in-package compiler-package
+ (define compiler-syntax-table
+ (make-syntax-table system-global-syntax-table))
+
+ (define lap-generator-syntax-table
+ (make-syntax-table compiler-syntax-table))
+
+ (define assembler-syntax-table
+ (make-syntax-table compiler-syntax-table)))
+
+(syntax-table-define (access compiler-syntax-table compiler-package) 'PACKAGE
+ (lambda (expression)
+ (apply (lambda (names . body)
+ (make-sequence
+ `(,@(map (lambda (name)
+ (make-definition name (make-unassigned-object)))
+ 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)))
+ '()))))
+ (cdr expression))))
+\f
+(let ()
+
+(define (parse-define-syntax pattern body if-variable if-lambda)
+ (cond ((pair? pattern)
+ (let loop ((pattern pattern) (body body))
+ (cond ((pair? (car pattern))
+ (loop (car pattern) `((LAMBDA ,(cdr pattern) ,@body))))
+ ((symbol? (car pattern))
+ (if-lambda pattern body))
+ (else
+ (error "Illegal name" parse-lambda-syntax (car pattern))))))
+ ((symbol? pattern)
+ (if-variable pattern body))
+ (else
+ (error "Illegal name" parse-lambda-syntax pattern))))
+
+(define lambda-list->bound-names
+ (let ((accumulate
+ (lambda (lambda-list)
+ (cons (let ((parameter (car lambda-list)))
+ (if (pair? parameter) (car parameter) parameter))
+ (lambda-list->bound-names (cdr lambda-list))))))
+ (named-lambda (lambda-list->bound-names lambda-list)
+ (cond ((symbol? lambda-list)
+ lambda-list)
+ ((not (pair? lambda-list))
+ (error "Illegal rest variable" lambda-list))
+ ((eq? (car lambda-list)
+ (access lambda-optional-tag lambda-package))
+ (if (pair? (cdr lambda-list))
+ (accumulate (cdr lambda-list))
+ (error "Missing optional variable" lambda-list)))
+ (else
+ (accumulate lambda-list))))))
+\f
+(syntax-table-define (access compiler-syntax-table compiler-package)
+ 'DEFINE-EXPORT
+ (macro (pattern . body)
+ (parse-define-syntax pattern body
+ (lambda (name body)
+ `(SET! ,pattern ,@body))
+ (lambda (pattern body)
+ `(SET! ,(car pattern)
+ (NAMED-LAMBDA ,pattern ,@body))))))
+
+(syntax-table-define (access compiler-syntax-table compiler-package)
+ 'DEFINE-INTEGRABLE
+ (macro (pattern . body)
+#|
+ (parse-define-syntax pattern body
+ (lambda (name body)
+ `(BEGIN (DECLARE (INTEGRATE ,pattern))
+ (DEFINE ,pattern ,@body)))
+ (lambda (pattern body)
+ `(BEGIN (DECLARE (INTEGRATE ,(car pattern)))
+ (DEFINE ,pattern
+ ,@(if (list? (cdr pattern))
+ `(DECLARE
+ (INTEGRATE
+ ,@(lambda-list->bound-names (cdr pattern))))
+ '())
+ ,@body))))
+|#
+ `(DEFINE ,pattern ,@body)))
+
+)
+\f
+(syntax-table-define (access compiler-syntax-table compiler-package)
+ 'DEFINE-VECTOR-SLOTS
+ (macro (class index . slots)
+ (define (loop slots n)
+ (if (null? slots)
+ '()
+ (cons (let ((ref-name (symbol-append class '- (car slots))))
+ `(BEGIN
+ (DEFINE-INTEGRABLE (,ref-name ,class)
+ (VECTOR-REF ,class ,n))
+ (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!)
+ ,class ,(car slots))
+ (VECTOR-SET! ,class ,n ,(car slots)))))
+ (loop (cdr slots) (1+ n)))))
+ (if (null? slots)
+ '*THE-NON-PRINTING-OBJECT*
+ `(BEGIN ,@(loop slots index)))))
+
+(let-syntax
+ ((define-type-definition
+ (macro (name reserved)
+ `(SYNTAX-TABLE-DEFINE (ACCESS COMPILER-SYNTAX-TABLE COMPILER-PACKAGE)
+ ',(symbol-append 'DEFINE- name)
+ (macro (type . slots)
+ (let ((tag-name (symbol-append type '-TAG)))
+ `(BEGIN (DEFINE ,tag-name
+ (MAKE-VECTOR-TAG ,',(symbol-append name '-TAG) ',type))
+ (DEFINE ,(symbol-append type '?)
+ (TAGGED-VECTOR-PREDICATE ,tag-name))
+ (DEFINE-VECTOR-SLOTS ,type ,,reserved ,@slots)
+ (DEFINE-VECTOR-METHOD ,tag-name ':DESCRIBE
+ (LAMBDA (,type)
+ (APPEND!
+ (,',(symbol-append name '-DESCRIBE) ,type)
+ (LIST ,@(map (lambda (slot)
+ (let ((ref-name
+ (symbol-append type '- slot)))
+ ``(,',ref-name
+ ,(,ref-name ,type))))
+ slots))))))))))))
+ (define-type-definition snode 5)
+ (define-type-definition pnode 6)
+ (define-type-definition rvalue 1)
+ (define-type-definition vnode 10))
+\f
+(let ((rtl-common
+ (lambda (type prefix components wrap-constructor)
+ `(BEGIN
+ (DEFINE-INTEGRABLE (,(symbol-append prefix 'MAKE- type) . REST)
+ ,(wrap-constructor `(CONS ',type REST)))
+ (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))
+ (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))))))))))
+ (syntax-table-define (access compiler-syntax-table compiler-package)
+ 'DEFINE-RTL-EXPRESSION
+ (macro (type prefix . components)
+ (rtl-common type prefix components identity-procedure)))
+
+ (syntax-table-define (access compiler-syntax-table compiler-package)
+ 'DEFINE-RTL-STATEMENT
+ (macro (type prefix . components)
+ (rtl-common type prefix components
+ (lambda (expression) `(STATEMENT->SCFG ,expression)))))
+
+ (syntax-table-define (access compiler-syntax-table compiler-package)
+ 'DEFINE-RTL-PREDICATE
+ (macro (type prefix . components)
+ (rtl-common type prefix components
+ (lambda (expression) `(PREDICATE->PCFG ,expression))))))
+\f
+(syntax-table-define (access compiler-syntax-table compiler-package)
+ 'DEFINE-REGISTER-REFERENCES
+ (macro (slot)
+ (let ((name (symbol-append 'REGISTER- slot)))
+ (let ((vector (symbol-append '* name '*)))
+ `(BEGIN (DEFINE ,vector)
+ (DEFINE-INTEGRABLE (,name REGISTER)
+ (VECTOR-REF ,vector REGISTER))
+ (DEFINE-INTEGRABLE
+ (,(symbol-append 'SET- name '!) REGISTER VALUE)
+ (VECTOR-SET! ,vector REGISTER VALUE)))))))
+
+(syntax-table-define (access compiler-syntax-table compiler-package)
+ 'UCODE-TYPE
+ (macro (name)
+ (or (microcode-type name)
+ (error "Unknown type code" name))))
+
+(syntax-table-define (access compiler-syntax-table compiler-package)
+ 'UCODE-PRIMITIVE
+ (macro (name)
+ (make-primitive-procedure name)))
+
+(syntax-table-define (access lap-generator-syntax-table compiler-package)
+ 'DEFINE-RULE
+ (in-package compiler-package
+ (declare (usual-integrations))
+ (macro (type pattern . body)
+ (parse-rule pattern body
+ (lambda (pattern names transformer qualifier actions)
+ `(,(case type
+ ((STATEMENT) 'ADD-STATEMENT-RULE!)
+ ((PREDICATE) 'ADD-STATEMENT-RULE!)
+ (else (error "Unknown rule type" type)))
+ ',pattern
+ ,(rule-result-expression names transformer qualifier
+ `(BEGIN ,@actions))))))))
+
+;;;; Datatype Definers
+
+;;; Edwin Variables:
+;;; Scheme Environment: system-global-environment
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ `(BEGIN ,@actions)))))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+;;;; Support for tagged objects
+
+(define (make-vector-tag parent name)
+ (let ((tag (cons '() (or parent vector-tag:object))))
+ (vector-tag-put! tag ':TYPE-NAME name)
+ ((access add-unparser-special-object! unparser-package) tag
+ (lambda (object)
+ (unparse-with-brackets
+ (lambda ()
+ (write-string "LIAR ")
+ ((vector-method object ':UNPARSE) object)))))
+ tag))
+
+(define (vector-tag-put! tag key value)
+ (let ((entry (assq key (car tag))))
+ (if entry
+ (set-cdr! entry value)
+ (set-car! tag (cons (cons key value) (car tag))))))
+
+(define (vector-tag-get tag key)
+ (define (loop tag)
+ (and (pair? tag)
+ (or (assq key (car tag))
+ (loop (cdr tag)))))
+ (let ((value
+ (or (assq key (car tag))
+ (loop (cdr tag)))))
+ (and value (cdr value))))
+
+(define vector-tag:object (list '()))
+(vector-tag-put! vector-tag:object ':TYPE-NAME 'OBJECT)
+
+(define-integrable (vector-tag vector)
+ (vector-ref vector 0))
+
+(define (define-vector-method tag name method)
+ (vector-tag-put! tag name method)
+ name)
+
+(define-integrable (vector-method vector name)
+ (or (vector-tag-get (vector-tag vector) name)
+ (error "Unbound method" vector name)))
+
+(define (define-unparser tag unparser)
+ (vector-tag-put! tag ':UNPARSE unparser))
+\f
+(define-integrable make-tagged-vector
+ vector)
+
+(define ((tagged-vector-predicate tag) object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (eq? tag (vector-tag object))))
+
+(define (tagged-vector-subclass-predicate tag)
+ (define (loop tag*)
+ (or (eq? tag tag*)
+ (and (not (null? (cdr tag*)))
+ (loop (cdr tag*)))))
+ (lambda (object)
+ (and (vector? object)
+ (not (zero? (vector-length object)))
+ (loop (vector-tag object)))))
+
+(define-unparser vector-tag:object
+ (lambda (object)
+ (write (vector-method object ':TYPE-NAME))
+ (write-string " ")
+ (write (primitive-datum object))))
+
+(define (po object)
+ (fluid-let ((*unparser-radix* 16))
+ (write-line object)
+ (for-each pp ((vector-method object ':DESCRIBE) object))))
+\f
+;;;; Queue
+
+(define (make-queue)
+ (cons '() '()))
+
+(define-integrable (queue-empty? queue)
+ (null? (car queue)))
+
+(define-integrable (queued? queue item)
+ (memq item (car queue)))
+
+(define (enqueue! queue object)
+ (let ((next (cons object '())))
+ (if (null? (cdr queue))
+ (set-car! queue next)
+ (set-cdr! (cdr queue) next))
+ (set-cdr! queue next)))
+
+(define (dequeue! queue)
+ (let ((next (car queue)))
+ (if (null? (cdr next))
+ (begin (set-car! queue '())
+ (set-cdr! queue '()))
+ (set-car! queue (cdr next)))
+ (car next)))
+
+(define (queue-map! queue procedure)
+ (define (loop)
+ (if (not (queue-empty? queue))
+ (begin (procedure (dequeue! queue))
+ (loop))))
+ (loop))
+\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 (generate-label #!optional prefix)
+ (if (unassigned? prefix) (set! prefix 'LABEL))
+ (string->symbol
+ (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:make-package) 'MAKE-PACKAGE)
+ ((or (eq? prefix lambda-tag:shallow-fluid-let)
+ (eq? prefix lambda-tag:deep-fluid-let)
+ (eq? prefix lambda-tag:common-lisp-fluid-let))
+ 'FLUID-LET)
+ (else prefix)))
+ "-"
+ (write-to-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 (copy-alist alist)
+ (if (null? alist)
+ '()
+ (cons (cons (caar alist) (cdar alist))
+ (copy-alist (cdr alist)))))
+
+(define (warn message . irritants)
+ (newline)
+ (write-string "Warning: ")
+ (write-string message)
+ (for-each (lambda (irritant)
+ (write-string " ")
+ (write irritant))
+ irritants))
+
+(define (show-time thunk)
+ (let ((start (runtime)))
+ (let ((value (thunk)))
+ (write-line (- (runtime) start))
+ value)))
+
+(define &make-object
+ (make-primitive-procedure '&MAKE-OBJECT))
+\f
+;;;; Set Operations
+
+(define (set-adjoin element set)
+ (if (memq element set)
+ set
+ (cons element set)))
+
+(define (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 (set-substitute set old new)
+ (define (loop set)
+ (cond ((null? set)
+ (error "SET-SUBSTITUTE: Missing item" old))
+ ((eq? (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))
+
+(define set-union
+ (let ()
+ (define (loop x y)
+ (if (null? x)
+ y
+ (loop (cdr x)
+ (if (memq (car x) y)
+ y
+ (cons (car x) y)))))
+ (named-lambda (set-union x y)
+ (if (null? y)
+ x
+ (loop x y)))))
+
+(define (set-difference set1 set2)
+ (cond ((null? set1) '())
+ ((memq (car set1) set2) (set-difference (cdr set1) set2))
+ (else (cons (car set1) (set-difference (cdr set1) set2)))))
+\f
+;;;; SCode Interface
+
+(let-syntax ((define-scode-operator
+ (macro (name)
+ `(DEFINE ,(symbol-append 'SCODE: name)
+ (ACCESS ,name SYSTEM-GLOBAL-ENVIRONMENT)))))
+ (define-scode-operator access-components)
+ (define-scode-operator access?)
+ (define-scode-operator assignment-components)
+ (define-scode-operator combination-components)
+ (define-scode-operator combination?)
+ (define-scode-operator comment-expression)
+ (define-scode-operator comment?)
+ (define-scode-operator conditional-components)
+ (define-scode-operator definition-components)
+ (define-scode-operator delay-expression)
+ (define-scode-operator disjunction-components)
+ (define-scode-operator in-package-components)
+ (define-scode-operator lambda-components)
+ (define-scode-operator lambda?)
+ (define-scode-operator make-combination)
+ (define-scode-operator make-conditional)
+ (define-scode-operator make-definition)
+ (define-scode-operator make-lambda)
+ (define-scode-operator make-quotation)
+ (define-scode-operator make-sequence)
+ (define-scode-operator make-variable)
+ (define-scode-operator open-block-components)
+ (define-scode-operator open-block?)
+ (define-scode-operator primitive-procedure?)
+ (define-scode-operator procedure?)
+ (define-scode-operator quotation-expression)
+ (define-scode-operator sequence-actions)
+ (define-scode-operator unassigned-object?)
+ (define-scode-operator unassigned?-name)
+ (define-scode-operator unbound?-name)
+ (define-scode-operator variable-name)
+ (define-scode-operator variable?))
+
+(define scode:constant?
+ (access scode-constant? system-global-environment))
+\f
+(define (scode:error-combination-components combination receiver)
+ (scode:combination-components combination
+ (lambda (operator operands)
+ (receiver (car operands)
+ (let ((irritant (cadr operands)))
+ (cond ((scode:access? irritant) '())
+ ((scode:combination? irritant)
+ (scode:combination-components irritant
+ (lambda (operator operands)
+ (if (and (scode:access? operator)
+ (scode:access-components operator
+ (lambda (environment name)
+ (and (null? environment)
+ (eq? name 'LIST)))))
+ operands
+ (list irritant)))))
+ (else (list irritant))))))))
+
+(define (scode:procedure-type-code *lambda)
+ (cond ((primitive-type? type-code:lambda *lambda)
+ type-code:procedure)
+ ((primitive-type? type-code:extended-lambda *lambda)
+ type-code:extended-procedure)
+ (else
+ (error "SCODE:PROCEDURE-TYPE-CODE: Unknown lambda type" *lambda))))
+\f
+;;;; Type Codes
+
+(define type-code:lambda
+ (microcode-type 'LAMBDA))
+
+(define type-code:extended-lambda
+ (microcode-type 'EXTENDED-LAMBDA))
+
+(define type-code:procedure
+ (microcode-type 'PROCEDURE))
+
+(define type-code:extended-procedure
+ (microcode-type 'EXTENDED-PROCEDURE))
+
+(define type-code:cell
+ (microcode-type 'CELL))
+
+(define type-code:compiled-expression
+ (microcode-type 'COMPILED-EXPRESSION))
+
+(define type-code:compiler-link
+ (microcode-type 'COMPILER-LINK))
+
+(define type-code:compiled-procedure
+ (microcode-type 'COMPILED-PROCEDURE))
+
+(define type-code:environment
+ (microcode-type 'ENVIRONMENT))
+
+(define type-code:stack-environment
+ (microcode-type 'STACK-ENVIRONMENT))
+
+(define type-code:return-address
+ (microcode-type 'COMPILER-RETURN-ADDRESS))
+
+(define type-code:unassigned
+ (microcode-type 'UNASSIGNED))
+\f
+;;; Disgusting hack to replace microcode implementation.
+
+(define (primitive-procedure-safe? object)
+ (not (memq object
+ (let-syntax ((primitives
+ (macro names
+ `'(,@(map make-primitive-procedure names)))))
+ (primitives call-with-current-continuation
+ non-reentrant-call-with-current-continuation
+ scode-eval
+ apply
+ garbage-collect
+ primitive-fasdump
+ with-history-disabled
+ force
+ primitive-purify
+ complete-garbage-collect
+ dump-band
+ primitive-impurify
+ with-threaded-continuation
+ within-control-point
+ with-interrupts-reduced
+ primitive-eval-step
+ primitive-apply-step
+ primitive-return-step
+ execute-at-new-state-point
+ translate-to-state-point
+ with-interrupt-mask
+ error-procedure)))))
+\f
+;;;; Special Compiler Support
+
+(define compiled-error-procedure
+ "Compiled error procedure")
+
+(define lambda-tag:delay
+ (make-named-tag "DELAY-LAMBDA"))
+
+(define (non-pointer-object? object)
+ (or (primitive-type? (ucode-type false) object)
+ (primitive-type? (ucode-type true) object)
+ (primitive-type? (ucode-type fixnum) object)
+ (primitive-type? (ucode-type character) object)
+ (primitive-type? (ucode-type unassigned) object)
+ (primitive-type? (ucode-type the-environment) object)
+ (primitive-type? (ucode-type extended-fixnum) object)
+ (primitive-type? (ucode-type manifest-nm-vector) object)
+ (primitive-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)))
+
+(define (operator-constant-foldable? operator)
+ (memq operator constant-foldable-operators))
+
+(define constant-foldable-operators
+ (map* (list primitive-type primitive-type?
+ eq? null? pair? car cdr vector-length vector-ref
+ number? complex? real? rational? integer?
+ zero? positive? negative? odd? even? exact? inexact?
+ = < > <= >= max min
+ + - * / 1+ -1+ abs quotient remainder modulo integer-divide
+ gcd lcm floor ceiling truncate round
+ exp log expt sqrt sin cos tan asin acos atan)
+ make-primitive-procedure
+ '(&+ &- &* &/ &< &> &= &ATAN)))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: compiler-package
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ (ucode-primitive &=) (ucode-primitive &atan)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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
+(define addressing-granularity 8)
+(define scheme-object-width 32)
+
+(define make-nmv-header)
+(let ()
+
+(set! make-nmv-header
+(named-lambda (make-nmv-header n)
+ (bit-string-append (unsigned-integer->bit-string 24 n)
+ nmv-type-string)))
+
+(define nmv-type-string
+ (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR)))
+
+)
+
+(define (object->bit-string object)
+ (bit-string-append
+ (unsigned-integer->bit-string 24 (primitive-datum object))
+ (unsigned-integer->bit-string 8 (primitive-type object))))
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-package compiler-package)
+;;; End:
+ (unsigned-integer->bit-string 8 (primitive-type object))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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.
+;;;
+
+;;;; 68000 Specific Coercions
+
+(declare (usual-integrations))
+\f
+(define coerce-quick
+ (standard-coercion
+ (lambda (n)
+ (cond ((< 0 n 8) n)
+ ((= n 8) 0)
+ (else (error "Bad quick immediate" n))))))
+
+(define coerce-short-label
+ (standard-coercion
+ (lambda (offset)
+ (or (if (negative? offset)
+ (and (>= offset -128) (+ offset 256))
+ (and (< offset 128) offset))
+ (error "Short label out of range" offset)))))
+
+(define make-coercion
+ (coercion-maker
+ `((UNSIGNED . ,coerce-unsigned-integer)
+ (SIGNED . ,coerce-signed-integer)
+ (QUICK . ,coerce-quick)
+ (SHIFT-NUMBER . ,coerce-quick)
+ (SHORT-LABEL . ,coerce-short-label))))
+
+(define-coercion 'UNSIGNED 1)
+(define-coercion 'UNSIGNED 2)
+(define-coercion 'UNSIGNED 3)
+(define-coercion 'UNSIGNED 4)
+(define-coercion 'UNSIGNED 5)
+(define-coercion 'UNSIGNED 6)
+(define-coercion 'UNSIGNED 8)
+(define-coercion 'UNSIGNED 9)
+(define-coercion 'UNSIGNED 10)
+(define-coercion 'UNSIGNED 12)
+(define-coercion 'UNSIGNED 13)
+(define-coercion 'UNSIGNED 16)
+(define-coercion 'UNSIGNED 32)
+
+(define-coercion 'SIGNED 8)
+(define-coercion 'SIGNED 16)
+(define-coercion 'SIGNED 32)
+
+(define-coercion 'QUICK 3)
+(define-coercion 'SHIFT-NUMBER 3)
+(define-coercion 'SHORT-LABEL 8)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-syntaxer-package compiler-package)
+;;; End:
+(define-coercion 'SHORT-LABEL 8)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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.
+;;;
+
+;;;; 68000 Instruction Set Macros
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+;;;; Instruction Definitions
+
+(syntax-table-define assembler-syntax-table 'MAKE-EA-DATABASE
+ (macro rules
+ (compile-database rules
+ (lambda (pattern actions)
+ (let ((keyword (car pattern))
+ (categories (car actions))
+ (mode (cadr actions))
+ (register (caddr actions))
+ (extension (cdddr actions)))
+ ;;(declare (integrate keyword categories mode register extension))
+ `(MAKE-EFFECTIVE-ADDRESS
+ ',keyword
+ (LAMBDA () ,(integer-syntaxer mode 'UNSIGNED 3))
+ (LAMBDA () ,(integer-syntaxer register 'UNSIGNED 3))
+ (LAMBDA (IMMEDIATE-SIZE INSTRUCTION-TAIL)
+ ,(if (null? extension)
+ 'INSTRUCTION-TAIL
+ `(CONS-SYNTAX ,(car extension) INSTRUCTION-TAIL)))
+ ',categories))))))
+
+(syntax-table-define assembler-syntax-table 'EXTENSION-WORD
+ (macro descriptors
+ (expand-descriptors descriptors
+ (lambda (instruction size source destination)
+ (if (or source destination)
+ (error "Source or destination used" 'EXTENSION-WORD)
+ (if (zero? (remainder size 16))
+ (apply optimize-group-syntax instruction)
+ (error "EXTENSION-WORD: Extensions must be 16 bit multiples"
+ size)))))))
+\f
+(define (parse-word expression tail)
+ (expand-descriptors (cdr expression)
+ (lambda (instruction size src dst)
+ (if (zero? (remainder size 16))
+ (let ((code
+ (let ((code
+ (let ((code (if dst `(,@dst '()) '())))
+ (if src
+ `(,@src ,code)
+ code))))
+ (if (null? tail)
+ code
+ `(,(if (null? code) 'CONS 'CONS-SYNTAX)
+ ,(car tail)
+ ,code)))))
+ `(,(if (null? code) 'CONS 'CONS-SYNTAX)
+ ,(apply optimize-group-syntax instruction)
+ ,code))
+ (error "PARSE-WORD: Instructions must be 16 bit multiples" size)))))
+
+(define (expand-descriptors descriptors receiver)
+ (if (null? descriptors)
+ (receiver '() 0 false false)
+ (expand-descriptors (cdr descriptors)
+ (lambda (instruction* size* source* destination*)
+ (expand-descriptor (car descriptors)
+ (lambda (instruction size source destination)
+ (receiver (append! instruction instruction*)
+ (+ size size*)
+ (if source
+ (if source*
+ (error "Multiple source definitions"
+ 'EXPAND-DESCRIPTORS)
+ source)
+ source*)
+ (if destination
+ (if destination*
+ (error "Multiple destination definitions"
+ 'EXPAND-DESCRIPTORS)
+ destination)
+ destination*))))))))
+\f
+(define (expand-descriptor descriptor receiver)
+ (let ((size (car descriptor))
+ (expression (cadr descriptor))
+ (coercion-type
+ (if (null? (cddr descriptor)) 'UNSIGNED (caddr descriptor))))
+ (case coercion-type
+ ((UNSIGNED SIGNED SHIFT-NUMBER QUICK)
+ (receiver `(,(integer-syntaxer expression coercion-type size))
+ size false false))
+ ((SHORT-LABEL)
+ (receiver `(,(integer-syntaxer
+ ``(- ,,expression (+ *PC* 2))
+ 'SHORT-LABEL
+ size))
+ size false false))
+ ((SOURCE-EA)
+ (receiver `(((EA-MODE ,expression))
+ ((EA-REGISTER ,expression)))
+ size
+ `((EA-EXTENSION ,expression) ,(cadddr descriptor))
+ false))
+ ((DESTINATION-EA)
+ (receiver `(((EA-MODE ,expression))
+ ((EA-REGISTER ,expression)))
+ size
+ false
+ `((EA-EXTENSION ,expression) '())))
+ ((DESTINATION-EA-REVERSED)
+ (receiver `(((EA-REGISTER ,expression))
+ ((EA-MODE ,expression)))
+ size
+ false
+ `((EA-EXTENSION ,expression) '())))
+ (else
+ (error "EXPAND-DESCRIPTOR: Badly-formed descriptor" descriptor)))))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-syntaxer-package compiler-package)
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; End:
+ (error "EXPAND-DESCRIPTOR: Badly-formed descriptor" descriptor)))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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.
+;;;
+
+;;;; 68000 Instruction Set Description
+;;; Originally from GJS (who did the hard part).
+
+(declare (usual-integrations))
+(using-syntax (access assembler-syntax-table compiler-package)
+\f
+;;;; Effective Addressing
+
+(define (make-effective-address keyword mode register extension categories)
+ (vector ea-tag keyword mode register extension categories))
+
+(define (effective-address? object)
+ (and (vector? object)
+ (not (zero? (vector-size object)))
+ (eq? (vector-ref object 0) ea-tag)))
+
+(define ea-tag
+ "Effective-Address")
+
+(define-integrable (ea-keyword ea)
+ (vector-ref ea 1))
+
+(define-integrable (ea-mode ea)
+ (vector-ref ea 2))
+
+(define-integrable (ea-register ea)
+ (vector-ref ea 3))
+
+(define-integrable (ea-extension ea)
+ (vector-ref ea 4))
+
+(define-integrable (ea-categories ea)
+ (vector-ref ea 5))
+\f
+(define (ea-all expression)
+ (let ((match-result (pattern-lookup ea-database expression)))
+ (and match-result (match-result))))
+
+(define ((ea-filtered filter) expression)
+ (let ((ea (ea-all expression)))
+ (and ea (filter ea) ea)))
+
+(define (ea-filtered-by-category category)
+ (ea-filtered
+ (lambda (ea)
+ (memq category (ea-categories ea)))))
+
+(define ea-d (ea-filtered-by-category 'DATA))
+(define ea-a (ea-filtered-by-category 'ALTERABLE))
+(define ea-c (ea-filtered-by-category 'CONTROL))
+
+(define (ea-filtered-by-categories categories)
+ (ea-filtered
+ (lambda (ea)
+ (eq?-subset? categories (ea-categories ea)))))
+
+(define (eq?-subset? x y)
+ (or (null? x)
+ (and (memq (car x) y)
+ (eq?-subset? (cdr x) y))))
+
+(define ea-d&a (ea-filtered-by-categories '(DATA ALTERABLE)))
+(define ea-c&a (ea-filtered-by-categories '(CONTROL ALTERABLE)))
+(define ea-m&a (ea-filtered-by-categories '(MEMORY ALTERABLE)))
+
+(define ea-d&-&
+ (ea-filtered
+ (lambda (ea)
+ (and (not (eq? (ea-keyword ea) '&))
+ (memq 'DATA (ea-categories ea))))))
+
+;;; These are just predicates, to be used in conjunction with EA-ALL.
+
+(define (ea-b=>-A ea s)
+ (not (and (eq? s 'B) (eq? (ea-keyword ea) 'A))))
+
+(define (ea-a&<b=>-A> ea s)
+ (and (memq 'ALTERABLE (ea-categories ea)) (ea-b=>-A ea s)))
+\f
+;;;; Effective Address Description
+
+(define ea-database
+ (make-ea-database
+ ((D (? r)) (DATA ALTERABLE) #b000 r)
+
+ ((A (? r)) (ALTERABLE) #b001 r)
+
+ ((@A (? r)) (DATA MEMORY CONTROL ALTERABLE) #b010 r)
+
+ ((@D (? r))
+ (DATA MEMORY CONTROL ALTERABLE) #b110 #b000
+ (output-@D-indirect r))
+
+ ((@A+ (? r)) (DATA MEMORY ALTERABLE) #b011 r)
+
+ ((@-A (? r)) (DATA MEMORY ALTERABLE) #b100 r)
+
+ ((@AO (? r) (? o))
+ (DATA MEMORY CONTROL ALTERABLE) #b101 r
+ (output-16bit-offset o))
+
+ ((@AR (? r) (? l))
+ (DATA MEMORY CONTROL ALTERABLE) #b101 r
+ (output-16bit-relative l))
+
+ ((@DO (? r) (? o))
+ (DATA MEMORY CONTROL ALTERABLE) #b110 #b000
+ (output-@DO-indirect r o))
+\f
+ ((@AOX (? r) (? o) (? xtype) (? xr) (? s))
+ (QUALIFIER (da? xtype) (wl? s))
+ (DATA MEMORY CONTROL ALTERABLE) #b110 r
+ (output-offset-index-register xtype xr s o))
+
+ ((@ARX (? r) (? l) (? xtype) (? xr) (? s))
+ (QUALIFIER (da? xtype) (wl? s))
+ (DATA MEMORY CONTROL ALTERABLE) #b110 r
+ (output-relative-index-register xtype xr s l))
+
+ ((W (? a))
+ (DATA MEMORY CONTROL ALTERABLE) #b111 #b000
+ (output-16bit-address a))
+
+ ((L (? a))
+ (DATA MEMORY CONTROL ALTERABLE) #b111 #b001
+ (output-32bit-address a))
+
+ ((@PCO (? o))
+ (DATA MEMORY CONTROL) #b111 #b010
+ (output-16bit-offset o))
+
+ ((@PCR (? l))
+ (DATA MEMORY CONTROL) #b111 #b010
+ (output-16bit-relative l))
+
+ ((@PCOX (? o) (? xtype) (? xr) (? s))
+ (QUALIFIER (da? xtype) (wl? s))
+ (DATA MEMORY CONTROL) #b111 #b011
+ (output-offset-index-register xtype xr s o))
+
+ ((@PCRX (? l) (? xtype) (? xr) (? s))
+ (QUALIFIER (da? xtype) (wl? s))
+ (DATA MEMORY CONTROL) #b111 #b011
+ (output-relative-index-register xtype xr s l))
+
+ ((& (? i))
+ (DATA MEMORY) #b111 #b100
+ (output-immediate-data immediate-size i))))
+\f
+;;;; Effective Address Extensions
+
+(define-integrable (output-16bit-offset o)
+ (EXTENSION-WORD (16 o SIGNED)))
+
+(define-integrable (output-16bit-relative l)
+ (EXTENSION-WORD (16 `(- ,l *PC*) SIGNED)))
+
+(define-integrable (output-offset-index-register xtype xr s o)
+ (EXTENSION-WORD (1 (encode-da xtype))
+ (3 xr)
+ (1 (encode-wl s))
+ (3 #b000)
+ (8 o SIGNED)))
+
+(define-integrable (output-relative-index-register xtype xr s l)
+ (EXTENSION-WORD (1 (encode-da xtype))
+ (3 xr)
+ (1 (encode-wl s))
+ (3 #b000)
+ (8 `(- ,l *PC*) SIGNED)))
+
+(define-integrable (output-16bit-address a)
+ (EXTENSION-WORD (16 a)))
+
+(define-integrable (output-32bit-address a)
+ (EXTENSION-WORD (32 a)))
+
+(define (output-immediate-data immediate-size i)
+ (case immediate-size
+ ((B)
+ (EXTENSION-WORD (8 #b00000000)
+ (8 i SIGNED)))
+ ((W)
+ (EXTENSION-WORD (16 i SIGNED)))
+ ((L)
+ (EXTENSION-WORD (32 i SIGNED)))
+ (else
+ (error "OUTPUT-IMMEDIATE-DATA: illegal immediate size"
+ immediate-size))))
+\f
+;;; New stuff for 68020
+
+(define (output-brief-format-extension-word immediate-size
+ index-register-type index-register
+ index-size scale-factor
+ displacement)
+ (EXTENSION-WORD (1 (encode-da index-register-type))
+ (3 index-register)
+ (1 (encode-wl index-size))
+ (2 (encode-bwlq scale-factor))
+ (1 #b0)
+ (8 displacement SIGNED)))
+
+(define (output-full-format-extension-word immediate-size
+ index-register-type index-register
+ index-size scale-factor
+ base-suppress? index-suppress?
+ base-displacement-size
+ base-displacement
+ memory-indirection-type
+ outer-displacement-size
+ outer-displacement)
+ (EXTENSION-WORD (1 (encode-da index-register-type))
+ (3 index-register)
+ (1 (encode-wl index-size))
+ (2 (encode-bwlq scale-factor))
+ (1 #b1)
+ (1 (if base-suppress? #b1 #b0))
+ (1 (if index-suppress? #b1 #b0))
+ (2 (encode-nwl base-displacement-size))
+ (1 #b0)
+ (3 (case memory-indirection-type
+ ((#F) #b000)
+ ((PRE) (encode-nwl outer-displacement-size))
+ ((POST)
+ (+ #b100 (encode-nwl outer-displacement-size))))))
+ (output-displacement base-displacement-size base-displacement)
+ (output-displacement outer-displacement-size outer-displacement))
+
+(define (output-displacement size displacement)
+ (case size
+ ((N))
+ ((W) (EXTENSION-WORD (16 displacement SIGNED)))
+ ((L) (EXTENSION-WORD (32 displacement SIGNED)))))
+\f
+(define-integrable (output-@D-indirect register)
+ (EXTENSION-WORD (1 #b0) ;index register = data
+ (3 register)
+ (1 #b1) ;index size = longword
+ (2 #b00) ;scale factor = 1
+ (1 #b1)
+ (1 #b1) ;suppress base register
+ (1 #b0) ;don't suppress index register
+ (2 #b01) ;null base displacement
+ (1 #b0)
+ (3 #b000) ;no memory indirection
+ ))
+
+(define (output-@DO-indirect register displacement)
+ (EXTENSION-WORD (1 #b0) ;index register = data
+ (3 register)
+ (1 #b1) ;index size = 32 bits
+ (2 #b00) ;scale factor = 1
+ (1 #b1)
+ (1 #b1) ;suppress base register
+ (1 #b0) ;don't suppress index register
+ (2 #b10) ;base displacement size = 16 bits
+ (1 #b0)
+ (3 #b000) ;no memory indirection
+ (16 displacement SIGNED)))
+\f
+;;;; Operand Syntaxers.
+
+(define (immediate-words data size)
+ (case size
+ ((B) (immediate-byte data))
+ ((W) (immediate-word data))
+ ((L) (immediate-long data))
+ (else (error "IMMEDIATE-WORD: Illegal size" size))))
+
+(define-integrable (immediate-byte data)
+ `(GROUP ,(make-bit-string 8 0)
+ ,(syntax-evaluation data coerce-8-bit-signed)))
+
+(define-integrable (immediate-word data)
+ (syntax-evaluation data coerce-16-bit-signed))
+
+(define-integrable (immediate-long data)
+ (syntax-evaluation data coerce-32-bit-signed))
+
+(define-integrable (relative-word address)
+ (syntax-evaluation `(- ,address *PC*) coerce-16-bit-signed))
+
+(define-integrable (offset-word data)
+ (syntax-evaluation data coerce-16-bit-signed))
+
+(define-integrable (output-bit-string bit-string)
+ bit-string)
+\f
+;;;; Symbolic Constants
+
+;(declare (integrate symbol-member bwl? bw? wl? rl? us? da? cc? nwl? bwlq?))
+
+(define ((symbol-member list) expression)
+; (declare (integrate list expression))
+ (memq expression list))
+
+(define bwl? (symbol-member '(B W L)))
+(define bw? (symbol-member '(B W)))
+(define wl? (symbol-member '(W L)))
+(define rl? (symbol-member '(R L)))
+(define us? (symbol-member '(U S)))
+(define da? (symbol-member '(D A)))
+(define nwl? (symbol-member '(N W L)))
+(define bwlq? (symbol-member '(B W L Q)))
+
+(define cc?
+ (symbol-member
+ '(T F HI LS HS LO CC CS NE EQ VC VS PL MI GE LT GT LE)))
+
+;(declare (integrate symbol-mapping encode-bwl encode-blw encode-bw encode-wl
+; encode-lw encode-rl encode-us encode-da granularity
+; encode-cc encode-nwl encode-bwlq))
+
+(define ((symbol-mapping alist) expression)
+; (declare (integrate alist expression))
+ (cdr (assq expression alist)))
+
+(define encode-bwl (symbol-mapping '((B . 0) (W . 1) (L . 2))))
+(define encode-blw (symbol-mapping '((B . 1) (W . 3) (L . 2))))
+(define encode-bw (symbol-mapping '((B . 0) (W . 1))))
+(define encode-wl (symbol-mapping '((W . 0) (L . 1))))
+(define encode-lw (symbol-mapping '((W . 1) (L . 0))))
+(define encode-rl (symbol-mapping '((R . 0) (L . 1))))
+(define encode-us (symbol-mapping '((U . 0) (S . 1))))
+(define encode-da (symbol-mapping '((D . 0) (A . 1))))
+(define granularity (symbol-mapping '((B . 8) (W . 16) (L . 32))))
+(define encode-nwl (symbol-mapping '((N . 1) (W . 2) (L . 3))))
+(define encode-bwlq (symbol-mapping '((B . 0) (W . 1) (L . 2) (Q . 3))))
+
+(define encode-cc
+ (symbol-mapping
+ '((T . 0) (F . 1) (HI . 2) (LS . 3) (HS . 4) (LO . 5)
+ (CC . 4) (CS . 5) (NE . 6) (EQ . 7) (VC . 8) (VS . 9)
+ (PL . 10) (MI . 11) (GE . 12) (LT . 13) (GT . 14) (LE . 15))))
+\f
+(define (register-list? expression)
+ (eq?-subset? expression '(D0 D1 D2 D3 D4 D5 D6 D7 A0 A1 A2 A3 A4 A5 A6 A7)))
+
+(define ((encode-register-list encoding) registers)
+ (let ((bit-string (make-bit-string 16 #!FALSE)))
+ (for-each (lambda (register)
+ (bit-string-set! bit-string (cdr (assq register encoding))))
+ registers)
+ bit-string))
+
+(define encode-c@a+register-list
+ (encode-register-list
+ '((A7 . 0) (A6 . 1) (A5 . 2) (A4 . 3) (A3 . 4) (A2 . 5) (A1 . 6) (A0 . 7)
+ (D7 . 8) (D6 . 9) (D5 . 10) (D4 . 11) (D3 . 12) (D2 . 13)
+ (D1 . 14) (D0 . 15))))
+
+(define encode-@-aregister-list
+ (encode-register-list
+ '((D0 . 0) (D1 . 1) (D2 . 2) (D3 . 3) (D4 . 4) (D5 . 5) (D6 . 6) (D7 . 7)
+ (A0 . 8) (A1 . 9) (A2 . 10) (A3 . 11) (A4 . 12) (A5 . 13)
+ (A6 . 14) (A7 . 15))))
+
+(define-instruction DC
+ ((W (? expression))
+ (WORD (16 expression SIGNED))))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-syntaxer-package compiler-package)
+;;; Scheme Syntax Table: (access assembler-syntax-table compiler-package)
+;;; End:
+ (WORD (16 expression SIGNED))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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.
+;;;
+
+;;;; 68000 Instruction Set Description
+;;; Originally from GJS (who did the hard part).
+
+(declare (usual-integrations))
+(using-syntax (access assembler-syntax-table compiler-package)
+\f
+;;;; BCD Arithmetic
+
+(let-syntax ((define-BCD-addition
+ (macro (keyword opcode)
+ `(define-instruction ,keyword
+ (((D (? ry)) (D (? rx)))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (6 #b100000)
+ (3 ry)))
+
+ (((@-A (? ry)) (@-A (? rx)))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (6 #b100001)
+ (3 ry)))))))
+ (define-BCD-addition ABCD #b1100)
+ (define-BCD-addition SBCD #b1000))
+
+(define-instruction NBCD
+ ((? dea ea-d&a)
+ (WORD (10 #b0100100000)
+ (6 dea DESTINATION-EA))))
+\f
+;;;; Binary Arithmetic
+
+(let-syntax ((define-binary-addition
+ (macro (keyword Qkeyword Xkeyword opcode Qbit Iopcode)
+ `(BEGIN
+ (define-instruction ,Qkeyword
+ (((? s) (& (? data)) (? ea ea-all))
+ (QUALIFIER (bwl? s) (ea-a&<b=>-A> ea s))
+ (WORD (4 #b0101)
+ (3 data QUICK)
+ (1 ,Qbit)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA))))
+
+ (define-instruction ,keyword
+ (((? s) (& (? data)) (? ea ea-d&a)) ;ADDI
+ (QUALIFIER (bwl? s))
+ (WORD (4 #b0000)
+ (4 ,Iopcode)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA))
+ (immediate-words data s))
+
+ (((? s) (? ea ea-all) (D (? rx)))
+ (QUALIFIER (bwl? s) (ea-b=>-A ea s))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (1 #b0)
+ (2 (encode-bwl s))
+ (6 ea SOURCE-EA s)))
+
+ (((? s) (D (? rx)) (? ea ea-m&a))
+ (QUALIFIER (bwl? s))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (1 #b1)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA)))
+
+ (((? s) (? ea ea-all) (A (? rx))) ;ADDA
+ (QUALIFIER (wl? s))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (1 (encode-wl s))
+ (2 #b11)
+ (6 ea SOURCE-EA s))))
+
+ (define-instruction ,Xkeyword
+ (((? s) (D (? ry)) (D (? rx)))
+ (QUALIFIER (bwl? s))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (1 #b1)
+ (2 (encode-bwl s))
+ (3 #b000)
+ (3 ry)))
+
+ (((? s) (@-A (? ry)) (@-A (? rx)))
+ (QUALIFIER (bwl? s))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (1 #b1)
+ (2 (encode-bwl s))
+ (3 #b001)
+ (3 ry))))))))
+ (define-binary-addition ADD ADDQ ADDX #b1101 #b0 #b0110)
+ (define-binary-addition SUB SUBQ SUBX #b1001 #b1 #b0100))
+\f
+(define-instruction DIV
+ (((? sgn) (D (? rx)) (? ea ea-d))
+ (QUALIFIER (us? sgn))
+ (WORD (4 #b1000)
+ (3 rx)
+ (1 (encode-us sgn))
+ (2 #b11)
+ (6 ea SOURCE-EA 'W))))
+
+(define-instruction EXT
+ (((? s) (D (? rx)))
+ (QUALIFIER (wl? s))
+ (WORD (9 #b010010001)
+ (1 (encode-wl s))
+ (3 #b000)
+ (3 rx))))
+
+(define-instruction MUL
+ (((? sgn) (? ea ea-d) (D (? rx)))
+ (QUALIFIER (us? sgn))
+ (WORD (4 #b1100)
+ (3 rx)
+ (1 (encode-us sgn))
+ (2 #b11)
+ (6 ea SOURCE-EA 'W))))
+
+(define-instruction NEG
+ (((? s) (? dea ea-d&a))
+ (QUALIFIER (bwl? s))
+ (WORD (8 #b01000100)
+ (2 (encode-bwl s))
+ (6 dea DESTINATION-EA))))
+
+(define-instruction NEGX
+ (((? s) (? dea ea-d&a))
+ (QUALIFIER (bwl? s))
+ (WORD (8 #b01000000)
+ (2 (encode-bwl s))
+ (6 dea DESTINATION-EA))))
+\f
+;;;; Comparisons
+
+(define-instruction CMP
+ (((? s) (? ea ea-all) (D (? rx)))
+ (QUALIFIER (bwl? s) (ea-b=>-A ea s))
+ (WORD (4 #b1011)
+ (3 rx)
+ (1 #b0)
+ (2 (encode-bwl s))
+ (6 ea SOURCE-EA s)))
+
+ (((? s) (? ea ea-all) (A (? rx))) ;CMPA
+ (QUALIFIER (wl? s))
+ (WORD (4 #b1011)
+ (3 rx)
+ (1 (encode-wl s))
+ (2 #b11)
+ (6 ea SOURCE-EA s)))
+
+ (((? s) (& (? data)) (? ea ea-d&a)) ;CMPI
+ (QUALIFIER (bwl? s))
+ (WORD (8 #b00001100)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA))
+ (immediate-words data s))
+
+ (((? s) (@A+ (? ry)) (@A+ (? rx))) ;CMPM
+ (QUALIFIER (bwl? s))
+ (WORD (4 #b1011)
+ (3 rx)
+ (1 #b1)
+ (2 (encode-bwl s))
+ (3 #b001)
+ (3 ry))))
+
+(define-instruction TST
+ (((? s) (? dea ea-d&a))
+ (QUALIFIER (bwl? s))
+ (WORD (8 #b01001010)
+ (2 (encode-bwl s))
+ (6 dea DESTINATION-EA))))
+\f
+;;;; Bitwise Logical
+
+(let-syntax ((define-bitwise-logical
+ (macro (keyword opcode Iopcode)
+ `(define-instruction ,keyword
+ (((? s) (? ea ea-d) (D (? rx)))
+ (QUALIFIER (bwl? s))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (1 #b0)
+ (2 (encode-bwl s))
+ (6 ea SOURCE-EA s)))
+
+ (((? s) (D (? rx)) (? ea ea-m&a))
+ (QUALIFIER (bwl? s))
+ (WORD (4 ,opcode)
+ (3 rx)
+ (1 #b1)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA)))
+
+ (((? s) (& (? data)) (? ea ea-d&a)) ;fooI
+ (QUALIFIER (bwl? s))
+ (WORD (4 #b0000)
+ (4 ,Iopcode)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA))
+ (immediate-words data s))
+
+ (((? s) (& (? data)) (SR)) ;fooI to CCR/SR
+ (QUALIFIER (bw? s))
+ (WORD (4 #b0000)
+ (4 ,Iopcode)
+ (2 (encode-bwl s))
+ (6 #b111100))
+ (immediate-words data s))))))
+ (define-bitwise-logical AND #b1100 #b0010)
+ (define-bitwise-logical OR #b1000 #b0000))
+
+(define-instruction EOR
+ (((? s) (D (? rx)) (? ea ea-d&a))
+ (QUALIFIER (bwl? s))
+ (WORD (4 #b1011)
+ (3 rx)
+ (1 #b1)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA)))
+
+ (((? s) (& (? data)) (? ea ea-d&a)) ;EORI
+ (QUALIFIER (bwl? s))
+ (WORD (8 #b00001010)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA))
+ (immediate-words data s))
+
+ (((? s) (& (? data)) (SR)) ;EORI to CCR/SR
+ (QUALIFIER (bw? s))
+ (WORD (8 #b00001010)
+ (2 (encode-bwl s))
+ (6 #b111100))
+ (immediate-words data s)))
+
+(define-instruction NOT
+ (((? s) (? dea ea-d&a))
+ (QUALIFIER (bwl? s))
+ (WORD (8 #b01000110)
+ (2 (encode-bwl s))
+ (6 dea DESTINATION-EA))))
+\f
+;;;; Shift
+
+(let-syntax ((define-shift-instruction
+ (macro (keyword bits)
+ `(define-instruction ,keyword
+ (((? d) (? s) (D (? ry)) (D (? rx)))
+ (QUALIFIER (rl? d) (bwl? s))
+ (WORD (4 #b1110)
+ (3 rx)
+ (1 (encode-rl d))
+ (2 (encode-bwl s))
+ (1 #b1)
+ (2 ,bits)
+ (3 ry)))
+
+ (((? d) (? s) (& (? data)) (D (? ry)))
+ (QUALIFIER (rl? d) (bwl? s))
+ (WORD (4 #b1110)
+ (3 data SHIFT-NUMBER)
+ (1 (encode-rl d))
+ (2 (encode-bwl s))
+ (1 #b0)
+ (2 ,bits)
+ (3 ry)))
+
+ (((? d) (? ea ea-m&a))
+ (QUALIFIER (rl? d))
+ (WORD (5 #b11100)
+ (2 ,bits)
+ (1 (encode-rl d))
+ (2 #b11)
+ (6 ea DESTINATION-EA)))))))
+ (define-shift-instruction AS #b00)
+ (define-shift-instruction LS #b01)
+ (define-shift-instruction ROX #b10)
+ (define-shift-instruction RO #b11))
+\f
+;;;; Bit Manipulation
+
+(let-syntax ((define-bit-manipulation
+ (macro (keyword bits ea-register-target ea-immediate-target)
+ `(define-instruction ,keyword
+ (((D (? rx)) (? ea ,ea-register-target))
+ (WORD (4 #b0000)
+ (3 rx)
+ (1 #b1)
+ (2 ,bits)
+ (6 ea DESTINATION-EA)))
+
+ (((& (? bitnum)) (? ea ,ea-immediate-target))
+ (WORD (8 #b00001000)
+ (2 ,bits)
+ (6 ea DESTINATION-EA))
+ (immediate-byte bitnum))))))
+ (define-bit-manipulation BTST #b00 ea-d ea-d&-&)
+ (define-bit-manipulation BCHG #b01 ea-d&a ea-d&a)
+ (define-bit-manipulation BCLR #b10 ea-d&a ea-d&a)
+ (define-bit-manipulation BSET #b11 ea-d&a ea-d&a))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-syntaxer-package compiler-package)
+;;; Scheme Syntax Table: (access assembler-syntax-table compiler-package)
+;;; End:
+ (define-bit-manipulation BSET #b11 ea-d&a ea-d&a))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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.
+;;;
+
+;;;; 68000 Instruction Set Description
+;;; Originally from GJS (who did the hard part).
+
+(declare (usual-integrations))
+(using-syntax (access assembler-syntax-table compiler-package)
+\f
+;;;; Control Transfer
+
+(define-instruction B
+ (((? c) S (@PCO (? o)))
+ (QUALIFIER (cc? c))
+ (WORD (4 #b0110)
+ (4 (encode-cc c))
+ (8 o SIGNED)))
+
+ (((? c) S (@PCR (? l)))
+ (QUALIFIER (cc? c))
+ (WORD (4 #b0110)
+ (4 (encode-cc c))
+ (8 l SHORT-LABEL)))
+
+ (((? c) L (@PCO (? o)))
+ (QUALIFIER (cc? c))
+ (WORD (4 #b0110)
+ (4 (encode-cc c))
+ (8 #b00000000))
+ (immediate-word o))
+
+ (((? c) L (@PCR (? l)))
+ (QUALIFIER (cc? c))
+ (WORD (4 #b0110)
+ (4 (encode-cc c))
+ (8 #b00000000))
+ (relative-word l)))
+
+(define-instruction BRA
+ ((S (@PCO (? o)))
+ (WORD (8 #b01100000)
+ (8 o SIGNED)))
+
+ ((S (@PCR (? l)))
+ (WORD (8 #b01100000)
+ (8 l SHORT-LABEL)))
+
+ ((L (@PCO (? o)))
+ (WORD (16 #b0110000000000000))
+ (immediate-word o))
+
+ ((L (@PCR (? l)))
+ (WORD (16 #b0110000000000000))
+ (relative-word l)))
+
+(define-instruction BSR
+ ((S (@PCO (? o)))
+ (WORD (8 #b01100001)
+ (8 o SIGNED)))
+
+ ((S (@PCR (? o)))
+ (WORD (8 #b01100001)
+ (8 o SHORT-LABEL)))
+
+ ((L (@PCO (? o)))
+ (WORD (16 #b0110000100000000))
+ (immediate-word o))
+
+ ((L (@PCR (? l)))
+ (WORD (16 #b0110000100000000))
+ (relative-word l)))
+\f
+(define-instruction DB
+ (((? c) (D (? rx)) (@PCO (? o)))
+ (QUALIFIER (cc? c))
+ (WORD (4 #b0101)
+ (4 (encode-cc c))
+ (5 #b11001)
+ (3 rx))
+ (immediate-word o))
+
+ (((? c) (D (? rx)) (@PCR (? l)))
+ (QUALIFIER (cc? c))
+ (WORD (4 #b0101)
+ (4 (encode-cc c))
+ (5 #b11001)
+ (3 rx))
+ (relative-word l)))
+
+(define-instruction JMP
+ (((? ea ea-c))
+ (WORD (10 #b0100111011)
+ (6 ea DESTINATION-EA))))
+
+(define-instruction JSR
+ (((? ea ea-c))
+ (WORD (10 #b0100111010)
+ (6 ea DESTINATION-EA))))
+
+(define-instruction RTE
+ (()
+ (WORD (16 #b0100111001110011))))
+
+(define-instruction RTR
+ (()
+ (WORD (16 #b0100111001110111))))
+
+(define-instruction RTS
+ (()
+ (WORD (16 #b0100111001110101))))
+
+(define-instruction TRAP
+ (((& (? v)))
+ (WORD (12 #b010011100100)
+ (4 v))))
+
+(define-instruction TRAPV
+ (()
+ (WORD (16 #b0100111001110110))))
+\f
+;;;; Randomness
+
+(define-instruction CHK
+ (((? ea ea-d) (D (? rx)))
+ (WORD (4 #b0100)
+ (3 rx)
+ (3 #b110)
+ (6 ea SOURCE-EA 'W))))
+
+(define-instruction LINK
+ (((A (? rx)) (& (? d)))
+ (WORD (13 #b0100111001010)
+ (3 rx))
+ (immediate-word d)))
+
+(define-instruction NOP
+ (()
+ (WORD (16 #b0100111001110001))))
+
+(define-instruction RESET
+ (()
+ (WORD (16 #b0100111001110000))))
+
+(define-instruction STOP
+ (((& (? data)))
+ (WORD (16 #b0100111001110010))
+ (immediate-word data)))
+
+(define-instruction SWAP
+ (((D (? rx)))
+ (WORD (13 #b0100100001000)
+ (3 rx))))
+
+(define-instruction UNLK
+ (((A (? rx)))
+ (WORD (13 #b0100111001011)
+ (3 rx))))
+\f
+;;;; Data Transfer
+
+(define-instruction CLR
+ (((? s) (? ea ea-d&a))
+ (QUALIFIER (bwl? s))
+ (WORD (8 #b01000010)
+ (2 (encode-bwl s))
+ (6 ea DESTINATION-EA))))
+
+(define-instruction EXG
+ (((D (? rx)) (D (? ry)))
+ (WORD (4 #b1100)
+ (3 rx)
+ (6 #b101000)
+ (3 ry)))
+
+ (((A (? rx)) (A (? ry)))
+ (WORD (4 #b1100)
+ (3 rx)
+ (6 #b101001)
+ (3 ry)))
+
+ (((D (? rx)) (A (? ry)))
+ (WORD (4 #b1100)
+ (3 rx)
+ (6 #b110001)
+ (3 ry)))
+
+ (((A (? ry)) (D (? rx)))
+ (WORD (4 #b1100)
+ (3 rx)
+ (6 #b110001)
+ (3 ry))))
+
+(define-instruction LEA
+ (((? ea ea-c) (A (? rx)))
+ (WORD (4 #b0100)
+ (3 rx)
+ (3 #b111)
+ (6 ea DESTINATION-EA))))
+
+(define-instruction PEA
+ (((? cea ea-c))
+ (WORD (10 #b0100100001)
+ (6 cea DESTINATION-EA))))
+
+(define-instruction S
+ (((? c) (? dea ea-d&a))
+ (QUALIFIER (cc? c))
+ (WORD (4 #b0101)
+ (4 (encode-cc c))
+ (2 #b11)
+ (6 dea DESTINATION-EA))))
+
+(define-instruction TAS
+ (((? dea ea-d&a))
+ (WORD (10 #b0100101011)
+ (6 dea DESTINATION-EA))))
+\f
+(define-instruction MOVEQ
+ (((& (? data)) (D (? rx)))
+ (WORD (4 #b0111)
+ (3 rx)
+ (1 #b0)
+ (8 data SIGNED))))
+
+(define-instruction MOVE
+ (((? s) (? sea ea-all) (A (? rx))) ;MOVEA
+ (QUALIFIER (wl? s))
+ (WORD (3 #b001)
+ (1 (encode-lw s))
+ (3 rx)
+ (3 #b001)
+ (6 sea SOURCE-EA s)))
+
+ (((? s) (? sea ea-all) (? dea ea-d&a))
+ (QUALIFIER (bwl? s) (ea-b=>-A sea s))
+ (WORD (2 #b00)
+ (2 (encode-blw s))
+ (6 dea DESTINATION-EA-REVERSED)
+ (6 sea SOURCE-EA s)))
+
+ ((W (? ea ea-d) (CCR)) ;MOVE to CCR
+ (WORD (10 #b0100010011)
+ (6 ea SOURCE-EA 'W)))
+
+ ((W (? ea ea-d) (SR)) ;MOVE to SR
+ (WORD (10 #b0100011011)
+ (6 ea SOURCE-EA 'W)))
+
+ ((W (SR) (? ea ea-d&a)) ;MOVE from SR
+ (WORD (10 #b0100000011)
+ (6 ea DESTINATION-EA)))
+
+ ((L (USP) (A (? rx))) ;MOVE from USP
+ (WORD (13 #b0100111001101)
+ (3 rx)))
+
+ ((L (A (? rx)) (USP)) ;MOVE to USP
+ (WORD (13 #b0100111001100)
+ (3 rx))))
+\f
+(define-instruction MOVEM
+ (((? s) (? r) (? dea ea-c&a))
+ (QUALIFIER (wl? s) (register-list? r))
+ (WORD (9 #b010010001)
+ (1 (encode-wl s))
+ (6 dea DESTINATION-EA))
+ (output-bit-string (encode-c@a+register-list r)))
+
+ (((? s) (? r) (@-a (? rx)))
+ (QUALIFIER (wl? s) (register-list? r))
+ (WORD (9 #b010010001)
+ (1 (encode-wl s))
+ (3 #b100)
+ (3 rx))
+ (output-bit-string (encode-@-aregister-list r)))
+
+ (((? s) (? sea ea-c) (? r))
+ (QUALIFIER (wl? s) (register-list? r))
+ (WORD (9 #b010011001)
+ (1 (encode-wl s))
+ (6 sea SOURCE-EA s))
+ (output-bit-string (encode-c@a+register-list r)))
+
+ (((? s) (@A+ (? rx)) (? r))
+ (QUALIFIER (wl? s) (register-list? r))
+ (WORD (9 #b010011001)
+ (1 (encode-wl s))
+ (3 #b011)
+ (3 rx))
+ (output-bit-string (encode-c@a+register-list r))))
+\f
+(define-instruction MOVEP
+ (((? s) (D (? rx)) (@AO (? ry) (? o)))
+ (QUALIFIER (wl? s))
+ (WORD (4 #b0000)
+ (3 rx)
+ (2 #b11)
+ (1 (encode-wl s))
+ (3 #b001)
+ (3 ry))
+ (offset-word o))
+
+ (((? s) (D (? rx)) (@AR (? ry) (? l)))
+ (QUALIFIER (wl? s))
+ (WORD (4 #b0000)
+ (3 rx)
+ (2 #b11)
+ (1 (encode-wl s))
+ (3 #b001)
+ (3 ry))
+ (relative-word l))
+
+ (((? s) (@AO (? ry) (? o)) (D (? rx)))
+ (QUALIFIER (wl? s))
+ (WORD (4 #b0000)
+ (3 rx)
+ (2 #b10)
+ (1 (encode-wl s))
+ (3 #b001)
+ (3 ry))
+ (offset-word o))
+
+ (((? s) (@AR (? ry) (? l)) (D (? rx)))
+ (QUALIFIER (wl? s))
+ (WORD (4 #b0000)
+ (3 rx)
+ (2 #b10)
+ (1 (encode-wl s))
+ (3 #b001)
+ (3 ry))
+ (relative-word l)))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-syntaxer-package compiler-package)
+;;; Scheme Syntax Table: (access assembler-syntax-table compiler-package)
+;;; End:
+ (relative-word l)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 68020
+
+(declare (usual-integrations))
+(using-syntax (access lap-generator-syntax-table compiler-package)
+\f
+;;;; Basic machine instructions
+
+(define (register->register-transfer source target)
+ `(,(machine->machine-register source target)))
+
+(define (home->register-transfer source target)
+ `(,(pseudo->machine-register source target)))
+
+(define (register->home-transfer source target)
+ `(,(machine->pseudo-register source target)))
+
+(define-integrable (pseudo->machine-register source target)
+ (memory->machine-register (pseudo-register-home source) target))
+
+(define-integrable (machine->pseudo-register source target)
+ (machine-register->memory source (pseudo-register-home target)))
+
+(define-integrable (pseudo-register-home register)
+ (offset-reference regnum:regs-pointer
+ (+ #x000A (register-renumber register))))
+
+(define-integrable (machine->machine-register source target)
+ `(MOVE L ,(register-reference source) ,(register-reference target)))
+
+(define-integrable (machine-register->memory source target)
+ `(MOVE L ,(register-reference source) ,target))
+
+(define-integrable (memory->machine-register source target)
+ `(MOVE L ,source ,(register-reference target)))
+
+(define (offset-reference register offset)
+ (if (zero? offset)
+ (if (< register 8)
+ `(@D ,register)
+ `(@A ,(- register 8)))
+ (if (< register 8)
+ `(@DO ,register ,(* 4 offset))
+ `(@AO ,(- register 8) ,(* 4 offset)))))
+
+(define (load-dnw n d)
+ (cond ((zero? n) `(CLR W (D ,d)))
+ ((<= -128 n 127) `(MOVEQ (& ,n) (D ,d)))
+ (else `(MOVE W (& ,n) (D ,d)))))
+
+(define (test-dnw n d)
+ (if (zero? n)
+ `(TST W (D ,d))
+ `(CMP W (& ,n) (D ,d))))
+\f
+(define (increment-anl an n)
+ (case n
+ ((0) '())
+ ((1 2) `((ADDQ L (& ,(* 4 n)) (A ,an))))
+ ((-1 -2) `((SUBQ L (& ,(* -4 n)) (A ,an))))
+ (else `((LEA (@AO ,an ,(* 4 n)) (A ,an))))))
+
+(define (load-constant constant target)
+ (if (non-pointer-object? constant)
+ (load-non-pointer (primitive-type constant)
+ (primitive-datum constant)
+ target)
+ `(MOVE L (@PCR ,(constant->label constant)) ,target)))
+
+(define (load-non-pointer type datum target)
+ (cond ((not (zero? type))
+ `(MOVE L (& ,(make-non-pointer-literal type datum)) ,target))
+ ((and (zero? datum)
+ (memq (car target) '(D @D @A @A+ @-A @AO @DO @AOX W L)))
+ `(CLR L ,target))
+ ((and (<= -128 datum 127) (eq? (car target) 'D))
+ `(MOVEQ (& ,datum) ,target))
+ (else
+ `(MOVE L (& ,datum) ,target))))
+
+(define (test-type type expression)
+ (if (and (zero? type) (TSTable-expression? expression))
+ `(TST B ,expression)
+ `(CMP B (& ,type) ,expression)))
+
+(define (test-non-pointer type datum expression)
+ (if (and (zero? type) (zero? datum) (TSTable-expression? expression))
+ `(TST L ,expression)
+ `(CMP L (& ,(make-non-pointer-literal type datum)) ,expression)))
+
+(define make-non-pointer-literal
+ (let ((type-scale-factor (expt 2 24)))
+ (lambda (type datum)
+ (+ (* type type-scale-factor) datum))))
+
+(define (set-standard-branches! cc)
+ (set-current-branches! (lambda (label)
+ `((B ,cc L (@PCR ,label))))
+ (lambda (label)
+ `((B ,(invert-cc cc) L (@PCR ,label))))))
+\f
+(define (invert-cc cc)
+ (cdr (or (assq cc
+ '((T . F) (F . T)
+ (HI . LS) (LS . HI)
+ (HS . LO) (LO . HS)
+ (CC . CS) (CS . CC)
+ (NE . EQ) (EQ . NE)
+ (VC . VS) (VS . VC)
+ (PL . MI) (MI . PL)
+ (GE . LT) (LT . GE)
+ (GT . LE) (LE . GT)
+ ))
+ (error "INVERT-CC: Not a known CC" cc))))
+
+(define (expression->machine-register! expression register)
+ (let ((target (register-reference register)))
+ (let ((result
+ (case (car expression)
+ ((REGISTER) `((MOVE L ,(coerce->any (cadr expression)) ,target)))
+ ((OFFSET)
+ `((MOVE L ,(indirect-reference! (cadadr expression)
+ (caddr expression))
+ ,target)))
+ ((CONSTANT) `(,(load-constant (cadr expression) target)))
+ (else (error "Bad expression type" (car expression))))))
+ (delete-machine-register! register)
+ result)))
+
+(define-integrable (TSTable-expression? expression)
+ (memq (car expression) '(D @D @A @A+ @-A @DO @AO @AOX W L)))
+
+(define-integrable (register-expression? expression)
+ (memq (car expression) '(A D)))
+\f
+(define (indirect-reference! register offset)
+ (offset-reference (coerce->indirect-register! register) offset))
+
+(define (coerce->indirect-register! register)
+ (cond ((memv register '(13 14 15)) register)
+ ((and (pseudo-register? register)
+ (dead-register? register)
+ (let ((alias (register-alias register 'DATA)))
+ (and alias
+ (begin (prefix-instructions!
+ `((AND L ,mask-reference
+ ,(register-reference alias))))
+ alias)))))
+ (else
+ (with-temporary-register! 'DATA
+ (lambda (temp)
+ (prefix-instructions!
+ (let ((temp-ref (register-reference temp)))
+ `((MOVE L ,(coerce->any register) ,temp-ref)
+ (AND L ,mask-reference ,temp-ref))))
+ temp)))))
+
+(define (coerce->any register)
+ (if (machine-register? register)
+ (register-reference register)
+ (let ((alias (register-alias register false)))
+ (if alias
+ (register-reference alias)
+ (pseudo-register-home register)))))
+
+(define (code-object-label-initialize code-object)
+ false)
+
+(define (generate-n-times n limit instruction with-counter)
+ (if (<= n limit)
+ (let loop ((n n))
+ (if (zero? n)
+ '()
+ `(,instruction
+ ,@(loop (-1+ n)))))
+ (let ((loop (generate-label 'LOOP)))
+ (with-counter
+ (lambda (counter)
+ `(,(load-dnw (-1+ n) counter)
+ (LABEL ,loop)
+ ,instruction
+ (DB F (D ,counter) (@PCR ,loop))))))))
+\f
+;;;; Registers/Entries
+
+(let-syntax ((define-entries
+ (macro names
+ (define (loop names index)
+ (if (null? names)
+ '()
+ (cons `(DEFINE ,(symbol-append 'ENTRY:COMPILER-
+ (car names))
+ '(@AO 6 ,index))
+ (loop (cdr names) (+ index 6)))))
+ `(BEGIN ,@(loop names #x00F0)))))
+ (define-entries apply error wrong-number-of-arguments interrupt-procedure
+ interrupt-continuation lookup-apply lookup access unassigned? unbound?
+ set! define primitive-apply enclose setup-lexpr setup-ic-procedure))
+
+(define reg:temp '(@AO 6 #x0010))
+(define reg:enclose-result '(@AO 6 #x0014))
+(define reg:compiled-memtop '(@A 6))
+
+(define popper:apply-closure '(@AO 6 #x0168))
+(define popper:apply-stack '(@AO 6 #x01C8))
+(define popper:value '(@AO 6 #x0228))
+\f
+;;;; Transfers to Registers
+
+;;; All assignments to pseudo registers are required to delete the
+;;; dead registers BEFORE performing the assignment. This is because
+;;; the register being assigned may be PSEUDO-REGISTER=? to one of the
+;;; dead registers, and thus would be flushed if the deletions
+;;; happened after the assignment.
+
+(define-rule statement
+ (ASSIGN (REGISTER 15) (OFFSET-ADDRESS (REGISTER 15) (? n)))
+ (increment-anl 7 n))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+ (QUALIFIER (pseudo-register? target))
+ (let ((source (coerce->any source)))
+ (delete-dead-registers!)
+ (allocate-register-for-assignment! target false
+ (lambda (target)
+ `((MOVE L ,source ,(register-reference target)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
+ (QUALIFIER (pseudo-register? target))
+ (let ((address (coerce->indirect-register! address)))
+ (delete-dead-registers!)
+ ;; The fact that the target register here is a data register is a
+ ;; heuristic that works reasonably well since if the value is a
+ ;; pointer, we will probably want to dereference it, which
+ ;; requires that we first mask it.
+ (allocate-register-for-assignment! target 'DATA
+ (lambda (target)
+ `((MOVE L
+ ,(offset-reference address offset)
+ ,(register-reference target)))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
+ (let ((target* (coerce->any target))
+ (datum* (coerce->any datum)))
+ (if (pseudo-register? target)
+ (delete-dead-registers!))
+ (if (register-expression? target*)
+ `((MOVE L ,datum ,reg:temp)
+ (MOVE B (& ,type) ,reg:temp)
+ (MOVE L ,reg:temp ,target*))
+ `((MOVE L ,datum ,target*)
+ (MOVE B (& ,type) ,target*)))))
+\f
+;;;; Transfers to Memory
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+ (let ((target (indirect-reference! a n)))
+ `((MOVE L ,(coerce->any r) ,target)
+ (MOVE B (& ,type) ,target))))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (CONSTANT (? object)))
+ `(,(load-constant object (indirect-reference! a n))))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (REGISTER (? r)))
+ `((MOVE L ,(coerce->any r) ,(indirect-reference! a n))))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
+ (OFFSET (REGISTER (? a1)) (? n1)))
+ (let ((a1 (coerce->indirect-register! a1)))
+ `((MOVE L
+ ,(offset-reference a1 n1)
+ ,(offset-reference (coerce->indirect-register! a0) n0)))))
+\f
+;;;; Consing
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object)))
+ `(,(load-constant object '(@A+ 5))))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r)))
+ `((MOVE L ,(coerce->any r) (@A+ 5))))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (OFFSET (REGISTER (? r)) (? n)))
+ `((MOVE L ,(indirect-reference! r n) (@A+ 5))))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? procedure)))
+ (with-temporary-register! 'ADDRESS
+ (lambda (a)
+ (let ((a (register-reference a)))
+ `((LEA (@PCR ,(procedure-external-label procedure)) ,a)
+ (MOVE L ,a (@A+ 5))
+ (MOVE B (& ,type-code:return-address) (@AO 5 -4)))))))
+\f
+;;;; Pushes
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object)))
+ `(,(load-constant object '(@-A 7))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (UNASSIGNED))
+ `(,(load-non-pointer type-code:unassigned 0 '(@-A 7))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r)))
+ `((MOVE L ,(coerce->any r) (@-A 7))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
+ `((MOVE L ,(indirect-reference! r n) (@-A 7))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+ (OFFSET-ADDRESS (REGISTER 15) (? n)))
+ `((PEA ,(offset-reference a7 n))
+ (MOVE B (& ,type-code:stack-environment) (@A 7))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+ (ENTRY:CONTINUATION (? continuation)))
+ `((PEA (@PCR ,(continuation-label continuation)))
+ (MOVE B (& ,type-code:return-address) (@A 7))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+ `((MOVE L ,(coerce->any r) (@-A 7))
+ (MOVE B (& ,type) (@A 7))))
+\f
+;;;; Predicates
+
+(define-rule predicate
+ (TRUE-TEST (REGISTER (? register)))
+ (set-standard-branches! 'NE)
+ `(,(test-non-pointer (ucode-type false) 0 (coerce->any register))))
+
+(define-rule predicate
+ (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset)))
+ (set-standard-branches! 'NE)
+ `(,(test-non-pointer (ucode-type false) 0
+ (indirect-reference! register offset))))
+
+(define-rule predicate
+ (TRUE-TEST (TYPE-TEST (REGISTER (? register)) (? type)))
+ (set-standard-branches! 'EQ)
+ (let ((register (coerce->any register)))
+ (if (memq (car register) '(A D))
+ `((MOVE L ,register ,reg:temp)
+ ,(test-type type reg:temp))
+ `(,(test-type type register)))))
+
+(define-rule predicate
+ (TRUE-TEST (TYPE-TEST (OFFSET (REGISTER (? register)) (? offset)) (? type)))
+ (set-standard-branches! 'EQ)
+ `(,(test-type type (indirect-reference! register offset))))
+
+(define-rule predicate
+ (TRUE-TEST (UNASSIGNED-TEST (REGISTER (? register))))
+ (set-standard-branches! 'EQ)
+ `(,(test-non-pointer (ucode-type unassigned) 0 (coerce->any register))))
+
+(define-rule predicate
+ (TRUE-TEST (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset))))
+ (set-standard-branches! 'EQ)
+ `(,(test-non-pointer (ucode-type unassigned) 0
+ (indirect-reference! register offset))))
+\f
+;;;; Invocations
+
+(define-rule statement
+ (INVOCATION:APPLY (? number-pushed) (? prefix) (? continuation))
+ `(,@(generate-invocation-prefix prefix)
+ ,(load-dnw number-pushed 0)
+ (JMP ,entry:compiler-apply)))
+
+(define-rule statement
+ (INVOCATION:JUMP (? n)
+ (APPLY-CLOSURE (? frame-size) (? receiver-offset))
+ (? continuation) (? procedure))
+ `(,@(clear-map!)
+ ,@(apply-closure-sequence frame-size receiver-offset
+ (procedure-label procedure))))
+
+(define-rule statement
+ (INVOCATION:JUMP (? n)
+ (APPLY-STACK (? frame-size) (? receiver-offset)
+ (? n-levels))
+ (? continuation) (? procedure))
+ `(,@(clear-map!)
+ ,@(apply-stack-sequence frame-size receiver-offset n-levels
+ (procedure-label procedure))))
+
+(define-rule statement
+ (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? procedure))
+ (QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK))))
+ `(,@(generate-invocation-prefix prefix)
+ (BRA L (@PCR ,(procedure-label procedure)))))
+
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation)
+ (? procedure))
+ `(,@(generate-invocation-prefix prefix)
+ ,(load-dnw number-pushed 0)
+ (BRA L (@PCR ,(procedure-label procedure)))))
+\f
+(define-rule statement
+ (INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation)
+ (? environment) (? name))
+ (let ((set-environment (expression->machine-register! environment d4)))
+ (delete-dead-registers!)
+ `(,@set-environment
+ ,@(generate-invocation-prefix prefix)
+ ,(load-constant name '(D 5))
+ (MOVE W (& ,(1+ number-pushed)) (D 0))
+ (JMP ,entry:compiler-lookup-apply))))
+
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? number-pushed) (? prefix) (? continuation)
+ (? primitive))
+ `(,@(generate-invocation-prefix prefix)
+ ,@(if (eq? primitive compiled-error-procedure)
+ `(,(load-dnw (1+ number-pushed) 0)
+ (JMP ,entry:compiler-error))
+ `(,(load-dnw (primitive-datum primitive) 6)
+ (JMP ,entry:compiler-primitive-apply)))))
+
+(define-rule statement
+ (RETURN)
+ `(,@(clear-map!)
+ (CLR B (@A 7))
+ (RTS)))
+\f
+(define (generate-invocation-prefix prefix)
+ `(,@(clear-map!)
+ ,@(case (car prefix)
+ ((NULL) '())
+ ((MOVE-FRAME-UP)
+ (apply generate-invocation-prefix:move-frame-up (cdr prefix)))
+ ((APPLY-CLOSURE)
+ (apply generate-invocation-prefix:apply-closure (cdr prefix)))
+ ((APPLY-STACK)
+ (apply generate-invocation-prefix:apply-stack (cdr prefix)))
+ (else (error "GENERATE-INVOCATION-PREFIX: bad prefix type" prefix)))))
+
+(define (generate-invocation-prefix:move-frame-up frame-size how-far)
+ (cond ((or (zero? frame-size) (zero? how-far)) '())
+ ((= frame-size 1)
+ `((MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))))
+ ((= frame-size 2)
+ (if (= how-far 1)
+ `((MOVE L ,(offset-reference a7 1) ,(offset-reference a7 2))
+ (MOVE L (@A+ 7) (@A 7)))
+ (let ((i `(MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))))
+ `(,i ,i ,@(increment-anl 7 (- how-far 2))))))
+ (else
+ (with-temporary-register! 'ADDRESS
+ (lambda (a0)
+ ;; If we can guarantee that interrupts will not use the user
+ ;; stack, we can use A7 here rather than allocating this
+ ;; second temporary register.
+ (with-temporary-register! 'ADDRESS
+ (lambda (a1)
+ `((LEA ,(offset-reference a7 frame-size)
+ ,(register-reference a0))
+ (LEA ,(offset-reference a7 (+ frame-size how-far))
+ ,(register-reference a1))
+ ,@(generate-n-times frame-size 5
+ `(MOVE L
+ (@-A ,(- a0 8))
+ (@-A ,(- a1 8)))
+ (lambda (generator)
+ (with-temporary-register! 'DATA generator)))
+ (MOVE L ,(register-reference a1) (A 7))))))))))
+
+(define (generate-invocation-prefix:apply-closure frame-size receiver-offset)
+ (let ((label (generate-label)))
+ `(,@(apply-closure-sequence frame-size receiver-offset label)
+ (LABEL ,label))))
+
+(define (generate-invocation-prefix:apply-stack frame-size receiver-offset
+ n-levels)
+ (let ((label (generate-label)))
+ `(,@(apply-stack-sequence frame-size receiver-offset n-levels label)
+ (LABEL ,label))))
+\f
+;;;; Interpreter Calls
+
+(define-rule statement
+ (INTERPRETER-CALL:ACCESS (? environment) (? name))
+ (lookup-call entry:compiler-access environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? environment) (? name))
+ (lookup-call entry:compiler-lookup environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name))
+ (lookup-call entry:compiler-unassigned? environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (? environment) (? name))
+ (lookup-call entry:compiler-unbound? environment name))
+
+(define (lookup-call entry environment name)
+ (let ((set-environment (expression->machine-register! environment a0)))
+ `(,@set-environment
+ ,@(clear-map!)
+ ,(load-constant name '(A 1))
+ (JSR ,entry)
+ ,@(make-external-label (generate-label)))))
+
+(define-rule statement
+ (INTERPRETER-CALL:ENCLOSE (? number-pushed))
+ `((MOVE L (A 5) ,reg:enclose-result)
+ (MOVE B (& ,(ucode-type vector)) ,reg:enclose-result)
+ ,(load-non-pointer (ucode-type manifest-vector) number-pushed
+ '(@A+ 5))
+ ,@(generate-n-times number-pushed 5 '(MOVE L (@A+ 7) (@A+ 5))
+ (lambda (generator)
+ `(,@(clear-registers! d0)
+ ,@(generator 0)))))
+#| Alternate sequence which minimizes code size.
+ `(,@(clear-registers! a0 a1 d0)
+ (MOVE W (& ,number-pushed) (D 0))
+ (JSR ,entry:compiler-enclose))|#
+ )
+\f
+(define-rule statement
+ (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
+ (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
+ (assignment-call:default entry:compiler-define environment name value))
+
+(define-rule statement
+ (INTERPRETER-CALL:SET! (? environment) (? name) (? value))
+ (QUALIFIER (not (eq? 'CONS-POINTER (car value))))
+ (assignment-call:default entry:compiler-set! environment name value))
+
+(define (assignment-call:default entry environment name value)
+ (let ((set-environment (expression->machine-register! environment a0)))
+ (let ((set-value (expression->machine-register! value a2)))
+ `(,@set-environment
+ ,@set-value
+ ,@(clear-map!)
+ ,(load-constant name '(A 1))
+ (JSR ,entry)
+ ,@(make-external-label (generate-label))))))
+
+(define-rule statement
+ (INTERPRETER-CALL:DEFINE (? environment) (? name)
+ (CONS-POINTER (CONSTANT (? type))
+ (REGISTER (? datum))))
+ (assignment-call:cons-pointer entry:compiler-define environment name type
+ datum))
+
+(define-rule statement
+ (INTERPRETER-CALL:SET! (? environment) (? name)
+ (CONS-POINTER (CONSTANT (? type))
+ (REGISTER (? datum))))
+ (assignment-call:cons-pointer entry:compiler-set! environment name type
+ datum))
+
+(define (assignment-call:cons-pointer entry environment name type datum)
+ (let ((set-environment (expression->machine-register! environment a0)))
+ `(,@set-environment
+ (MOVE L ,(coerce->any datum) ,reg:temp)
+ (MOVE B (& ,type) ,reg:temp)
+ ,@(clear-map!)
+ (MOVE L ,reg:temp (A 2))
+ ,(load-constant name '(A 1))
+ (JSR ,entry)
+ ,@(make-external-label (generate-label)))))
+\f
+;;;; Procedure/Continuation Entries
+
+;;; 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.
+
+(define-rule statement
+ (PROCEDURE-HEAP-CHECK (? procedure))
+ (let ((gc-label (generate-label)))
+ `(,@(procedure-header procedure gc-label)
+ (CMP L ,reg:compiled-memtop (A 5))
+ (B GE S (@PCR ,gc-label)))))
+
+(define-rule statement
+ (SETUP-CLOSURE-LEXPR (? procedure))
+ (lexpr-header procedure 1))
+
+(define-rule statement
+ (SETUP-STACK-LEXPR (? procedure))
+ (lexpr-header procedure 0))
+
+;;; Note: do not change the MOVE.W in the setup-lexpr call to a MOVEQ.
+;;; The setup-lexpr code assumes a fixed calling sequence to compute
+;;; the GC address if that is needed.
+
+(define (lexpr-header procedure extra)
+ `(,@(procedure-header procedure false)
+ (MOVE W
+ (& ,(+ (length (procedure-required procedure))
+ (length (procedure-optional procedure))
+ extra))
+ (D 1))
+ (MOVEQ (& ,(if (procedure-rest procedure) 1 0)) (D 2))
+ (JSR , entry:compiler-setup-lexpr)))
+
+(define-rule statement
+ (CONTINUATION-HEAP-CHECK (? continuation))
+ (let ((gc-label (generate-label))
+ (internal-label (continuation-label continuation)))
+ `((LABEL ,gc-label)
+ (JSR ,entry:compiler-interrupt-continuation)
+ ,@(make-external-label internal-label)
+ (CMP L ,reg:compiled-memtop (A 5))
+ (B GE S (@PCR ,gc-label)))))
+\f
+(define (procedure-header procedure gc-label)
+ (let ((internal-label (procedure-label procedure)))
+ (append! (if (closure-procedure? procedure)
+ (let ((required (1+ (length (procedure-required procedure))))
+ (optional (length (procedure-optional procedure)))
+ (label (procedure-external-label procedure)))
+ (if (and (procedure-rest procedure)
+ (zero? required))
+ (begin (set-procedure-external-label! procedure
+ internal-label)
+ `((ENTRY-POINT ,internal-label)))
+ `((ENTRY-POINT ,label)
+ ,@(make-external-label label)
+ ,(test-dnw required 0)
+ ,@(cond ((procedure-rest procedure)
+ `((B GE S (@PCR ,internal-label))))
+ ((zero? optional)
+ `((B EQ S (@PCR ,internal-label))))
+ (else
+ (let ((wna-label (generate-label)))
+ `((B LT S (@PCR ,wna-label))
+ ,(test-dnw (+ required optional) 0)
+ (B LE S (@PCR ,internal-label))
+ (LABEL ,wna-label)))))
+ (JMP ,entry:compiler-wrong-number-of-arguments))))
+ '())
+ (if gc-label
+ `((LABEL ,gc-label)
+ (JSR ,entry:compiler-interrupt-procedure))
+ '())
+ `(,@(make-external-label internal-label)))))
+
+(define *block-start-label*)
+
+(define (make-external-label label)
+ `((DC W (- ,label ,*block-start-label*))
+ (LABEL ,label)))
+\f
+;;;; Poppers
+
+(define-rule statement
+ (MESSAGE-RECEIVER:CLOSURE (? frame-size))
+ `(;; Push (JSR (@AO 0 #x0000))
+ (MOVE L (& #x4EA80000) (@-A 7))
+ ;; Push (PEA (@PCO ,(+ 6 (* 4 frame-size))))
+ (MOVE L (& ,(+ #x487A0000 (+ 6 (* 4 frame-size)))) (@-A 7))))
+
+(define-rule statement
+ (MESSAGE-RECEIVER:STACK (? frame-size))
+ `(;; Push (JSR (@AO 0 #x0020))
+ (MOVE L (& #x4EA80020) (@-A 7))
+ ;; Push (DB F (D 0) (@PCO ,(+ 6 (* 4 frame-size))))
+ (MOVE L (& ,(+ #x51C80000 (+ 6 (* 4 frame-size)))) (@-A 7))))
+
+(define-rule statement
+ (MESSAGE-RECEIVER:SUBPROBLEM (? continuation))
+ `((PEA (@PCR ,(continuation-label continuation)))
+ (MOVE B (& ,type-code:return-address) (@A 7))
+ ;; Push (JSR (@AO 0 #x0040))
+ (MOVE L (& #x4EA80040) (@-A 7))))
+
+(define-rule statement
+ (MESSAGE-SENDER:VALUE (? receiver-offset))
+ `(,@(clear-map!)
+ (MOVEQ (& -1) (D 0))
+ (LEA ,popper:value (A 0))
+ (JMP (@AO 7 ,(* receiver-offset 4)))))
+
+(define (apply-closure-sequence frame-size receiver-offset label)
+ `((MOVEQ (& -1) (D 0))
+ ,(load-dnw frame-size 1)
+ (LEA ,popper:apply-closure (A 0))
+ (LEA (@PCR ,label) (A 1))
+ (JMP (@AO 7 ,(* receiver-offset 4)))))
+
+(define (apply-stack-sequence frame-size receiver-offset n-levels label)
+ `((MOVEQ (& ,n-levels) (D 0))
+ ,(load-dnw frame-size 1)
+ (LEA ,popper:apply-stack (A 0))
+ (LEA (@PCR ,label) (A 1))
+ (JMP (@AO 7 ,(* receiver-offset 4)))))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-generator-package compiler-package)
+;;; Scheme Syntax Table: (access lap-generator-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+(define popper:value '(@AO 6 #x01E8))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 68020
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f(define (rtl:message-receiver-size:closure) 2)
+(define (rtl:message-receiver-size:stack) 2)
+(define (rtl:message-receiver-size:subproblem) 2)
+
+(define-integrable (stack->memory-offset offset)
+ offset)
+
+(define (rtl:expression-cost expression)
+ ;; Returns an estimate of the cost of evaluating the expression.
+ ;; For simplicity, we try to estimate the actual number of cycles
+ ;; that a typical code sequence would produce.
+ (case (rtl:expression-type expression)
+ ((CONSTANT)
+ (let ((value (cadr expression)))
+ (cond ((false? value) 4) ;clr.l reg
+ ((or (eq? value true)
+ (char? value)
+ (and (integer? value)
+ (<= -#x80000000 value #x7FFFFFFF)))
+ 12) ;move.l #...,reg
+ (else 16)))) ;move.l d(pc),reg
+ ((CONS-POINTER)
+ ;; Best case = 12 cycles, worst = 44
+ ;; move.l reg,d(reg) = 16
+ ;; move.b reg,d(reg) = 12
+ ;; move.l d(reg),reg = 16
+ (+ 30
+ (rtl:expression-cost (rtl:cons-pointer-type expression))
+ (rtl:expression-cost (rtl:cons-pointer-datum expression))))
+ ;; move.l d(reg),reg = 16
+ ;; and.l d7,reg = 6
+ ((OBJECT->ADDRESS) 22)
+ ((OFFSET) 16) ;move.l d(reg),reg
+ ((OFFSET-ADDRESS) 8) ;lea d(an),reg
+ ((POST-INCREMENT) 12) ;move.l (reg)+,reg
+ ((PRE-INCREMENT) 14) ;move.l -(reg),reg
+ ((REGISTER) 4) ;move.l reg,reg
+ ((ENTRY:CONTINUATION ENTRY:PROCEDURE UNASSIGNED) 16) ;move.l d(pc),reg
+ ;; **** Random. Fix this later.
+ ((TYPE-TEST UNASSIGNED-TEST)
+ (+ 40 (rtl:expression-cost (rtl:test-expression expression))))
+ (else (error "Unknown expression type" expression))))
+\f
+(define (rtl:machine-register? rtl-register)
+ (case rtl-register
+ ((STACK-POINTER) (interpreter-stack-pointer))
+ ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access))
+ ((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
+ ((MEMORY_TOP) 0)
+ ((STACK_GUARD) 1)
+ ((VALUE) 2)
+ ((ENVIRONMENT) 3)
+ ((TEMPORARY) 4)
+ ((INTERPRETER-CALL-RESULT:ENCLOSE) 5)
+ (else false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+\f
+(define-integrable d0 0)
+(define-integrable d1 1)
+(define-integrable d2 2)
+(define-integrable d3 3)
+(define-integrable d4 4)
+(define-integrable d5 5)
+(define-integrable d6 6)
+(define-integrable d7 7)
+
+(define-integrable a0 8)
+(define-integrable a1 9)
+(define-integrable a2 10)
+(define-integrable a3 11)
+(define-integrable a4 12)
+(define-integrable a5 13)
+(define-integrable a6 14)
+(define-integrable a7 15)
+
+(define number-of-machine-registers 16)
+
+(define-integrable (sort-machine-registers registers)
+ registers)
+
+(define (pseudo-register=? x y)
+ (= (register-renumber x) (register-renumber y)))
+
+(define available-machine-registers
+ (list d0 d1 d2 d3 d4 d5 d6 a0 a1 a2 a3 a4))
+
+(define-integrable (register-contains-address? register)
+ (memv register '(13 14 15)))
+
+(define register-type
+ (let ((types (make-vector 16)))
+ (let loop ((i 0) (j 8))
+ (if (< i 8)
+ (begin (vector-set! types i 'DATA)
+ (vector-set! types j 'ADDRESS)
+ (loop (1+ i) (1+ j)))))
+ (lambda (register)
+ (vector-ref types register))))
+
+(define register-reference
+ (let ((references (make-vector 16)))
+ (let loop ((i 0) (j 8))
+ (if (< i 8)
+ (begin (vector-set! references i `(D ,i))
+ (vector-set! references j `(A ,i))
+ (loop (1+ i) (1+ j))))) (lambda (register)
+ (vector-ref references register))))
+
+(define mask-reference
+ '(D 7))
+\f
+(define regnum:free-pointer a5)
+(define regnum:regs-pointer a6)
+(define regnum:stack-pointer a7)
+
+(define-integrable (interpreter-register:access)
+ (rtl:make-machine-register d0))
+
+(define-integrable (interpreter-register:enclose)
+ (rtl:make-machine-register a0))
+
+(define-integrable (interpreter-register:lookup)
+ (rtl:make-machine-register d0))
+
+(define-integrable (interpreter-register:unassigned?)
+ (rtl:make-machine-register d0))
+
+(define-integrable (interpreter-register:unbound?)
+ (rtl:make-machine-register d0))
+
+(define-integrable (interpreter-free-pointer)
+ (rtl:make-machine-register regnum:free-pointer))
+
+(define-integrable (interpreter-free-pointer? register)
+ (= (rtl:register-number register) regnum:free-pointer))
+
+(define-integrable (interpreter-regs-pointer)
+ (rtl:make-machine-register regnum:regs-pointer))
+
+(define-integrable (interpreter-regs-pointer? register)
+ (= (rtl:register-number register) regnum:regs-pointer))
+
+(define-integrable (interpreter-stack-pointer)
+ (rtl:make-machine-register regnum:stack-pointer))
+
+(define-integrable (interpreter-stack-pointer? register)
+ (= (rtl:register-number register) regnum:stack-pointer))
+
+(define (lap:make-label-statement label)
+ `(LABEL ,label))
+
+(define (lap:make-unconditional-branch label)
+ `(BRA L (@PCR ,label)))
+
+(define (lap:make-entry-point label block-start-label)
+ `((ENTRY-POINT ,label)
+ (DC W (- ,label ,block-start-label))
+ (LABEL ,label)))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: compiler-package
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ (LABEL ,label)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 Make File for MC68020
+
+(declare (usual-integrations))
+\f
+(set-working-directory-pathname! "$zcomp")
+(load "load" system-global-environment)
+
+(load-system system-global-environment
+ 'COMPILER-PACKAGE
+ '(SYSTEM-GLOBAL-ENVIRONMENT)
+ '(
+ (SYSTEM-GLOBAL-ENVIRONMENT
+ "macros.bin.52" ;compiler syntax
+ "pbs.bin.1" ;bit-string read/write syntax
+ )
+
+ (COMPILER-PACKAGE
+ "mc68020/machin.bin.40" ;machine dependent stuff
+ "toplev.bin.86" ;top level
+ "utils.bin.69" ;odds and ends
+ "cfg.bin.136" ;control flow graph
+ "ctypes.bin.32" ;CFG datatypes
+ "dtypes.bin.83" ;DFG datatypes
+ "dfg.bin.54" ;data flow graph
+ "rtl.bin.106" ;register transfer language
+ "emodel.bin.93" ;environment model
+ "rtypes.bin.10" ;RTL analyzer datatypes
+ "nmatch.bin.11" ;simple pattern matcher
+ )
+
+ (CONVERTER-PACKAGE
+ "graphc.bin.107" ;SCode->flow-graph converter
+ )
+
+ (DATAFLOW-PACKAGE
+ "dflow.bin.99" ;Dataflow analyzer
+ )
+
+ (CALL-CONSTRUCTOR-PACKAGE
+ "calls.bin.73" ;Call-sequence constructor
+ )
+
+ (RTL-GENERATOR-PACKAGE
+ "cgen.bin.187" ;RTL generator
+ "linear.bin.72" ;linearization
+ )
+
+ (RTL-CSE-PACKAGE
+ "rcse.bin.91" ;RTL common subexpression eliminator
+ )
+
+ (RTL-ANALYZER-PACKAGE
+ "rlife.bin.49" ;RTL register lifetime analyzer
+ "ralloc.bin.7" ;RTL register allocator
+ )
+
+ (LAP-GENERATOR-PACKAGE
+ "lapgen.bin.17" ;LAP generator.
+ "regmap.bin.84" ;Hardware register allocator.
+ "mc68020/lapgen.bin.138" ;code generation rules.
+ )
+
+ (LAP-SYNTAXER-PACKAGE
+ "syntax.bin.12" ;Generic syntax phase
+ "mc68020/coerce.bin.6" ;Coercions: integer -> bit string
+ "asmmac.bin.1" ;Macros for hairy syntax
+ "mc68020/insmac.bin.117" ;Macros for hairy syntax
+ "mc68020/instr1.bin.58" ;68000 Effective addressing
+ "mc68020/instr2.bin.8" ;68000 Instructions
+ "mc68020/instr3.bin.8" ; " "
+ )
+
+ (LAP-PACKAGE
+ "mc68020/assmd.bin.28" ;Machine dependent
+ "symtab.bin.36" ;Symbol tables
+ "block.bin.19" ;Assembly blocks
+ "laptop.bin.90" ;Assembler top level
+ )
+
+ ))
+
+(in-package compiler-package
+ (define compiler-system
+ (make-environment
+ (define :name "Liar (Bobcat 68020)")
+ (define :version 3)
+ (define :modification 0)))
+ (add-system! compiler-system))
+
+(%ge compiler-package)
+(%gst (access compiler-syntax-table compiler-package))
+(%gst (access compiler-syntax-table compiler-package))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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
+(define addressing-granularity 8)
+(define scheme-object-width 32)
+
+(define make-nmv-header)
+(let ()
+
+(set! make-nmv-header
+(named-lambda (make-nmv-header n)
+ (bit-string-append (unsigned-integer->bit-string 24 n)
+ nmv-type-string)))
+
+(define nmv-type-string
+ (unsigned-integer->bit-string 8 (microcode-type 'MANIFEST-NM-VECTOR)))
+
+)
+
+(define (object->bit-string object)
+ (bit-string-append
+ (unsigned-integer->bit-string 24 (primitive-datum object))
+ (unsigned-integer->bit-string 8 (primitive-type object))))
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-package compiler-package)
+;;; End:
+ (unsigned-integer->bit-string 8 (primitive-type object))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 Specific Coercions
+
+(declare (usual-integrations))
+\f
+(define (parse-word expression tail)
+ (expand-descriptors (cdr expression)
+ (lambda (instruction size)
+ (if (not (zero? (remainder size 32)))
+ (error "PARSE-WORD: Instructions must be 32 bit multiples" size))
+ (let ((instruction (apply optimize-group-syntax instruction)))
+ (if (null? tail)
+ `(CONS ,instruction '())
+ `(CONS-SYNTAX ,instruction (CONS ,(car tail) '())))))))
+
+(define (expand-descriptors descriptors receiver)
+ (if (null? descriptors)
+ (receiver '() 0)
+ (expand-descriptors (cdr descriptors)
+ (lambda (instruction* size*)
+ (expand-descriptor (car descriptors)
+ (lambda (instruction size)
+ (receiver (append! instruction instruction*)
+ (+ size size*))))))))
+
+(define (expand-descriptor descriptor receiver)
+ (let ((size (car descriptor)))
+ (receiver `(,(integer-syntaxer (cadr descriptor)
+ (if (null? (cddr descriptor))
+ 'UNSIGNED
+ (caddr descriptor))
+ size))
+ size)))
+\f
+(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-assemble3:x
+ (standard-coercion
+ (lambda (n)
+ (+ (* (land n 3) 2) (quotient n 4)))))
+
+(define coerce-assemble12:X
+ (standard-coercion
+ (lambda (n)
+ (let ((qr (integer-divide n 4)))
+ (if (not (zero? (integer-divide-remainder qr)))
+ (error "COERCE-ASSEMBLE12:X: offset not multiple of 4" n))
+ (let ((n (integer-divide-quotient qr)))
+ (+ (* (land n #x3FF) 2) (quotient (land n #x400) #x400)))))))
+
+(define coerce-assemble12:Y
+ (standard-coercion
+ (lambda (n)
+ (quotient (land (quotient n 4) #x800) #x800))))
+
+(define coerce-assemble17:X
+ (standard-coercion
+ (lambda (n)
+ (let ((qr (integer-divide n 4)))
+ (if (not (zero? (integer-divide-remainder qr)))
+ (error "COERCE-ASSEMBLE17:X: offset not multiple of 4" n))
+ (quotient (land (integer-divide-quotient qr) #xF800) #x800)))))
+
+(define coerce-assemble17:Y
+ (standard-coercion
+ (lambda (n)
+ (let ((n (quotient n 4)))
+ (+ (quotient (land n #x400) #x400) (* (land n #x3FF) 2))))))
+
+(define coerce-assemble17:Z
+ (standard-coercion
+ (lambda (n)
+ (+ (quotient (land (quotient n 4) #x10000) #x10000)))))
+
+(define coerce-assemble21:X
+ (standard-coercion
+ (lambda (n)
+ (+ (* (land n #x7C) #x4000)
+ (* (land n #x180) #x80)
+ (* (land n #x3) #x1000)
+ (quotient (land n #xFFE00) #x100)
+ (quotient (land n #x100000) #x100000)))))
+\f
+(define make-coercion
+ (coercion-maker
+ `((ASSEMBLE3:X . ,coerce-assemble3:x)
+ (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-coercion 'UNSIGNED 1)
+(define-coercion 'UNSIGNED 2)
+(define-coercion 'UNSIGNED 3)
+(define-coercion 'UNSIGNED 4)
+(define-coercion 'UNSIGNED 5)
+(define-coercion 'UNSIGNED 6)
+(define-coercion 'UNSIGNED 7)
+(define-coercion 'UNSIGNED 8)
+(define-coercion 'UNSIGNED 9)
+(define-coercion 'UNSIGNED 10)
+(define-coercion 'UNSIGNED 11)
+(define-coercion 'UNSIGNED 12)
+(define-coercion 'UNSIGNED 13)
+(define-coercion 'UNSIGNED 14)
+(define-coercion 'UNSIGNED 16)
+(define-coercion 'UNSIGNED 32)
+
+(define-coercion 'SIGNED 8)
+(define-coercion 'SIGNED 16)
+(define-coercion 'SIGNED 32)
+
+(define-coercion 'RIGHT-SIGNED 5)
+(define-coercion 'RIGHT-SIGNED 11)
+(define-coercion 'RIGHT-SIGNED 14)
+(define-coercion 'ASSEMBLE3:X 3)
+(define-coercion 'ASSEMBLE12:X 11)
+(define-coercion 'ASSEMBLE12:Y 1)
+(define-coercion 'ASSEMBLE17:X 5)
+(define-coercion 'ASSEMBLE17:Y 11)
+(define-coercion 'ASSEMBLE17:Z 1)
+(define-coercion 'ASSEMBLE21:X 21)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-syntaxer-package compiler-package)
+;;; End:
+(define-coercion 'ASSEMBLE21:X 21)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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 Spectrum
+
+(declare (usual-integrations))
+(using-syntax (access lap-generator-syntax-table compiler-package)
+\f
+;;;; Interface to Allocator
+
+(define (register->register-transfer source destination)
+ `(,(machine->machine-register source destination)))
+
+(define (home->register-transfer source destination)
+ `(,(pseudo->machine-register source destination)))
+
+(define (register->home-transfer source destination)
+ `(,(machine->pseudo-register source destination)))
+
+(define-integrable (pseudo->machine-register source target)
+ (memory->machine-register (pseudo-register-home source) target))
+
+(define-integrable (machine->pseudo-register source target)
+ (machine-register->memory source (pseudo-register-home target)))
+
+(define-integrable (pseudo-register-home register)
+ (index-reference regnum:regs-pointer
+ (+ #x000A (register-renumber register))))
+\f
+;;;; Basic machine instructions
+
+(define-integrable (machine->machine-register source target)
+ `(OR () ,source 0 ,target))
+
+(define-integrable (machine-register->memory source target)
+ `(STW () ,source ,target))
+
+(define-integrable (machine-register->memory-post-increment source target)
+ ;; Used for heap allocation
+ `(STWM () ,source ,(index-reference target 1)))
+
+(define-integrable (machine-register->memory-pre-decrement source target)
+ ;; Used for stack push
+ `(STWM () ,source ,(index-reference target -1)))
+
+(define-integrable (memory->machine-register source target)
+ `(LDW () ,source ,target))
+
+(define-integrable (memory-post-increment->machine-register source target)
+ ;; Used for stack pop
+ `(LDWM () ,(index-reference source 1) ,target))
+
+(define-integrable (invoke-entry entry)
+ `(BE (N) ,entry))
+
+(define (assign&invoke-entry number target entry)
+ (if (<= -8192 number 8191)
+ `((BE () ,entry)
+ (LDI () ,number ,target))
+ `((LDIL () (LEFT ,number) ,target)
+ (BE () ,entry)
+ (LDO () (OFFSET (RIGHT ,number) ,target) ,target))))
+
+(define (branch->label label)
+ `(BL (N) ,(label-relative-expression label) 0))
+
+(define-integrable (index-reference register offset)
+ `(INDEX ,(* 4 offset) 0 ,(register-reference register)))
+
+(define-integrable (offset-reference register offset)
+ `(OFFSET ,(* 4 offset) ,(register-reference register)))
+
+(define-integrable (short-offset? offset)
+ (< offset 2048))
+\f
+;;;; Instruction Sequence Generators
+
+(define (indirect-reference! register offset)
+ (index-reference (coerce->indirect-register! register) offset))
+
+(define (coerce->indirect-register! register)
+ (if (stripped-register? register)
+ register
+ (with-temporary-register! false
+ (lambda (temp0)
+ (prefix-instructions!
+ (let ((simple-case
+ (lambda (register)
+ (object->address register temp0))))
+ (if (machine-register? register)
+ (simple-case register)
+ (let ((alias (register-alias register false)))
+ (if alias
+ (simple-case alias)
+ `(,(pseudo->machine-register register r1)
+ ,(machine->machine-register
+ regnum:address-offset
+ temp0)
+ (DEP () ,r1 31 24 ,temp0)))))))
+ temp0))))
+
+(define (object->address source #!optional target)
+ (if (unassigned? target) (set! target source))
+ `((EXTRU () ,source 31 24 ,target)
+ (OR () ,regnum:address-offset ,target ,target)))
+
+(define (register->machine-register register target)
+ (if (machine-register? register)
+ (machine->machine-register register target)
+ (let ((alias (register-alias register false)))
+ (if alias
+ (machine->machine-register alias target)
+ (pseudo->machine-register register target)))))
+
+(package (register->memory
+ register->memory-post-increment
+ register->memory-pre-decrement)
+ (define ((->memory machine-register->memory) register target)
+ (guarantee-machine-register! register false
+ (lambda (alias)
+ `(,(machine-register->memory alias target)))))
+ (define-export register->memory
+ (->memory machine-register->memory))
+ (define-export register->memory-post-increment
+ (->memory machine-register->memory-post-increment))
+ (define-export register->memory-pre-decrement
+ (->memory machine-register->memory-pre-decrement)))
+\f
+(package (memory->memory
+ memory->memory-post-increment
+ memory->memory-pre-decrement)
+ (define ((->memory machine-register->memory) source target)
+ `(,(memory->machine-register source r1)
+ ,(machine-register->memory r1 target)))
+ (define-export memory->memory
+ (->memory machine-register->memory))
+ (define-export memory->memory-post-increment
+ (->memory machine-register->memory-post-increment))
+ (define-export memory->memory-pre-decrement
+ (->memory machine-register->memory-pre-decrement)))
+
+(package (scheme-constant->memory
+ scheme-constant->memory-post-increment
+ scheme-constant->memory-pre-decrement)
+ (define ((->memory machine-register->memory) constant target)
+ `(,@(scheme-constant->machine-register constant r1)
+ ,(machine-register->memory r1 target)))
+ (define-export scheme-constant->memory
+ (->memory machine-register->memory))
+ (define-export scheme-constant->memory-post-increment
+ (->memory machine-register->memory-post-increment))
+ (define-export scheme-constant->memory-pre-decrement
+ (->memory machine-register->memory-pre-decrement)))
+
+(define (scheme-constant->machine-register constant target)
+ (if (non-pointer-object? constant)
+ (non-pointer->machine-register (primitive-type constant)
+ (primitive-datum constant)
+ target)
+ `(,(memory->machine-register (scheme-constant-reference constant)
+ target))))
+
+(define-integrable (scheme-constant-reference constant)
+ `(INDEX (label->machine-constant (scheme-constant-label constant)) 0
+ ,regnum:code-object-base))
+
+(define (non-pointer->machine-register type datum target)
+ (if (and (zero? datum)
+ (deposit-type-constant? type))
+ (if (zero? type)
+ `((OR () 0 0 ,target))
+ (with-type-deposit-parameters type
+ (lambda (const end)
+ `((ZDEPI () ,const ,end 8 ,target)))))
+ (let ((number (make-non-pointer type datum)))
+ (if (<= -8192 number 8191)
+ `((LDI () ,number ,target))
+ (long-machine-constant->machine-register number target)))))
+\f
+(define (machine-constant->machine-register constant target)
+ (non-pointer->machine-register (machine-constant->type constant)
+ (machine-constant->datum constant)
+ target))
+
+(define (long-machine-constant->machine-register number target)
+ `((LDIL () (LEFT ,number) ,target)
+ (LDO () (OFFSET (RIGHT ,number) ,target) ,target)))
+
+(define (label->machine-register type label target)
+ (let ((constant (label->machine-constant label)))
+ `((ADDIL () (LEFT ,constant) ,regnum:code-object-base)
+ (LDO () (OFFSET (RIGHT ,constant) ,r1) ,target)
+ ,@(cons-pointer->machine-register type target target))))
+
+(define-integrable (label->machine-constant label)
+ `(- ,label ,(code-object-base)))
+
+(package (label->memory-post-increment
+ label->memory-pre-decrement)
+ (define ((label->memory machine-register->memory) type label target)
+ (with-temporary-register! false
+ (lambda (temp)
+ `(,@(label->machine-register type label temp)
+ ,(machine-register->memory temp target)))))
+ (define-export label->memory-post-increment
+ (label->memory machine-register->memory-post-increment))
+ (define-export label->memory-pre-decrement
+ (label->memory machine-register->memory-pre-decrement)))
+
+(define (cons-pointer->machine-register type source target)
+ (guarantee-machine-register! source false
+ (lambda (source)
+ (if (eqv? source target)
+ (with-temporary-register! false
+ (lambda (temp)
+ `(,@(cons-pointer->machine-register type source temp)
+ ,(machine->machine-register temp source))))
+ `(,@(if (deposit-type-constant? type)
+ (with-type-deposit-parameters type
+ (lambda (type end)
+ `((ZDEPI () ,type ,end 8 ,target))))
+ `((LDI () ,type ,target)
+ (ZDEP () ,target 7 8 ,target)))
+ (DEP () ,source 31 24 ,target))))))
+
+(package (cons-pointer->memory
+ cons-pointer->memory-post-increment
+ cons-pointer->memory-pre-decrement)
+ (define ((->memory machine-register->memory) type source target)
+ (with-temporary-register! false
+ (lambda (temp)
+ `(,@(cons-pointer->machine-register type source temp)
+ ,(machine-register->memory temp target)))))
+ (define cons-pointer->memory
+ (->memory machine-register->memory))
+ (define cons-pointer->memory-post-increment
+ (->memory machine-register->memory-post-increment))
+ (define cons-pointer->memory-pre-decrement
+ (->memory machine-register->memory-pre-decrement)))
+\f
+(define (test:machine/machine-register condition source0 source1 receiver)
+ (let ((make-branch
+ (lambda (completer)
+ (lambda (label)
+ `((COMB (,completer N) ,source0 ,source1
+ ,(label-relative-expression label)))))))
+ (receiver '()
+ (make-branch condition)
+ (make-branch (invert-test-completer condition)))))
+
+(define (test:short-machine-constant/machine-register condition constant source
+ receiver)
+ (let ((make-branch
+ (lambda (completer)
+ (lambda (label)
+ `((COMIB (,completer N) ,constant ,source
+ ,(label-relative-expression label)))))))
+ (receiver '()
+ (make-branch condition)
+ (make-branch (invert-test-completer condition)))))
+
+(define (invert-test-completer completer)
+ (cdr (or (assq completer
+ '((EQ . LTGT) (LTGT . EQ)
+ (LT . GTEQ) (GTEQ . LT)
+ (GT . LTEQ) (GT . LTEQ)
+ (LTLT . GTGTEQ) (GTGTEQ . LTLT)
+ (GTGT . LTLTEQ) (GTGT . LTLTEQ)
+ ))
+ (error "Unknown test completer" completer))))
+
+(define (test:machine-constant/machine-register condition constant source
+ receiver)
+ (cond ((zero? constant)
+ (test:machine/machine-register condition 0 source receiver))
+ ((test-short-constant? constant)
+ (test:short-machine-constant/machine-register condition constant
+ source receiver))
+ (else
+ `(,@(non-pointer->machine-register 0 constant r1)
+ ,@(test:machine/machine-register condition r1 source receiver)))))
+
+(define (test:machine-constant/register condition constant source receiver)
+ (guarantee-machine-register! source false
+ (lambda (alias)
+ (test:machine-constant/machine-register condition constant alias
+ receiver))))
+
+(define (test:machine-constant/memory condition constant source receiver)
+ (with-temporary-register! false
+ (lambda (temp)
+ `(,(memory->machine-register source temp)
+ ,@(test:machine-constant/machine-register condition constant temp
+ receiver)))))
+\f
+(define (test:type/machine-register condition type source receiver)
+ (with-temporary-register! false
+ (lambda (temp)
+ `(,(extract-type-machine->machine-register source temp)
+ ,@(test:machine-constant/machine-register condition type temp
+ receiver)))))
+
+(define (test:type/register condition type source receiver)
+ (guarantee-machine-register! source false
+ (lambda (alias)
+ (test:type/machine-register condition type alias receiver))))
+
+(define (test:type/memory condition type source receiver)
+ (with-temporary-register! false
+ (lambda (temp)
+ `(,(memory->machine-register source temp)
+ ,@(cond ((zero? type)
+ (test:machine/machine-register condition 0 temp receiver))
+ ((test-short-constant? type)
+ `(,(extract-type-machine->machine-register temp temp)
+ ,@(test:short-machine-constant/machine-register condition
+ type
+ temp
+ receiver)))
+ (else
+ `(,@(non-pointer->machine-register 0 type r1)
+ ,(extract-type-machine->machine-register temp temp)
+ ,@(test:machine/machine-register condition r1 temp
+ receiver))))))))
+
+(define (standard-predicate-receiver prefix consequent alternative)
+ (set-current-branches! consequent alternative)
+ prefix)
+
+(define ((inline-predicate-receiver label) prefix consequent alternative)
+ `(,@prefix ,@(consequent label)))
+
+(define-integrable (extract-type-machine->machine-register source target)
+ `(EXTRU () ,source 7 8 ,target))
+
+(define-integrable (test-short-constant? constant)
+ (<= -16 constant 15))
+\f
+(define (deposit-type-constant? n)
+ ;; Assume that (<= 0 n 127).
+ (or (< n 16)
+ (zero? (remainder n
+ (cond ((< n 32) 2)
+ ((< n 64) 4)
+ (else 8))))))
+
+(define (with-type-deposit-parameters type receiver)
+ ;; This one is for type codes, assume that (<= 0 n 127).
+ (cond ((< type 16) (receiver type 7))
+ ((< type 32) (receiver (quotient type 2) 6))
+ ((< type 64) (receiver (quotient type 4) 5))
+ (else (receiver (quotient type 8) 4))))
+
+(define (code-object-label-initialize code-object)
+ (cond ((procedure? code-object) false)
+ ((continuation? code-object) (continuation-label code-object))
+ ((quotation? code-object) (quotation-label code-object))
+ (else
+ (error "CODE-OBJECT-LABEL-INITIALIZE: Unknown code object type"
+ code-object))))
+
+(define (code-object-base)
+ ;; This will fail if the difference between the beginning of the
+ ;; code-object and LABEL is greater than 11 bits (signed).
+ (or *code-object-label*
+ (let ((label (generate-label)))
+ (prefix-instructions!
+ `((BL () 0 ,regnum:code-object-base)
+ (LABEL ,label)))
+ (let ((label `(+ ,label 4)))
+ (set! *code-object-label* label)
+ label))))
+
+(define (generate-n-times n limit prefix suffix with-counter)
+ (if (<= n limit)
+ (let loop ((n n))
+ (if (zero? n)
+ '()
+ `(,@prefix
+ ,suffix
+ ,@(loop (-1+ n)))))
+ (let ((loop (generate-label 'LOOP)))
+ (with-counter
+ (lambda (counter)
+ `(,@(machine-constant->machine-register (-1+ n) counter)
+ (LABEL ,loop)
+ ,@prefix
+ (ADDIBF (EQ) -1 ,counter ,(label-relative-expression loop))
+ ,suffix))))))
+
+(define-integrable (label-relative-expression label)
+ `(- (- ,label *PC*) 8))
+\f
+;;;; Registers/Entries
+
+(let-syntax ((define-entries
+ (macro names
+ (define (loop names index)
+ (if (null? names)
+ '()
+ (cons `(DEFINE ,(symbol-append 'ENTRY:COMPILER-
+ (car names))
+ `(INDEX ,,index 5 ,regnum:regs-pointer))
+ (loop (cdr names) (+ index 8)))))
+ `(BEGIN ,@(loop names #x00F0)))))
+ (define-entries apply error wrong-number-of-arguments interrupt-procedure
+ interrupt-continuation lookup-apply lookup access unassigned? unbound?
+ set! define primitive-apply enclose setup-lexpr setup-ic-procedure))
+
+(define reg:temp `(INDEX #x0010 0 ,regnum:regs-pointer))
+(define reg:enclose-result `(INDEX #x0014 0 ,regnum:regs-pointer))
+(define reg:compiled-memtop `(INDEX 0 0 ,regnum:regs-pointer))
+
+;(define popper:apply-closure '(INDEX ??? 0 ,regnum:regs-pointer))
+;(define popper:apply-stack '(INDEX ??? 0 ,regnum:regs-pointer))
+;(define popper:value '(INDEX ??? 0 ,regnum:regs-pointer))
+
+(package (type->machine-constant
+ make-non-pointer
+ machine-constant->type
+ machine-constant->datum)
+ (define type-scale-factor
+ (expt 2 24))
+ (define-export (type->machine-constant type)
+ (* type type-scale-factor))
+ (define-export (make-non-pointer type datum)
+ (+ (* type type-scale-factor) datum))
+ (define-export (machine-constant->type constant)
+ (quotient constant type-scale-factor))
+ (define-export (machine-constant->datum constant)
+ (remainder constant type-scale-factor)))
+
+(define constant:compiled-expression
+ (type->machine-constant (ucode-type compiled-expression)))
+
+(define constant:return-address
+ (type->machine-constant (ucode-type return-address)))
+
+(define constant:unassigned
+ (make-non-pointer (ucode-type unassigned) 0))
+
+(define constant:false
+ (make-non-pointer (ucode-type false) 0))
+\f
+;;;; Transfers to Registers
+
+(define-rule statement
+ (ASSIGN (REGISTER 30) (OFFSET-ADDRESS (REGISTER 30) (? n)))
+ `((LDO () ,(offset-reference regnum:stack-pointer n) ,r30)))
+
+;;; All assignments to pseudo registers are required to delete the
+;;; dead registers BEFORE performing the assignment. This is because
+;;; the register being assigned may be PSEUDO-REGISTER=? to one of the
+;;; dead registers, and thus would be flushed if the deletions
+;;; happened after the assignment.
+
+(define-rule statement
+ (ASSIGN (REGISTER (? p)) (OFFSET (REGISTER (? a0)) (? n)))
+ (QUALIFIER (and (pseudo-register? p) (short-offset? n)))
+ (let ((ir (indirect-reference! a0 n)))
+ (delete-dead-registers!)
+ (allocate-register-for-assignment! p false
+ (lambda (target)
+ `(,(memory->machine-register ir target))))))
+\f
+;;;; Transfers to Memory
+
+(define-rule statement
+ ;; The code assumes r cannot be trashed
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+ (QUALIFIER (short-offset? n))
+ (cons-pointer->memory type r (indirect-reference! a n)))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (CONSTANT (? object)))
+ (QUALIFIER (short-offset? n))
+ (scheme-constant->memory object (indirect-reference! a n)))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (REGISTER (? r)))
+ (QUALIFIER (short-offset? n))
+ (register->memory r (indirect-reference! a n)))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? r-target)) (? n-target))
+ (OFFSET (REGISTER (? r-source)) (? n-source)))
+ (QUALIFIER (and (short-offset? n-target) (short-offset? n-source)))
+ (memory->memory (indirect-reference! r-source n-source)
+ (indirect-reference! r-target n-target)))
+\f
+;;;; Consing
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (CONSTANT (? object)))
+ (scheme-constant->memory-post-increment object r25))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (REGISTER (? r)))
+ (register->memory-post-increment r r25))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (OFFSET (REGISTER (? r)) (? n)))
+ (memory->memory-post-increment (indirect-reference! r n) r25))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 25) 1) (ENTRY:PROCEDURE (? procedure)))
+ (label->memory-post-increment (ucode-type compiled-expression)
+ (procedure-external-label procedure)
+ r25))
+\f
+;;;; Pushes
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (CONSTANT (? object)))
+ (scheme-constant->memory-pre-decrement object r30))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (UNASSIGNED))
+ (scheme-constant->memory-pre-decrement constant:unassigned r30))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (REGISTER (? r)))
+ (register->memory-pre-decrement r r30))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 30) -1) (OFFSET (REGISTER (? r)) (? n)))
+ (QUALIFIER (short-offset? n))
+ (memory->memory-pre-decrement (indirect-reference! r n) r30))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 30) -1)
+ (OFFSET-ADDRESS (REGISTER 30) (? n)))
+ (QUALIFIER (short-offset? n))
+ (with-temporary-register! false
+ (lambda (temp)
+ `((LDI () ,(ucode-type stack-environment) ,temp)
+ (LDO () ,(offset-reference r30 n) ,r1)
+ (DEP () ,temp 7 8 ,r1)
+ ,(register->memory-pre-decrement r1 r30)))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 30) -1)
+ (ENTRY:CONTINUATION (? continuation)))
+ (label->memory-pre-decrement (ucode-type return-address)
+ (continuation-label continuation)
+ r30))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 30) -1)
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+ (cons-pointer->memory-pre-decrement type r r30))
+\f
+;;;; Predicates
+
+(define-rule predicate
+ (TRUE-TEST (REGISTER (? register)))
+ (test:machine-constant/register 'LTGT constant:false register
+ standard-predicate-receiver))
+
+(define-rule predicate
+ (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset)))
+ (test:machine-constant/memory 'LTGT constant:false
+ (indirect-reference! register offset)
+ standard-predicate-receiver))
+
+(define-rule predicate
+ (TRUE-TEST (TYPE-TEST (REGISTER (? register)) (? type)))
+ (test:type/register 'LTGT type register standard-predicate-receiver))
+
+(define-rule predicate
+ (TRUE-TEST (TYPE-TEST (OFFSET (REGISTER (? register)) (? offset)) (? type)))
+ (test:type/memory 'LTGT type (indirect-reference! register offset)
+ standard-predicate-receiver))
+
+(define-rule predicate
+ (TRUE-TEST (UNASSIGNED-TEST (REGISTER (? register))))
+ (test:machine-constant/register 'LTGT constant:unassigned register
+ standard-predicate-receiver))
+
+(define-rule predicate
+ (TRUE-TEST (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset))))
+ (test:machine-constant/memory 'LTGT constant:unassigned
+ (indirect-reference! register offset)
+ standard-predicate-receiver))
+\f
+;;;; Invocations
+
+(define-rule statement
+ (INVOCATION:APPLY (? number-pushed) (? prefix) (? continuation))
+ `(,@(generate-invocation-prefix prefix)
+ ,@(assign&invoke-entry number-pushed regnum:frame-size
+ entry:compiler-apply)))
+
+(define-rule statement
+ (INVOCATION:JUMP (? number-pushed) (? prefix) (? continuation) (? procedure))
+ `(,@(generate-invocation-prefix prefix)
+ ,(branch->label (procedure-label procedure))))
+
+(define-rule statement
+ (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation)
+ (? procedure))
+ `(,@(generate-invocation-prefix prefix)
+ ,@(machine-constant->machine-register number-pushed regnum:frame-size)
+ ,(branch->label (procedure-label procedure))))
+
+(define-rule statement
+ (INVOCATION:LOOKUP (? number-pushed) (? prefix) (? continuation)
+ (? environment) (? name))
+ (let ((set-environment (expression->address-register! environment a0)))
+ (delete-dead-registers!)
+ `(,@set-environment
+ ,@(generate-invocation-prefix prefix)
+ ,(load-constant name '(A 1))
+ (MOVE W (& ,(1+ number-pushed)) (D 0))
+ ,(invoke-entry entry:compiler-lookup-apply))))
+
+(define-rule statement
+ (INVOCATION:PRIMITIVE (? number-pushed) (? prefix) (? continuation)
+ (? primitive))
+ `(,@(generate-invocation-prefix prefix)
+ ,@(if (eq? primitive compiled-error-procedure)
+ (assign&invoke-entry number-pushed regnum:frame-size
+ entry:compiler-error)
+ ;; Simple thing for now.
+ (assign&invoke-entry (primitive-datum primitive)
+ regnum:call-argument-0
+ entry:compiler-primitive-apply))))
+
+(define-rule statement
+ (RETURN)
+ `(,@(clear-map!)
+ ,(memory-post-increment->machine-register regnum:stack-pointer
+ regnum:code-object-base)
+ ,@(object->address regnum:code-object-base)
+ (BE (N) (INDEX 0 1 ,regnum:code-object-base))))
+\f
+(define (generate-invocation-prefix prefix)
+ `(,@(clear-map!)
+ ,@(case (car prefix)
+ ((NULL) '())
+ ((MOVE-FRAME-UP)
+ (apply generate-invocation-prefix:move-frame-up (cdr prefix)))
+ (else (error "GENERATE-INVOCATION-PREFIX: bad prefix type" prefix)))))
+
+(define (load-memory source offset target)
+ `(LDW () ,(index-reference source offset) ,target))
+
+(define (store-memory source target offset)
+ `(STW () ,source ,(index-reference target offset)))
+
+(define (load-memory-increment source offset target)
+ `(LDWM () ,(index-reference source offset) ,target))
+
+(define (store-memory-increment source target offset)
+ `(STWM () ,source ,(index-reference target offset)))
+
+(define (generate-invocation-prefix:move-frame-up frame-size how-far)
+ (cond ((or (zero? frame-size) (zero? how-far)) '())
+ ((= frame-size 1)
+ `(,(load-memory-increment regnum:stack-pointer (+ frame-size how-far)
+ r1)
+ ,(store-memory r1 regnum:stack-pointer 0)))
+ ((= frame-size 2)
+ (with-temporary-register! false
+ (lambda (temp)
+ `(,(load-memory-increment regnum:stack-pointer 1 r1)
+ ,(load-memory-increment regnum:stack-pointer (-1+ how-far) temp)
+ ,(store-memory r1 regnum:stack-pointer 0)
+ ,(store-memory temp regnum:stack-pointer 1)))))
+ (else
+ (with-temporary-register! false
+ (lambda (temp0)
+ (with-temporary-register! false
+ (lambda (temp1)
+ `((LDO ()
+ ,(offset-reference regnum:stack-pointer frame-size)
+ ,temp0)
+ (LDO ()
+ ,(offset-reference regnum:stack-pointer
+ (+ frame-size how-far))
+ ,temp1)
+ ,@(generate-n-times
+ frame-size 5
+ `(,(load-memory-increment temp0 -1 r1))
+ (store-memory-increment r1 temp1 -1)
+ (lambda (generator)
+ (with-temporary-register! false generator)))
+ ,(machine->machine-register temp1
+ regnum:stack-pointer)))))))))
+\f
+;;; 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.
+
+(define-rule statement
+ (PROCEDURE-HEAP-CHECK (? procedure))
+ (let ((label (generate-label)))
+ `(,@(procedure-header procedure)
+ (COMBT (LT N) ,regnum:free-pointer ,regnum:memtop-pointer
+ ,(label-relative-expression label))
+ (BLE (N) ,entry:compiler-interrupt-procedure)
+ (LABEL ,label))))
+
+(define-rule statement
+ (CONTINUATION-HEAP-CHECK (? continuation))
+ (let ((label (generate-label)))
+ `(,@(make-external-label (continuation-label continuation))
+ (COMBT (LT N) ,regnum:free-pointer ,regnum:memtop-pointer
+ ,(label-relative-expression label))
+ (BLE (N) ,entry:compiler-interrupt-procedure)
+ (LABEL ,label))))
+\f
+(define (procedure-header procedure)
+ (let ((internal-label (procedure-label procedure)))
+ (append! (if (closure-procedure? procedure)
+ (let ((required (1+ (length (procedure-required procedure))))
+ (optional (length (procedure-optional procedure)))
+ (label (procedure-external-label procedure)))
+ (if (and (procedure-rest procedure)
+ (zero? required))
+ (begin (set-procedure-external-label! procedure
+ internal-label)
+ `((ENTRY-POINT ,internal-label)))
+ `((ENTRY-POINT ,label)
+ ,@(make-external-label label)
+ ,@(cond ((procedure-rest procedure)
+ (test:machine-constant/machine-register
+ 'GTEQ required regnum:frame-size
+ (inline-predicate-receiver internal-label)))
+ ((zero? optional)
+ (test:machine-constant/machine-register
+ 'EQ required regnum:frame-size
+ (inline-predicate-receiver internal-label)))
+ (else
+ (let ((wna-label (generate-label)))
+ `(,@(test:machine-constant/machine-register
+ 'LT required regnum:frame-size
+ (inline-predicate-receiver wna-label))
+ ,@(test:machine-constant/machine-register
+ 'LTEQ (+ required optional)
+ regnum:frame-size
+ (inline-predicate-receiver
+ internal-label))
+ (LABEL ,wna-label)))))
+ ,(invoke-entry
+ entry:compiler-wrong-number-of-arguments))))
+ '())
+ `(,@(make-external-label internal-label)))))
+
+(define *block-start-label*)
+
+(define (make-external-label label)
+ `((WORD (- ,label ,*block-start-label*))
+ (LABEL ,label)))
+\f
+;;;; Environment Calls
+
+(define-rule statement
+ (INTERPRETER-CALL:ACCESS (? environment) (? name))
+ (lookup-call entry:compiler-access environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:LOOKUP (? environment) (? name))
+ (lookup-call entry:compiler-lookup environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNASSIGNED? (? environment) (? name))
+ (lookup-call entry:compiler-unassigned? environment name))
+
+(define-rule statement
+ (INTERPRETER-CALL:UNBOUND? (? environment) (? name))
+ (lookup-call entry:compiler-unbound? environment name))
+
+(define (lookup-call entry environment name)
+ (let ((set-environment (expression->address-register! environment a0))
+ (label (generate-label)))
+ `(,@set-environment
+ ,@(clear-map!)
+ ,(constant->machine-register name regnum:argument-1)
+ (BLE (N) ,entry)
+ ,@(make-external-label label))))
+
+(define-rule statement
+ (INTERPRETER-CALL:SET! (? environment) (? name) (? value))
+ (let ((set-environment (expression->address-register! environment a0))
+ (label (generate-label)))
+ (let ((set-value (expression->address-register! value a2)))
+ `(,@set-environment
+ ,@set-value
+ ,@(clear-map!)
+ ,(load-constant name '(A 1))
+ (JSR ,entry:compiler-set!)
+ ,@(make-external-label label)))))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access lap-generator-package compiler-package)
+;;; Scheme Syntax Table: (access lap-generator-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ (BLE (N) ,popper:value)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+;(define (rtl:message-receiver-size:closure) 2)
+;(define (rtl:message-receiver-size:stack) 2)
+;(define (rtl:message-receiver-size:subproblem) 2)
+
+(define-integrable (stack->memory-offset offset)
+ offset)
+
+(define (rtl:expression-cost expression)
+ ;; Returns an estimate of the cost of evaluating the expression.
+ ;; For time being, disable this feature.
+ 1)
+
+(define (rtl:machine-register? rtl-register)
+ (case rtl-register
+ ((STACK-POINTER) (interpreter-stack-pointer))
+ ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access))
+ ((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
+ ((MEMORY_TOP) 0)
+ ((STACK_GUARD) 1)
+ ((VALUE) 2)
+ ((ENVIRONMENT) 3)
+ ((TEMPORARY) 4)
+ ((INTERPRETER-CALL-RESULT:ENCLOSE) 5)
+ (else false)))
+
+(define (rtl:interpreter-register->offset locative)
+ (or (rtl:interpreter-register? locative)
+ (error "Unknown register type" locative)))
+\f
+(define-integrable r0 0)
+(define-integrable r1 1)
+(define-integrable r2 2)
+(define-integrable r3 3)
+(define-integrable r4 4)
+(define-integrable r5 5)
+(define-integrable r6 6)
+(define-integrable r7 7)
+(define-integrable r8 8)
+(define-integrable r9 9)
+(define-integrable r10 10)
+(define-integrable r11 11)
+(define-integrable r12 12)
+(define-integrable r13 13)
+(define-integrable r14 14)
+(define-integrable r15 15)
+(define-integrable r16 16)
+(define-integrable r17 17)
+(define-integrable r18 18)
+(define-integrable r19 19)
+(define-integrable r20 20)
+(define-integrable r21 21)
+(define-integrable r22 22)
+(define-integrable r23 23)
+(define-integrable r24 24)
+(define-integrable r25 25)
+(define-integrable r26 26)
+(define-integrable r27 27)
+(define-integrable r28 28)
+(define-integrable r29 29)
+(define-integrable r30 30)
+(define-integrable r31 31)
+
+(define number-of-machine-registers 32)
+(define machine-register<? >)
+
+(define (pseudo-register=? x y)
+ (= (register-renumber x) (register-renumber y)))
+
+(define available-machine-registers
+ (sort (list r3 r4 r5 r6 r7 r8 r9 r10 r11 r12 r13 r14 r15 r16 r17 r18
+ r19 r20 r21 r22)
+ machine-register<?))
+
+(define-integrable (stripped-register? register)
+ (memv register '(23 24 25 30)))
+
+(define-integrable (register-type register)
+ false)
+
+(define-integrable (register-reference register)
+ register)
+\f
+(define-integrable regnum:frame-size r3)
+(define-integrable regnum:call-argument-0 r4)
+(define-integrable regnum:call-argument-1 r5)
+(define-integrable regnum:call-argument-2 r6)
+(define-integrable regnum:call-value r28)
+
+(define-integrable regnum:memtop-pointer r23)
+(define-integrable regnum:regs-pointer r24)
+(define-integrable regnum:free-pointer r25)
+(define-integrable regnum:code-object-base r26)
+(define-integrable regnum:address-offset r27)
+(define-integrable regnum:stack-pointer r30)
+
+(define-integrable (interpreter-register:access)
+ (rtl:make-machine-register regnum:call-value))
+
+(define-integrable (interpreter-register:lookup)
+ (rtl:make-machine-register regnum:call-value))
+
+(define-integrable (interpreter-register:unassigned?)
+ (rtl:make-machine-register regnum:call-value))
+
+(define-integrable (interpreter-register:unbound?)
+ (rtl:make-machine-register regnum:call-value))
+
+(define-integrable (interpreter-free-pointer)
+ (rtl:make-machine-register regnum:free-pointer))
+
+(define-integrable (interpreter-free-pointer? register)
+ (= (rtl:register-number register) regnum:free-pointer))
+
+(define-integrable (interpreter-regs-pointer)
+ (rtl:make-machine-register regnum:regs-pointer))
+
+(define-integrable (interpreter-regs-pointer? register)
+ (= (rtl:register-number register) regnum:regs-pointer))
+
+(define-integrable (interpreter-stack-pointer)
+ (rtl:make-machine-register regnum:stack-pointer))
+
+(define-integrable (interpreter-stack-pointer? register)
+ (= (rtl:register-number register) regnum:stack-pointer))
+\f
+(define (lap:make-label-statement label)
+ `(LABEL ,label))
+
+(define (lap:make-unconditional-branch label)
+ `((BL (N) (- (- ,label *PC*) 8) 0)))
+
+(define (lap:make-entry-point label block-start-label)
+ `((ENTRY-POINT ,label)
+ (WORD (- ,label ,block-start-label))
+ (LABEL ,label)))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: compiler-package
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ (LABEL ,label)))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+(define (register-allocation 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)
+ (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)))))
+ (walk-bblock-forward bblock
+ (lambda (rnode)
+ (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))))
+ (rnode-dead-registers rnode))
+ (mark-births! live
+ (rnode-rtl rnode)
+ 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)))
+ (vector-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)
+ (< (/ (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))))))))
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access rtl-analyzer-package compiler-package)
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ register))))))))
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+(define (common-subexpression-elimination blocks n-registers)
+ (fluid-let ((*next-quantity-number* 0))
+ (state:initialize n-registers
+ (lambda ()
+ (for-each walk-block blocks)))))
+
+(define (walk-block block)
+ (state:reset!)
+ (walk-rnode block))
+
+(define (walk-rnode rnode)
+ ((vector-method rnode walk-rnode) rnode))
+
+(define-vector-method rtl-snode-tag walk-rnode
+ (lambda (rnode)
+ (cse-statement (rnode-rtl rnode))
+ (let ((next (snode-next rnode)))
+ (if next (walk-rnode next)))))
+
+(define-vector-method rtl-pnode-tag walk-rnode
+ (lambda (rnode)
+ (cse-statement (rnode-rtl rnode))
+ (let ((consequent (pnode-consequent rnode))
+ (alternative (pnode-alternative rnode)))
+ (if consequent
+ (if alternative
+ ;; Copy the world's state.
+ (let ((state (state:get)))
+ (walk-rnode consequent)
+ (state:set! state)
+ (walk-rnode alternative))
+ (walk-rnode consequent))
+ (if alternative
+ (walk-rnode alternative))))))
+
+(define (cse-statement statement)
+ ((cdr (or (assq (rtl:expression-type statement) cse-methods)
+ (error "Missing CSE method" (car statement))))
+ statement))
+
+(define cse-methods '())
+
+(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)
+\f
+(define-cse-method 'ASSIGN
+ (lambda (statement)
+ (expression-replace! rtl:assign-expression rtl:set-assign-expression!
+ statement
+ (let ((address (rtl:assign-address statement)))
+ (cond ((rtl:register? address)
+ (lambda (volatile? insert-source!)
+ (register-expression-invalidate! address)
+ (if (not volatile?)
+ (insert-register-destination! address (insert-source!)))))
+ ((stack-reference? address)
+ (lambda (volatile? insert-source!)
+ (stack-reference-invalidate! address)
+ (if (not volatile?)
+ (insert-stack-destination! address (insert-source!)))))
+ (else
+ (lambda (volatile? insert-source!)
+ (let ((memory-invalidate!
+ (if (destination-safe? address)
+ (lambda () 'DONE)
+ (memory-invalidator
+ (expression-varies? address)))))
+ (full-expression-hash address
+ (lambda (hash volatile?* in-memory?*)
+ (cond (volatile?* (memory-invalidate!))
+ ((not volatile?)
+ (let ((address
+ (find-cheapest-expression address hash
+ false)))
+ (let ((element (insert-source!)))
+ (memory-invalidate!)
+ (insert-memory-destination!
+ address
+ element
+ (modulo (+ (symbol-hash 'ASSIGN) hash)
+ n-buckets)))))))))
+ ;; **** Kludge. Works only because stack-pointer
+ ;; gets used in very fixed way by code generator.
+ (if (stack-push/pop? address)
+ (stack-pointer-adjust!
+ (rtl:address-number address))))))))))
+\f
+(define (noop statement)
+ 'DONE)
+
+(define (trivial-action volatile? insert-source!)
+ (if (not volatile?) (insert-source!)))
+
+(define ((normal-action thunk) volatile? insert-source!)
+ (thunk)
+ (if (not volatile?) (insert-source!)))
+
+(define-cse-method 'EQ-TEST
+ (lambda (statement)
+ (expression-replace! rtl:eq-test-expression-1
+ rtl:set-eq-test-expression-1!
+ statement
+ trivial-action)
+ (expression-replace! rtl:eq-test-expression-2
+ rtl:set-eq-test-expression-2!
+ statement
+ trivial-action)))
+
+(define (define-trivial-method type get-expression set-expression!)
+ (define-cse-method type
+ (lambda (statement)
+ (expression-replace! get-expression set-expression! statement
+ trivial-action))))
+
+(define-trivial-method 'TRUE-TEST
+ rtl:true-test-expression
+ rtl:set-true-test-expression!)
+
+(define-trivial-method 'TYPE-TEST
+ rtl:type-test-expression
+ rtl:set-type-test-expression!)
+
+(define-cse-method 'RETURN noop)
+(define-cse-method 'PROCEDURE-HEAP-CHECK noop)
+(define-cse-method 'CONTINUATION-HEAP-CHECK noop)
+
+(define (define-lookup-method type get-environment set-environment! register)
+ (define-cse-method type
+ (lambda (statement)
+ (expression-replace! get-environment set-environment! statement
+ (normal-action (lambda () (expression-invalidate! (register))))))))
+
+(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:LOOKUP
+ rtl:interpreter-call:lookup-environment
+ rtl:set-interpreter-call:lookup-environment!
+ interpreter-register:lookup)
+\f
+(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-cse-method 'INTERPRETER-CALL:ENCLOSE
+ (lambda (statement)
+ (let ((n (rtl:interpreter-call:enclose-size statement)))
+ (stack-region-invalidate! 0 n)
+ (stack-pointer-adjust! n))
+ (expression-invalidate! (interpreter-stack-pointer))))
+
+(define (define-assignment-method type
+ get-environment set-environment!
+ get-value set-value!)
+ (lambda (statement)
+ (expression-replace! get-value set-value! statement trivial-action)
+ (expression-replace! get-environment set-environment! statement
+ (normal-action (lambda () (memory-invalidate! true))))))
+
+(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!)
+
+(define (define-invocation-method type)
+ (define-cse-method type
+ (lambda (statement)
+ (let ((prefix (rtl:invocation-prefix statement)))
+ (case (car prefix)
+ ((NULL) (continuation-adjustment statement))
+ ((MOVE-FRAME-UP)
+ (let ((size (second prefix))
+ (distance (third prefix)))
+ (stack-region-invalidate! 0 (+ size distance)) ;laziness
+ (stack-pointer-adjust! distance))
+ (expression-invalidate! (interpreter-stack-pointer)))
+ ((APPLY-STACK APPLY-CLOSURE) (trash-stack statement))
+ (else (error "Bad prefix type" prefix)))))))
+\f
+(define (continuation-adjustment statement)
+ (let ((continuation (rtl:invocation-continuation statement)))
+ (if continuation
+ (stack-pointer-adjust! (+ (rtl:invocation-pushed statement)
+ (continuation-delta continuation))))))
+
+(define-invocation-method 'INVOCATION:APPLY)
+(define-invocation-method 'INVOCATION:JUMP)
+(define-invocation-method 'INVOCATION:LEXPR)
+(define-invocation-method 'INVOCATION:PRIMITIVE)
+
+(define-cse-method 'INVOCATION:LOOKUP
+ (lambda (statement)
+ (continuation-adjustment statement)
+ (expression-replace! rtl:invocation:lookup-environment
+ rtl:set-invocation:lookup-environment!
+ statement
+ trivial-action)))
+
+(define (define-message-receiver type)
+ (define-cse-method type
+ (lambda (statement)
+ (stack-pointer-adjust! -2)
+ (expression-invalidate! (interpreter-stack-pointer)))))
+
+(define-message-receiver 'MESSAGE-RECEIVER:CLOSURE)
+(define-message-receiver 'MESSAGE-RECEIVER:STACK)
+(define-message-receiver 'MESSAGE-RECEIVER:SUBPROBLEM)
+
+(define (define-stack-trasher type)
+ (define-cse-method type trash-stack))
+
+(define (trash-stack statement)
+ (stack-invalidate!)
+ (expression-invalidate! (interpreter-stack-pointer)))
+
+(define-stack-trasher 'SETUP-CLOSURE-LEXPR)
+(define-stack-trasher 'SETUP-STACK-LEXPR)
+(define-stack-trasher 'MESSAGE-SENDER:VALUE)
+\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
+ (expression-canonicalize (statement-expression statement))))
+ (full-expression-hash expression
+ (lambda (hash volatile? in-memory?)
+ (let ((element
+ (find-cheapest-valid-element expression hash volatile?)))
+ (define (finish 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
+ (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
+;;;; Invalidation
+
+(define (memory-invalidator variable?)
+ (let ((predicate (if variable? element-address-varies? element-in-memory?)))
+ (lambda ()
+ (hash-table-delete-class! predicate))))
+
+(define (memory-invalidate! variable?)
+ (hash-table-delete-class!
+ (if variable? element-address-varies? element-in-memory?)))
+
+(define (element-address-varies? element)
+ (expression-address-varies? (element-expression element)))
+
+(define (expression-invalidate! expression)
+ ;; Delete any expression which refers to this expression from the
+ ;; table.
+ (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.
+ (register-invalidate! (rtl:register-number expression))
+ (let ((hash (expression-hash 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 (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)))
+\f
+;;;; Destination 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 ((class (element->class element))
+ (register (rtl:register-number expression)))
+ (define (register-equivalence! quantity)
+ (set-register-quantity! register quantity)
+ (let ((last (quantity-last-register quantity)))
+ (if last
+ (begin (set-register-next-equivalent! last register)
+ (set-register-previous-equivalent! register last))
+ (begin (set-quantity-first-register! quantity register)
+ (set-quantity-last-register! quantity register))))
+ (set-register-next-equivalent! register false)
+ (set-quantity-last-register! quantity register))
+
+ (set-register-expression! register expression)
+ (if class
+ (let ((expression (element-expression class)))
+ (cond ((rtl:register? expression)
+ (register-equivalence!
+ (register-quantity (rtl:register-number expression))))
+ ((stack-reference? expression)
+ (register-equivalence!
+ (stack-reference-quantity expression))))))
+ (set-element-in-memory?!
+ (hash-table-insert! (expression-hash expression) expression class)
+ false)))
+
+(define (insert-stack-destination! expression element)
+ (set-element-in-memory?! (hash-table-insert! (expression-hash expression)
+ expression
+ (element->class element))
+ false))
+
+(define (insert-memory-destination! expression element hash)
+ (let ((class (element->class element)))
+ (mention-registers! expression)
+ (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 all expressions which refer to it
+ ;; from the hash table.
+ (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))))))))
+\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,
+ ;; CLASS will be false. [ref crock-1]
+ (let ((class (element-first-value element)))
+ (or class
+ (element->class (element-next-value element))))))
+\f
+;;;; Expression Hash
+
+(define (expression-hash expression)
+ (full-expression-hash expression
+ (lambda (hash 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
+ (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.
+ (let ((register (rtl:offset-register expression)))
+ (if (interpreter-stack-pointer? register)
+ (quantity-number (stack-reference-quantity expression))
+ (begin (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 hash-object))
+
+ (let ((hash (loop expression)))
+ (receiver (modulo hash n-buckets) do-not-record? hash-arg-in-memory?))))
+
+(define (hash-object object)
+ (cond ((integer? object) object)
+ ((symbol? object) (symbol-hash object))
+ (else (hash object))))
+\f
+;;;; Expression Predicates
+
+(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))
+ (case type
+ ((REGISTER)
+ (register-equivalent? x y))
+ ((OFFSET)
+ (let ((rx (rtl:offset-register x)))
+ (and (register-equivalent? rx (rtl:offset-register y))
+ (if (interpreter-stack-pointer? rx)
+ (eq? (stack-reference-quantity x)
+ (stack-reference-quantity y))
+ (= (rtl:offset-number x)
+ (rtl:offset-number 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? (register-quantity x) (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))
+\f
+(define (expression-address-varies? expression)
+ (if (memq (rtl:expression-type expression)
+ '(OFFSET PRE-INCREMENT POST-INCREMENT))
+ (register-expression-varies? (rtl:address-register expression))
+ (rtl:any-subexpression? expression expression-address-varies?)))
+
+(define (expression-varies? expression)
+ ;; This procedure should not be called on a register expression.
+ (let ((type (rtl:expression-type expression)))
+ (or (memq type '(OFFSET PRE-INCREMENT POST-INCREMENT))
+ (if (eq? type 'REGISTER)
+ (register-expression-varies? expression)
+ (rtl:any-subexpression? expression expression-varies?)))))
+
+(define (register-expression-varies? expression)
+ (not (= regnum:regs-pointer (rtl:register-number expression))))
+
+(define (destination-safe? expression)
+ ;; Pushing on the stack and consing can't invalidate anything.
+ (and (memq (rtl:expression-type expression) '(PRE-INCREMENT POST-INCREMENT))
+ (or (interpreter-stack-pointer? (rtl:address-register expression))
+ (interpreter-free-pointer? (rtl:address-register expression)))))
+
+(define (stack-push/pop? expression)
+ (and (memq (rtl:expression-type expression) '(PRE-INCREMENT POST-INCREMENT))
+ (interpreter-stack-pointer? (rtl:address-register expression))))
+\f
+;;;; Stack References
+
+(define *stack-offset*)
+(define *stack-reference-quantities*)
+
+(define (stack-reference? expression)
+ (and (eq? (rtl:expression-type expression) 'OFFSET)
+ (interpreter-stack-pointer? (rtl:address-register expression))))
+
+(define (stack-reference-quantity expression)
+ (let ((n (+ *stack-offset* (rtl:offset-number 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 (stack-pointer-adjust! offset)
+ (set! *stack-offset* (+ (stack->memory-offset offset) *stack-offset*)))
+
+(define (stack-invalidate!)
+ (set! *stack-reference-quantities* '()))
+
+(define (stack-region-invalidate! start end)
+ (let ((end (+ *stack-offset* end)))
+ (define (loop i quantities)
+ (if (< i end)
+ (loop (1+ i)
+ (del-ass=! i quantities))
+ (set! *stack-reference-quantities* quantities)))
+ (loop (+ *stack-offset* start) *stack-reference-quantities*)))
+
+(define (stack-reference-invalidate! expression)
+ (expression-invalidate! expression)
+ (set! *stack-reference-quantities*
+ (del-ass=! (+ *stack-offset* (rtl:offset-number expression))
+ *stack-reference-quantities*)))
+
+(define ass= (association-procedure = car))
+(define del-ass=! (delete-association-procedure list-deletor! = car))
+\f
+;;;; Hash Table Abstraction
+
+(define n-buckets 31)
+
+(define (make-hash-table)
+ (make-vector n-buckets false))
+
+(define *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 element-tag (make-vector-tag false 'ELEMENT))
+(define element? (tagged-vector-predicate element-tag))
+
+(define-vector-slots element 1
+ expression cost in-memory?
+ next-hash previous-hash
+ next-value previous-value first-value)
+
+(define (make-element expression)
+ (vector element-tag expression false false false false false false false))
+\f
+(define (hash-table-lookup hash expression)
+ (define (loop element)
+ (and element
+ (if (let ((expression* (element-expression element)))
+ (or (eq? expression expression*)
+ (expression-equivalent? expression expression* true)))
+ element
+ (loop (element-next-hash element)))))
+ (loop (hash-table-ref hash)))
+
+(define (hash-table-insert! hash expression class)
+ (let ((element (make-element expression))
+ (cost (rtl:expression-cost expression)))
+ (set-element-cost! element cost)
+ (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))
+ ((< cost (element-cost 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))
+ ((<= cost (element-cost 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 n-buckets)
+ (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
+(package (hash-table-copy)
+
+(define *elements*)
+
+(define-export (hash-table-copy table)
+ (fluid-let ((*elements* '()))
+ (vector-map table element-copy)))
+
+(define (element-copy element)
+ (and element
+ (let ((entry (assq element *elements*)))
+ (if entry
+ (cdr entry)
+ (let ((new (make-element (element-expression element))))
+ (set! *elements* (cons (cons element new) *elements*))
+ (set-element-cost! new (element-cost element))
+ (set-element-in-memory?! new (element-in-memory? element))
+ (set-element-next-hash!
+ new
+ (element-copy (element-next-hash element)))
+ (set-element-previous-hash!
+ new
+ (element-copy (element-previous-hash element)))
+ (set-element-next-value!
+ new
+ (element-copy (element-next-value element)))
+ (set-element-previous-value!
+ new
+ (element-copy (element-previous-value element)))
+ (set-element-first-value!
+ new
+ (element-copy (element-first-value element)))
+ new)))))
+
+)
+\f
+;;;; State Abstraction
+
+(define (state:initialize n-registers thunk)
+ (fluid-let ((*register-quantity* (make-vector n-registers))
+ (*register-next-equivalent* (make-vector n-registers))
+ (*register-previous-equivalent* (make-vector n-registers))
+ (*register-expression* (make-vector n-registers))
+ (*register-tick* (make-vector n-registers))
+ (*register-in-table* (make-vector n-registers))
+ (*hash-table* (make-hash-table))
+ (*stack-offset*)
+ (*stack-reference-quantities*))
+ (thunk)))
+
+(define (state:reset!)
+ (vector-fill-with-quantities! *register-quantity*)
+ (vector-fill! *register-next-equivalent* false)
+ (vector-fill! *register-previous-equivalent* false)
+ (vector-fill! *register-expression* false)
+ (for-each-machine-register
+ (lambda (register)
+ (set-register-expression! register (rtl:make-machine-register register))))
+ (vector-fill! *register-tick* 0)
+ (vector-fill! *register-in-table* -1)
+ (set! *hash-table* (make-hash-table))
+ (set! *stack-offset* 0)
+ (set! *stack-reference-quantities* '()))
+
+(define (vector-fill-with-quantities! vector)
+ (define (loop i)
+ (vector-set! vector i (new-quantity i))
+ (if (not (zero? i))
+ (loop (-1+ i))))
+ (loop (-1+ (vector-length vector))))
+
+(define (state:get)
+ (vector (vector-map *register-quantity* quantity-copy)
+ (vector-copy *register-next-equivalent*)
+ (vector-copy *register-previous-equivalent*)
+ (vector-copy *register-expression*)
+ (vector-copy *register-tick*)
+ (vector-copy *register-in-table*)
+ (hash-table-copy *hash-table*)
+ *stack-offset*
+ (copy-alist *stack-reference-quantities*)))
+
+(define (state:set! state)
+ (set! *register-quantity* (vector-ref state 0))
+ (set! *register-next-equivalent* (vector-ref state 1))
+ (set! *register-previous-equivalent* (vector-ref state 2))
+ (set! *register-expression* (vector-ref state 3))
+ (set! *register-tick* (vector-ref state 4))
+ (set! *register-in-table* (vector-ref state 5))
+ (set! *hash-table* (vector-ref state 6))
+ (set! *stack-offset* (vector-ref state 7))
+ (set! *stack-reference-quantities* (vector-ref state 8)))
+\f
+;;;; Register/Quantity Abstractions
+
+(define quantity-tag (make-vector-tag false 'QUANTITY))
+(define quantity? (tagged-vector-predicate quantity-tag))
+(define-vector-slots quantity 1 number first-register last-register)
+
+(define *next-quantity-number*)
+
+(define (generate-quantity-number)
+ (let ((n *next-quantity-number*))
+ (set! *next-quantity-number* (1+ *next-quantity-number*))
+ n))
+
+(define (make-quantity number first-register last-register)
+ (vector quantity-tag number first-register last-register))
+
+(define (new-quantity register)
+ (make-quantity (generate-quantity-number) register register))
+
+(define (quantity-copy quantity)
+ (make-quantity (quantity-number quantity)
+ (quantity-first-register quantity)
+ (quantity-last-register quantity)))
+
+(define-register-references quantity)
+(define-register-references next-equivalent)
+(define-register-references previous-equivalent)
+(define-register-references expression)
+(define-register-references tick)
+(define-register-references in-table)
+
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access rtl-cse-package compiler-package)
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ rtl:set-interpreter-call:set!-value!)
\ No newline at end of file
--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; Copyright (c) 1986 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
+
+(declare (usual-integrations))
+(using-syntax (access compiler-syntax-table compiler-package)
+\f
+;;;; Basic Blocks
+
+(define *blocks*)
+(define *block-number*)
+
+(define (find-blocks rnodes)
+ (fluid-let ((*generation* (make-generation))
+ (*blocks* '())
+ (*block-number* 0))
+ (for-each (lambda (rnode)
+ (set-node-generation! rnode *generation*))
+ rnodes)
+ (for-each walk-entry rnodes)
+ *blocks*))
+
+(define (walk-next next)
+ (if (not (eq? (node-generation next) *generation*))
+ (walk-entry next)))
+
+(define (walk-entry rnode)
+ (let ((bblock (make-bblock *block-number* rnode *n-registers*)))
+ (set! *block-number* (1+ *block-number*))
+ (set! *blocks* (cons bblock *blocks*))
+ (walk-rnode bblock rnode)))
+
+(define (walk-rnode bblock rnode)
+ (set-node-generation! rnode *generation*)
+ (set-rnode-bblock! rnode bblock)
+ ((vector-method rnode walk-rnode) bblock rnode))
+
+(define-vector-method rtl-snode-tag walk-rnode
+ (lambda (bblock snode)
+ (let ((next (snode-next snode)))
+ (cond ((not next)
+ (set-bblock-exit! bblock snode))
+ ((or (not (null? (cdr (node-previous next))))
+ (rtl:invocation? (rnode-rtl snode)))
+ (set-bblock-exit! bblock snode)
+ (walk-next next))
+ (else
+ (walk-rnode bblock next))))))
+
+(define-vector-method rtl-pnode-tag walk-rnode
+ (lambda (bblock pnode)
+ (set-bblock-exit! bblock pnode)
+ (walk-next (pnode-consequent pnode))
+ (walk-next (pnode-alternative pnode))))
+\f
+;;;; Lifetime Analysis
+
+(define (lifetime-analysis bblocks)
+ (let ((changed? false))
+ (define (loop first-pass?)
+ (for-each (lambda (bblock)
+ (let ((live-at-entry (bblock-live-at-entry bblock))
+ (live-at-exit (bblock-live-at-exit bblock))
+ (new-live-at-exit (bblock-new-live-at-exit bblock)))
+ (if (or first-pass?
+ (not (regset=? live-at-exit new-live-at-exit)))
+ (begin (set! changed? true)
+ (regset-copy! live-at-exit new-live-at-exit)
+ (regset-copy! live-at-entry live-at-exit)
+ (propagate-block bblock)
+ (for-each-previous-node (bblock-entry bblock)
+ (lambda (rnode)
+ (regset-union! (bblock-new-live-at-exit
+ (rnode-bblock rnode))
+ live-at-entry)))))))
+ 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)))
+\f
+(define (propagate-block bblock)
+ (propagation-loop bblock
+ (lambda (old dead live rtl rnode)
+ (update-live-registers! old dead live rtl 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 (old dead live rtl rnode)
+ (if (rtl:invocation? rtl)
+ (for-each-regset-member old register-crosses-call!))
+ (if (instruction-dead? rtl old)
+ (rtl-snode-delete! rnode)
+ (begin (update-live-registers! old dead live rtl rnode)
+ (for-each-regset-member old
+ increment-register-live-length!))))))
+
+(define (propagation-loop bblock procedure)
+ (let ((old (bblock-live-at-entry bblock))
+ (dead (regset-allocate *n-registers*))
+ (live (regset-allocate *n-registers*)))
+ (let loop ((rnode (bblock-exit bblock)))
+ (regset-clear! dead)
+ (regset-clear! live)
+ (let ((previous
+ (and (not (eq? rnode (bblock-entry bblock)))
+ (node-previous-node rnode))))
+ (procedure old dead live (rnode-rtl rnode) rnode)
+ (if previous (loop previous))))))
+
+(define (update-live-registers! old dead live rtl rnode)
+ (mark-set-registers! old dead rtl rnode)
+ (mark-used-registers! old live rtl rnode)
+ (regset-difference! old dead)
+ (regset-union! old live))
+
+(define (instruction-dead? rtl needed)
+ (and (rtl:assign? rtl)
+ (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))))))))
+\f
+(define (mark-set-registers! needed dead rtl rnode)
+ ;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT
+ ;; modes, since they are only used on the stack pointer.
+ (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 rnode
+ (let ((rnode* (register-next-use register)))
+ (record-register-reference register rnode)
+ (if (and (regset-member? needed register)
+ rnode*
+ (eq? (rnode-bblock rnode) (rnode-bblock rnode*)))
+ (set-rnode-logical-link! rnode* rnode)))))))))
+
+(define (mark-used-registers! needed live rtl rnode)
+ (define (loop expression)
+ (if (interesting-register? expression)
+ (let ((register (rtl:register-number expression)))
+ (regset-adjoin! live register)
+ (if rnode
+ (begin (record-register-reference register rnode)
+ (set-register-next-use! register rnode)
+ (if (and (not (regset-member? needed register))
+ (not (rnode-dead-register? rnode register)))
+ (begin (set-rnode-dead-registers!
+ rnode
+ (cons register
+ (rnode-dead-registers rnode)))
+ (increment-register-n-deaths! register))))))
+ (rtl:for-each-subexpression expression loop)))
+ (if (and (rtl:assign? rtl)
+ (rtl:register? (rtl:assign-address rtl)))
+ (if (let ((register (rtl:register-number (rtl:assign-address rtl))))
+ (or (machine-register? register)
+ (regset-member? needed register)))
+ (loop (rtl:assign-expression rtl)))
+ (rtl:for-each-subexpression rtl loop)))
+
+(define (record-register-reference register rnode)
+ (let ((bblock (rnode-bblock rnode))
+ (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 (interesting-register? expression)
+ (and (rtl:register? expression)
+ (pseudo-register? (rtl:register-number expression))))
+\f
+;;;; Optimization
+
+(define (optimize-block bblock)
+ (let ((live (regset-copy (bblock-live-at-entry bblock)))
+ (births (make-regset *n-registers*)))
+ (define (loop rnode next)
+ (optimize-rtl live rnode next)
+ (if (not (eq? next (bblock-exit bblock)))
+ (begin (regset-clear! births)
+ (mark-set-registers! live births (rnode-rtl rnode) false)
+ (for-each (lambda (register)
+ (regset-delete! live register))
+ (rnode-dead-registers rnode))
+ (regset-union! live births)
+ (loop next (snode-next next)))))
+ (let ((entry (bblock-entry bblock)))
+ (if (not (eq? entry (bblock-exit bblock)))
+ (loop entry (snode-next entry))))))
+
+(define (rtl-snode-delete! rnode)
+ (bblock-edit! (rnode-bblock rnode)
+ (lambda ()
+ (snode-delete! rnode))))
+
+(define (bblock-edit! bblock thunk)
+ (if (rtl-pnode? (bblock-exit bblock))
+ (let ((entry (make-entry-holder)))
+ (entry-holder-connect! entry (bblock-entry bblock))
+ (thunk)
+ (set-bblock-entry! bblock (entry-holder-disconnect! entry)))
+ (let ((entry (make-entry-holder))
+ (exit (make-exit-holder)))
+ (entry-holder-connect! entry (bblock-entry bblock))
+ (snode-next-connect! (bblock-exit bblock) exit)
+ (thunk)
+ (let ((next (entry-holder-disconnect! entry))
+ (hooks (node-previous-disconnect! exit)))
+ (if next
+ (begin (set-bblock-entry! bblock next)
+ (set-bblock-exit! bblock (hook-node (car hooks)))))))))
+\f
+(define (optimize-rtl live rnode next)
+ (let ((rtl (rnode-rtl rnode)))
+ (if (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl)))
+ (if (rtl:register? address)
+ (let ((register (rtl:register-number address)))
+ (if (and (pseudo-register? register)
+ (= 2 (register-n-refs register))
+ (rnode-dead-register? next register))
+ (begin
+ (let ((dead (rnode-dead-registers rnode)))
+ (for-each increment-register-live-length! dead)
+ (set-rnode-dead-registers!
+ next
+ (set-union dead
+ (delv! register
+ (rnode-dead-registers next)))))
+ (for-each-regset-member live
+ decrement-register-live-length!)
+ (rtl:modify-subexpressions (rnode-rtl next)
+ (lambda (expression set-expression!)
+ (if (and (rtl:register? expression)
+ (= (rtl:register-number expression)
+ register))
+ (set-expression! (rtl:assign-expression rtl)))))
+ (rtl-snode-delete! rnode)
+ (reset-register-n-refs! register)
+ (reset-register-n-deaths! register)
+ (reset-register-live-length! register)
+ (set-register-next-use! register false)
+ (set-register-bblock! register false)))))))))
+
+(define set-union
+ (let ()
+ (define (loop x y)
+ (if (null? x)
+ y
+ (loop (cdr x)
+ (if (memv (car x) y)
+ y
+ (cons (car x) y)))))
+ (named-lambda (set-union x y)
+ (if (null? y)
+ x
+ (loop x y)))))
+\f
+;;;; Debugging Output
+
+(define (dump-register-info)
+ (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 (bblock-number bblock)))
+ (else
+ (write-string "; no block!")))))))))
+
+(define (dump-block-info bblocks)
+ (let ((null-set (make-regset *n-registers*))
+ (machine-regs (make-regset *n-registers*)))
+ (for-each-machine-register
+ (lambda (register)
+ (regset-adjoin! machine-regs register)))
+ (for-each (lambda (bblock)
+ (newline)
+ (newline)
+ (write bblock)
+ (let ((exit (bblock-exit bblock)))
+ (let loop ((rnode (bblock-entry bblock)))
+ (pp (rnode-rtl rnode))
+ (if (not (eq? rnode exit))
+ (loop (snode-next rnode)))))
+ (let ((live-at-exit (bblock-live-at-exit bblock)))
+ (regset-difference! live-at-exit machine-regs)
+ (if (not (regset=? null-set live-at-exit))
+ (begin (newline)
+ (write-string "Registers live at end:")
+ (for-each-regset-member live-at-exit
+ (lambda (register)
+ (write-string " ")
+ (write register)))))))
+ (reverse bblocks))))
+\f
+;;; end USING-SYNTAX
+)
+
+;;; Edwin Variables:
+;;; Scheme Environment: (access rtl-analyzer-package compiler-package)
+;;; Scheme Syntax Table: (access compiler-syntax-table compiler-package)
+;;; Tags Table Pathname: (access compiler-tags-pathname compiler-package)
+;;; End:
+ (pseudo-register? (rtl:register-number expression))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff