From 8bf2d36323ff519f751099d153e46792432a127a Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Wed, 8 Jul 1987 22:10:08 +0000 Subject: [PATCH] The RTL is now translated directly to bits, rather than LAP. --- v7/src/compiler/back/asmmac.scm | 14 +- v7/src/compiler/back/lapgn1.scm | 6 +- v7/src/compiler/back/lapgn2.scm | 4 +- v7/src/compiler/back/lapgn3.scm | 4 +- v7/src/compiler/back/regmap.scm | 34 +- v7/src/compiler/back/syntax.scm | 98 ++-- v7/src/compiler/machines/bobcat/insmac.scm | 176 ++++++-- v7/src/compiler/machines/bobcat/instr1.scm | 418 ++++-------------- v7/src/compiler/machines/bobcat/instr2.scm | 208 ++++----- v7/src/compiler/machines/bobcat/instr3.scm | 146 +++--- v7/src/compiler/machines/bobcat/lapgen.scm | 191 ++++---- v7/src/compiler/machines/bobcat/machin.scm | 29 +- .../compiler/machines/bobcat/make.scm-68040 | 28 +- v7/src/compiler/machines/bobcat/rules1.scm | 113 ++--- v7/src/compiler/machines/bobcat/rules2.scm | 12 +- v7/src/compiler/machines/bobcat/rules3.scm | 314 ++++++------- v7/src/compiler/machines/bobcat/rules4.scm | 34 +- 17 files changed, 850 insertions(+), 979 deletions(-) diff --git a/v7/src/compiler/back/asmmac.scm b/v7/src/compiler/back/asmmac.scm index ef75dd962..311c88340 100644 --- a/v7/src/compiler/back/asmmac.scm +++ b/v7/src/compiler/back/asmmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.2 1987/03/19 00:49:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/asmmac.scm,v 1.3 1987/07/08 22:00:25 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -50,10 +50,9 @@ MIT in each case. |# `(LIST ,@(map (lambda (case) (parse-rule (car case) (cdr case) - (lambda (pattern names transformer qualifier actions) + (lambda (pattern variables qualifier actions) `(CONS ',pattern - ,(rule-result-expression names - transformer + ,(rule-result-expression variables qualifier (procedure pattern actions)))))) @@ -95,11 +94,14 @@ MIT in each case. |# (define-integrable (make-constant bit-string) `',bit-string) - (lambda components + (lambda (components early?) (let ((components (find-constant components))) (cond ((null? components) (error "OPTIMIZE-GROUP-SYNTAX: No components in group!")) ((null? (cdr components)) (car components)) (else - `(OPTIMIZE-GROUP ,@components))))))) \ No newline at end of file + `(,(if early? + 'OPTIMIZE-GROUP-EARLY + 'OPTIMIZE-GROUP) + ,@components))))))) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index f92ea948c..6ab80acb1 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.38 1987/06/29 20:31:38 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.39 1987/07/08 22:00:41 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -43,7 +43,7 @@ MIT in each case. |# (define *dead-registers*) (define *continuation-queue*) -(define (generate-lap quotations procedures continuations receiver) +(define (generate-bits quotations procedures continuations receiver) (with-new-node-marks (lambda () (fluid-let ((*next-constant* 0) @@ -123,7 +123,7 @@ MIT in each case. |# (rnode-frame-pointer-offset rnode))) (let ((instructions (match-result))) (set-rnode-lap! rnode - (append! *prefix-instructions* instructions))) + (LAP ,@*prefix-instructions* ,@instructions))) (delete-dead-registers!) (set-rnode-register-map! rnode *register-map*) *frame-pointer-offset*) diff --git a/v7/src/compiler/back/lapgn2.scm b/v7/src/compiler/back/lapgn2.scm index c9639c235..b0b87f3c3 100644 --- a/v7/src/compiler/back/lapgn2.scm +++ b/v7/src/compiler/back/lapgn2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.2 1987/06/15 22:04:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.3 1987/07/08 22:01:02 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -41,7 +41,7 @@ MIT in each case. |# (define *needed-registers*) (define-integrable (prefix-instructions! instructions) - (set! *prefix-instructions* (append! *prefix-instructions* instructions))) + (set! *prefix-instructions* (LAP ,@*prefix-instructions* ,@instructions))) (define-integrable (need-register! register) (set! *needed-registers* (cons register *needed-registers*))) diff --git a/v7/src/compiler/back/lapgn3.scm b/v7/src/compiler/back/lapgn3.scm index 4b8b38eb2..9597557d7 100644 --- a/v7/src/compiler/back/lapgn3.scm +++ b/v7/src/compiler/back/lapgn3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 1.1 1987/06/13 21:18:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 1.2 1987/07/08 22:01:20 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -46,7 +46,7 @@ MIT in each case. |# (define (allocate-constant-label) (let ((label (string->symbol - (string-append "CONSTANT-" (write-to-string *next-constant*))))) + (string-append "CONSTANT-" (number->string *next-constant*))))) (set! *next-constant* (1+ *next-constant*)) label)) diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm index 20bde5a4d..d57f57b4f 100644 --- a/v7/src/compiler/back/regmap.scm +++ b/v7/src/compiler/back/regmap.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 1.89 1987/06/13 20:16:51 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 1.90 1987/07/08 22:01:47 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -297,15 +297,15 @@ REGISTER-RENUMBERs are equal. (allocator-values alias (register-map:add-alias map entry alias) - (append! instructions - (register->register-transfer - (map-entry:any-alias entry) - alias))) + (LAP ,@instructions + ,@(register->register-transfer + (map-entry:any-alias entry) + alias))) (allocator-values alias (register-map:add-home map home alias true) - (append! instructions - (home->register-transfer home alias))))))))) + (LAP ,@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 @@ -465,8 +465,8 @@ REGISTER-RENUMBERs are equal. (let ((instructions (loop (cdr entries)))) (if (map-entry-saved-into-home? (car entries)) instructions - (append! (save-into-home-instruction (car entries)) - instructions))))) + (LAP ,@(save-into-home-instruction (car entries)) + ,@instructions))))) loop) (define (shared-loop tail) @@ -477,9 +477,9 @@ REGISTER-RENUMBERs are equal. (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))))) + (LAP ,@(register->register-transfer (car input-aliases) + (car output-aliases)) + ,@(loop (cdr output-aliases))))) (loop (eqv-set-difference (map-entry-aliases (cdar entries)) input-aliases))))) loop) @@ -494,11 +494,11 @@ REGISTER-RENUMBERs are equal. (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)))) + (LAP ,@(register->register-transfer (car aliases) + (car registers)) + ,@(loop (cdr registers))))) + (LAP ,@(home->register-transfer home (car aliases)) + ,@(loop (cdr aliases)))) instructions)))) ) \ No newline at end of file diff --git a/v7/src/compiler/back/syntax.scm b/v7/src/compiler/back/syntax.scm index d5c1d4da0..9eb1bbb13 100644 --- a/v7/src/compiler/back/syntax.scm +++ b/v7/src/compiler/back/syntax.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.14 1987/05/26 13:24:04 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/syntax.scm,v 1.15 1987/07/08 22:03:07 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,32 +36,36 @@ MIT in each case. |# (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 (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 (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) + (define (internal directives) + (map (lambda (directive) + (cond ((bit-string? directive) (vector 'CONSTANT directive)) + ((pair? directive) + (if (eq? (car directive) 'GROUP) + (vector 'GROUP (internal (cdr directive))) + (list->vector directive))) + ((vector? directive) directive) + (else + (error "CONVERT-OUTPUT: Unknown directive" directive)))) + directives)) + (internal (instruction-sequence->directives directives))) + +(define-export (lap:syntax-instruction instruction) (if (memq (car instruction) '(EQUATE SCHEME-OBJECT ENTRY-POINT LABEL)) - (list instruction) + (directive->instruction-sequence instruction) (let ((match-result (instruction-lookup instruction))) - (or (and match-result (match-result)) - (error "SYNTAX-INSTRUCTION: Badly formed instruction" + (or (and match-result + (instruction->instruction-sequence (match-result))) + (error "LAP:SYNTAX-INSTRUCTION: Badly formed instruction" instruction))))) (define (instruction-lookup instruction) @@ -91,30 +95,18 @@ MIT in each case. |# (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 (optimize-group . components) + (optimize-group-internal components + (lambda (result make-group?) + (if make-group? + `(GROUP ,@result) + result)))) + +;; For completeness + +(define optimize-group-early optimize-group) -(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 +(define optimize-group-internal (let () (define (loop1 components) (cond ((null? components) '()) @@ -135,20 +127,22 @@ MIT in each case. |# (cons (car components) (loop1 (cdr components))))))) - (lambda components + (lambda (components receiver) (let ((components (loop1 components))) - (cond ((null? components) (error "OPTIMIZE-GROUP: No components")) - ((null? (cdr components)) (car components)) - (else `(GROUP ,@components))))))) + (cond ((null? components) + (error "OPTIMIZE-GROUP: No components")) + ((null? (cdr components)) + (receiver (car components) false)) + (else (receiver components true))))))) ;;;; Coercion Machinery (define (make-coercion-name coercion-type size) (string->symbol (string-append "COERCE-" - (write-to-string size) + (number->string size) "-BIT-" - (write-to-string coercion-type)))) + (symbol->string coercion-type)))) (define coercion-property-tag "Coercion") diff --git a/v7/src/compiler/machines/bobcat/insmac.scm b/v7/src/compiler/machines/bobcat/insmac.scm index 70bd10805..aa66e115f 100644 --- a/v7/src/compiler/machines/bobcat/insmac.scm +++ b/v7/src/compiler/machines/bobcat/insmac.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.118 1987/03/19 00:52:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/insmac.scm,v 1.119 1987/07/08 22:05:47 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,27 +36,30 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Instruction Definitions +;;;; Effective addressing -(syntax-table-define assembler-syntax-table 'MAKE-EA-DATABASE +(define ea-database-name 'ea-database) + +(syntax-table-define assembler-syntax-table 'DEFINE-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)))))) + `(define ,ea-database-name + ,(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 + ,(integer-syntaxer mode 'UNSIGNED 3) + ,(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 @@ -65,29 +68,90 @@ MIT in each case. |# (if (or source destination) (error "Source or destination used" 'EXTENSION-WORD) (if (zero? (remainder size 16)) - (apply optimize-group-syntax instruction) + (optimize-group-syntax instruction false) (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))))) +;;;; Transformers + +(syntax-table-define assembler-syntax-table 'DEFINE-EA-TRANSFORMER + (macro (name #!optional categories keywords) + (define (filter special generator extraction) + (define (multiple rem) + (if (null? rem) + `() + `(,(generator (car rem) 'temp) + ,@(multiple (cdr rem))))) + + (cond ((null? special) + `()) + ((null? (cdr special)) + `(,(generator (car special) extraction))) + (else + `((let ((temp ,extraction)) + (and ,@(multiple special))))))) + + `(define (,name expression) + (let ((match-result (pattern-lookup ,ea-database-name expression))) + (and match-result + ,(if (unassigned? categories) + `(match-result) + `(let ((ea (match-result))) + (and ,@(filter categories + (lambda (cat exp) `(memq ',cat ,exp)) + `(ea-categories ea)) + ,@(if (unassigned? keywords) + `() + (filter keywords + (lambda (key exp) `(not (eq? ',key ,exp))) + `(ea-keyword ea))) + ea)))))))) + +(syntax-table-define assembler-syntax-table 'DEFINE-SYMBOL-TRANSFORMER + (macro (name . alist) + `(begin + (declare (integrate-operator ,name)) + (define (,name symbol) + (declare (integrate symbol)) + (let ((place (assq symbol ',alist))) + (if (null? place) + #F + (cdr place))))))) + +(syntax-table-define assembler-syntax-table 'DEFINE-REG-LIST-TRANSFORMER + (macro (name . alist) + `(begin + (declare (integrate-operator ,name)) + (define (,name reg-list) + (declare (integrate reg-list)) + (encode-register-list reg-list ',alist))))) + +;;;; Utility procedures + +(define (parse-word expression tail #!optional early?) + (define (kernel) + (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) + ,(optimize-group-syntax instruction + (if (unassigned? early?) false early?)) + ,code)) + (error "PARSE-WORD: Instructions must be 16 bit multiples" size))))) + (if (or (unassigned? early?) (not early?)) + (kernel) + (with-early-selectors kernel))) (define (expand-descriptors descriptors receiver) (if (null? descriptors) @@ -111,6 +175,20 @@ MIT in each case. |# destination) destination*)))))))) +(define ea-keyword-selector 'EA-KEYWORD) +(define ea-categories-selector 'EA-CATEGORIES) +(define ea-mode-selector 'EA-MODE) +(define ea-register-selector 'EA-REGISTER) +(define ea-extension-selector 'EA-EXTENSION) + +(define (with-early-selectors handle) + (fluid-let ((ea-keyword-selector 'EA-KEYWORD-EARLY) + (ea-categories-selector 'EA-CATEGORIES-EARLY) + (ea-mode-selector 'EA-MODE-EARLY) + (ea-register-selector 'EA-REGISTER-EARLY) + (ea-extension-selector 'EA-EXTENSION-EARLY)) + (handle))) + (define (expand-descriptor descriptor receiver) (let ((size (car descriptor)) (expression (cadr descriptor)) @@ -127,22 +205,22 @@ MIT in each case. |# size)) size false false)) ((SOURCE-EA) - (receiver `(((EA-MODE ,expression)) - ((EA-REGISTER ,expression))) + (receiver `((,ea-mode-selector ,expression) + (,ea-register-selector ,expression)) size - `((EA-EXTENSION ,expression) ,(cadddr descriptor)) + `((,ea-extension-selector ,expression) ,(cadddr descriptor)) false)) ((DESTINATION-EA) - (receiver `(((EA-MODE ,expression)) - ((EA-REGISTER ,expression))) + (receiver `((,ea-mode-selector ,expression) + (,ea-register-selector ,expression)) size false - `((EA-EXTENSION ,expression) '()))) + `((,ea-extension-selector ,expression) '()))) ((DESTINATION-EA-REVERSED) - (receiver `(((EA-REGISTER ,expression)) - ((EA-MODE ,expression))) + (receiver `((,ea-register-selector ,expression) + (,ea-mode-selector ,expression)) size false - `((EA-EXTENSION ,expression) '()))) + `((,ea-extension-selector ,expression) '()))) (else (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 index 317483f78..6caf7caff 100644 --- a/v7/src/compiler/machines/bobcat/instr1.scm +++ b/v7/src/compiler/machines/bobcat/instr1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.61 1987/04/27 20:26:11 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr1.scm,v 1.62 1987/07/08 22:06:08 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -37,359 +37,107 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Effective Addressing +;;;; Effective Address transformers and description database -(define (make-effective-address keyword mode register extension categories) - (vector ea-tag keyword mode register extension categories)) +(define-ea-database + ((D (? r)) (DATA ALTERABLE) #b000 r) -(define (effective-address? object) - (and (vector? object) - (not (zero? (vector-length object))) - (eq? (vector-ref object 0) ea-tag))) + ((A (? r)) (ALTERABLE) #b001 r) -(define ea-tag - "Effective-Address") + ((@A (? r)) (DATA MEMORY CONTROL ALTERABLE) #b010 r) -(define-integrable (ea-keyword ea) - (vector-ref ea 1)) + ((@D (? r)) + (DATA MEMORY CONTROL ALTERABLE) #b110 #b000 + (output-@D-indirect r)) -(define-integrable (ea-mode ea) - (vector-ref ea 2)) + ((@A+ (? r)) (DATA MEMORY ALTERABLE) #b011 r) -(define-integrable (ea-register ea) - (vector-ref ea 3)) + ((@-A (? r)) (DATA MEMORY ALTERABLE) #b100 r) -(define-integrable (ea-extension ea) - (vector-ref ea 4)) + ((@AO (? r) (? o)) + (DATA MEMORY CONTROL ALTERABLE) #b101 r + (output-16bit-offset o)) -(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 + ((@AR (? r) (? l)) + (DATA MEMORY CONTROL ALTERABLE) #b101 r + (output-16bit-relative l)) -(define ea-database - (make-ea-database - ((D (? r)) (DATA ALTERABLE) #b000 r) + ((@DO (? r) (? o)) + (DATA MEMORY CONTROL ALTERABLE) #b110 #b000 + (output-@DO-indirect r o)) + + ((@AOX (? r) (? o) (? xtype da) (? xr) (? s wl)) + (DATA MEMORY CONTROL ALTERABLE) #b110 r + (output-offset-index-register xtype xr s o)) - ((A (? r)) (ALTERABLE) #b001 r) + ((@ARX (? r) (? l) (? xtype da) (? xr) (? s wl)) + (DATA MEMORY CONTROL ALTERABLE) #b110 r + (output-relative-index-register xtype xr s l)) - ((@A (? r)) (DATA MEMORY CONTROL ALTERABLE) #b010 r) + ((W (? a)) + (DATA MEMORY CONTROL ALTERABLE) #b111 #b000 + (output-16bit-address a)) - ((@D (? r)) - (DATA MEMORY CONTROL ALTERABLE) #b110 #b000 - (output-@D-indirect r)) + ((L (? a)) + (DATA MEMORY CONTROL ALTERABLE) #b111 #b001 + (output-32bit-address a)) - ((@A+ (? r)) (DATA MEMORY ALTERABLE) #b011 r) + ((@PCO (? o)) + (DATA MEMORY CONTROL) #b111 #b010 + (output-16bit-offset o)) - ((@-A (? r)) (DATA MEMORY ALTERABLE) #b100 r) + ((@PCR (? l)) + (DATA MEMORY CONTROL) #b111 #b010 + (output-16bit-relative l)) - ((@AO (? r) (? o)) - (DATA MEMORY CONTROL ALTERABLE) #b101 r - (output-16bit-offset o)) + ((@PCOX (? o) (? xtype da) (? xr) (? s wl)) + (DATA MEMORY CONTROL) #b111 #b011 + (output-offset-index-register xtype xr s o)) - ((@AR (? r) (? l)) - (DATA MEMORY CONTROL ALTERABLE) #b101 r - (output-16bit-relative l)) + ((@PCRX (? l) (? xtype da) (? xr) (? s wl)) + (DATA MEMORY CONTROL) #b111 #b011 + (output-relative-index-register xtype xr s 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))) + ((& (? i)) + (DATA MEMORY) #b111 #b100 + (output-immediate-data immediate-size i))) -(define-integrable (immediate-word data) - (syntax-evaluation data coerce-16-bit-signed)) +(define-ea-transformer ea-all) -(define-integrable (immediate-long data) - (syntax-evaluation data coerce-32-bit-signed)) +(define-ea-transformer ea-d (DATA)) +(define-ea-transformer ea-a (ALTERABLE)) +(define-ea-transformer ea-c (CONTROL)) -(define-integrable (relative-word address) - (syntax-evaluation `(- ,address *PC*) coerce-16-bit-signed)) +(define-ea-transformer ea-d&a (DATA ALTERABLE)) +(define-ea-transformer ea-c&a (CONTROL ALTERABLE)) +(define-ea-transformer ea-m&a (MEMORY ALTERABLE)) -(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-operator 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-operator 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-ea-transformer ea-d&-& (DATA) (&)) +(define-ea-transformer ea-all-A () (A)) -(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)))) \ No newline at end of file +;;;; Special purpose transformers + +(define-symbol-transformer da (D . 0) (A . 1)) +(define-symbol-transformer nwl (N . 1) (W . 2) (L . 3)) +(define-symbol-transformer bwlq (B . 0) (W . 1) (L . 2) (Q . 3)) +(define-symbol-transformer bwl-b (W . 1) (L . 2)) +(define-symbol-transformer bwl (B . 0) (W . 1) (L . 2)) +(define-symbol-transformer bw (B . 0) (W . 1)) +(define-symbol-transformer wl (W . 0) (L . 1)) +(define-symbol-transformer lw (W . 1) (L . 0)) +(define-symbol-transformer rl (R . 0) (L . 1)) +(define-symbol-transformer us (U . 0) (S . 1)) +(define-symbol-transformer cc + (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-reg-list-transformer @+reg-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-reg-list-transformer @-reg-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)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/instr2.scm b/v7/src/compiler/machines/bobcat/instr2.scm index b2f9ef748..8b1119caf 100644 --- a/v7/src/compiler/machines/bobcat/instr2.scm +++ b/v7/src/compiler/machines/bobcat/instr2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr2.scm,v 1.9 1987/03/19 00:53:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr2.scm,v 1.10 1987/07/08 22:06:40 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -37,6 +37,12 @@ MIT in each case. |# (declare (usual-integrations)) +;;;; Pseudo ops + +(define-instruction DC + ((W (? expression)) + (WORD (16 expression SIGNED)))) + ;;;; BCD Arithmetic (let-syntax ((define-BCD-addition @@ -66,149 +72,162 @@ MIT in each case. |# (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)) + (define-instruction ,Qkeyword ;ADDQ + ((B (& (? data)) (? ea ea-all-A)) + (WORD (4 #b0101) + (3 data QUICK) + (1 ,Qbit) + (2 #b00) + (6 ea DESTINATION-EA))) + + (((? s bwl-b) (& (? data)) (? ea ea-all)) (WORD (4 #b0101) (3 data QUICK) (1 ,Qbit) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA)))) (define-instruction ,keyword - (((? s) (& (? data)) (? ea ea-d&a)) ;ADDI - (QUALIFIER (bwl? s)) + (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) ;ADDI (WORD (4 #b0000) (4 ,Iopcode) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA)) - (immediate-words data s)) + (immediate-words data ssym)) - (((? s) (? ea ea-all) (D (? rx))) - (QUALIFIER (bwl? s) (ea-b=>-A ea s)) + ((B (? ea ea-all-A) (D (? rx))) (WORD (4 ,opcode) (3 rx) (1 #b0) - (2 (encode-bwl s)) - (6 ea SOURCE-EA s))) + (2 #b00) + (6 ea SOURCE-EA 'B))) - (((? s) (D (? rx)) (? ea ea-m&a)) - (QUALIFIER (bwl? s)) + (((? s bwl-b ssym) (? ea ea-all) (D (? rx))) + (WORD (4 ,opcode) + (3 rx) + (1 #b0) + (2 s) + (6 ea SOURCE-EA ssym))) + + (((? s bwl) (D (? rx)) (? ea ea-m&a)) (WORD (4 ,opcode) (3 rx) (1 #b1) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA))) - (((? s) (? ea ea-all) (A (? rx))) ;ADDA - (QUALIFIER (wl? s)) + (((? s wl ssym) (? ea ea-all) (A (? rx))) ;ADDA (WORD (4 ,opcode) (3 rx) - (1 (encode-wl s)) + (1 s) (2 #b11) - (6 ea SOURCE-EA s)))) + (6 ea SOURCE-EA ssym)))) (define-instruction ,Xkeyword - (((? s) (D (? ry)) (D (? rx))) - (QUALIFIER (bwl? s)) + (((? s bwl) (D (? ry)) (D (? rx))) (WORD (4 ,opcode) (3 rx) (1 #b1) - (2 (encode-bwl s)) + (2 s) (3 #b000) (3 ry))) - (((? s) (@-A (? ry)) (@-A (? rx))) - (QUALIFIER (bwl? s)) + (((? s bwl) (@-A (? ry)) (@-A (? rx))) (WORD (4 ,opcode) (3 rx) (1 #b1) - (2 (encode-bwl s)) + (2 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)) + (((? sgn us) (D (? rx)) (? ea ea-d)) (WORD (4 #b1000) (3 rx) - (1 (encode-us sgn)) + (1 sgn) (2 #b11) (6 ea SOURCE-EA 'W)))) (define-instruction EXT - (((? s) (D (? rx))) - (QUALIFIER (wl? s)) + (((? s wl) (D (? rx))) (WORD (9 #b010010001) - (1 (encode-wl s)) + (1 s) (3 #b000) (3 rx)))) (define-instruction MUL - (((? sgn) (? ea ea-d) (D (? rx))) - (QUALIFIER (us? sgn)) + (((? sgn us) (? ea ea-d) (D (? rx))) (WORD (4 #b1100) (3 rx) - (1 (encode-us sgn)) + (1 sgn) (2 #b11) (6 ea SOURCE-EA 'W)))) (define-instruction NEG - (((? s) (? dea ea-d&a)) - (QUALIFIER (bwl? s)) + (((? s bwl) (? dea ea-d&a)) (WORD (8 #b01000100) - (2 (encode-bwl s)) + (2 s) (6 dea DESTINATION-EA)))) (define-instruction NEGX - (((? s) (? dea ea-d&a)) - (QUALIFIER (bwl? s)) + (((? s bwl) (? dea ea-d&a)) (WORD (8 #b01000000) - (2 (encode-bwl s)) + (2 s) (6 dea DESTINATION-EA)))) ;;;; Comparisons (define-instruction CMP - (((? s) (? ea ea-all) (D (? rx))) - (QUALIFIER (bwl? s) (ea-b=>-A ea s)) + ((B (? ea ea-all-A) (D (? rx))) + (WORD (4 #b1011) + (3 rx) + (1 #b0) + (2 #b00) + (6 ea SOURCE-EA 'B))) + + (((? s bwl-b ssym) (? ea ea-all) (D (? rx))) (WORD (4 #b1011) (3 rx) (1 #b0) - (2 (encode-bwl s)) - (6 ea SOURCE-EA s))) + (2 s) + (6 ea SOURCE-EA ssym))) - (((? s) (? ea ea-all) (A (? rx))) ;CMPA - (QUALIFIER (wl? s)) + (((? s wl ssym) (? ea ea-all) (A (? rx))) ;CMPA (WORD (4 #b1011) (3 rx) - (1 (encode-wl s)) + (1 s) (2 #b11) - (6 ea SOURCE-EA s))) + (6 ea SOURCE-EA ssym))) - (((? s) (& (? data)) (? ea ea-d&a)) ;CMPI - (QUALIFIER (bwl? s)) + (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) ;CMPI (WORD (8 #b00001100) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA)) - (immediate-words data s)) + (immediate-words data ssym)) - (((? s) (@A+ (? ry)) (@A+ (? rx))) ;CMPM - (QUALIFIER (bwl? s)) + (((? s bwl) (@A+ (? ry)) (@A+ (? rx))) ;CMPM (WORD (4 #b1011) (3 rx) (1 #b1) - (2 (encode-bwl s)) + (2 s) (3 #b001) (3 ry)))) +;; Also provided for efficiency. Less rules to search. + +(define-instruction CMPI + (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) + (WORD (8 #b00001100) + (2 s) + (6 ea DESTINATION-EA)) + (immediate-words data ssym))) + (define-instruction TST - (((? s) (? dea ea-d&a)) - (QUALIFIER (bwl? s)) + (((? s bwl) (? dea ea-d&a)) (WORD (8 #b01001010) - (2 (encode-bwl s)) + (2 s) (6 dea DESTINATION-EA)))) ;;;; Bitwise Logical @@ -216,68 +235,60 @@ MIT in each case. |# (let-syntax ((define-bitwise-logical (macro (keyword opcode Iopcode) `(define-instruction ,keyword - (((? s) (? ea ea-d) (D (? rx))) - (QUALIFIER (bwl? s)) + (((? s bwl ssym) (? ea ea-d) (D (? rx))) (WORD (4 ,opcode) (3 rx) (1 #b0) - (2 (encode-bwl s)) - (6 ea SOURCE-EA s))) + (2 s) + (6 ea SOURCE-EA ssym))) - (((? s) (D (? rx)) (? ea ea-m&a)) - (QUALIFIER (bwl? s)) + (((? s bwl) (D (? rx)) (? ea ea-m&a)) (WORD (4 ,opcode) (3 rx) (1 #b1) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA))) - (((? s) (& (? data)) (? ea ea-d&a)) ;fooI - (QUALIFIER (bwl? s)) + (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) ;fooI (WORD (4 #b0000) (4 ,Iopcode) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA)) - (immediate-words data s)) + (immediate-words data ssym)) - (((? s) (& (? data)) (SR)) ;fooI to CCR/SR - (QUALIFIER (bw? s)) + (((? s bwl ssym) (& (? data)) (SR)) ;fooI to CCR/SR (WORD (4 #b0000) (4 ,Iopcode) - (2 (encode-bwl s)) + (2 s) (6 #b111100)) - (immediate-words data s)))))) + (immediate-words data ssym)))))) (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)) + (((? s bwl) (D (? rx)) (? ea ea-d&a)) (WORD (4 #b1011) (3 rx) (1 #b1) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA))) - (((? s) (& (? data)) (? ea ea-d&a)) ;EORI - (QUALIFIER (bwl? s)) + (((? s bwl ssym) (& (? data)) (? ea ea-d&a)) ;EORI (WORD (8 #b00001010) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA)) - (immediate-words data s)) + (immediate-words data ssym)) - (((? s) (& (? data)) (SR)) ;EORI to CCR/SR - (QUALIFIER (bw? s)) + (((? s bw ssym) (& (? data)) (SR)) ;EORI to CCR/SR (WORD (8 #b00001010) - (2 (encode-bwl s)) + (2 s) (6 #b111100)) - (immediate-words data s))) + (immediate-words data ssym))) (define-instruction NOT - (((? s) (? dea ea-d&a)) - (QUALIFIER (bwl? s)) + (((? s bwl) (? dea ea-d&a)) (WORD (8 #b01000110) - (2 (encode-bwl s)) + (2 s) (6 dea DESTINATION-EA)))) ;;;; Shift @@ -285,31 +296,28 @@ MIT in each case. |# (let-syntax ((define-shift-instruction (macro (keyword bits) `(define-instruction ,keyword - (((? d) (? s) (D (? ry)) (D (? rx))) - (QUALIFIER (rl? d) (bwl? s)) + (((? d rl) (? s bwl) (D (? ry)) (D (? rx))) (WORD (4 #b1110) (3 rx) - (1 (encode-rl d)) - (2 (encode-bwl s)) + (1 d) + (2 s) (1 #b1) (2 ,bits) (3 ry))) - (((? d) (? s) (& (? data)) (D (? ry))) - (QUALIFIER (rl? d) (bwl? s)) + (((? d rl) (? s bwl) (& (? data)) (D (? ry))) (WORD (4 #b1110) (3 data SHIFT-NUMBER) - (1 (encode-rl d)) - (2 (encode-bwl s)) + (1 d) + (2 s) (1 #b0) (2 ,bits) (3 ry))) - (((? d) (? ea ea-m&a)) - (QUALIFIER (rl? d)) + (((? d rl) (? ea ea-m&a)) (WORD (5 #b11100) (2 ,bits) - (1 (encode-rl d)) + (1 d) (2 #b11) (6 ea DESTINATION-EA))))))) (define-shift-instruction AS #b00) @@ -337,4 +345,4 @@ MIT in each case. |# (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)) \ No newline at end of file + (define-bit-manipulation BSET #b11 ea-d&a ea-d&a)) diff --git a/v7/src/compiler/machines/bobcat/instr3.scm b/v7/src/compiler/machines/bobcat/instr3.scm index 045d6090d..9e63db9da 100644 --- a/v7/src/compiler/machines/bobcat/instr3.scm +++ b/v7/src/compiler/machines/bobcat/instr3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.9 1987/03/19 00:53:25 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/instr3.scm,v 1.10 1987/07/08 22:07:19 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -40,29 +40,25 @@ MIT in each case. |# ;;;; Control Transfer (define-instruction B - (((? c) S (@PCO (? o))) - (QUALIFIER (cc? c)) + (((? c cc) S (@PCO (? o))) (WORD (4 #b0110) - (4 (encode-cc c)) + (4 c) (8 o SIGNED))) - (((? c) S (@PCR (? l))) - (QUALIFIER (cc? c)) + (((? c cc) S (@PCR (? l))) (WORD (4 #b0110) - (4 (encode-cc c)) + (4 c) (8 l SHORT-LABEL))) - (((? c) L (@PCO (? o))) - (QUALIFIER (cc? c)) + (((? c cc) L (@PCO (? o))) (WORD (4 #b0110) - (4 (encode-cc c)) + (4 c) (8 #b00000000)) (immediate-word o)) - (((? c) L (@PCR (? l))) - (QUALIFIER (cc? c)) + (((? c cc) L (@PCR (? l))) (WORD (4 #b0110) - (4 (encode-cc c)) + (4 c) (8 #b00000000)) (relative-word l))) @@ -101,18 +97,16 @@ MIT in each case. |# (relative-word l))) (define-instruction DB - (((? c) (D (? rx)) (@PCO (? o))) - (QUALIFIER (cc? c)) + (((? c cc) (D (? rx)) (@PCO (? o))) (WORD (4 #b0101) - (4 (encode-cc c)) + (4 c) (5 #b11001) (3 rx)) (immediate-word o)) - (((? c) (D (? rx)) (@PCR (? l))) - (QUALIFIER (cc? c)) + (((? c cc) (D (? rx)) (@PCR (? l))) (WORD (4 #b0101) - (4 (encode-cc c)) + (4 c) (5 #b11001) (3 rx)) (relative-word l))) @@ -189,10 +183,9 @@ MIT in each case. |# ;;;; Data Transfer (define-instruction CLR - (((? s) (? ea ea-d&a)) - (QUALIFIER (bwl? s)) + (((? s bwl) (? ea ea-d&a)) (WORD (8 #b01000010) - (2 (encode-bwl s)) + (2 s) (6 ea DESTINATION-EA)))) (define-instruction EXG @@ -233,10 +226,9 @@ MIT in each case. |# (6 cea DESTINATION-EA)))) (define-instruction S - (((? c) (? dea ea-d&a)) - (QUALIFIER (cc? c)) + (((? c cc) (? dea ea-d&a)) (WORD (4 #b0101) - (4 (encode-cc c)) + (4 c) (2 #b11) (6 dea DESTINATION-EA)))) @@ -245,28 +237,20 @@ MIT in each case. |# (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))) + ((B (? sea ea-all-A) (? dea ea-d&a)) + (WORD (3 #b000) + (1 #b1) + (6 dea DESTINATION-EA-REVERSED) + (6 sea SOURCE-EA 'B))) - (((? s) (? sea ea-all) (? dea ea-d&a)) - (QUALIFIER (bwl? s) (ea-b=>-A sea s)) - (WORD (2 #b00) - (2 (encode-blw s)) + ;; the following includes the MOVEA instruction + + (((? s lw ssym) (? sea ea-all) (? dea ea-all)) + (WORD (3 #b001) + (1 s) (6 dea DESTINATION-EA-REVERSED) - (6 sea SOURCE-EA s))) + (6 sea SOURCE-EA ssym))) ((W (? ea ea-d) (CCR)) ;MOVE to CCR (WORD (10 #b0100010011) @@ -288,74 +272,90 @@ MIT in each case. |# (WORD (13 #b0100111001100) (3 rx)))) +;; MOV is a special case, separated for efficiency so there are less rules to try. + +(define-instruction MOV + ((B (? sea ea-all-A) (? dea ea-d&a)) + (WORD (3 #b000) + (1 #b1) + (6 dea DESTINATION-EA-REVERSED) + (6 sea SOURCE-EA 'B))) + + ;; the following includes the MOVEA instruction + + (((? s lw ssym) (? sea ea-all) (? dea ea-all)) + (WORD (3 #b001) + (1 s) + (6 dea DESTINATION-EA-REVERSED) + (6 sea SOURCE-EA ssym)))) + +(define-instruction MOVEQ + (((& (? data)) (D (? rx))) + (WORD (4 #b0111) + (3 rx) + (1 #b0) + (8 data SIGNED)))) + (define-instruction MOVEM - (((? s) (? r) (? dea ea-c&a)) - (QUALIFIER (wl? s) (register-list? r)) + (((? s wl) (? r @+reg-list) (? dea ea-c&a)) (WORD (9 #b010010001) - (1 (encode-wl s)) + (1 s) (6 dea DESTINATION-EA)) - (output-bit-string (encode-c@a+register-list r))) + (output-bit-string r)) - (((? s) (? r) (@-a (? rx))) - (QUALIFIER (wl? s) (register-list? r)) + (((? s wl) (? r @-reg-list) (@-a (? rx))) (WORD (9 #b010010001) - (1 (encode-wl s)) + (1 s) (3 #b100) (3 rx)) - (output-bit-string (encode-@-aregister-list r))) + (output-bit-string r)) - (((? s) (? sea ea-c) (? r)) - (QUALIFIER (wl? s) (register-list? r)) + (((? s wl) (? sea ea-c) (? r @+reg-list)) (WORD (9 #b010011001) - (1 (encode-wl s)) + (1 s) (6 sea SOURCE-EA s)) - (output-bit-string (encode-c@a+register-list r))) + (output-bit-string r)) - (((? s) (@A+ (? rx)) (? r)) - (QUALIFIER (wl? s) (register-list? r)) + (((? s wl) (@A+ (? rx)) (? r @+reg-list)) (WORD (9 #b010011001) - (1 (encode-wl s)) + (1 s) (3 #b011) (3 rx)) - (output-bit-string (encode-c@a+register-list r)))) + (output-bit-string r))) (define-instruction MOVEP - (((? s) (D (? rx)) (@AO (? ry) (? o))) - (QUALIFIER (wl? s)) + (((? s wl) (D (? rx)) (@AO (? ry) (? o))) (WORD (4 #b0000) (3 rx) (2 #b11) - (1 (encode-wl s)) + (1 s) (3 #b001) (3 ry)) (offset-word o)) - (((? s) (D (? rx)) (@AR (? ry) (? l))) - (QUALIFIER (wl? s)) + (((? s wl) (D (? rx)) (@AR (? ry) (? l))) (WORD (4 #b0000) (3 rx) (2 #b11) - (1 (encode-wl s)) + (1 s) (3 #b001) (3 ry)) (relative-word l)) - (((? s) (@AO (? ry) (? o)) (D (? rx))) - (QUALIFIER (wl? s)) + (((? s wl) (@AO (? ry) (? o)) (D (? rx))) (WORD (4 #b0000) (3 rx) (2 #b10) - (1 (encode-wl s)) + (1 s) (3 #b001) (3 ry)) (offset-word o)) - (((? s) (@AR (? ry) (? l)) (D (? rx))) - (QUALIFIER (wl? s)) + (((? s wl) (@AR (? ry) (? l)) (D (? rx))) (WORD (4 #b0000) (3 rx) (2 #b10) - (1 (encode-wl s)) + (1 s) (3 #b001) (3 ry)) - (relative-word l))) \ No newline at end of file + (relative-word l))) diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index e6f2f4512..0e0684449 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.183 1987/06/15 22:03:23 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.184 1987/07/08 22:07:44 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -32,20 +32,20 @@ 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 +;;;; RTL Rules for 68020. Part 1 (declare (usual-integrations)) ;;;; Basic machine instructions (define (register->register-transfer source target) - `(,(machine->machine-register source target))) + (LAP ,(machine->machine-register source target))) (define (home->register-transfer source target) - `(,(pseudo->machine-register source target))) + (LAP ,(pseudo->machine-register source target))) (define (register->home-transfer source target) - `(,(machine->pseudo-register source target))) + (LAP ,(machine->pseudo-register source target))) (define-integrable (pseudo->machine-register source target) (memory->machine-register (pseudo-register-home source) target)) @@ -58,67 +58,82 @@ MIT in each case. |# (+ #x000A (register-renumber register)))) (define-integrable (machine->machine-register source target) - `(MOVE L ,(register-reference source) ,(register-reference target))) + (INST (MOV L + ,(register-reference source) + ,(register-reference target)))) (define-integrable (machine-register->memory source target) - `(MOVE L ,(register-reference source) ,target)) + (INST (MOV L + ,(register-reference source) + ,target))) (define-integrable (memory->machine-register source target) - `(MOVE L ,source ,(register-reference target))) + (INST (MOV L + ,source + ,(register-reference target)))) (define (offset-reference register offset) (if (zero? offset) (if (< register 8) - `(@D ,register) - `(@A ,(- register 8))) + (INST-EA (@D ,register)) + (INST-EA (@A ,(- register 8)))) (if (< register 8) - `(@DO ,register ,(* 4 offset)) - `(@AO ,(- register 8) ,(* 4 offset))))) + (INST-EA (@DO ,register ,(* 4 offset))) + (INST-EA (@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))))) + (cond ((zero? n) + (INST (CLR W (D ,d)))) + ((<= -128 n 127) + (INST (MOVEQ (& ,n) (D ,d)))) + (else + (INST (MOV W (& ,n) (D ,d)))))) (define (test-dnw n d) (if (zero? n) - `(TST W (D ,d)) - `(CMP W (& ,n) (D ,d)))) + (INST (TST W (D ,d))) + (INST (CMPI 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)))))) + ((0) (LAP)) + ((1 2) (LAP (ADDQ L (& ,(* 4 n)) (A ,an)))) + ((-1 -2) (LAP (SUBQ L (& ,(* -4 n)) (A ,an)))) + (else (LAP (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))) + (INST (MOV 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)) + (INST (MOV 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-byte n expression) - (if (and (zero? n) (TSTable-expression? expression)) - `(TST B ,expression) - `(CMP B (& ,n) ,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))) + (memq (lap:ea-keyword target) '(D @D @A @A+ @-A @AO @DO @AOX W L))) + (INST (CLR L ,target))) + ((and (<= -128 datum 127) (eq? (lap:ea-keyword target) 'D)) + (INST (MOVEQ (& ,datum) ,target))) + (else (INST (MOV L (& ,datum) ,target))))) + +(define (test-byte n effective-address) + (if (and (zero? n) (TSTable-effective-address? effective-address)) + (INST (TST B ,effective-address)) + (INST (CMPI B (& ,n) ,effective-address)))) + +(define (test-non-pointer type datum effective-address) + (if (and (zero? type) (zero? datum) + (TSTable-effective-address? effective-address)) + (INST (TST L ,effective-address)) + (INST (CMPI L + (& ,(make-non-pointer-literal type datum)) + ,effective-address)))) (define make-non-pointer-literal (let ((type-scale-factor (expt 2 24))) @@ -128,10 +143,11 @@ MIT in each case. |# 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)))))) + (set-current-branches! + (lambda (label) + (LAP (B ,cc L (@PCR ,label)))) + (lambda (label) + (LAP (B ,(invert-cc cc) L (@PCR ,label)))))) (define (invert-cc cc) (cdr (or (assq cc @@ -152,26 +168,27 @@ MIT in each case. |# (let ((result (case (car expression) ((REGISTER) - `((MOVE L ,(coerce->any (cadr expression)) ,target))) + (LAP (MOV L ,(coerce->any (cadr expression)) ,target))) ((OFFSET) - `((MOVE L - ,(indirect-reference! (cadadr expression) - (caddr expression)) - ,target))) + (LAP + (MOV L + ,(indirect-reference! (cadadr expression) + (caddr expression)) + ,target))) ((CONSTANT) - `(,(load-constant (cadr expression) target))) + (LAP ,(load-constant (cadr expression) target))) ((UNASSIGNED) - `(,(load-non-pointer type-code:unassigned 0 target))) + (LAP ,(load-non-pointer type-code:unassigned 0 target))) (else (error "Unknown 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 (TSTable-effective-address? effective-address) + (memq (lap:ea-keyword effective-address) '(D @D @A @A+ @-A @DO @AO @AOX W L))) -(define-integrable (register-expression? expression) - (memq (car expression) '(A D))) +(define-integrable (register-effective-address? effective-address) + (memq (lap:ea-keyword effective-address) '(A D))) (define (indirect-reference! register offset) (if (= register regnum:frame-pointer) @@ -206,26 +223,43 @@ MIT in each case. |# 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)))))))) - + (cond ((> n limit) + (let ((loop (generate-label 'LOOP))) + (with-counter + (lambda (counter) + (LAP ,(load-dnw (-1+ n) counter) + (LABEL ,loop) + ,instruction + (DB F (D ,counter) (@PCR ,loop))))))) + ((zero? n) + (LAP)) + (else + (let loop ((n (-1+ n))) + (if (zero? n) + (LAP ,instruction) + (LAP ,(copy-instruction-sequence instruction) + ,@(loop (-1+ n)))))))) + (define-integrable (data-register? register) (< register 8)) (define (address-register? register) (and (< register 16) (>= register 8))) + +(define-integrable (lap:ea-keyword expression) + (car expression)) + +(define-export (lap:make-label-statement label) + (INST (LABEL ,label))) + +(define-export (lap:make-unconditional-branch label) + (INST (BRA L (@PCR ,label)))) + +(define-export (lap:make-entry-point label block-start-label) + (LAP (ENTRY-POINT ,label) + (DC W (- ,label ,block-start-label)) + (LABEL ,label))) ;;;; Registers/Entries @@ -234,9 +268,10 @@ MIT in each case. |# (define (loop names index) (if (null? names) '() - (cons `(DEFINE ,(symbol-append 'ENTRY:COMPILER- - (car names)) - '(@AO 6 ,index)) + (cons `(DEFINE-INTEGRABLE + ,(symbol-append 'ENTRY:COMPILER- + (car names)) + (INST-EA (@AO 6 ,index))) (loop (cdr names) (+ index 6))))) `(BEGIN ,@(loop names start))))) (define-entries #x00F0 apply error wrong-number-of-arguments @@ -248,11 +283,11 @@ MIT in each case. |# safe-reference-trap unassigned?-trap cache-variable-multiple uuo-link-multiple)) -(define reg:compiled-memtop '(@A 6)) -(define reg:environment '(@AO 6 #x000C)) -(define reg:temp '(@AO 6 #x0010)) -(define reg:enclose-result '(@AO 6 #x0014)) +(define-integrable reg:compiled-memtop (INST-EA (@A 6))) +(define-integrable reg:environment (INST-EA (@AO 6 #x000C))) +(define-integrable reg:temp (INST-EA (@AO 6 #x0010))) +(define-integrable reg:enclose-result (INST-EA (@AO 6 #x0014))) -(define popper:apply-closure '(@AO 6 #x0168)) -(define popper:apply-stack '(@AO 6 #x01A8)) -(define popper:value '(@AO 6 #x01E8)) \ No newline at end of file +(define-integrable popper:apply-closure (INST-EA (@AO 6 #x0168))) +(define-integrable popper:apply-stack (INST-EA (@AO 6 #x01A8))) +(define-integrable popper:value (INST-EA (@AO 6 #x01E8))) diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index 9ff2dbd40..9468ab70f 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.49 1987/06/01 16:10:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.50 1987/07/08 22:09:50 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -131,10 +131,10 @@ MIT in each case. |# (define-integrable a7 15) (define number-of-machine-registers 16) -(define regnum:frame-pointer a4) -(define regnum:free-pointer a5) -(define regnum:regs-pointer a6) -(define regnum:stack-pointer a7) +(define-integrable regnum:frame-pointer a4) +(define-integrable regnum:free-pointer a5) +(define-integrable regnum:regs-pointer a6) +(define-integrable regnum:stack-pointer a7) (define-integrable (sort-machine-registers registers) registers) @@ -162,12 +162,12 @@ MIT in each case. |# (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)) + (begin (vector-set! references i (INST-EA (D ,i))) + (vector-set! references j (INST-EA (A ,i))) (loop (1+ i) (1+ j))))) (lambda (register) (vector-ref references register)))) -(define mask-reference '(D 7)) +(define mask-reference (INST-EA (D 7))) (define-integrable (interpreter-register:access) (rtl:make-machine-register d0)) @@ -214,13 +214,8 @@ MIT in each case. |# (define-integrable (interpreter-stack-pointer? register) (= (rtl:register-number register) regnum:stack-pointer)) -(define (lap:make-label-statement label) - `(LABEL ,label)) +;;;; Exports from machines/lapgen -(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))) \ No newline at end of file +(define lap:make-label-statement) +(define lap:make-unconditional-branch) +(define lap:make-entry-point) \ 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 index ccc6c0478..5617ec5a1 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.29 1987/07/03 19:00:22 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.30 1987/07/08 22:10:08 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -46,11 +46,11 @@ MIT in each case. |# (make-environment (define :name "Liar (Bobcat 68020)") (define :version 1) - (define :modification 29) + (define :modification 30) (define :files) ; (parse-rcs-header -; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.29 1987/07/03 19:00:22 cph Exp $" +; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.30 1987/07/08 22:10:08 jinx Exp $" ; (lambda (filename version date time zone author state) ; (set! :version (car version)) ; (set! :modification (cadr version)))) @@ -95,6 +95,7 @@ MIT in each case. |# "base/regset.bin" ;RTL Register Sets "base/pmlook.bin" ;pattern matcher: lookup "base/pmpars.bin" ;pattern matcher: parser + "back-end/insseq.bin" ;lap instruction sequences )) (cons converter-package @@ -139,36 +140,27 @@ MIT in each case. |# "front-end/ralloc.bin" ;RTL register allocator )) - (cons lap-generator-package + (cons lap-syntax-package '("back-end/lapgn1.bin" ;LAP generator. "back-end/lapgn2.bin" "back-end/lapgn3.bin" - )) - - (cons (access register-allocator-package lap-generator-package) - '("back-end/regmap.bin" ;Hardware register allocator. - )) - - (cons lap-generator-package - '("machines/bobcat/lapgen.bin" ;code generation rules. + "back-end/regmap.bin" ;Hardware register allocator. + "machines/bobcat/lapgen.bin" ;code generation rules. "machines/bobcat/rules1.bin" "machines/bobcat/rules2.bin" "machines/bobcat/rules3.bin" "machines/bobcat/rules4.bin" - )) - - - (cons lap-syntaxer-package - '("back-end/syntax.bin" ;Generic syntax phase + "back-end/syntax.bin" ;Generic syntax phase "machines/bobcat/coerce.bin" ;Coercions: integer -> bit string "back-end/asmmac.bin" ;Macros for hairy syntax "machines/bobcat/insmac.bin" ;Macros for hairy syntax + "machines/bobcat/insutl.bin" ;Utilities for instructions "machines/bobcat/instr1.bin" ;68000 Effective addressing "machines/bobcat/instr2.bin" ;68000 Instructions "machines/bobcat/instr3.bin" ; " " )) - (cons lap-package + (cons bit-package '("machines/bobcat/assmd.bin" ;Machine dependent "back-end/symtab.bin" ;Symbol tables "back-end/block.bin" ;Assembly blocks diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm index d420433f5..30fc9c551 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 1.5 1987/07/03 21:59:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 1.6 1987/07/08 22:08:21 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -47,7 +47,7 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER 12) (REGISTER 15)) (enable-frame-pointer-offset! 0) - '()) + (LAP)) (define-rule statement (ASSIGN (REGISTER 15) (OFFSET-ADDRESS (REGISTER 15) (? n))) @@ -56,42 +56,44 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER 15) (? n))) (QUALIFIER (pseudo-register? target)) - `((LEA (@AO 7 ,(* 4 n)) ,(reference-assignment-alias! target 'ADDRESS)))) + (LAP + (LEA (@AO 7 ,(* 4 n)) + ,(reference-assignment-alias! target 'ADDRESS)))) (define-rule statement (ASSIGN (REGISTER 15) (REGISTER (? source))) (disable-frame-pointer-offset! - `((MOVE L ,(coerce->any source) (A 7))))) + (LAP (MOV L ,(coerce->any source) (A 7))))) (define-rule statement (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) (QUALIFIER (pseudo-register? target)) - `(,(load-constant source (coerce->any target)))) + (LAP ,(load-constant source (coerce->any target)))) (define-rule statement (ASSIGN (REGISTER (? target)) (VARIABLE-CACHE (? name))) (QUALIFIER (pseudo-register? target)) - `((MOVE L - (@PCR ,(free-reference-label name)) - ,(reference-assignment-alias! target 'DATA)))) + (LAP (MOV L + (@PCR ,(free-reference-label name)) + ,(reference-assignment-alias! target 'DATA)))) (define-rule statement (ASSIGN (REGISTER (? target)) (REGISTER (? source))) (QUALIFIER (pseudo-register? target)) (move-to-alias-register! source 'DATA target) - '()) + (LAP)) (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->ADDRESS (REGISTER (? source)))) (QUALIFIER (pseudo-register? target)) (let ((target (move-to-alias-register! source 'DATA target))) - `((AND L ,mask-reference ,target)))) + (LAP (AND L ,mask-reference ,target)))) (define-rule statement (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source)))) (QUALIFIER (pseudo-register? target)) (let ((target (move-to-alias-register! source 'DATA target))) - `((RO L L (& 8) ,target)))) + (LAP (RO L L (& 8) ,target)))) (define-rule statement (ASSIGN (REGISTER (? target)) (OFFSET (REGISTER (? address)) (? offset))) @@ -102,18 +104,20 @@ MIT in each case. |# ;; 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. - `((MOVE L - ,source - ,(register-reference (allocate-alias-register! target 'DATA)))))) + (LAP (MOV L + ,source + ,(register-reference + (allocate-alias-register! target 'DATA)))))) (define-rule statement (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1)) (QUALIFIER (pseudo-register? target)) (record-pop!) (delete-dead-registers!) - `((MOVE L - (@A+ 7) - ,(register-reference (allocate-alias-register! target 'DATA))))) + (LAP (MOV L + (@A+ 7) + ,(register-reference + (allocate-alias-register! target 'DATA))))) (define-rule statement (ASSIGN (REGISTER (? target)) @@ -122,119 +126,126 @@ MIT in each case. |# (let ((target* (coerce->any target)) (datum (coerce->any datum))) (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*))))) + (if (register-effective-address? target*) + (LAP (MOV L ,datum ,reg:temp) + (MOV B (& ,type) ,reg:temp) + (MOV L ,reg:temp ,target*)) + (LAP (MOV L ,datum ,target*) + (MOV B (& ,type) ,target*))))) ;;;; Transfers to Memory (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (CONSTANT (? object))) - `(,(load-constant object (indirect-reference! a n)))) + (LAP ,(load-constant object (indirect-reference! a n)))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (UNASSIGNED)) - `(,(load-non-pointer (ucode-type unassigned) 0 (indirect-reference! a n)))) + (LAP ,(load-non-pointer (ucode-type unassigned) 0 (indirect-reference! a n)))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (REGISTER (? r))) - `((MOVE L ,(coerce->any r) ,(indirect-reference! a n)))) + (LAP (MOV L + ,(coerce->any r) + ,(indirect-reference! a n)))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (POST-INCREMENT (REGISTER 15) 1)) (record-pop!) - `((MOVE L (@A+ 7) ,(indirect-reference! a n)))) + (LAP (MOV L + (@A+ 7) + ,(indirect-reference! a n)))) (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)))) + (LAP (MOV L ,(coerce->any r) ,target) + (MOV B (& ,type) ,target)))) (define-rule statement (ASSIGN (OFFSET (REGISTER (? a0)) (? n0)) (OFFSET (REGISTER (? a1)) (? n1))) (let ((source (indirect-reference! a1 n1))) - `((MOVE L ,source ,(indirect-reference! a0 n0))))) + (LAP (MOV L + ,source + ,(indirect-reference! a0 n0))))) ;;;; Consing (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (CONSTANT (? object))) - `(,(load-constant object '(@A+ 5)))) + (LAP ,(load-constant object (INST-EA (@A+ 5))))) (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (UNASSIGNED)) - `(,(load-non-pointer (ucode-type unassigned) 0 '(@A+ 5)))) + (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@A+ 5))))) (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (REGISTER (? r))) - `((MOVE L ,(coerce->any r) (@A+ 5)))) + (LAP (MOV 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)))) + (LAP (MOV L ,(indirect-reference! r n) (@A+ 5)))) (define-rule statement (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? label))) (let ((temporary (register-reference (allocate-temporary-register! 'ADDRESS)))) - `((LEA (@PCR ,(procedure-external-label (label->procedure label))) - ,temporary) - (MOVE L ,temporary (@A+ 5)) - (MOVE B (& ,(ucode-type compiled-expression)) (@AO 5 -4))))) + (LAP (LEA (@PCR ,(procedure-external-label (label->procedure label))) + ,temporary) + (MOV L ,temporary (@A+ 5)) + (MOV B (& ,(ucode-type compiled-expression)) (@AO 5 -4))))) ;;;; Pushes (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object))) (record-push! - `(,(load-constant object '(@-A 7))))) + (LAP ,(load-constant object (INST-EA (@-A 7)))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (UNASSIGNED)) (record-push! - `(,(load-non-pointer (ucode-type unassigned) 0 '(@-A 7))))) + (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@-A 7)))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r))) (record-push! (if (= r regnum:frame-pointer) - `((PEA ,(offset-reference regnum:stack-pointer (frame-pointer-offset))) - (MOVE B (& ,(ucode-type stack-environment)) (@A 7))) - `((MOVE L ,(coerce->any r) (@-A 7)))))) + (LAP (PEA ,(offset-reference regnum:stack-pointer + (frame-pointer-offset))) + (MOV B (& ,(ucode-type stack-environment)) (@A 7))) + (LAP (MOV L ,(coerce->any r) (@-A 7)))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) (record-push! - `((MOVE L ,(coerce->any r) (@-A 7)) - (MOVE B (& ,type) (@A 7))))) + (LAP (MOV L ,(coerce->any r) (@-A 7)) + (MOV B (& ,type) (@A 7))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n))) (record-push! - `((MOVE L ,(indirect-reference! r n) (@-A 7))))) + (LAP (MOV L ,(indirect-reference! r n) (@-A 7))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET-ADDRESS (REGISTER 12) (? n))) (record-push! - `((PEA ,(offset-reference regnum:stack-pointer - (+ n (frame-pointer-offset)))) - (MOVE B (& ,(ucode-type stack-environment)) (@A 7))))) + (LAP (PEA ,(offset-reference regnum:stack-pointer + (+ n (frame-pointer-offset)))) + (MOV B (& ,(ucode-type stack-environment)) (@A 7))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (ENTRY:CONTINUATION (? label))) (record-continuation-frame-pointer-offset! label) (record-push! - `((PEA (@PCR ,label)) - (MOVE B (& ,(ucode-type compiler-return-address)) (@A 7))))) \ No newline at end of file + (LAP (PEA (@PCR ,label)) + (MOV B (& ,(ucode-type compiler-return-address)) (@A 7))))) diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm index 5e0069b6c..6a11e70b0 100644 --- a/v7/src/compiler/machines/bobcat/rules2.scm +++ b/v7/src/compiler/machines/bobcat/rules2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 1.1.1.1 1987/07/01 21:00:21 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 1.2 1987/07/08 22:08:40 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -93,9 +93,7 @@ MIT in each case. |# (primitive-datum constant) memory-reference)) (let ((temp (reference-temporary-register! false))) - (LAP (MOVE/SIMPLE L - ,memory-reference - ,temp) + (LAP (MOV L ,memory-reference ,temp) (CMP L (@PCR ,(constant->label constant)) ,temp))))) @@ -125,9 +123,9 @@ MIT in each case. |# (let ((temp (reference-temporary-register! false))) (let ((finish (lambda (register-1 offset-1 register-2 offset-2) - (LAP (MOVE/SIMPLE L - ,(indirect-reference! register-1 offset-1) - ,temp) + (LAP (MOV L + ,(indirect-reference! register-1 offset-1) + ,temp) (CMP L ,(indirect-reference! register-2 offset-2) ,temp))))) diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 3efed529e..d21c70d94 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.6 1987/07/07 22:31:24 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.7 1987/07/08 22:08:57 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -41,17 +41,17 @@ MIT in each case. |# (define-rule statement (INVOCATION:APPLY (? frame-size) (? prefix) (? continuation)) (disable-frame-pointer-offset! - `(,@(generate-invocation-prefix prefix '()) - ,(load-dnw frame-size 0) - (JMP ,entry:compiler-apply)))) + (LAP ,@(generate-invocation-prefix prefix '()) + ,(load-dnw frame-size 0) + (JMP ,entry:compiler-apply)))) (define-rule statement (INVOCATION:JUMP (? n) (APPLY-CLOSURE (? frame-size) (? receiver-offset)) (? continuation) (? label)) (disable-frame-pointer-offset! - `(,@(clear-map!) - ,@(apply-closure-sequence frame-size receiver-offset label)))) + (LAP ,@(clear-map!) + ,@(apply-closure-sequence frame-size receiver-offset label)))) (define-rule statement (INVOCATION:JUMP (? n) @@ -59,23 +59,23 @@ MIT in each case. |# (? n-levels)) (? continuation) (? label)) (disable-frame-pointer-offset! - `(,@(clear-map!) - ,@(apply-stack-sequence frame-size receiver-offset n-levels label)))) + (LAP ,@(clear-map!) + ,@(apply-stack-sequence frame-size receiver-offset n-levels label)))) (define-rule statement (INVOCATION:JUMP (? frame-size) (? prefix) (? continuation) (? label)) (QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK)))) (disable-frame-pointer-offset! - `(,@(generate-invocation-prefix prefix '()) - (BRA L (@PCR ,label))))) + (LAP ,@(generate-invocation-prefix prefix '()) + (BRA L (@PCR ,label))))) (define-rule statement (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation) (? label)) (disable-frame-pointer-offset! - `(,@(generate-invocation-prefix prefix '()) - ,(load-dnw number-pushed 0) - (BRA L (@PCR ,label))))) + (LAP ,@(generate-invocation-prefix prefix '()) + ,(load-dnw number-pushed 0) + (BRA L (@PCR ,label))))) (define-rule statement (INVOCATION:CACHE-REFERENCE (? frame-size) (? prefix) (? continuation) @@ -83,11 +83,11 @@ MIT in each case. |# (disable-frame-pointer-offset! (let ((set-extension (expression->machine-register! extension a3))) (delete-dead-registers!) - `(,@set-extension - ,@(generate-invocation-prefix prefix (list a3)) - ,(load-dnw frame-size 0) - (LEA (@PCR ,*block-start-label*) (A 1)) - (JMP ,entry:compiler-cache-reference-apply))))) + (LAP ,@set-extension + ,@(generate-invocation-prefix prefix (list a3)) + ,(load-dnw frame-size 0) + (LEA (@PCR ,*block-start-label*) (A 1)) + (JMP ,entry:compiler-cache-reference-apply))))) (define-rule statement (INVOCATION:LOOKUP (? frame-size) (? prefix) (? continuation) @@ -95,132 +95,143 @@ MIT in each case. |# (disable-frame-pointer-offset! (let ((set-environment (expression->machine-register! environment d4))) (delete-dead-registers!) - `(,@set-environment - ,@(generate-invocation-prefix prefix (list d4)) - ,(load-constant name '(D 5)) - ,(load-dnw frame-size 0) - (JMP ,entry:compiler-lookup-apply))))) + (LAP ,@set-environment + ,@(generate-invocation-prefix prefix (list d4)) + ,(load-constant name (INST-EA (D 5))) + ,(load-dnw (1+ frame-size) 0) + (JMP ,entry:compiler-lookup-apply))))) (define-rule statement (INVOCATION:PRIMITIVE (? frame-size) (? prefix) (? continuation) (? primitive)) (disable-frame-pointer-offset! - `(,@(generate-invocation-prefix prefix '()) - ,@(if (eq? primitive compiled-error-procedure) - `(,(load-dnw frame-size 0) - (JMP ,entry:compiler-error)) - `(,(load-dnw (primitive-datum primitive) 6) - (JMP ,entry:compiler-primitive-apply)))))) + (LAP ,@(generate-invocation-prefix prefix '()) + ,@(if (eq? primitive compiled-error-procedure) + (LAP ,(load-dnw frame-size 0) + (JMP ,entry:compiler-error)) + (LAP ,(load-dnw (primitive-datum primitive) 6) + (JMP ,entry:compiler-primitive-apply)))))) (define-rule statement (INVOCATION:UUO-LINK (? frame-size) (? prefix) (? continuation) (? name)) (disable-frame-pointer-offset! - `(,@(generate-invocation-prefix prefix '()) - ,(load-dnw frame-size 0) - (MOVE L (@PCR ,(free-uuo-link-label name)) (D 1)) - (MOVE L (D 1) (@-A 7)) - (AND L (D 7) (D 1)) - (MOVE L (D 1) (A 1)) - (MOVE L (@A 1) (D 1)) - (AND L (D 7) (D 1)) - (MOVE L (D 1) (A 0)) - (JMP (@A 0))))) + (LAP ,@(generate-invocation-prefix prefix '()) + ,(load-dnw frame-size 0) + (MOVE L (@PCR ,(free-uuo-link-label name)) (D 1)) + (MOVE L (D 1) (@-A 7)) + (AND L (D 7) (D 1)) + (MOVE L (D 1) (A 1)) + (MOVE L (@A 1) (D 1)) + (AND L (D 7) (D 1)) + (MOVE L (D 1) (A 0)) + (JMP (@A 0))))) (define-rule statement (RETURN) (disable-frame-pointer-offset! - `(,@(clear-map!) - (CLR B (@A 7)) - (RTS)))) + (LAP ,@(clear-map!) + (CLR B (@A 7)) + (RTS)))) (define (generate-invocation-prefix prefix needed-registers) (let ((clear-map (clear-map!))) (need-registers! needed-registers) - `(,@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 "bad prefix type" prefix)))))) + (LAP ,@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 "bad prefix type" prefix)))))) (define (generate-invocation-prefix:move-frame-up frame-size how-far) - (cond ((zero? how-far) '()) + (cond ((zero? how-far) + (LAP)) ((zero? frame-size) (increment-anl 7 how-far)) ((= frame-size 1) - `((MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far))) - ,@(increment-anl 7 (-1+ how-far)))) + (LAP (MOV L (@A+ 7) ,(offset-reference a7 (-1+ how-far))) + ,@(increment-anl 7 (-1+ how-far)))) ((= frame-size 2) (if (= how-far 1) - `((MOVE L (@AO 7 4) (@AO 7 8)) - (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)))))) + (LAP (MOV L (@AO 7 4) (@AO 7 8)) + (MOV L (@A+ 7) (@A 7))) + (let ((i (INST (MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))))) + (LAP ,(copy-instruction-sequence i) + ,i + ,@(increment-anl 7 (- how-far 2)))))) (else (let ((temp-0 (allocate-temporary-register! 'ADDRESS)) (temp-1 (allocate-temporary-register! 'ADDRESS))) - `((LEA ,(offset-reference a7 frame-size) - ,(register-reference temp-0)) - (LEA ,(offset-reference a7 (+ frame-size how-far)) - ,(register-reference temp-1)) - ,@(generate-n-times frame-size 5 - `(MOVE L - (@-A ,(- temp-0 8)) - (@-A ,(- temp-1 8))) - (lambda (generator) - (generator (allocate-temporary-register! 'DATA)))) - (MOVE L ,(register-reference temp-1) (A 7))))))) + (LAP (LEA ,(offset-reference a7 frame-size) + ,(register-reference temp-0)) + (LEA ,(offset-reference a7 (+ frame-size how-far)) + ,(register-reference temp-1)) + ,@(generate-n-times frame-size 5 + (INST (MOV L + (@-A ,(- temp-0 8)) + (@-A ,(- temp-1 8)))) + (lambda (generator) + (generator (allocate-temporary-register! 'DATA)))) + (MOV L ,(register-reference temp-1) (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)))) + (LAP ,@(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)))) + (LAP ,@(apply-stack-sequence frame-size receiver-offset n-levels label) + (LABEL ,label)))) -;;; This is invoked by the top level of the LAP generator. +;;; This is invoked by the top level of the LAP GENERATOR. (define generate/quotation-header - (let ((declare-constant - (lambda (entry) - `(SCHEME-OBJECT ,(cdr entry) ,(car entry))))) + (let () + (define (declare-constants constants code) + (define (inner constants) + (if (null? constants) + code + (let ((entry (car constants))) + (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry)) + ,@(inner (cdr constants)))))) + (inner constants)) + (lambda (block-label constants references uuo-links) - `(,@(map declare-constant references) - ,@(map declare-constant uuo-links) - ,@(map declare-constant constants) - ,@(let ((environment-label (allocate-constant-label))) - `((SCHEME-OBJECT ,environment-label ENVIRONMENT) - (LEA (@PCR ,environment-label) (A 0)))) - ,@(if (or (not (null? references)) - (not (null? uuo-links))) - `((MOVE L ,reg:environment (@A 0)) - (LEA (@PCR ,block-label) (A 0)) - ,@(if (null? references) - '() - `((LEA (@PCR ,(cdar references)) (A 1)) - ,@(if (null? (cdr references)) - `((JSR ,entry:compiler-cache-variable)) - `(,(load-dnw (length references) 1) - (JSR ,entry:compiler-cache-variable-multiple))) - ,@(make-external-label (generate-label)))) - ,@(if (null? uuo-links) - '() - `((LEA (@PCR ,(cdar uuo-links)) (A 1)) - ,@(if (null? (cdr uuo-links)) - `((JSR ,entry:compiler-uuo-link)) - `(,(load-dnw (length uuo-links) 1) - (JSR ,entry:compiler-uuo-link-multiple))) - ,@(make-external-label (generate-label))))) - `(,(load-constant 0 '(@A 0)))))))) + (declare-constants references + (declare-constants uuo-links + (declare-constants constants + (LAP + ,@(let ((environment-label (allocate-constant-label))) + (LAP (SCHEME-OBJECT ,environment-label ENVIRONMENT) + (LEA (@PCR ,environment-label) (A 0)))) + ,@(if (or (not (null? references)) + (not (null? uuo-links))) + (LAP (MOV L ,reg:environment (@A 0)) + (LEA (@PCR ,block-label) (A 0)) + ,@(if (null? references) + (LAP) + (LAP (LEA (@PCR ,(cdar references)) (A 1)) + ,@(if (null? (cdr references)) + (LAP (JSR ,entry:compiler-cache-variable)) + (LAP ,(load-dnw (length references) 1) + (JSR ,entry:compiler-cache-variable-multiple))) + ,@(make-external-label (generate-label)))) + ,@(if (null? uuo-links) + (LAP) + (LAP (LEA (@PCR ,(cdar uuo-links)) (A 1)) + ,@(if (null? (cdr uuo-links)) + (LAP (JSR ,entry:compiler-uuo-link)) + (LAP ,(load-dnw (length uuo-links) 1) + (JSR ,entry:compiler-uuo-link-multiple))) + ,@(make-external-label (generate-label))))) + (LAP ,(load-constant 0 '(@A 0))))))))))) ;;;; Procedure/Continuation Entries @@ -237,9 +248,9 @@ MIT in each case. |# (PROCEDURE-HEAP-CHECK (? label)) (disable-frame-pointer-offset! (let ((gc-label (generate-label))) - `(,@(procedure-header (label->procedure label) gc-label) - (CMP L ,reg:compiled-memtop (A 5)) - (B GE S (@PCR ,gc-label)))))) + (LAP ,@(procedure-header (label->procedure label) gc-label) + (CMP L ,reg:compiled-memtop (A 5)) + (B GE S (@PCR ,gc-label)))))) ;;; 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 @@ -251,58 +262,57 @@ MIT in each case. |# (SETUP-LEXPR (? label)) (disable-frame-pointer-offset! (let ((procedure (label->procedure label))) - `(,@(procedure-header procedure false) - (MOVE W - (& ,(+ (procedure-required procedure) - (procedure-optional procedure) - (if (procedure/closure? procedure) 1 0))) - (D 1)) - (MOVEQ (& ,(if (procedure-rest procedure) 1 0)) (D 2)) - (JSR , entry:compiler-setup-lexpr))))) + (LAP ,@(procedure-header procedure false) + (MOV W + (& ,(+ (procedure-required procedure) + (procedure-optional procedure) + (if (procedure/closure? procedure) 1 0))) + (D 1)) + (MOVEQ (& ,(if (procedure-rest procedure) 1 0)) (D 2)) + (JSR ,entry:compiler-setup-lexpr))))) (define-rule statement (CONTINUATION-HEAP-CHECK (? internal-label)) (enable-frame-pointer-offset! (continuation-frame-pointer-offset (label->continuation internal-label))) (let ((gc-label (generate-label))) - `((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))))) + (LAP (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)) (external-label (procedure-external-label procedure))) - (append! (case (procedure-name procedure) ;really `procedure/type'. - ((IC) - `((ENTRY-POINT ,external-label) - (EQUATE ,external-label ,internal-label))) - ((CLOSURE) - (let ((required (1+ (procedure-required procedure))) - (optional (procedure-optional procedure))) - `((ENTRY-POINT ,external-label) - ,@(make-external-label external-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)))) - (else - '())) - (if gc-label - `((LABEL ,gc-label) - (JSR ,entry:compiler-interrupt-procedure)) - '()) - (make-external-label internal-label)))) + (LAP ,@(case (procedure-name procedure) ;really `procedure/type'. + ((IC) + (LAP (ENTRY-POINT ,external-label) + (EQUATE ,external-label ,internal-label))) + ((CLOSURE) + (let ((required (1+ (procedure-required procedure))) + (optional (procedure-optional procedure))) + (LAP (ENTRY-POINT ,external-label) + ,@(make-external-label external-label) + ,(test-dnw required 0) + ,@(cond ((procedure-rest procedure) + (LAP (B GE S (@PCR ,internal-label)))) + ((zero? optional) + (LAP (B EQ S (@PCR ,internal-label)))) + (else + (let ((wna-label (generate-label))) + (LAP (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)))) + (else (LAP))) + ,@(if gc-label + (LAP (LABEL ,gc-label) + (JSR ,entry:compiler-interrupt-procedure)) + (LAP)) + ,@(make-external-label internal-label)))) (define (make-external-label label) - `((DC W (- ,label ,*block-start-label*)) - (LABEL ,label))) \ No newline at end of file + (LAP (DC W (- ,label ,*block-start-label*)) + (LABEL ,label))) diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm index 347734dd9..350c5c67d 100644 --- a/v7/src/compiler/machines/bobcat/rules4.scm +++ b/v7/src/compiler/machines/bobcat/rules4.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 1.1.1.1 1987/07/01 21:02:12 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 1.2 1987/07/08 22:09:26 jinx Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -68,13 +68,13 @@ MIT in each case. |# (INTERPRETER-CALL:ENCLOSE (? number-pushed)) (decrement-frame-pointer-offset! number-pushed - (LAP (MOVE/SIMPLE L (A 5) ,reg:enclose-result) - (MOVE/SIMPLE B (& ,(ucode-type vector)) ,reg:enclose-result) + (LAP (MOV L (A 5) ,reg:enclose-result) + (MOV B (& ,(ucode-type vector)) ,reg:enclose-result) ,(load-non-pointer (ucode-type manifest-vector) number-pushed (INST-EA (@A+ 5))) ,@(generate-n-times number-pushed 5 - (INST (MOVE/SIMPLE L (@A+ 7) (@A+ 5))) + (INST (MOV L (@A+ 7) (@A+ 5))) (lambda (generator) (generator (allocate-temporary-register! 'DATA))))) #| Alternate sequence which minimizes code size. ; @@ -82,7 +82,7 @@ MIT in each case. |# registers containing objects and registers containing unboxed things, and as a result can write unboxed stuff to memory. (LAP ,@(clear-registers! a0 a1 d0) - (MOVE/SIMPLE W (& ,number-pushed) (D 0)) + (MOV W (& ,number-pushed) (D 0)) (JSR ,entry:compiler-enclose)) |# )) @@ -127,10 +127,10 @@ MIT in each case. |# (let ((datum (coerce->any datum))) (let ((clear-map (clear-map!))) (LAP ,@set-environment - (MOVE/SIMPLE L ,datum ,reg:temp) - (MOVE/SIMPLE B (& ,type) ,reg:temp) + (MOV L ,datum ,reg:temp) + (MOV B (& ,type) ,reg:temp) ,@clear-map - (MOVE/SIMPLE L ,reg:temp (A 2)) + (MOV L ,reg:temp (A 2)) ,(load-constant name (INST-EA (A 1))) (JSR ,entry) ,@(make-external-label (generate-label))))))) @@ -166,10 +166,10 @@ MIT in each case. |# (let ((datum (coerce->any datum))) (let ((clear-map (clear-map!))) (LAP ,@set-extension - (MOVE/SIMPLE L ,datum ,reg:temp) - (MOVE/SIMPLE B (& ,type) ,reg:temp) + (MOV L ,datum ,reg:temp) + (MOV B (& ,type) ,reg:temp) ,@clear-map - (MOVE/SIMPLE L ,reg:temp (A 1)) + (MOV L ,reg:temp (A 1)) (JSR ,entry:compiler-assignment-trap) ,@(make-external-label (generate-label))))))) @@ -178,14 +178,14 @@ MIT in each case. |# (define-rule statement (MESSAGE-RECEIVER:CLOSURE (? frame-size)) (record-push! - (LAP (MOVE/SIMPLE L (& ,(* frame-size 4)) (@-A 7))))) + (LAP (MOV L (& ,(* frame-size 4)) (@-A 7))))) (define-rule statement (MESSAGE-RECEIVER:STACK (? frame-size)) (record-push! - (LAP (MOVE/SIMPLE L - (& ,(+ #x00100000 (* frame-size 4))) - (@-A 7))))) + (LAP (MOV L + (& ,(+ #x00100000 (* frame-size 4))) + (@-A 7))))) (define-rule statement (MESSAGE-RECEIVER:SUBPROBLEM (? label)) @@ -193,8 +193,8 @@ MIT in each case. |# (increment-frame-pointer-offset! 2 (LAP (PEA (@PCR ,label)) - (MOVE/SIMPLE B (& ,type-code:return-address) (@A 7)) - (MOVE/SIMPLE L (& #x00200000) (@-A 7))))) + (MOV B (& ,type-code:return-address) (@A 7)) + (MOV L (& #x00200000) (@-A 7))))) (define (apply-closure-sequence frame-size receiver-offset label) (LAP ,(load-dnw frame-size 1) -- 2.25.1