#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.4 1992/02/05 17:21:48 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.5 1992/02/06 05:09:03 jinx Exp $
$MC68020-Header: /scheme/compiler/bobcat/RCS/lapgen.scm,v 4.42 1991/05/28 19:14:26 jinx Exp $
Copyright (c) 1992 Massachusetts Institute of Technology
(LAP (LEA ,target (@RO ,pc-register (- ,label-expr ,pc-label)))))))
\f
(define (with-pc recvr)
- (let ((pc-info (pc-registered?)))
- (if pc-info
- (recvr (pc-info/label pc-info)
- (pc-info/reg pc-info))
- (let ((reg (allocate-temporary-register! 'GENERAL)))
- (pc->reg reg
- (lambda (label code)
- (pc-register! (make-pc-info label reg))
- (LAP ,@code
- (recvr label reg))))))))
-
-(define (pc->reg reg recvr)
- (let ((label (GENERATE-LABEL 'GET-PC)))
- (recvr label
- (LAP (CALL (@PCR ,label))
- (LABEL ,label)
- (POP (R ,reg))))))
+ (with-values (lambda () (get-cached-label))
+ (lambda (label reg)
+ (if label
+ (recvr label reg)
+ (let ((temporary (allocate-temporary-register! 'GENERAL))
+ (label (generate-label 'GET-PC)))
+ (cache-label! label temporary)
+ (LAP (CALL (@PCR ,label))
+ (LABEL ,label)
+ (POP (R ,(register-reference temporary)))
+ ,@(recvr label temporary)))))))
+
+(define-integrable (get-cached-label)
+ (register-map-label *register-map* 'GENERAL))
+
+(define-integrable (cache-label! label temporary)
+ (set! *register-map*
+ (set-machine-register-label *register-map* alias label))
+ unspecific)
(define (compare/register*register reg1 reg2)
(cond ((register-alias reg1 'GENERAL)
error
primitive-error
|#
- ))
-\f
-;;; *** Here ***
-
-;;;; Register-Allocator Interface
-
-(define (reference->register-transfer source target)
- (if (and (effective-address/register? source)
- (= (lap:ea-R-register source) target))
- (LAP)
- (LAP (MOV L ,source ,(register-reference target)))))
-
-(define (register->register-transfer source target)
- (LAP ,@(machine->machine-register source target)))
-
-(define (home->register-transfer source target)
- (LAP ,@(pseudo->machine-register source target)))
-
-(define (register->home-transfer source target)
- (LAP ,@(machine->pseudo-register source target)))
-
-(define-integrable (pseudo-register-home register)
- (offset-reference regnum:regs-pointer
- (pseudo-register-offset register)))
-
-(define (register-types-compatible? type1 type2)
- (boolean=? (eq? type1 'FLOAT) (eq? type2 'FLOAT)))
-
-(define (register-type register)
- ;; This will have to be changed when floating point support is added.
- (if (or (machine-register? register)
- (register-value-class=word? register))
- 'GENERAL
- (error "unable to determine register type" register)))
-
-(define register-reference
- (let ((references (make-vector number-of-machine-registers)))
- (let loop ((i 0))
- (if (< i number-of-machine-registers)
- (begin
- (vector-set! references i (INST-EA (R ,i)))
- (loop (1+ i)))))
- (lambda (register)
- (vector-ref references register))))
-
-(define mask-reference
- (register-reference regnum:pointer-mask))
-
-(define (lap:make-label-statement label)
- ;; This should use LAP rather than INST, but
- ;; that requires changing back/linear.scm
- (INST (LABEL ,label)))
-
-(define (lap:make-unconditional-branch label)
- (LAP (BR (@PCR ,label)))) ; Unsized
-
-(define (lap:make-entry-point label block-start-label)
- block-start-label
- (LAP (ENTRY-POINT ,label)
- ,@(make-external-label expression-code-word label)))
-\f
-;;;; Basic Machine Instructions
-
-(define-integrable (pseudo->machine-register source target)
- (memory->machine-register (pseudo-register-home source) target))
-
-(define-integrable (machine->pseudo-register source target)
- (machine-register->memory source (pseudo-register-home target)))
-
-(define (pseudo-float? register)
- (and (pseudo-register? register)
- (value-class=float? (pseudo-register-value-class register))))
-
-(define (pseudo-word? register)
- (and (pseudo-register? register)
- (value-class=word? (pseudo-register-value-class register))))
-
-(define-integrable (machine->machine-register source target)
- (LAP (MOV L
- ,(register-reference source)
- ,(register-reference target))))
-
-(define-integrable (machine-register->memory source target)
- (LAP (MOV L
- ,(register-reference source)
- ,target)))
-
-(define-integrable (memory->machine-register source target)
- (LAP (MOV L
- ,source
- ,(register-reference target))))
-
-(define (byte-offset-reference register offset)
- (if (zero? offset)
- (INST-EA (@R ,register))
- (INST-EA (@RO ,(datum-size offset) ,register ,offset))))
-
-(define-integrable (offset-reference register offset)
- (byte-offset-reference register (* 4 offset)))
-
-(define-integrable (pseudo-register-offset register)
- ;; Offset into register block for temporary registers
- (+ (+ (* 16 4) (* 40 8))
- (* 2 (register-renumber register))))
-
-(define (datum-size datum)
- (cond ((<= -128 datum 127) 'B)
- ((<= -32768 datum 32767) 'W)
- (else 'L)))
-\f
-;;;; Utilities needed by the rules files.
-
-(define-integrable (standard-target-reference target)
- (delete-dead-registers!)
- (reference-target-alias! target 'GENERAL))
-
-(define-integrable (any-register-reference register)
- (standard-register-reference register false true))
-
-(define-integrable (standard-temporary-reference)
- (reference-temporary-register! 'GENERAL))
-
-;;; Assignments
-
-(define-integrable (convert-object/constant->register target constant
- rtconversion
- ctconversion)
- (let ((target (standard-target-reference target)))
- (if (non-pointer-object? constant)
- (ctconversion constant target)
- (rtconversion (constant->ea constant) target))))
-
-(define-integrable (convert-object/register->register target source conversion)
- ;; `conversion' often expands into multiple references to `target'.
- (with-register-copy-alias! source 'GENERAL target
- (lambda (target)
- (conversion target target))
- conversion))
-
-(define-integrable (convert-object/offset->register target address
- offset conversion)
- (let ((source (indirect-reference! address offset)))
- (conversion source
- (standard-target-reference target))))
-
-;;; Predicates
-
-(define (predicate/memory-operand? expression)
- (or (rtl:offset? expression)
- (and (rtl:post-increment? expression)
- (interpreter-stack-pointer?
- (rtl:post-increment-register expression)))))
-
-(define (predicate/memory-operand-reference expression)
- (case (rtl:expression-type expression)
- ((OFFSET) (offset->indirect-reference! expression))
- ((POST-INCREMENT) (INST-EA (@R+ 14)))
- (else (error "Illegal memory operand" expression))))
-
-(define (compare/register*register register-1 register-2 cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,(any-register-reference register-1)
- ,(any-register-reference register-2))))
-
-(define (compare/register*memory register memory cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,(any-register-reference register) ,memory)))
-
-(define (compare/memory*memory memory-1 memory-2 cc)
- (set-standard-branches! cc)
- (LAP (CMP L ,memory-1 ,memory-2)))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Interpreter and interface calls
-
-(define (interpreter-call-argument? expression)
- (or (rtl:register? expression)
- (rtl:constant? expression)
- (and (rtl:cons-pointer? expression)
- (rtl:machine-constant? (rtl:cons-pointer-type expression))
- (rtl:machine-constant? (rtl:cons-pointer-datum expression)))
- (and (rtl:offset? expression)
- (rtl:register? (rtl:offset-base expression)))))
-
-(define (interpreter-call-argument->machine-register! expression register)
- (let ((target (register-reference register)))
- (case (car expression)
- ((REGISTER)
- (load-machine-register! (rtl:register-number expression) register))
- ((CONSTANT)
- (LAP ,@(clear-registers! register)
- ,@(load-constant (rtl:constant-value expression) target)))
- ((CONS-POINTER)
- (LAP ,@(clear-registers! register)
- ,@(load-non-pointer (rtl:machine-constant-value
- (rtl:cons-pointer-type expression))
- (rtl:machine-constant-value
- (rtl:cons-pointer-datum expression))
- target)))
- ((OFFSET)
- (let ((source-reference (offset->indirect-reference! expression)))
- (LAP ,@(clear-registers! register)
- (MOV L ,source-reference ,target))))
- (else
- (error "Unknown expression type" (car expression))))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Object structure.
-
-(define (cons-pointer/ea type-ea datum target)
- (LAP (ROTL (S ,scheme-datum-width) ,type-ea ,target)
- (BIS L ,datum ,target)))
-
-(define (cons-pointer/constant type datum target)
- (if (ea/same? datum target)
- (LAP (BIS L (&U ,(make-non-pointer-literal type 0)) ,target))
- (cons-pointer/ea (INST-EA (S ,type)) datum target)))
-
-(define (set-type/ea type-ea target)
- (LAP (INSV ,type-ea (S ,scheme-datum-width) (S ,scheme-type-width)
- ,target)))
-
-(define-integrable (set-type/constant type target)
- (set-type/ea (INST-EA (S ,type)) target))
-
-(define-integrable (extract-type source target)
- (LAP (EXTV Z (S ,scheme-datum-width) (S ,scheme-type-width)
- ,source ,target)))
-
-(define (object->type source target)
- (extract-type source target))
-
-(define-integrable (ct/object->type object target)
- (load-immediate (object-type object) target))
-
-(define (object->datum source target)
- (if (eq? source target)
- (LAP (BIC L ,mask-reference ,target))
- (LAP (BIC L ,mask-reference ,source ,target))))
-
-(define-integrable (ct/object->datum object target)
- (load-immediate (object-datum object) target))
-
-(define (object->address source target)
- (declare (integrate-operator object->datum))
- (object->datum source target))
-
-(define-integrable (ct/object->address object target)
- (declare (integrate-operator ct/object->datum))
- (ct/object->datum object target))
-
-(define (compare-type type ea)
- (set-standard-branches! 'EQL)
- (LAP (CMPV Z (S ,scheme-datum-width) (S ,scheme-type-width)
- ,ea ,(make-immediate type))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-(define-integrable (ea/same? ea1 ea2)
- (equal? ea1 ea2))
-
-(define (ea/copy source target)
- (if (ea/same? source target)
- (LAP)
- (LAP (MOV L ,source ,target))))
-
-(define (increment/ea ea offset)
- (cond ((zero? offset)
- (LAP))
- ((= offset 1)
- (LAP (INC L ,ea)))
- ((= offset -1)
- (LAP (DEC L ,ea)))
- ((<= 0 offset 63)
- (LAP (ADD L (S ,offset) ,ea)))
- ((<= -63 offset 0)
- (LAP (SUB L (S ,(- 0 offset)) ,ea)))
- ((effective-address/register? ea)
- (let ((size (datum-size offset)))
- (if (not (eq? size 'L))
- (LAP (MOVA L (@RO ,size ,(lap:ea-R-register ea) ,offset)
- ,ea))
- (LAP (ADD L (& ,offset) ,ea)))))
- (else
- (LAP (ADD L (& ,offset) ,ea)))))
-
-(define (add-constant/ea source offset target)
- (if (ea/same? source target)
- (increment/ea target offset)
- (cond ((zero? offset)
- (LAP (MOV L ,source ,target)))
- ((<= 0 offset 63)
- (LAP (ADD L (S ,offset) ,source ,target)))
- ((<= -63 offset 0)
- (LAP (SUB L (S ,(- 0 offset)) ,source ,target)))
- ((effective-address/register? source)
- (let ((size (datum-size offset)))
- (if (not (eq? size 'L))
- (LAP (MOVA L (@RO ,size ,(lap:ea-R-register source) ,offset)
- ,target))
- (LAP (ADD L (& ,offset) ,source ,target)))))
- (else
- (LAP (ADD L (& ,offset) ,source ,target))))))
-
-(define-integrable (increment-rn rn value)
- (increment/ea (INST-EA (R ,rn)) value))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Constants
-
-(define (make-immediate value)
- (if (<= 0 value 63)
- (INST-EA (S ,value))
- (INST-EA (& ,value))))
-
-(define (constant->ea constant)
- (if (non-pointer-object? constant)
- (non-pointer->ea (object-type constant)
- (careful-object-datum constant))
- (INST-EA (@PCR ,(constant->label constant)))))
-
-(define (non-pointer->ea type datum)
- (if (and (zero? type)
- (<= 0 datum 63))
- (INST-EA (S ,datum))
- (INST-EA (&U ,(make-non-pointer-literal type datum)))))
-
-(define (load-constant constant target)
- (if (non-pointer-object? constant)
- (load-non-pointer (object-type constant)
- (object-datum constant)
- target)
- (LAP (MOV L (@PCR ,(constant->label constant)) ,target))))
-
-(define (load-non-pointer type datum target)
- (if (not (zero? type))
- (LAP (MOV L (&U ,(make-non-pointer-literal type datum)) ,target))
- (load-immediate datum target)))
-
-(define (load-immediate value target)
- (cond ((zero? value)
- (LAP (CLR L ,target)))
- ((<= 0 value 63)
- (LAP (MOV L (S ,value) ,target)))
- (else
- (let ((size (datum-size value)))
- (if (not (eq? size 'L))
- (LAP (CVT ,size L (& ,value) ,target))
- (LAP (MOV L (& ,value) ,target)))))))
-
-(define-integrable (load-rn value rn)
- (load-immediate value (INST-EA (R ,rn))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Predicate utilities
-
-(define (set-standard-branches! condition-code)
- (set-current-branches!
- (lambda (label)
- (LAP (B ,condition-code (@PCR ,label))))
- (lambda (label)
- (LAP (B ,(invert-cc condition-code) (@PCR ,label))))))
-
-(define (test-byte n effective-address)
- (cond ((zero? n)
- (LAP (TST B ,effective-address)))
- ((<= 0 n 63)
- (LAP (CMP B ,effective-address (S ,n))))
- (else
- (LAP (CMP B ,effective-address (& ,n))))))
-
-(define (test-non-pointer type datum effective-address)
- (cond ((not (zero? type))
- (LAP (CMP L
- ,effective-address
- (&U ,(make-non-pointer-literal type datum)))))
- ((zero? datum)
- (LAP (TST L ,effective-address)))
- ((<= 0 datum 63)
- (LAP (CMP L ,effective-address (S ,datum))))
- (else
- (LAP (CMP L
- ,effective-address
- (&U ,(make-non-pointer-literal type datum)))))))
-
-(define (invert-cc condition-code)
- (cdr (or (assq condition-code
- '((NEQU . EQLU) (EQLU . NEQU)
- (NEQ . EQL) (EQL . NEQ)
- (GTR . LEQ) (LEQ . GTR)
- (GEQ . LSS) (LSS . GEQ)
- (VC . VS) (VS . VC)
- (CC . CS) (CS . CC)
- (GTRU . LEQU) (LEQU . GTRU)
- (GEQU . LSSU) (LSSU . GEQU)))
- (error "INVERT-CC: Not a known CC" condition-code))))
-
-(define (invert-cc-noncommutative condition-code)
- ;; Despite the fact that the name of this procedure is similar to
- ;; that of `invert-cc', it is quite different. `invert-cc' is used
- ;; when the branches of a conditional are being exchanged, while
- ;; this is used when the arguments are being exchanged.
- (cdr (or (assq condition-code
- '((NEQU . NEQU) (EQLU . EQLU)
- (NEQ . NEQ) (EQL . EQL)
- (GTR . LSS) (LSS . GTR)
- (GEQ . LEQ) (LEQ . GEQ)
- ;; *** Are these two really correct? ***
- (VC . VC) (VS . VS)
- (CC . CC) (CS . CS)
- (GTRU . LSSU) (LSSU . GTRU)
- (GEQU . LEQU) (LEQU . GEQU)))
- (error "INVERT-CC-NONCOMMUTATIVE: Not a known CC" condition-code))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-(define-integrable (effective-address/register? ea)
- (eq? (lap:ea-keyword ea) 'R))
-
-(define-integrable (effective-address/register-indirect? ea)
- (eq? (lap:ea-keyword ea) '@R))
-
-(define-integrable (effective-address/register-offset? ea)
- (eq? (lap:ea-keyword ea) '@RO))
-
-(define (offset->indirect-reference! offset)
- (indirect-reference! (rtl:register-number (rtl:offset-base offset))
- (rtl:offset-number offset)))
-
-(define-integrable (indirect-reference! register offset)
- (offset-reference (allocate-indirection-register! register) offset))
-
-(define-integrable (indirect-byte-reference! register offset)
- (byte-offset-reference (allocate-indirection-register! register) offset))
-
-(define (allocate-indirection-register! register)
- (load-alias-register! register 'GENERAL))
-
-(define (generate-n-times n limit instruction-gen with-counter)
- (if (> n limit)
- (let ((loop (generate-label 'LOOP)))
- (with-counter
- (lambda (counter)
- (LAP ,@(load-rn (-1+ n) counter)
- (LABEL ,loop)
- ,@(instruction-gen)
- (SOB GEQ (R ,counter) (@PCR ,loop))))))
- (let loop ((n n))
- (if (zero? n)
- (LAP)
- (LAP ,@(instruction-gen)
- ,@(loop (-1+ n)))))))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; CHAR->ASCII utilities
-
-(define (coerce->any/byte-reference register)
- (if (machine-register? register)
- (register-reference register)
- (let ((alias (register-alias register false)))
- (if alias
- (register-reference alias)
- (indirect-char/ascii-reference!
- regnum:regs-pointer
- (pseudo-register-offset register))))))
-
-(define-integrable (indirect-char/ascii-reference! register offset)
- (indirect-byte-reference! register (* offset 4)))
-
-(define (char->signed-8-bit-immediate character)
- (let ((ascii (char->ascii character)))
- (if (< ascii 128)
- ascii
- (- ascii 256))))
-
-(define-integrable (lap:ea-keyword expression)
- (car expression))
-
-(define-integrable (lap:ea-R-register expression)
- (cadr expression))
-
-(define-integrable (lap:ea-@R-register expression)
- (cadr expression))
-
-(define-integrable (lap:ea-@RO-register expression)
- (caddr expression))
-
-(define-integrable (lap:ea-@RO-offset expression)
- (cadddr expression))
-\f
-;;;; Utilities needed by the rules files (contd.)
-
-;;; Layout of the Scheme register array.
-
-(define-integrable reg:compiled-memtop (INST-EA (@R 10)))
-(define-integrable reg:environment (INST-EA (@RO B 10 #x000C)))
-(define-integrable reg:temp (INST-EA (@RO B 10 #x0010)))
-(define-integrable reg:lexpr-primitive-arity (INST-EA (@RO B 10 #x001C)))
-
-(let-syntax ((define-codes
- (macro (start . names)
- (define (loop names index)
- (if (null? names)
- '()
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'CODE:COMPILER-
- (car names))
- ,index)
- (loop (cdr names) (1+ index)))))
- `(BEGIN ,@(loop names start)))))
- (define-codes #x012
- primitive-apply primitive-lexpr-apply
- apply error lexpr-apply link
- interrupt-closure interrupt-dlink interrupt-procedure
- interrupt-continuation interrupt-ic-procedure
- assignment-trap cache-reference-apply
- reference-trap safe-reference-trap unassigned?-trap
- -1+ &/ &= &> 1+ &< &- &* negative? &+ positive? zero?
- access lookup safe-lookup unassigned? unbound?
- set! define lookup-apply))
-
-(let-syntax ((define-entries
- (macro (start . names)
- (define (loop names index)
- (if (null? names)
- '()
- (cons `(DEFINE-INTEGRABLE
- ,(symbol-append 'ENTRY:COMPILER-
- (car names))
- (INST-EA (@RO B 10 ,index)))
- (loop (cdr names) (+ index 8)))))
- `(BEGIN ,@(loop names start)))))
- (define-entries #x40
- scheme-to-interface ; Main entry point (only one necessary)
- scheme-to-interface-jsb ; Used by rules3&4, for convenience.
- trampoline-to-interface ; Used by trampolines, for convenience.
- ;; If more are added, the size of the addressing mode must be changed.
- ))
-
-(define-integrable (invoke-interface code)
- (LAP ,@(load-rn code 0)
- (JMP ,entry:compiler-scheme-to-interface)))
-
-#|
-;; If the entry point scheme-to-interface-jsb were not available,
-;; this code should replace the definition below.
-;; The others can be handled similarly.
-
-(define-integrable (invoke-interface-jsb code)
- (LAP ,@(load-rn code 0)
- (MOVA B (@PCO B 10) (R 1))
- (JMP ,entry:compiler-scheme-to-interface)))
-|#
-
-(define-integrable (invoke-interface-jsb code)
- (LAP ,@(load-rn code 0)
- (JSB ,entry:compiler-scheme-to-interface-jsb)))
+ ))
\ No newline at end of file
projects / mit-scheme.git / commitdiff