#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.43 1992/05/14 03:06:23 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.44 1992/07/05 14:20:16 jinx Exp $
Copyright (c) 1988-1992 Massachusetts Institute of Technology
(and (effective-address/address-register? source)
(= (+ 8 (lap:ea-operand-1 source)) target)))
(LAP)
- (LAP ,(memory->machine-register source target))))
+ (memory->machine-register source target)))
(define (register->register-transfer source target)
- (LAP ,(machine->machine-register source target)))
+ (machine->machine-register source target))
(define (home->register-transfer source target)
- (LAP ,(pseudo->machine-register source target)))
+ (pseudo->machine-register source target))
(define (register->home-transfer source target)
- (LAP ,(machine->pseudo-register source target)))
+ (machine->pseudo-register source target))
(define (pseudo-register-home register)
(offset-reference regnum:regs-pointer (pseudo-register-offset register)))
(if (not (register-types-compatible? source target))
(error "Moving between incompatible register types" source target))
(if (float-register? source)
- (INST (FMOVE ,(register-reference source)
- ,(register-reference target)))
- (INST (MOV L
- ,(register-reference source)
- ,(register-reference target)))))
+ (LAP (FMOVE ,(register-reference source)
+ ,(register-reference target)))
+ (LAP (MOV L
+ ,(register-reference source)
+ ,(register-reference target)))))
(define (machine-register->memory source target)
(if (float-register? source)
- (INST (FMOVE D ,(register-reference source) ,target))
- (INST (MOV L ,(register-reference source) ,target))))
+ (LAP (FMOVE D ,(register-reference source) ,target))
+ (LAP (MOV L ,(register-reference source) ,target))))
(define (memory->machine-register source target)
(if (float-register? target)
- (INST (FMOVE D ,source ,(register-reference target)))
- (INST (MOV L ,source ,(register-reference target)))))
+ (LAP (FMOVE D ,source ,(register-reference target)))
+ (LAP (MOV L ,source ,(register-reference target)))))
(define (offset-reference register offset)
(byte-offset-reference register (* 4 offset)))
\f
(define (load-dnl n d)
(cond ((zero? n)
- (INST (CLR L (D ,d))))
+ (LAP (CLR L (D ,d))))
((<= -128 n 127)
- (INST (MOVEQ (& ,n) (D ,d))))
+ (LAP (MOVEQ (& ,n) (D ,d))))
(else
- (INST (MOV L (& ,n) (D ,d))))))
+ (LAP (MOV L (& ,n) (D ,d))))))
(define (load-dnw n d)
(cond ((zero? n)
- (INST (CLR W (D ,d))))
+ (LAP (CLR W (D ,d))))
((<= -128 n 127)
- (INST (MOVEQ (& ,n) (D ,d))))
+ (LAP (MOVEQ (& ,n) (D ,d))))
(else
- (INST (MOV W (& ,n) (D ,d))))))
-
-(define (test-dnw n d)
- (if (zero? n)
- (INST (TST W (D ,d)))
- (INST (CMPI W (& ,n) (D ,d)))))
+ (LAP (MOV W (& ,n) (D ,d))))))
(define (ea+=constant ea c)
(cond ((zero? c)
(define (memory-set-type type target)
(if (= 8 scheme-type-width)
- (INST (MOV B (& ,type) ,target))
- (INST (OR B (& ,(* type-scale-factor type)) ,target))))
+ (LAP (MOV B (& ,type) ,target))
+ (LAP (OR B (& ,(* type-scale-factor type)) ,target))))
\f
(define (test-byte n effective-address)
;; This is used to test actual bytes.
;; Type codes are "preprocessed" by the pertinent rule.
(if (and (zero? n) (effective-address/data&alterable? effective-address))
- (INST (TST B ,effective-address))
- (INST (CMPI B (& ,n) ,effective-address))))
+ (LAP (TST B ,effective-address))
+ (LAP (CMPI B (& ,n) ,effective-address))))
(define (test-non-pointer-constant constant target)
(test-non-pointer (object-type constant)
(if (and (zero? type)
(zero? datum)
(effective-address/data&alterable? effective-address))
- (INST (TST L ,effective-address))
- (INST (CMPI UL
- (& ,(make-non-pointer-literal type datum))
- ,effective-address))))
+ (LAP (TST L ,effective-address))
+ (LAP (CMPI UL
+ (& ,(make-non-pointer-literal type datum))
+ ,effective-address))))
(define (set-standard-branches! cc)
(set-current-branches!
(let ((loop (generate-label 'LOOP)))
(with-counter
(lambda (counter)
- (LAP ,(load-dnw (-1+ n) counter)
+ (LAP ,@(load-dnw (-1+ n) counter)
(LABEL ,loop)
- ,(instruction-gen)
+ ,@(instruction-gen)
(DB F (D ,counter) (@PCR ,loop))))))
(let loop ((n n))
(if (zero? n)
(LAP)
- (LAP ,(instruction-gen)
+ (LAP ,@(instruction-gen)
,@(loop (-1+ n)))))))
(define (standard-target-expression? target)
(register-reference (move-to-alias-register! source type target))))
(lambda (target)
(LAP
- ,(if (eq? type 'FLOAT)
- (load-float-register
- (standard-register-reference source type false)
- target)
- (INST (MOV L
+ ,@(if (eq? type 'FLOAT)
+ (load-float-register
+ (standard-register-reference source type false)
+ target)
+ (LAP (MOV L
,(standard-register-reference source type true)
,target)))
,@(operate-on-target target)))))
(lambda (target)
(let ((temp (reference-temporary-register! type)))
(LAP ,@(operate-on-machine-target temp)
- ,(if (eq? type 'FLOAT)
- (load-float-register temp target)
- (INST (MOV L ,temp ,target))))))))
+ ,@(if (eq? type 'FLOAT)
+ (load-float-register temp target)
+ (LAP (MOV L ,temp ,target))))))))
(case (rtl:expression-type target)
((REGISTER)
(let ((register (rtl:register-number target)))
(define (load-float-register source target)
(if (effective-address/float-register? source)
- (INST (FMOVE ,source ,target))
- (INST (FMOVE D ,source ,target))))
+ (LAP (FMOVE ,source ,target))
+ (LAP (FMOVE D ,source ,target))))
(define (reuse-and-operate-on-machine-target! type target operate-on-target)
(reuse-machine-target! type target
target source1 source2)
(let ((worst-case
(lambda (target source1 source2)
- (LAP ,(if (eq? target-type 'FLOAT)
- (load-float-register source1 target)
- (INST (MOV L ,source1 ,target)))
+ (LAP ,@(if (eq? target-type 'FLOAT)
+ (load-float-register source1 target)
+ (LAP (MOV L ,source1 ,target)))
,@(operate target source2)))))
(reuse-machine-target! target-type target
(lambda (target)
(define (test-fixnum effective-address)
(if (effective-address/data&alterable? effective-address)
- (INST (TST L ,effective-address))
- (INST (CMPI L (& 0) ,effective-address))))
+ (LAP (TST L ,effective-address))
+ (LAP (CMPI L (& 0) ,effective-address))))
(define (fixnum-predicate->cc predicate)
(case predicate
(LAP (LS R L (& ,m) ,target)
,@(word->fixnum target))
(let ((temp (reference-temporary-register! 'DATA)))
- (LAP ,(load-dnl m temp)
+ (LAP ,@(load-dnl m temp)
(LS R L ,temp ,target)
,@(word->fixnum target))))))
(else
(if (< n 9)
(LAP (LS L L (& ,n) ,target))
(let ((temp (reference-temporary-register! 'DATA)))
- (LAP ,(load-dnl n temp)
+ (LAP ,@(load-dnl n temp)
(LS L L ,temp ,target))))))))
\f
;;; Quotient is weird because it must shift left the quotient,
(define (char->signed-8-bit-immediate character)
(let ((ascii (char->ascii character)))
(if (< ascii 128) ascii (- ascii 256))))
-
-#|
-
-;; *** This is believed to be a fossil. ***
-;; Left here until the first compilation to make sure that it really is.
-;; Can be removed the next time it is seen.
-
-(define (byte-offset->register source source-reg target)
- ;; This code uses a temporary register because right now the register
- ;; allocator thinks that it could use the same register for the target
- ;; and source, while what we want to happen is to first clear the target
- ;; and then move from source to target.
- ;; Optimal Code: (CLR L ,target-ref)
- ;; (MOV B ,source ,target)
- ;; source-register is passed in to check for this. Yuck.
- (delete-dead-registers!)
- (let* ((temp-ref (register-reference (allocate-temporary-register! 'DATA)))
- (target (allocate-alias-register! target 'DATA)))
- (if (= target source-reg)
- (LAP (CLR L ,temp-ref)
- (MOV B ,source ,temp-ref)
- (MOV L ,temp-ref ,(register-reference target)))
- (LAP (CLR L ,(register-reference target))
- (MOV B ,source ,(register-reference target))))))
-
-|#
\f
;;;; Registers/Entries
))
(define-integrable (invoke-interface code)
- (LAP ,(load-dnw code 0)
+ (LAP ,@(load-dnw code 0)
(JMP ,entry:compiler-scheme-to-interface)))
#|
;; The others can be handled similarly.
(define-integrable (invoke-interface-jsr code)
- (LAP ,(load-dnw code 0)
+ (LAP ,@(load-dnw code 0)
(LEA (@PCO 12) (A 0))
(MOV L (A 0) (D 1))
(JMP ,entry:compiler-scheme-to-interface)))
|#
(define-integrable (invoke-interface-jsr code)
- (LAP ,(load-dnw code 0)
+ (LAP ,@(load-dnw code 0)
(JSR ,entry:compiler-scheme-to-interface-jsr)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.36 1991/10/25 06:49:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.37 1992/07/05 14:20:36 jinx Exp $
-Copyright (c) 1988-91 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
(let ((target (indirect-reference! address offset)))
(LAP (MOV L ,(standard-register-reference datum 'DATA true) ,target)
- ,(memory-set-type type target))))
+ ,@(memory-set-type type target))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? address)) (? offset))
(target (indirect-reference! address offset)))
(LAP (LEA ,(indirect-reference! source n) ,temp)
(MOV L ,temp ,target)
- ,(memory-set-type type target))))
+ ,@(memory-set-type type target))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? address)) (? offset))
(target (indirect-reference! address offset)))
(LAP (LEA ,(indirect-byte-reference! source n) ,temp)
(MOV L ,temp ,target)
- ,(memory-set-type type target))))
+ ,@(memory-set-type type target))))
\f
;; Common case that can be done cheaply:
(LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label)))
,temp)
(MOV L ,temp ,target)
- ,(memory-set-type type target))))
+ ,@(memory-set-type type target))))
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a0)) (? n0))
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type)) (REGISTER (? datum))))
(LAP (MOV L ,(standard-register-reference datum 'DATA true) (@-A 7))
- ,(memory-set-type type (INST-EA (@A 7)))))
+ ,@(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(ENTRY:PROCEDURE (? label))))
(LAP (PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
- ,(memory-set-type type (INST-EA (@A 7)))))
+ ,@(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(ENTRY:CONTINUATION (? label))))
(LAP (PEA (@PCR ,label))
- ,(memory-set-type type (INST-EA (@A 7)))))
+ ,@(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(OFFSET-ADDRESS (REGISTER (? r)) (? n))))
(LAP (PEA ,(indirect-reference! r n))
- ,(memory-set-type type (INST-EA (@A 7)))))
+ ,@(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1)
(CONS-POINTER (MACHINE-CONSTANT (? type))
(BYTE-OFFSET-ADDRESS (REGISTER (? r)) (? n))))
(LAP (PEA ,(indirect-byte-reference! r n))
- ,(memory-set-type type (INST-EA (@A 7)))))
+ ,@(memory-set-type type (INST-EA (@A 7)))))
(define-rule statement
(ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.12 1990/01/18 22:44:04 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.13 1992/07/05 14:20:58 jinx Exp $
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. |#
;;;; LAP Generation Rules: Predicates
+;;; package: (compiler lap-syntaxer)
(declare (usual-integrations))
\f
(define-rule predicate
(TYPE-TEST (REGISTER (? register)) (? type))
(set-standard-branches! 'EQ)
- (LAP ,(test-byte type (reference-alias-register! register 'DATA))))
+ (test-byte type (reference-alias-register! register 'DATA)))
(define-rule predicate
(TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
(set-standard-branches! 'EQ)
(let ((source (indirect-reference! address offset)))
(cond ((= scheme-type-width 8)
- (LAP ,(test-byte type source)))
+ (test-byte type source))
((and (zero? type) use-68020-instructions?)
(LAP (BFTST ,source (& 0) (& ,scheme-type-width))))
(else
(LAP ,@(object->type source target)
,@(if (zero? type)
(LAP)
- (LAP ,(test-byte type target)))))
+ (test-byte type target))))
\f
(define-rule predicate
(EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
(if (non-pointer-object? constant)
(begin
(set-standard-branches! 'EQ)
- (LAP ,(test-non-pointer-constant
- constant
- (standard-register-reference register 'DATA true))))
+ (test-non-pointer-constant
+ constant
+ (standard-register-reference register 'DATA true)))
(compare/register*memory register
(INST-EA (@PCR ,(constant->label constant)))
'EQ)))
(if (non-pointer-object? constant)
(begin
(set-standard-branches! 'EQ)
- (LAP ,(test-non-pointer-constant constant memory)))
+ (test-non-pointer-constant constant memory))
(compare/memory*memory memory
(INST-EA (@PCR ,(constant->label constant)))
'EQ))))
(define (eq-test/synthesized-constant*register type datum register)
(set-standard-branches! 'EQ)
- (LAP ,(test-non-pointer type
- datum
- (standard-register-reference register 'DATA true))))
+ (test-non-pointer type
+ datum
+ (standard-register-reference register 'DATA true)))
(define-rule predicate
(EQ-TEST (CONS-POINTER (MACHINE-CONSTANT (? type))
(define (eq-test/synthesized-constant*memory type datum memory)
(set-standard-branches! 'EQ)
- (LAP ,(test-non-pointer type
- datum
- (predicate/memory-operand-reference memory))))
+ (test-non-pointer type
+ datum
+ (predicate/memory-operand-reference memory)))
\f
;;;; Fixnum/Flonum Predicates
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
(set-standard-branches! (fixnum-predicate->cc predicate))
- (LAP ,(test-fixnum (standard-register-reference register 'DATA true))))
+ (test-fixnum (standard-register-reference register 'DATA true)))
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (OBJECT->FIXNUM (REGISTER (? register))))
(FIXNUM-PRED-1-ARG (? predicate) (? memory))
(QUALIFIER (predicate/memory-operand? memory))
(set-standard-branches! (fixnum-predicate->cc predicate))
- (LAP ,(test-fixnum (predicate/memory-operand-reference memory))))
+ (test-fixnum (predicate/memory-operand-reference memory)))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.31 1991/05/28 19:14:55 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.32 1992/07/05 14:20:51 jinx Exp $
-Copyright (c) 1988-1991 Massachusetts Institute of Technology
+Copyright (c) 1988-1992 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define-integrable (clear-continuation-type-code)
(if (= scheme-type-width 8)
- (INST (CLR B (@A 7)))
- (INST (AND L ,mask-reference (@A 7)))))
+ (LAP (CLR B (@A 7)))
+ (LAP (AND L ,mask-reference (@A 7)))))
(define-rule statement
(POP-RETURN)
(LAP ,@(clear-map!)
- ,(clear-continuation-type-code)
+ ,@(clear-continuation-type-code)
(RTS)))
(define-rule statement
((7) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-7)))
((8) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-8)))
(else
- (LAP ,(load-dnl frame-size 2)
+ (LAP ,@(load-dnl frame-size 2)
(JMP ,entry:compiler-shortcircuit-apply))))))
(define-rule statement
frame-size continuation
;; It expects the procedure at the top of the stack
(LAP ,@(clear-map!)
- ,(clear-continuation-type-code)
+ ,@(clear-continuation-type-code)
(RTS)))
(define-rule statement
(INVOCATION:LEXPR (? number-pushed) (? continuation) (? label))
continuation
(LAP ,@(clear-map!)
- ,(load-dnl number-pushed 2)
+ ,@(load-dnl number-pushed 2)
(LEA (@PCR ,label) (A 0))
(MOV L (A 0) (D 1))
,@(invoke-interface code:compiler-lexpr-apply)))
continuation
;; It expects the procedure at the top of the stack
(LAP ,@(clear-map!)
- ,(load-dnl number-pushed 2)
- ,(clear-continuation-type-code)
+ ,@(load-dnl number-pushed 2)
+ ,@(clear-continuation-type-code)
(MOV L (@A+ 7) (D 1))
,@(invoke-interface code:compiler-lexpr-apply)))
(delete-dead-registers!)
(LAP ,@set-extension
,@(clear-map!)
- ,(load-dnl frame-size 3)
+ ,@(load-dnl frame-size 3)
(LEA (@PCR ,*block-label*) (A 1))
(MOV L (A 1) (D 2))
,@(invoke-interface code:compiler-cache-reference-apply))))
(LAP ,@set-environment
,@(clear-map!)
,@(load-constant name (INST-EA (D 2)))
- ,(load-dnl frame-size 3)
+ ,@(load-dnl frame-size 3)
,@(invoke-interface code:compiler-lookup-apply))))
(define-rule statement
continuation
(LAP ,@(clear-map!)
,@(if (eq? primitive compiled-error-procedure)
- (LAP ,(load-dnl frame-size 1)
+ (LAP ,@(load-dnl frame-size 1)
(JMP ,entry:compiler-error))
(let ((arity (primitive-procedure-arity primitive)))
(cond ((not (negative? arity))
(JMP ,entry:compiler-primitive-lexpr-apply)))
(else
;; Unknown primitive arity. Go through apply.
- (LAP ,(load-dnl frame-size 2)
+ (LAP ,@(load-dnl frame-size 2)
(MOV L (@PCR ,(constant->label primitive)) (D 1))
,@(invoke-interface code:compiler-apply))))))))
\f
(LAP (MOV L (@AO 7 4) (@AO 7 8))
(MOV L (@A+ 7) (@A 7)))
(let ((i (lambda ()
- (INST (MOV L (@A+ 7)
- ,(offset-reference a7 (-1+ how-far)))))))
- (LAP ,(i)
- ,(i)
+ (LAP (MOV L (@A+ 7)
+ ,(offset-reference a7 (-1+ how-far)))))))
+ (LAP ,@(i)
+ ,@(i)
,@(increment-machine-register 15 (* 4 (- how-far 2)))))))
(else
(generate/move-frame-up frame-size (offset-reference a7 offset))))))
,@(generate-n-times
frame-size 5
(lambda ()
- (INST (MOV L
- (@-A ,(- temp 8))
- (@-A ,(- destination 8)))))
+ (LAP (MOV L
+ (@-A ,(- temp 8))
+ (@-A ,(- destination 8)))))
(lambda (generator)
(generator (allocate-temporary-register! 'DATA))))
(MOV L ,(register-reference destination) (A 7)))))
;; and returns its value in a0.
(define (MC68040/allocate-closure size)
- (LAP ,(load-dnl size 0)
+ (LAP ,@(load-dnl size 0)
(JSR ,entry:compiler-allocate-closure)))
;; If this issues too much code, the optional code can be eliminated at
(MOV L (A 0) (D 2))
(LEA (@PCR ,free-ref-label) (A 0))
(MOV L (A 0) (D 3))
- ,(load-dnl n-sections 4)
+ ,@(load-dnl n-sections 4)
(JSR ,entry:compiler-link)
,@(make-external-label (continuation-code-word false)
(generate-label))))
(let ((load-offset
(lambda (offset)
(if (<= -32768 offset 32767)
- (INST (LEA (@AO 0 ,offset) (A 1)))
- (INST (LEA (@AOF 0 E (,offset L) #F
- ((D 0) L 1) Z
- (0 N))
- (A 1)))))))
+ (LAP (LEA (@AO 0 ,offset) (A 1)))
+ (LAP (LEA (@AOF 0 E (,offset L) #F
+ ((D 0) L 1) Z
+ (0 N))
+ (A 1)))))))
(LAP (MOV L (@PCR ,code-block-label) (D 2))
(AND L ,mask-reference (D 2))
(MOV L (D 2) (A 0))
- ,(load-offset environment-offset)
+ ,@(load-offset environment-offset)
(MOV L ,reg:environment (@A 1))
- ,(load-offset free-ref-offset)
+ ,@(load-offset free-ref-offset)
(MOV L (A 1) (D 3))
- ,(load-dnl n-sections 4)
+ ,@(load-dnl n-sections 4)
(JSR ,entry:compiler-link)
,@(make-external-label (continuation-code-word false)
(generate-label)))))
projects / mit-scheme.git / commitdiff