From effa5893dbe9e2b2e8d4e96d4d6cf63f0de91c91 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Sat, 13 Dec 1986 17:18:25 +0000 Subject: [PATCH] *** empty log message *** --- v7/src/compiler/back/lapgn1.scm | 265 ++++++ v7/src/compiler/back/regmap.scm | 541 +++++++++++ v7/src/compiler/back/symtab.scm | 83 ++ v7/src/compiler/back/syntax.scm | 207 +++++ v7/src/compiler/base/cfg1.scm | 548 +++++++++++ v7/src/compiler/base/ctypes.scm | 124 +++ v7/src/compiler/base/macros.scm | 270 ++++++ v7/src/compiler/base/utils.scm | 458 +++++++++ v7/src/compiler/machines/bobcat/assmd.scm | 66 ++ v7/src/compiler/machines/bobcat/coerce.scm | 90 ++ v7/src/compiler/machines/bobcat/insmac.scm | 161 ++++ v7/src/compiler/machines/bobcat/instr1.scm | 407 ++++++++ v7/src/compiler/machines/bobcat/instr2.scm | 353 +++++++ v7/src/compiler/machines/bobcat/instr3.scm | 374 ++++++++ v7/src/compiler/machines/bobcat/lapgen.scm | 763 +++++++++++++++ v7/src/compiler/machines/bobcat/machin.scm | 218 +++++ .../compiler/machines/bobcat/make.scm-68040 | 129 +++ v7/src/compiler/machines/spectrum/assmd.scm | 66 ++ v7/src/compiler/machines/spectrum/coerce.scm | 174 ++++ v7/src/compiler/machines/spectrum/lapgen.scm | 845 +++++++++++++++++ v7/src/compiler/machines/spectrum/machin.scm | 193 ++++ v7/src/compiler/rtlopt/ralloc.scm | 140 +++ v7/src/compiler/rtlopt/rcse1.scm | 878 ++++++++++++++++++ v7/src/compiler/rtlopt/rlife.scm | 370 ++++++++ 24 files changed, 7723 insertions(+) create mode 100644 v7/src/compiler/back/lapgn1.scm create mode 100644 v7/src/compiler/back/regmap.scm create mode 100644 v7/src/compiler/back/symtab.scm create mode 100644 v7/src/compiler/back/syntax.scm create mode 100644 v7/src/compiler/base/cfg1.scm create mode 100644 v7/src/compiler/base/ctypes.scm create mode 100644 v7/src/compiler/base/macros.scm create mode 100644 v7/src/compiler/base/utils.scm create mode 100644 v7/src/compiler/machines/bobcat/assmd.scm create mode 100644 v7/src/compiler/machines/bobcat/coerce.scm create mode 100644 v7/src/compiler/machines/bobcat/insmac.scm create mode 100644 v7/src/compiler/machines/bobcat/instr1.scm create mode 100644 v7/src/compiler/machines/bobcat/instr2.scm create mode 100644 v7/src/compiler/machines/bobcat/instr3.scm create mode 100644 v7/src/compiler/machines/bobcat/lapgen.scm create mode 100644 v7/src/compiler/machines/bobcat/machin.scm create mode 100644 v7/src/compiler/machines/bobcat/make.scm-68040 create mode 100644 v7/src/compiler/machines/spectrum/assmd.scm create mode 100644 v7/src/compiler/machines/spectrum/coerce.scm create mode 100644 v7/src/compiler/machines/spectrum/lapgen.scm create mode 100644 v7/src/compiler/machines/spectrum/machin.scm create mode 100644 v7/src/compiler/rtlopt/ralloc.scm create mode 100644 v7/src/compiler/rtlopt/rcse1.scm create mode 100644 v7/src/compiler/rtlopt/rlife.scm diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm new file mode 100644 index 000000000..d4e0834f6 --- /dev/null +++ b/v7/src/compiler/back/lapgn1.scm @@ -0,0 +1,265 @@ +;;; -*-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) + +(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*))) + +(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) + +;;;; 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))))) + +(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*)) + +(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 diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm new file mode 100644 index 000000000..fa52c5d76 --- /dev/null +++ b/v7/src/compiler/back/regmap.scm @@ -0,0 +1,541 @@ +;;; -*-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) + +#| + +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. + +|# + +(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 + +;;;; 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)) + +;;;; 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*)))) + +;;;; 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))))) + +;;;; 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"))) + +;;;; 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 '()))))) + +) + +(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 '())))) + +(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))) + +;;;; 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) + +(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 diff --git a/v7/src/compiler/back/symtab.scm b/v7/src/compiler/back/symtab.scm new file mode 100644 index 000000000..f7a8a8414 --- /dev/null +++ b/v7/src/compiler/back/symtab.scm @@ -0,0 +1,83 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm new file mode 100644 index 000000000..3e5f68176 --- /dev/null +++ b/v7/src/compiler/back/syntax.scm @@ -0,0 +1,207 @@ +;;; -*-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)) + +(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)))) + +(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))))))) + +;;;; 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)) + +(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 diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm new file mode 100644 index 000000000..6058c7745 --- /dev/null +++ b/v7/src/compiler/base/cfg1.scm @@ -0,0 +1,548 @@ +;;; -*-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) + +;;;; 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) + +;;;; 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))) + +(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))) + +;;;; 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)))) + +;;;; 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)) + +;;;; 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)) + +;;;; 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*))))) + +(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*)) + +) + +(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*)) + +) + +;;;; 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)))))) + +(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 diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm new file mode 100644 index 000000000..c491967c3 --- /dev/null +++ b/v7/src/compiler/base/ctypes.scm @@ -0,0 +1,124 @@ +;;; -*-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) + +(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))) + +(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 diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm new file mode 100644 index 000000000..2a9250070 --- /dev/null +++ b/v7/src/compiler/base/macros.scm @@ -0,0 +1,270 @@ +;;; -*-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)) + +(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)))) + +(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)))))) + +(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))) + +) + +(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)) + +(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)))))) + +(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 diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm new file mode 100644 index 000000000..61d2dcbd4 --- /dev/null +++ b/v7/src/compiler/base/utils.scm @@ -0,0 +1,458 @@ +;;; -*-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) + +;;;; 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)) + +(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)))) + +;;;; 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)) + +;;;; 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)) + +(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)) + +;;;; 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))))) + +;;;; 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)) + +(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)))) + +;;;; 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)) + +;;; 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))))) + +;;;; 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 diff --git a/v7/src/compiler/machines/bobcat/assmd.scm b/v7/src/compiler/machines/bobcat/assmd.scm new file mode 100644 index 000000000..4f70eb3b2 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/assmd.scm @@ -0,0 +1,66 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/compiler/machines/bobcat/coerce.scm b/v7/src/compiler/machines/bobcat/coerce.scm new file mode 100644 index 000000000..32023278f --- /dev/null +++ b/v7/src/compiler/machines/bobcat/coerce.scm @@ -0,0 +1,90 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm new file mode 100644 index 000000000..2e43f4ec4 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/insmac.scm @@ -0,0 +1,161 @@ +;;; -*-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) + +;;;; 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))))))) + +(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*)))))))) + +(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 diff --git a/v7/src/compiler/machines/bobcat/instr1.scm b/v7/src/compiler/machines/bobcat/instr1.scm new file mode 100644 index 000000000..7eb6449b9 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/instr1.scm @@ -0,0 +1,407 @@ +;;; -*-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) + +;;;; 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)) + +(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&-A> ea s) + (and (memq 'ALTERABLE (ea-categories ea)) (ea-b=>-A ea s))) + +;;;; 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)) + + ((@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)))) + +;;;; 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)))) + +;;; 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))))) + +(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))) + +;;;; 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) + +;;;; 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)))) + +(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 diff --git a/v7/src/compiler/machines/bobcat/instr2.scm b/v7/src/compiler/machines/bobcat/instr2.scm new file mode 100644 index 000000000..3038f8db2 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/instr2.scm @@ -0,0 +1,353 @@ +;;; -*-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) + +;;;; 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)))) + +;;;; 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&-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)) + +(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)))) + +;;;; 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)))) + +;;;; 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)))) + +;;;; 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)) + +;;;; 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 diff --git a/v7/src/compiler/machines/bobcat/instr3.scm b/v7/src/compiler/machines/bobcat/instr3.scm new file mode 100644 index 000000000..660662723 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/instr3.scm @@ -0,0 +1,374 @@ +;;; -*-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) + +;;;; 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))) + +(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)))) + +;;;; 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)))) + +;;;; 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)))) + +(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)))) + +(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)))) + +(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 diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm new file mode 100644 index 000000000..474bf281a --- /dev/null +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -0,0 +1,763 @@ +;;; -*-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) + +;;;; 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)))) + +(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)))))) + +(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))) + +(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)))))))) + +;;;; 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)) + +;;;; 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*))))) + +;;;; 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))))) + +;;;; 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))))))) + +;;;; 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)))) + +;;;; 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)))) + +;;;; 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))))) + +(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))) + +(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)))) + +;;;; 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))|# + ) + +(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))))) + +;;;; 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))))) + +(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))) + +;;;; 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 diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm new file mode 100644 index 000000000..dd80bfc66 --- /dev/null +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -0,0 +1,218 @@ +;;; -*-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) + (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)))) + +(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))) + +(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)) + +(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 diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 new file mode 100644 index 000000000..92e16ce6d --- /dev/null +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -0,0 +1,129 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/compiler/machines/spectrum/assmd.scm b/v7/src/compiler/machines/spectrum/assmd.scm new file mode 100644 index 000000000..4f70eb3b2 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/assmd.scm @@ -0,0 +1,66 @@ +;;; -*-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)) + +(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 diff --git a/v7/src/compiler/machines/spectrum/coerce.scm b/v7/src/compiler/machines/spectrum/coerce.scm new file mode 100644 index 000000000..b8792bf57 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/coerce.scm @@ -0,0 +1,174 @@ +;;; -*-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)) + +(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))) + +(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))))) + +(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 diff --git a/v7/src/compiler/machines/spectrum/lapgen.scm b/v7/src/compiler/machines/spectrum/lapgen.scm new file mode 100644 index 000000000..03cb576d7 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/lapgen.scm @@ -0,0 +1,845 @@ +;;; -*-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) + +;;;; 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)))) + +;;;; 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)) + +;;;; 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))) + +(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))))) + +(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))) + +(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))))) + +(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)) + +(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)) + +;;;; 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)) + +;;;; 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)))))) + +;;;; 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))) + +;;;; 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)) + +;;;; 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)) + +;;;; 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)) + +;;;; 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)))) + +(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))))))))) + +;;; 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)))) + +(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))) + +;;;; 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 diff --git a/v7/src/compiler/machines/spectrum/machin.scm b/v7/src/compiler/machines/spectrum/machin.scm new file mode 100644 index 000000000..d80258a14 --- /dev/null +++ b/v7/src/compiler/machines/spectrum/machin.scm @@ -0,0 +1,193 @@ +;;; -*-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) + +;(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))) + +(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-registerrenumber (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) + + ;; 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) + allocaterenumber) + (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 diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm new file mode 100644 index 000000000..dafd7ac87 --- /dev/null +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -0,0 +1,878 @@ +;;; -*-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) + +(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) + +(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)))))))))) + +(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) + +(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))))))) + +(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) + +;;;; 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)))) + +;;;; 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))) + +;;;; 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)))))))) + +;;;; 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)))))) + +;;;; 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)))) + +;;;; 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)) + +(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)))) + +;;;; 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)) + +;;;; 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)) + +(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)) + +(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))))))) + +(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))))) + +) + +;;;; 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))) + +;;;; 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 diff --git a/v7/src/compiler/rtlopt/rlife.scm b/v7/src/compiler/rtlopt/rlife.scm new file mode 100644 index 000000000..9d6b86f1d --- /dev/null +++ b/v7/src/compiler/rtlopt/rlife.scm @@ -0,0 +1,370 @@ +;;; -*-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) + +;;;; 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)))) + +;;;; 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))) + +(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)))))))) + +(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)))) + +;;;; 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))))))))) + +(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))))) + +;;;; 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)))) + +;;; 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 -- 2.25.1