From 9e49d7a5e5ce244dd8d44f01b98fc80bd5846466 Mon Sep 17 00:00:00 2001 From: "Brian A. LaMacchia" Date: Tue, 5 Jan 1988 15:58:40 +0000 Subject: [PATCH] Initial revision --- v7/src/compiler/machines/vax/lapgen.scm | 348 ++++++++++++++++++++++++ v7/src/compiler/machines/vax/make.scm | 194 +++++++++++++ v7/src/compiler/machines/vax/rules1.scm | 259 ++++++++++++++++++ v7/src/compiler/machines/vax/rules2.scm | 186 +++++++++++++ 4 files changed, 987 insertions(+) create mode 100644 v7/src/compiler/machines/vax/lapgen.scm create mode 100644 v7/src/compiler/machines/vax/make.scm create mode 100644 v7/src/compiler/machines/vax/rules1.scm create mode 100644 v7/src/compiler/machines/vax/rules2.scm diff --git a/v7/src/compiler/machines/vax/lapgen.scm b/v7/src/compiler/machines/vax/lapgen.scm new file mode 100644 index 000000000..8b8ba040d --- /dev/null +++ b/v7/src/compiler/machines/vax/lapgen.scm @@ -0,0 +1,348 @@ +#| -*-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)) + +;;;; 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))))) + +;; 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)))))))) + +(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)))) + +(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))) + +(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))))))) + +(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))) + +;;;; 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))) + +(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 diff --git a/v7/src/compiler/machines/vax/make.scm b/v7/src/compiler/machines/vax/make.scm new file mode 100644 index 000000000..b79777263 --- /dev/null +++ b/v7/src/compiler/machines/vax/make.scm @@ -0,0 +1,194 @@ +#| -*-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)) + +;(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 diff --git a/v7/src/compiler/machines/vax/rules1.scm b/v7/src/compiler/machines/vax/rules1.scm new file mode 100644 index 000000000..f6c9fed57 --- /dev/null +++ b/v7/src/compiler/machines/vax/rules1.scm @@ -0,0 +1,259 @@ +#| -*-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)) + +;;;; 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)) + +(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?)))))) + +;;;; 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))))) + +;;;; 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)))) + +;;;; 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))))) diff --git a/v7/src/compiler/machines/vax/rules2.scm b/v7/src/compiler/machines/vax/rules2.scm new file mode 100644 index 000000000..0b87e7bbe --- /dev/null +++ b/v7/src/compiler/machines/vax/rules2.scm @@ -0,0 +1,186 @@ +#| -*-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)) + +;;;; 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)))) + +;; *** 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))))) + +(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 -- 2.25.1