#| -*-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
`(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))))))
(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)))))))
#| -*-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
(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)
(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*)
#| -*-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
(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*)))
#| -*-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
(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))
#| -*-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
(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
(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)
(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)
(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
#| -*-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
(declare (usual-integrations))
\f
-(define (syntax-instructions instructions)
- (convert-output
- (let loop ((instructions instructions))
- (if (null? instructions)
- '()
- (append-syntax! (syntax-instruction (car instructions))
- (loop (cdr instructions)))))))
+(define (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)
(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) '())
(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)))))))
\f
;;;; 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")
#| -*-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
(declare (usual-integrations))
\f
-;;;; 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
(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)))))))
\f
-(define (parse-word expression tail)
- (expand-descriptors (cdr expression)
- (lambda (instruction size src dst)
- (if (zero? (remainder size 16))
- (let ((code
- (let ((code
- (let ((code (if dst `(,@dst '()) '())))
- (if src
- `(,@src ,code)
- code))))
- (if (null? tail)
- code
- `(,(if (null? code) 'CONS 'CONS-SYNTAX)
- ,(car tail)
- ,code)))))
- `(,(if (null? code) 'CONS 'CONS-SYNTAX)
- ,(apply optimize-group-syntax instruction)
- ,code))
- (error "PARSE-WORD: Instructions must be 16 bit multiples" size)))))
+;;;; 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)))))
+\f
+;;;; 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)
destination)
destination*))))))))
\f
+(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))
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
#| -*-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
(declare (usual-integrations))
\f
-;;;; 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))
-\f
-(define (ea-all expression)
- (let ((match-result (pattern-lookup ea-database expression)))
- (and match-result (match-result))))
-
-(define ((ea-filtered filter) expression)
- (let ((ea (ea-all expression)))
- (and ea (filter ea) ea)))
-
-(define (ea-filtered-by-category category)
- (ea-filtered
- (lambda (ea)
- (memq category (ea-categories ea)))))
-
-(define ea-d (ea-filtered-by-category 'DATA))
-(define ea-a (ea-filtered-by-category 'ALTERABLE))
-(define ea-c (ea-filtered-by-category 'CONTROL))
-
-(define (ea-filtered-by-categories categories)
- (ea-filtered
- (lambda (ea)
- (eq?-subset? categories (ea-categories ea)))))
-
-(define (eq?-subset? x y)
- (or (null? x)
- (and (memq (car x) y)
- (eq?-subset? (cdr x) y))))
-
-(define ea-d&a (ea-filtered-by-categories '(DATA ALTERABLE)))
-(define ea-c&a (ea-filtered-by-categories '(CONTROL ALTERABLE)))
-(define ea-m&a (ea-filtered-by-categories '(MEMORY ALTERABLE)))
-
-(define ea-d&-&
- (ea-filtered
- (lambda (ea)
- (and (not (eq? (ea-keyword ea) '&))
- (memq 'DATA (ea-categories ea))))))
-
-;;; These are just predicates, to be used in conjunction with EA-ALL.
-
-(define (ea-b=>-A ea s)
- (not (and (eq? s 'B) (eq? (ea-keyword ea) 'A))))
-
-(define (ea-a&<b=>-A> ea s)
- (and (memq 'ALTERABLE (ea-categories ea)) (ea-b=>-A ea s)))
-\f
-;;;; Effective Address Description
+ ((@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))
+ \f
+ ((@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))
-\f
- ((@AOX (? r) (? o) (? xtype) (? xr) (? s))
- (QUALIFIER (da? xtype) (wl? s))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-offset-index-register xtype xr s o))
-
- ((@ARX (? r) (? l) (? xtype) (? xr) (? s))
- (QUALIFIER (da? xtype) (wl? s))
- (DATA MEMORY CONTROL ALTERABLE) #b110 r
- (output-relative-index-register xtype xr s l))
-
- ((W (? a))
- (DATA MEMORY CONTROL ALTERABLE) #b111 #b000
- (output-16bit-address a))
-
- ((L (? a))
- (DATA MEMORY CONTROL ALTERABLE) #b111 #b001
- (output-32bit-address a))
-
- ((@PCO (? o))
- (DATA MEMORY CONTROL) #b111 #b010
- (output-16bit-offset o))
-
- ((@PCR (? l))
- (DATA MEMORY CONTROL) #b111 #b010
- (output-16bit-relative l))
-
- ((@PCOX (? o) (? xtype) (? xr) (? s))
- (QUALIFIER (da? xtype) (wl? s))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-offset-index-register xtype xr s o))
-
- ((@PCRX (? l) (? xtype) (? xr) (? s))
- (QUALIFIER (da? xtype) (wl? s))
- (DATA MEMORY CONTROL) #b111 #b011
- (output-relative-index-register xtype xr s l))
-
- ((& (? i))
- (DATA MEMORY) #b111 #b100
- (output-immediate-data immediate-size i))))
-\f
-;;;; Effective Address Extensions
-
-(define-integrable (output-16bit-offset o)
- (EXTENSION-WORD (16 o SIGNED)))
-
-(define-integrable (output-16bit-relative l)
- (EXTENSION-WORD (16 `(- ,l *PC*) SIGNED)))
-
-(define-integrable (output-offset-index-register xtype xr s o)
- (EXTENSION-WORD (1 (encode-da xtype))
- (3 xr)
- (1 (encode-wl s))
- (3 #b000)
- (8 o SIGNED)))
-
-(define-integrable (output-relative-index-register xtype xr s l)
- (EXTENSION-WORD (1 (encode-da xtype))
- (3 xr)
- (1 (encode-wl s))
- (3 #b000)
- (8 `(- ,l *PC*) SIGNED)))
-
-(define-integrable (output-16bit-address a)
- (EXTENSION-WORD (16 a)))
-
-(define-integrable (output-32bit-address a)
- (EXTENSION-WORD (32 a)))
-
-(define (output-immediate-data immediate-size i)
- (case immediate-size
- ((B)
- (EXTENSION-WORD (8 #b00000000)
- (8 i SIGNED)))
- ((W)
- (EXTENSION-WORD (16 i SIGNED)))
- ((L)
- (EXTENSION-WORD (32 i SIGNED)))
- (else
- (error "OUTPUT-IMMEDIATE-DATA: illegal immediate size"
- immediate-size))))
-\f
-;;; New stuff for 68020
-
-(define (output-brief-format-extension-word immediate-size
- index-register-type index-register
- index-size scale-factor
- displacement)
- (EXTENSION-WORD (1 (encode-da index-register-type))
- (3 index-register)
- (1 (encode-wl index-size))
- (2 (encode-bwlq scale-factor))
- (1 #b0)
- (8 displacement SIGNED)))
-
-(define (output-full-format-extension-word immediate-size
- index-register-type index-register
- index-size scale-factor
- base-suppress? index-suppress?
- base-displacement-size
- base-displacement
- memory-indirection-type
- outer-displacement-size
- outer-displacement)
- (EXTENSION-WORD (1 (encode-da index-register-type))
- (3 index-register)
- (1 (encode-wl index-size))
- (2 (encode-bwlq scale-factor))
- (1 #b1)
- (1 (if base-suppress? #b1 #b0))
- (1 (if index-suppress? #b1 #b0))
- (2 (encode-nwl base-displacement-size))
- (1 #b0)
- (3 (case memory-indirection-type
- ((#F) #b000)
- ((PRE) (encode-nwl outer-displacement-size))
- ((POST)
- (+ #b100 (encode-nwl outer-displacement-size))))))
- (output-displacement base-displacement-size base-displacement)
- (output-displacement outer-displacement-size outer-displacement))
-
-(define (output-displacement size displacement)
- (case size
- ((N))
- ((W) (EXTENSION-WORD (16 displacement SIGNED)))
- ((L) (EXTENSION-WORD (32 displacement SIGNED)))))
-\f
-(define-integrable (output-@D-indirect register)
- (EXTENSION-WORD (1 #b0) ;index register = data
- (3 register)
- (1 #b1) ;index size = longword
- (2 #b00) ;scale factor = 1
- (1 #b1)
- (1 #b1) ;suppress base register
- (1 #b0) ;don't suppress index register
- (2 #b01) ;null base displacement
- (1 #b0)
- (3 #b000) ;no memory indirection
- ))
-
-(define (output-@DO-indirect register displacement)
- (EXTENSION-WORD (1 #b0) ;index register = data
- (3 register)
- (1 #b1) ;index size = 32 bits
- (2 #b00) ;scale factor = 1
- (1 #b1)
- (1 #b1) ;suppress base register
- (1 #b0) ;don't suppress index register
- (2 #b10) ;base displacement size = 16 bits
- (1 #b0)
- (3 #b000) ;no memory indirection
- (16 displacement SIGNED)))
-\f
-;;;; Operand Syntaxers.
-
-(define (immediate-words data size)
- (case size
- ((B) (immediate-byte data))
- ((W) (immediate-word data))
- ((L) (immediate-long data))
- (else (error "IMMEDIATE-WORD: Illegal size" size))))
-
-(define-integrable (immediate-byte data)
- `(GROUP ,(make-bit-string 8 0)
- ,(syntax-evaluation data coerce-8-bit-signed)))
+ ((& (? 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)
-\f
-;;;; 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))
\f
-(define (register-list? expression)
- (eq?-subset? expression '(D0 D1 D2 D3 D4 D5 D6 D7 A0 A1 A2 A3 A4 A5 A6 A7)))
-
-(define ((encode-register-list encoding) registers)
- (let ((bit-string (make-bit-string 16 #!FALSE)))
- (for-each (lambda (register)
- (bit-string-set! bit-string (cdr (assq register encoding))))
- registers)
- bit-string))
-
-(define encode-c@a+register-list
- (encode-register-list
- '((A7 . 0) (A6 . 1) (A5 . 2) (A4 . 3) (A3 . 4) (A2 . 5) (A1 . 6) (A0 . 7)
- (D7 . 8) (D6 . 9) (D5 . 10) (D4 . 11) (D3 . 12) (D2 . 13)
- (D1 . 14) (D0 . 15))))
-
-(define encode-@-aregister-list
- (encode-register-list
- '((D0 . 0) (D1 . 1) (D2 . 2) (D3 . 3) (D4 . 4) (D5 . 5) (D6 . 6) (D7 . 7)
- (A0 . 8) (A1 . 9) (A2 . 10) (A3 . 11) (A4 . 12) (A5 . 13)
- (A6 . 14) (A7 . 15))))
-
-(define-instruction DC
- ((W (? expression))
- (WORD (16 expression SIGNED))))
\ 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
#| -*-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
(declare (usual-integrations))
\f
+;;;; Pseudo ops
+
+(define-instruction DC
+ ((W (? expression))
+ (WORD (16 expression SIGNED))))
+\f
;;;; BCD Arithmetic
(let-syntax ((define-BCD-addition
(let-syntax ((define-binary-addition
(macro (keyword Qkeyword Xkeyword opcode Qbit Iopcode)
`(BEGIN
- (define-instruction ,Qkeyword
- (((? s) (& (? data)) (? ea ea-all))
- (QUALIFIER (bwl? s) (ea-a&<b=>-A> ea s))
+ (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))
\f
(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))))
\f
;;;; 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))))
\f
;;;; Bitwise Logical
(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))))
\f
;;;; Shift
(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)
(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))
#| -*-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
;;;; 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)))
(relative-word l)))
\f
(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)))
;;;; 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
(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))))
(WORD (10 #b0100101011)
(6 dea DESTINATION-EA))))
\f
-(define-instruction MOVEQ
- (((& (? data)) (D (? rx)))
- (WORD (4 #b0111)
- (3 rx)
- (1 #b0)
- (8 data SIGNED))))
-
(define-instruction MOVE
- (((? s) (? sea ea-all) (A (? rx))) ;MOVEA
- (QUALIFIER (wl? s))
- (WORD (3 #b001)
- (1 (encode-lw s))
- (3 rx)
- (3 #b001)
- (6 sea SOURCE-EA s)))
+ ((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)
(WORD (13 #b0100111001100)
(3 rx))))
\f
+;; 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)))
\f
(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)))
#| -*-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
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))
\f
;;;; 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))
(+ #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)))))
\f
(define (increment-anl an n)
(case n
- ((0) '())
- ((1 2) `((ADDQ L (& ,(* 4 n)) (A ,an))))
- ((-1 -2) `((SUBQ L (& ,(* -4 n)) (A ,an))))
- (else `((LEA (@AO ,an ,(* 4 n)) (A ,an))))))
+ ((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)))
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))))))
\f
(define (invert-cc cc)
(cdr (or (assq cc
(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)))
\f
(define (indirect-reference! register offset)
(if (= register regnum:frame-pointer)
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))))))))
+\f
(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)))
\f
;;;; Registers/Entries
(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
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)))
#| -*-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
(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)
(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)))
\f
(define-integrable (interpreter-register:access)
(rtl:make-machine-register d0))
(define-integrable (interpreter-stack-pointer? register)
(= (rtl:register-number register) regnum:stack-pointer))
\f
-(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
#| -*-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
(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))))
"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
"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
#| -*-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
(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)))
(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))
\f
(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)))
;; 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))
(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*)))))
\f
;;;; 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)))))
\f
;;;; 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)))))
\f
;;;; 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)))))
#| -*-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
(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)))))
(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)))))
#| -*-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
(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)
(? 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)))))
\f
(define-rule statement
(INVOCATION:CACHE-REFERENCE (? frame-size) (? prefix) (? continuation)
(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)
(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))))
\f
(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))))
\f
-;;; 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)))))))))))
\f
;;;; Procedure/Continuation Entries
(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
(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)))))
\f
(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)))
#| -*-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
(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. ;
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))
|#
))
(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)))))))
(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)))))))
\f
(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))
(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)
projects / mit-scheme.git / commitdiff