--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/lapgen.scm,v 4.1 1988/01/05 15:57:17 bal Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; RTL Rules for DEC VAX. Part 1
+;;; Matches MC68020 version 1.188
+
+(declare (usual-integrations))
+\f
+;;;; Basic machine instructions
+
+(define (register->register-transfer source target)
+ (LAP ,(machine->machine-register source target)))
+
+(define (home->register-transfer source target)
+ (LAP ,(pseudo->machine-register source target)))
+
+(define (register->home-transfer source target)
+ (LAP ,(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)
+ (INST (MOV L
+ ,(register-reference source)
+ ,(register-reference target))))
+
+(define-integrable (machine-register->memory source target)
+ (INST (MOV L
+ ,(register-reference source)
+ ,target)))
+
+(define-integrable (memory->machine-register source target)
+ (INST (MOV L
+ ,source
+ ,(register-reference target))))
+
+(define (offset-type offset)
+ (cond ((<= -128 offset 127) 'B)
+ ((<= -32768 offset 32767) 'W)
+ (else 'L)))
+
+(define (offset-reference register offset)
+ (if (zero? offset)
+ (INST-EA (@R ,register))
+ (let ((real-offset (* 4 offset)))
+ (INST-EA (@RO ,(offset-type real-offset) ,register ,real-offset)))))
+\f
+;; N is always unsigned.
+;; Actually loaded as long (the popper code depends on this).
+
+(define (load-rnw n r)
+ (cond ((zero? n)
+ (INST (CLR L (R ,r))))
+ ((<= 0 n 63)
+ (INST (MOVZ B L (S ,n) (R ,r))))
+ ((<= 0 n 127)
+ (INST (MOVZ B L (& ,n) (R ,r))))
+ (else
+ (INST (MOVZ W L (& ,n) (R ,r))))))
+
+(define (test-rnw n r)
+ (cond ((zero? n)
+ (INST (TST W (R ,r))))
+ ((<= 0 n 63)
+ (INST (CMP W (R ,r) (S ,n))))
+ (else
+ (INST (CMP W (R ,r) (& ,n))))))
+
+(define (increment-rnl rn n)
+ (if (zero? n)
+ (LAP)
+ (let ((offset (* 4 n)))
+ (cond ((<= 0 offset 63)
+ (LAP (ADD L (S ,offset) (R ,rn))))
+ ((<= -63 offset 0)
+ (LAP (SUB L (S ,offset) (R ,rn))))
+ (else
+ (LAP (MOVA L (@RO ,(offset-type offset) ,rn ,offset)
+ (R ,rn))))))))
+\f
+(define (push-constant constant)
+ (if (non-pointer-object? constant)
+ (push-non-pointer (primitive-type constant)
+ (primitive-datum constant))
+ (INST (PUSHL (@PCR ,(constant->label constant))))))
+
+(define (push-non-pointer type datum)
+ (cond ((not (zero? type))
+ (INST (PUSHL (& ,(make-non-pointer-literal type datum)))))
+ ((zero? datum)
+ (INST (CLR L (@-R 14))))
+ ((<= 0 datum 63)
+ (INST (PUSHL (S ,datum))))
+ (else
+ (INST (CVT ,(offset-type datum) L (& ,datum) (@-R 14))))))
+
+(define (load-constant constant target)
+ (if (non-pointer-object? constant)
+ (load-non-pointer (primitive-type constant)
+ (primitive-datum constant)
+ target)
+ (INST (MOV L
+ (@PCR ,(constant->label constant))
+ ,target))))
+
+(define (load-non-pointer type datum target)
+ (cond ((not (zero? type))
+ (INST (MOV L
+ (& ,(make-non-pointer-literal type datum))
+ ,target)))
+ ((zero? datum)
+ (INST (CLR L ,target)))
+ ((<= 0 datum 63)
+ (INST (MOV L (S ,datum) ,target)))
+ (else
+ (INST (CVT ,(offset-type datum) L (& ,datum) ,target)))))
+
+(define (test-non-pointer type datum effective-address)
+ ;; *** These may be backwards ***
+ (cond ((not (zero? type))
+ (INST (CMP L
+ (& ,(make-non-pointer-literal type datum))
+ ,effective-address)))
+ ((zero? datum)
+ (INST (TST L ,effective-address)))
+ ((<= 0 datum 63)
+ (INST (CMP L (S ,datum) ,effective-address)))
+ (else
+ (INST (CMP L
+ (& ,(make-non-pointer-literal type datum))
+ ,effective-address)))))
+
+(define make-non-pointer-literal
+ (let ((type-scale-factor (expt 2 24)))
+ (lambda (type datum)
+ (+ (* (if (negative? datum) (1+ type) type)
+ type-scale-factor)
+ datum))))
+\f
+(define (test-byte n effective-address)
+ (cond ((zero? n)
+ (INST (TST B ,effective-address)))
+ ;; These may be backwards
+ ((<= 0 n 63)
+ (INST (CMP B (S ,n) ,effective-address)))
+ (else
+ (INST (CMP B (& ,n) ,effective-address)))))
+
+(define (set-standard-branches! cc)
+ (set-current-branches!
+ (lambda (label)
+ (LAP (B ,cc (@PCR ,label))))
+ (lambda (label)
+ (LAP (B ,(invert-cc cc) (@PCR ,label))))))
+
+(define (invert-cc cc)
+ (cdr (or (assq cc
+ '((NEQU . EQLU) (EQLU . NEQU)
+ (NEQ . EQL) (EQL . NEQ)
+ (GTR . LEQ) (LEQ . GTR)
+ (GEQ . LSS) (LSS . GEQ)
+ (VC . VS) (VS . VC)
+ (CC . CS) (CS . CC)
+ (GTRU . LEQU) (LEQU . GTRU)
+ (GEQU . LSSU) (LSSU . GEQU)))
+ (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)
+ (LAP (MOV L ,(coerce->any (cadr expression)) ,target)))
+ ((OFFSET)
+ (LAP
+ (MOV L
+ ,(indirect-reference! (cadadr expression)
+ (caddr expression))
+ ,target)))
+ ((CONSTANT)
+ (LAP ,(load-constant (cadr expression) target)))
+ ((UNASSIGNED)
+ (LAP ,(load-non-pointer type-code:unassigned 0 target)))
+ (else
+ (error "Unknown expression type" (car expression))))))
+ (delete-machine-register! register)
+ result)))
+\f
+(define (indirect-reference! register offset)
+ (if (= register regnum:frame-pointer)
+ (offset-reference regnum:stack-pointer (+ offset (frame-pointer-offset)))
+ (offset-reference
+ (if (machine-register? register)
+ register
+ (or (register-alias register false)
+ ;; This means that someone has written an address out
+ ;; to memory, something that should happen only when the
+ ;; register block spills something.
+ (begin (warn "Needed to load indirect register!" register)
+ (load-alias-register! register 'GENERAL))))
+ offset)))
+
+(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 (coerce->machine-register register)
+ (if (machine-register? register)
+ (register-reference register)
+ (reference-alias-register! register false)))
+
+;; *** What is this? ***
+
+(define (code-object-label-initialize code-object)
+ false)
+
+(define (generate-n-times n limit instruction-gen with-counter)
+ (if (> n limit)
+ (let ((loop (generate-label 'LOOP)))
+ (with-counter
+ (lambda (counter)
+ (LAP ,(load-rnw (-1+ n) counter)
+ (LABEL ,loop)
+ ,(instruction-gen)
+ (SOB GEQ (R ,counter) (@PCR ,loop))))))
+ (let loop ((n n))
+ (if (zero? n)
+ (LAP)
+ (LAP ,(instruction-gen)
+ ,@(loop (-1+ n)))))))
+\f
+(define-integrable (lap:ea-keyword expression)
+ (car expression))
+
+(define-integrable (lap:ea-@R-register expression)
+ (cadr expression))
+
+(define-integrable (lap:ea-@RO-register expression)
+ (caddr expression))
+
+(define-integrable (lap:ea-@RO-offset expression)
+ (cadddr expression))
+
+(define-export (lap:make-label-statement label)
+ (INST (LABEL ,label)))
+
+(define-export (lap:make-unconditional-branch label)
+ (INST (BR (@PCR ,label)))) ; Unsized
+
+(define-export (lap:make-entry-point label block-start-label)
+ (set! compiler:external-labels
+ (cons label compiler:external-labels))
+ (LAP (ENTRY-POINT ,label)
+ (BLOCK-OFFSET ,label)
+ (LABEL ,label)))
+\f
+;;;; Registers/Entries
+
+(let-syntax ((define-entries
+ (macro (start . names)
+ (define (loop names index)
+ (if (null? names)
+ '()
+ (cons `(DEFINE-INTEGRABLE
+ ,(symbol-append 'ENTRY:COMPILER-
+ (car names))
+ (INST-EA (@RO W 13 ,index)))
+ (loop (cdr names) (+ index 6)))))
+ `(BEGIN ,@(loop names start)))))
+ (define-entries #x00F0
+ return-to-interpreter uuo-link-trap apply error
+ wrong-number-of-arguments interrupt-procedure
+ interrupt-continuation lookup-apply lookup access unassigned?
+ unbound? set! define primitive-apply setup-lexpr
+ safe-lookup cache-variable reference-trap assignment-trap uuo-link
+ cache-reference-apply safe-reference-trap unassigned?-trap
+ cache-variable-multiple uuo-link-multiple))
+
+(define-integrable reg:compiled-memtop (INST-EA (@R 13)))
+(define-integrable reg:environment (INST-EA (@RO B 13 #x0C)))
+(define-integrable reg:temp (INST-EA (@RO B 13 #x10)))
+(define-integrable reg:enclose-result (INST-EA (@RO B 13 #x14)))
+
+;; These are the results of using bump-type on the corresponding values.
+(define-integrable reg:temp-type (INST-EA (@RO B 13 #x13)))
+(define-integrable reg:enclose-result-type (INST-EA (@RO B 13 #x17)))
+
+(define-integrable popper:apply-closure (INST-EA (@RO W 13 #x021C)))
+(define-integrable popper:apply-stack (INST-EA (@RO W 13 #x027C)))
+(define-integrable popper:value (INST-EA (@RO W 13 #x02DC)))
+\f
+(define (bump-type effective-address)
+ (cond ((eq? (lap:ea-keyword effective-address) '@R)
+ (INST-EA (@RO B ,(lap:ea-@R-register effective-address) 3)))
+ ((eq? (lap:ea-keyword effective-address) '@RO)
+ (let ((offset (+ 3 (lap:ea-@RO-offset effective-address))))
+ (INST-EA (@RO ,(offset-type offset)
+ ,(lap:ea-@RO-register effective-address)
+ ,offset))))
+ (else #F)))
+
+(define (immediate-type type-code)
+ (if (<= 0 type-code 63)
+ (INST-EA (S ,type-code))
+ (INST-EA (& ,type-code))))
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/make.scm,v 1.0 1988/01/05 15:53:49 bal Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiler Make File for DEC VAX
+
+(declare (usual-integrations))
+\f
+;(set-working-directory-pathname! "$zcomp")
+;(load "base/rcs" system-global-environment)
+(load "base/pkging" system-global-environment)
+
+(in-package compiler-package
+
+ (define compiler-system
+ (make-environment
+ (define :name "Liar (DEC VAX)")
+ (define :version 3)
+ (define :modification 0)
+ (define :files)
+
+; (parse-rcs-header
+; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/make.scm,v 1.0 1988/01/05 15:53:49 bal Exp $"
+; (lambda (filename version date time zone author state)
+; (set! :version (car version))
+; (set! :modification (cadr version))))
+
+ (define :files-lists
+ (list
+ (cons system-global-environment
+ '("base/pbs.bin" ;bit-string read/write syntax
+ ))
+
+ (cons compiler-package
+ '("base/macros.bin" ;compiler syntax
+ "base/decls.bin" ;declarations
+
+ "base/object.bin" ;tagged object support
+ "base/queue.bin" ;queue abstraction
+ "base/sets.bin" ;set abstraction
+ "base/mvalue.bin" ;multiple-value support
+
+ "machines/vax/machin.bin" ;machine dependent stuff
+ "base/toplv1.bin" ;top level
+ "base/toplv2.bin"
+ "base/toplv3.bin"
+ "base/utils.bin" ;odds and ends
+ "base/cfg1.bin" ;control flow graph
+ "base/cfg2.bin"
+ "base/cfg3.bin"
+ "base/rgraph.bin" ;program graph abstraction
+ "base/ctypes.bin" ;CFG datatypes
+ "base/dtype1.bin" ;DFG datatypes
+ "base/dtype2.bin"
+ "base/dtype3.bin"
+ "base/dfg.bin" ;data flow graph
+ "base/rtlty1.bin" ;RTL: type definitions
+ "base/rtlty2.bin"
+ "base/rtlexp.bin" ;RTL: expression operations
+ "base/rtlcon.bin" ;RTL: complex constructors
+ "base/rtlreg.bin" ;RTL: registers
+ "base/rtlcfg.bin" ;RTL: CFG types
+ "base/emodel.bin" ;environment model
+ "base/rtypes.bin" ;RTL Registers
+ "base/regset.bin" ;RTL Register Sets
+ "base/pmlook.bin" ;pattern matcher: lookup
+ "base/pmpars.bin" ;pattern matcher: parser
+ "base/infutl.bin" ;utilities for info generation, shared
+ "back-end/insseq.bin" ;lap instruction sequences
+ "machines/vax/dassm1.bin" ;disassembler
+ "base/linear.bin" ;linearization
+ ))
+
+ (cons disassembler-package
+ '("machines/vax/dsyn.bin" ; disassembler instruction syntax
+ "machines/vax/dassm2.bin" ;disassembler
+ "machines/vax/dassm3.bin"
+ "machines/vax/instr1.dbin" ;disassembler instruction definitions
+ "machines/vax/instr2.dbin"
+ "machines/vax/instr3.dbin"
+ ))
+
+ (cons converter-package
+ '("alpha/fggen1.bin" ;SCode->flow-graph converter
+ "alpha/fggen2.bin"
+ "alpha/declar.bin" ;Declaration handling
+ ))
+
+ (cons dataflow-package
+ '("alpha/dflow1.bin" ;Dataflow analyzer
+ "alpha/dflow2.bin"
+ "alpha/dflow3.bin"
+ "alpha/dflow4.bin"
+ "alpha/dflow5.bin"
+ "alpha/dflow6.bin"
+ ))
+
+ (cons rtl-generator-package
+ '("front-end/rtlgen.bin" ;RTL generator
+ "front-end/rgproc.bin" ;RTL generator: Procedure Headers
+ "front-end/rgstmt.bin" ;RTL generator: Statements
+ "front-end/rgpred.bin" ;RTL generator: Predicates
+ "front-end/rgrval.bin" ;RTL generator: RValues
+ "front-end/rgcomb.bin" ;RTL generator: Combinations
+ "front-end/rgpcom.bin" ;RTL generator: Primitive open-coding
+ ))
+
+ (cons rtl-cse-package
+ '("front-end/rcse1.bin" ;RTL common subexpression eliminator
+ "front-end/rcse2.bin"
+ "front-end/rcseep.bin" ;CSE expression predicates
+ "front-end/rcseht.bin" ;CSE hash table
+ "front-end/rcserq.bin" ;CSE register/quantity abstractions
+ ))
+
+ (cons rtl-analyzer-package
+ '("front-end/rlife.bin" ;RTL register lifetime analyzer
+ "front-end/rdeath.bin" ;RTL dead code eliminations
+ "front-end/rdebug.bin" ;RTL optimizer debugging output
+ "front-end/ralloc.bin" ;RTL register allocator
+ ))
+
+ (cons debugging-information-package
+ '("base/infgen.bin" ;debugging information generation
+ ))
+
+ (cons lap-syntax-package
+ '("back-end/lapgn1.bin" ;LAP generator.
+ "back-end/lapgn2.bin"
+ "back-end/lapgn3.bin"
+ "back-end/regmap.bin" ;Hardware register allocator.
+ "machines/vax/lapgen.bin" ;code generation rules.
+ "machines/vax/rules1.bin"
+ "machines/vax/rules2.bin"
+ "machines/vax/rules3.bin"
+ "machines/vax/rules4.bin"
+ "back-end/syntax.bin" ;Generic syntax phase
+ "machines/vax/coerce.bin" ;Coercions: integer -> bit string
+ "back-end/asmmac.bin" ;Macros for hairy syntax
+ "machines/vax/insmac.bin" ;Macros for hairy syntax
+ "machines/vax/insutl.bin" ;Utilities and effective addressing
+ "machines/vax/instr1.bin" ;VAX Instructions
+ "machines/vax/instr2.bin" ; " "
+ "machines/vax/instr3.bin" ; " "
+ ))
+
+ (cons bit-package
+ '("machines/vax/assmd.bin" ;Machine dependent
+ "back-end/symtab.bin" ;Symbol tables
+ "back-end/bitutl.bin" ;Assembly blocks
+ "back-end/bittop.bin" ;Assembler top level
+ ))
+
+ ))
+
+ ))
+
+ (load-system! compiler-system true))
+
+(for-each (lambda (name)
+ (local-assignment system-global-environment name
+ (lexical-reference compiler-package name)))
+ '(COMPILE-BIN-FILE COMPILE-PROCEDURE COMPILER:RESET!))
+(toggle-gc-notification!)
\ No newline at end of file
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules1.scm,v 1.0 1988/01/05 15:58:25 bal Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; VAX LAP Generation Rules: Data Transfers
+;;; Matches MC68020 version 1.6
+
+(declare (usual-integrations))
+\f
+;;;; Transfers to Registers
+
+;;; All assignments to pseudo registers are required to delete the
+;;; dead registers BEFORE performing the assignment. This is because
+;;; the register being assigned may be PSEUDO-REGISTER=? to one of the
+;;; dead registers, and thus would be flushed if the deletions
+;;; happened after the assignment.
+
+(define-rule statement
+ (ASSIGN (REGISTER 10) (REGISTER 14))
+ (enable-frame-pointer-offset! 0)
+ (LAP))
+
+(define-rule statement
+ (ASSIGN (REGISTER 14) (OFFSET-ADDRESS (REGISTER 14) (? n)))
+ (decrement-frame-pointer-offset! n (increment-rnl 14 n)))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER 14) (? n)))
+ (QUALIFIER (pseudo-register? target))
+ ;; An alias is used here as eager register caching. It wins often.
+ (let ((offset (* 4 n)))
+ (LAP
+ (MOVA L (@RO ,(offset-type offset) 14 ,offset)
+ ,(reference-assignment-alias! target 'GENERAL)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER 14) (REGISTER (? source)))
+ (disable-frame-pointer-offset!
+ (LAP (MOV L ,(coerce->any source) (R 14)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (CONSTANT (? source)))
+ (QUALIFIER (pseudo-register? target))
+ (LAP ,(load-constant source (coerce->any target))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name)))
+ (QUALIFIER (pseudo-register? target))
+ (LAP (MOV L
+ (@PCR ,(free-reference-label name))
+ ,(reference-assignment-alias! target 'GENERAL))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (REGISTER (? source)))
+ (QUALIFIER (pseudo-register? target))
+ (move-to-alias-register! source 'GENERAL target)
+ (LAP))
+\f
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (with-register-copy-alias! source 'GENERAL target
+ (lambda (target)
+ (LAP (BIC L ,mask-reference ,target)))
+ (lambda (source target)
+ (LAP (BIC L ,mask-reference ,source ,target)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target))
+ (with-register-copy-alias! source 'GENERAL target
+ (lambda (target)
+ (LAP (ROTL (S 8) ,target ,target)))
+ (lambda (source target)
+ (LAP (ROTL (S 8) ,source ,target)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset)))
+ (QUALIFIER (pseudo-register? target))
+ (let ((source (indirect-reference! address offset)))
+ (delete-dead-registers!)
+ (LAP (MOV L
+ ,source
+ ,(register-reference
+ (allocate-alias-register! target 'GENERAL))))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 14) 1))
+ (QUALIFIER (pseudo-register? target))
+ (record-pop!)
+ (delete-dead-registers!)
+ (LAP (MOV L
+ (@R+ 14)
+ ,(register-reference
+ (allocate-alias-register! target 'GENERAL)))))
+
+(define-rule statement
+ (ASSIGN (REGISTER (? target))
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? datum))))
+ (QUALIFIER (pseudo-register? target))
+ (let ((target* (coerce->any target))
+ (datum (coerce->any datum)))
+ (delete-dead-registers!)
+ (let ((can-bump? (bump-type target*)))
+ (if (not can-bump?)
+ (LAP (MOV L ,datum ,reg:temp)
+ (MOV B ,(immediate-type type) ,reg:temp-type)
+ (MOV L ,reg:temp ,target*))
+ (LAP (MOV L ,datum ,target*)
+ (MOV B ,(immediate-type type) ,can-bump?))))))
+\f
+;;;; Transfers to Memory
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (CONSTANT (? object)))
+ (LAP ,(load-constant object (indirect-reference! a n))))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (UNASSIGNED))
+ (LAP ,(load-non-pointer (ucode-type unassigned) 0
+ (indirect-reference! a n))))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (REGISTER (? r)))
+ (LAP (MOV L
+ ,(coerce->any r)
+ ,(indirect-reference! a n))))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (POST-INCREMENT (REGISTER 14) 1))
+ (record-pop!)
+ (LAP (MOV L
+ (@R+ 14)
+ ,(indirect-reference! a n))))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? a)) (? n))
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+ (let ((target (indirect-reference! a n)))
+ (LAP (MOV L ,(coerce->any r) ,target)
+ (MOV B ,(immediate-type type) ,(bump-type target)))))
+
+(define-rule statement
+ (ASSIGN (OFFSET (REGISTER (? r0)) (? n0))
+ (OFFSET (REGISTER (? r1)) (? n1)))
+ (let ((source (indirect-reference! r1 n1)))
+ (LAP (MOV L
+ ,source
+ ,(indirect-reference! r0 n0)))))
+\f
+;;;; Consing
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (CONSTANT (? object)))
+ (LAP ,(load-constant object (INST-EA (@R+ 12)))))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (UNASSIGNED))
+ (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@R+ 12)))))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (REGISTER (? r)))
+ (LAP (MOV L ,(coerce->any r) (@R+ 12))))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (OFFSET (REGISTER (? r)) (? n)))
+ (LAP (MOV L ,(indirect-reference! r n) (@R+ 12))))
+
+(define-rule statement
+ (ASSIGN (POST-INCREMENT (REGISTER 12) 1) (ENTRY:PROCEDURE (? label)))
+ (LAP (MOVA B (@PCR ,(procedure-external-label (label->procedure label)))
+ (@R+ 12))
+ (MOV B ,(immediate-type (ucode-type compiled-expression))
+ (@RO B 12 -1))))
+\f
+;;;; Pushes
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (CONSTANT (? object)))
+ (record-push!
+ (LAP ,(push-constant object))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (UNASSIGNED))
+ (record-push!
+ (LAP ,(push-non-pointer (ucode-type unassigned) 0))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (REGISTER (? r)))
+ (record-push!
+ (if (= r regnum:frame-pointer)
+ (LAP (PUSHA L ,(offset-reference regnum:stack-pointer
+ (frame-pointer-offset)))
+ (MOV B ,(immediate-type (ucode-type stack-environment))
+ (@RO B 14 3)))
+ (LAP (PUSHL ,(coerce->any r))))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
+ (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r))))
+ (record-push!
+ (LAP (PUSHL ,(coerce->any r))
+ (MOV B ,(immediate-type type) (@RO B 14 3)))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (OFFSET (REGISTER (? r)) (? n)))
+ (record-push!
+ (LAP (PUSHL ,(indirect-reference! r n)))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1)
+ (OFFSET-ADDRESS (REGISTER 10) (? n)))
+ (record-push!
+ (LAP (PUSHA L ,(offset-reference regnum:stack-pointer
+ (+ n (frame-pointer-offset))))
+ (MOV B ,(immediate-type (ucode-type stack-environment))
+ (@RO B 14 3)))))
+
+(define-rule statement
+ (ASSIGN (PRE-INCREMENT (REGISTER 14) -1) (ENTRY:CONTINUATION (? label)))
+ (record-continuation-frame-pointer-offset! label)
+ (record-push!
+ (LAP (PUSHA B (@PCR ,label))
+ (MOV B ,(immediate-type (ucode-type compiler-return-address))
+ (@RO B 14 3)))))
--- /dev/null
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/vax/rules2.scm,v 1.0 1988/01/05 15:58:40 bal Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; VAX LAP Generation Rules: Predicates
+;;; Matches MC68020 version 1.3
+
+(declare (usual-integrations))
+\f
+;;;; Predicates
+
+(define-rule predicate
+ (TRUE-TEST (REGISTER (? register)))
+ (set-standard-branches! 'NEQU)
+ (LAP ,(test-non-pointer (ucode-type false) 0 (coerce->any register))))
+
+(define-rule predicate
+ (TRUE-TEST (OFFSET (REGISTER (? register)) (? offset)))
+ (set-standard-branches! 'NEQ)
+ (LAP ,(test-non-pointer (ucode-type false) 0
+ (indirect-reference! register offset))))
+
+(define-rule predicate
+ (TYPE-TEST (REGISTER (? register)) (? type))
+ (QUALIFIER (pseudo-register? register))
+ (set-standard-branches! 'EQLU)
+ (LAP ,(test-byte type
+ (register-reference
+ (load-alias-register! register 'GENERAL)))))
+
+(define-rule predicate
+ (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
+ (QUALIFIER (pseudo-register? register))
+ (set-standard-branches! 'EQLU)
+ (with-temporary-register-copy! register 'GENERAL
+ (lambda (reference)
+ (LAP (ROTL (S 8) ,reference ,reference)
+ ,(test-byte type reference)))
+ (lambda (source reference)
+ (LAP (ROTL (S 8) ,source ,reference)
+ ,(test-byte type reference)))))
+
+(define-rule predicate
+ (UNASSIGNED-TEST (REGISTER (? register)))
+ (set-standard-branches! 'EQLU)
+ (LAP ,(test-non-pointer (ucode-type unassigned) 0
+ (coerce->any register))))
+
+(define-rule predicate
+ (UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset)))
+ (set-standard-branches! 'EQLU)
+ (LAP ,(test-non-pointer (ucode-type unassigned) 0
+ (indirect-reference! register offset))))
+\f
+;; *** Is all this hair needed on the VAX?
+;; The CMP instruction operates anywhere. ***
+;; *** All CMP instructions may be "backwards" ***
+
+(define (eq-test/constant*register constant register)
+ (set-standard-branches! 'EQLU)
+ (if (non-pointer-object? constant)
+ (LAP ,(test-non-pointer (primitive-type constant)
+ (primitive-datum constant)
+ (coerce->any register)))
+ (LAP (CMP L (@PCR ,(constant->label constant))
+ ,(coerce->machine-register register)))))
+
+(define (eq-test/constant*memory constant memory-reference)
+ (set-standard-branches! 'EQLU)
+ (if (non-pointer-object? constant)
+ (LAP ,(test-non-pointer (primitive-type constant)
+ (primitive-datum constant)
+ memory-reference))
+ (LAP (CMP L (@PCR ,(constant->label constant))
+ ,memory-reference))))
+
+(define (eq-test/register*register register-1 register-2)
+ (set-standard-branches! 'EQLU)
+ (LAP (CMP L ,(coerce->any register-2)
+ ,(coerce->any register-1))))
+
+(define (eq-test/register*memory register memory-reference)
+ (set-standard-branches! 'EQLU)
+ (LAP (CMP L ,memory-reference
+ ,(coerce->machine-register register))))
+
+(define (eq-test/memory*memory register-1 offset-1 register-2 offset-2)
+ (set-standard-branches! 'EQLU)
+ (let ((temp (reference-temporary-register! false)))
+ (let ((finish
+ (lambda (register-1 offset-1 register-2 offset-2)
+ (LAP (MOV L ,(indirect-reference! register-1 offset-1)
+ ,temp)
+ (CMP L ,(indirect-reference! register-2 offset-2)
+ ,temp)))))
+ (if (or (and (not (register-has-alias? register-1 'GENERAL))
+ (register-has-alias? register-2 'GENERAL))
+ (and (not (register-has-alias? register-1 'GENERAL))
+ (register-has-alias? register-2 'GENERAL)))
+ (finish register-2 offset-2 register-1 offset-1)
+ (finish register-1 offset-1 register-2 offset-2)))))
+\f
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
+ (eq-test/constant*register constant register))
+
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant)) (REGISTER (? register)))
+ (eq-test/constant*register constant register))
+
+(define-rule predicate
+ (EQ-TEST (OFFSET (REGISTER (? register)) (? offset)) (CONSTANT (? constant)))
+ (eq-test/constant*memory constant (indirect-reference! register offset)))
+
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant)) (OFFSET (REGISTER (? register)) (? offset)))
+ (eq-test/constant*memory constant (indirect-reference! register offset)))
+
+(define-rule predicate
+ (EQ-TEST (CONSTANT (? constant)) (POST-INCREMENT (REGISTER 14) 1))
+ (eq-test/constant*memory constant (INST-EA (@R+ 14))))
+
+(define-rule predicate
+ (EQ-TEST (POST-INCREMENT (REGISTER 14) 1) (CONSTANT (? constant)))
+ (eq-test/constant*memory constant (INST-EA (@R+ 14))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
+ (eq-test/register*register register-1 register-2))
+
+(define-rule predicate
+ (EQ-TEST (OFFSET (REGISTER (? register-1)) (? offset-1))
+ (REGISTER (? register-2)))
+ (eq-test/register*memory register-2
+ (indirect-reference! register-1 offset-1)))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register-1))
+ (OFFSET (REGISTER (? register-2)) (? offset-2)))
+ (eq-test/register*memory register-1
+ (indirect-reference! register-2 offset-2)))
+
+(define-rule predicate
+ (EQ-TEST (POST-INCREMENT (REGISTER 14) 1) (REGISTER (? register)))
+ (record-pop!)
+ (eq-test/register*memory register (INST-EA (@R+ 14))))
+
+(define-rule predicate
+ (EQ-TEST (REGISTER (? register)) (POST-INCREMENT (REGISTER 14) 1))
+ (record-pop!)
+ (eq-test/register*memory register (INST-EA (@R+ 14))))
+
+(define-rule predicate
+ (EQ-TEST (OFFSET (REGISTER (? register-1)) (? offset-1))
+ (OFFSET (REGISTER (? register-2)) (? offset-2)))
+ (eq-test/memory*memory register-1 offset-1 register-2 offset-2))
\ No newline at end of file
projects / mit-scheme.git / commitdiff