#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 1.1 1987/06/13 20:58:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 1.1.1.1 1987/07/01 20:59:41 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 (MOVE/SIMPLE 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 (MOVE/SIMPLE 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 (MOVE/SIMPLE 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 (MOVE/SIMPLE 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 (MOVE/SIMPLE L ,datum ,reg:temp)
+ (MOVE/SIMPLE B (& ,type) ,reg:temp)
+ (MOVE/SIMPLE L ,reg:temp ,target*))
+ (LAP (MOVE/SIMPLE L ,datum ,target*)
+ (MOVE/SIMPLE 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))
(REGISTER (? r)))
- `((MOVE L ,(coerce->any r) ,(indirect-reference! a n))))
+ (LAP (MOVE/SIMPLE 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 (MOVE/SIMPLE 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 (MOVE/SIMPLE L ,(coerce->any r) ,target)
+ (MOVE/SIMPLE 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 (MOVE/SIMPLE 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 type-code:unassigned 0 '(@A+ 5))))
+ (LAP ,(load-non-pointer type-code: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 (MOVE/SIMPLE 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 (MOVE/SIMPLE 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 (& ,type-code:return-address) (@AO 5 -4)))))
+ (LAP (LEA (@PCR ,(procedure-external-label (label->procedure label)))
+ ,temporary)
+ (MOVE/SIMPLE L ,temporary (@A+ 5))
+ (MOVE/SIMPLE B (& ,type-code:return-address) (@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 type-code:unassigned 0 '(@-A 7)))))
+ (LAP ,(load-non-pointer type-code: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 (& ,type-code:stack-environment) (@A 7)))
- `((MOVE L ,(coerce->any r) (@-A 7))))))
+ (LAP (PEA ,(offset-reference regnum:stack-pointer
+ (frame-pointer-offset)))
+ (MOVE/SIMPLE B (& ,type-code:stack-environment) (@A 7)))
+ (LAP (MOVE/SIMPLE 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 (MOVE/SIMPLE L ,(coerce->any r) (@-A 7))
+ (MOVE/SIMPLE 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 (MOVE/SIMPLE 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 (& ,type-code:stack-environment) (@A 7)))))
+ (LAP (PEA ,(offset-reference regnum:stack-pointer
+ (+ n (frame-pointer-offset))))
+ (MOVE/SIMPLE B (& ,type-code: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 (& ,type-code:return-address) (@A 7)))))
\ No newline at end of file
+ (LAP (PEA (@PCR ,label))
+ (MOVE/SIMPLE B (& ,type-code:return-address) (@A 7)))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 1.1 1987/06/13 20:58:48 cph Exp $
+$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 $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-rule predicate
(TRUE-TEST (REGISTER (? register)))
(set-standard-branches! 'NE)
- `(,(test-non-pointer (ucode-type false) 0 (coerce->any register))))
+ (LAP ,(test-non-pointer (ucode-type false) 0 (coerce->any register))))
(define-rule predicate
(TRUE-TEST (OFFSET (REGISTER (? register)) (? offset)))
(set-standard-branches! 'NE)
- `(,(test-non-pointer (ucode-type false) 0
- (indirect-reference! register offset))))
+ (LAP ,(test-non-pointer (ucode-type false) 0
+ (indirect-reference! register offset))))
(define-rule predicate
(TYPE-TEST (REGISTER (? register)) (? type))
(QUALIFIER (pseudo-register? register))
(set-standard-branches! 'EQ)
- `(,(test-byte type
- (register-reference (load-alias-register! register 'DATA)))))
+ (LAP ,(test-byte type
+ (register-reference (load-alias-register! register 'DATA)))))
(define-rule predicate
(TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
(QUALIFIER (pseudo-register? register))
(set-standard-branches! 'EQ)
(let ((reference (move-to-temporary-register! register 'DATA)))
- `((RO L L (& 8) ,reference)
- ,(test-byte type reference))))
+ (LAP (RO L L (& 8) ,reference)
+ ,(test-byte type reference))))
(define-rule predicate
(UNASSIGNED-TEST (REGISTER (? register)))
(set-standard-branches! 'EQ)
- `(,(test-non-pointer (ucode-type unassigned) 0 (coerce->any register))))
+ (LAP ,(test-non-pointer (ucode-type unassigned) 0
+ (coerce->any register))))
(define-rule predicate
(UNASSIGNED-TEST (OFFSET (REGISTER (? register)) (? offset)))
(set-standard-branches! 'EQ)
- `(,(test-non-pointer (ucode-type unassigned) 0
- (indirect-reference! register offset))))
+ (LAP ,(test-non-pointer (ucode-type unassigned) 0
+ (indirect-reference! register offset))))
\f
(define (eq-test/constant*register constant register)
(set-standard-branches! 'EQ)
(if (non-pointer-object? constant)
- `(,(test-non-pointer (primitive-type constant)
- (primitive-datum constant)
- (coerce->any register)))
- `((CMP L
- (@PCR ,(constant->label constant))
- ,(coerce->machine-register register)))))
+ (LAP ,(test-non-pointer (primitive-type constant)
+ (primitive-datum constant)
+ (coerce->any register)))
+ (LAP (CMP L
+ (@PCR ,(constant->label constant))
+ ,(coerce->machine-register register)))))
(define (eq-test/constant*memory constant memory-reference)
(set-standard-branches! 'EQ)
(if (non-pointer-object? constant)
- `(,(test-non-pointer (primitive-type constant)
- (primitive-datum constant)
- memory-reference))
+ (LAP ,(test-non-pointer (primitive-type constant)
+ (primitive-datum constant)
+ memory-reference))
(let ((temp (reference-temporary-register! false)))
- `((MOVE L ,memory-reference ,temp)
- (CMP L (@PCR ,(constant->label constant)) ,temp)))))
+ (LAP (MOVE/SIMPLE L
+ ,memory-reference
+ ,temp)
+ (CMP L
+ (@PCR ,(constant->label constant))
+ ,temp)))))
(define (eq-test/register*register register-1 register-2)
(set-standard-branches! 'EQ)
(let ((finish
(lambda (register-1 register-2)
- `((CMP L
- ,(coerce->any register-2)
- ,(coerce->machine-register register-1))))))
+ (LAP (CMP L
+ ,(coerce->any register-2)
+ ,(coerce->machine-register register-1))))))
(if (or (and (not (register-has-alias? register-1 'DATA))
(register-has-alias? register-2 'DATA))
(and (not (register-has-alias? register-1 'ADDRESS))
(define (eq-test/register*memory register memory-reference)
(set-standard-branches! 'EQ)
- `((CMP L ,memory-reference ,(coerce->machine-register register))))
+ (LAP (CMP L
+ ,memory-reference
+ ,(coerce->machine-register register))))
(define (eq-test/memory*memory register-1 offset-1 register-2 offset-2)
(set-standard-branches! 'EQ)
(let ((temp (reference-temporary-register! false)))
(let ((finish
(lambda (register-1 offset-1 register-2 offset-2)
- `((MOVE L ,(indirect-reference! register-1 offset-1) ,temp)
- (CMP L ,(indirect-reference! register-2 offset-2) ,temp)))))
+ (LAP (MOVE/SIMPLE L
+ ,(indirect-reference! register-1 offset-1)
+ ,temp)
+ (CMP L
+ ,(indirect-reference! register-2 offset-2)
+ ,temp)))))
(if (or (and (not (register-has-alias? register-1 'ADDRESS))
(register-has-alias? register-2 'ADDRESS))
(and (not (register-has-alias? register-1 'DATA))
(define-rule predicate
(EQ-TEST (CONSTANT (? constant)) (POST-INCREMENT (REGISTER 15) 1))
- (eq-test/constant*memory constant '(@A+ 7)))
+ (eq-test/constant*memory constant (INST-EA (@A+ 7))))
(define-rule predicate
(EQ-TEST (POST-INCREMENT (REGISTER 15) 1) (CONSTANT (? constant)))
- (eq-test/constant*memory constant '(@A+ 7)))
+ (eq-test/constant*memory constant (INST-EA (@A+ 7))))
(define-rule predicate
(EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
(define-rule predicate
(EQ-TEST (POST-INCREMENT (REGISTER 15) 1) (REGISTER (? register)))
(record-pop!)
- (eq-test/register*memory register '(@A+ 7)))
+ (eq-test/register*memory register (INST-EA (@A+ 7))))
(define-rule predicate
(EQ-TEST (REGISTER (? register)) (POST-INCREMENT (REGISTER 15) 1))
(record-pop!)
- (eq-test/register*memory register '(@A+ 7)))
+ (eq-test/register*memory register (INST-EA (@A+ 7))))
(define-rule predicate
(EQ-TEST (OFFSET (REGISTER (? register-1)) (? offset-1))
(OFFSET (REGISTER (? register-2)) (? offset-2)))
- (eq-test/memory*memory register-1 offset-1 register-2 offset-2))
\ No newline at end of file
+ (eq-test/memory*memory register-1 offset-1register-2 offset-2))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.1 1987/06/13 20:59:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.1.1.1 1987/07/01 21:01:13 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-rule statement
(INVOCATION:APPLY (? number-pushed) (? prefix) (? continuation))
(disable-frame-pointer-offset!
- `(,@(generate-invocation-prefix prefix '())
- ,(load-dnw number-pushed 0)
- (JMP ,entry:compiler-apply))))
+ (LAP ,@(generate-invocation-prefix prefix)
+ ,(load-dnw number-pushed 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 (? number-pushed) (? 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)
+ ,(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)
+ ,(load-constant name (INST-EA (D 5)))
+ ,(load-dnw (1+ frame-size) 0)
+ (JMP ,entry:compiler-lookup-apply)))))
(define-rule statement
(INVOCATION:PRIMITIVE (? number-pushed) (? prefix) (? continuation)
(? primitive))
(disable-frame-pointer-offset!
- `(,@(generate-invocation-prefix prefix '())
- ,@(if (eq? primitive compiled-error-procedure)
- `(,(load-dnw (1+ number-pushed) 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 (1+ number-pushed) 0)
+ (JMP ,entry:compiler-error))
+ (LAP ,(load-dnw (primitive-datum primitive) 6)
+ (JMP ,entry:compiler-primitive-apply))))))
(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))))))
+(define (generate-invocation-prefix prefix)
+ (LAP ,@(clear-map!)
+ ,@(case (car prefix)
+ ((NULL) (LAP))
+ ((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 "GENERATE-INVOCATION-PREFIX: bad prefix type" prefix)))))
(define (generate-invocation-prefix:move-frame-up frame-size how-far)
- (cond ((zero? how-far) '())
- ((zero? frame-size)
- (increment-anl 7 how-far))
+ (cond ((or (zero? frame-size) (zero? how-far))
+ (LAP))
((= frame-size 1)
- `((MOVE L (@A+ 7) ,(offset-reference a7 (-1+ how-far)))
- ,@(increment-anl 7 (-1+ how-far))))
+ (LAP (MOVE/SIMPLE 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 (MOVE/SIMPLE L (@AO 7 4) (@AO 7 8))
+ (MOVE/SIMPLE L (@A+ 7) (@A 7)))
+ (let ((i
+ (INST (MOVE/SIMPLE L
+ (@A+ 7)
+ ,(offset-reference a7 (-1+ how-far))))))
+ (LAP ,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 (MOVE/SIMPLE L
+ (@-A ,(- temp-0 8))
+ (@-A ,(- temp-1 8))))
+ (lambda (generator)
+ (generator (allocate-temporary-register! 'DATA))))
+ (MOVE/SIMPLE 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)
- ,@(if (or (not (null? references))
- (not (null? uuo-links)))
- `(,@(let ((environment-label (allocate-constant-label)))
- `((SCHEME-OBJECT ,environment-label ENVIRONMENT)
- (LEA (@PCR ,environment-label) (A 0))))
- (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)))))
- '())))))
+ (declare-constants references
+ (declare-constants uuo-links
+ (declare-constants constants
+ (if (or (not (null? references))
+ (not (null? uuo-links)))
+ (LAP ,@(let ((environment-label (allocate-constant-label)))
+ (LAP
+ (SCHEME-OBJECT ,environment-label ENVIRONMENT)
+ (LEA (@PCR ,environment-label) (A 0))))
+ (MOVE/SIMPLE 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))))))))
\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)
+ (MOVE/SIMPLE 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)))
- (append! (if (procedure/closure? procedure)
- (let ((required (1+ (procedure-required procedure)))
- (optional (procedure-optional procedure))
- (label (procedure-external-label procedure)))
- (if (and (procedure-rest procedure)
- (zero? required))
- (begin (set-procedure-external-label! procedure
- internal-label)
- `((ENTRY-POINT ,internal-label)))
- `((ENTRY-POINT ,label)
- ,@(make-external-label 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))))
- '())
- (if gc-label
- `((LABEL ,gc-label)
- (JSR ,entry:compiler-interrupt-procedure))
- '())
- `(,@(make-external-label internal-label)))))
+ (LAP ,@(if (procedure/closure? procedure)
+ (let ((required (1+ (procedure-required procedure)))
+ (optional (procedure-optional procedure))
+ (label (procedure-external-label procedure)))
+ (if (and (procedure-rest procedure)
+ (zero? required))
+ (begin (set-procedure-external-label! procedure
+ internal-label)
+ (LAP (ENTRY-POINT ,internal-label)))
+ (LAP (ENTRY-POINT ,label)
+ ,@(make-external-label 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))))
+ (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 1987/06/13 20:59:21 cph Exp $
+$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 $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (lookup-call entry environment name)
(let ((set-environment (expression->machine-register! environment a0)))
(let ((clear-map (clear-map!)))
- `(,@set-environment
- ,@clear-map
- ,(load-constant name '(A 1))
- (JSR ,entry)
- ,@(make-external-label (generate-label))))))
+ (LAP ,@set-environment
+ ,@clear-map
+ ,(load-constant name (INST-EA (A 1)))
+ (JSR ,entry)
+ ,@(make-external-label (generate-label))))))
(define-rule statement
(INTERPRETER-CALL:ENCLOSE (? number-pushed))
- (decrement-frame-pointer-offset! number-pushed
- `((MOVE L (A 5) ,reg:enclose-result)
- (MOVE B (& ,(ucode-type vector)) ,reg:enclose-result)
- ,(load-non-pointer (ucode-type manifest-vector) number-pushed
- '(@A+ 5))
- ,@(generate-n-times number-pushed 5 '(MOVE L (@A+ 7) (@A+ 5))
- (lambda (generator)
- (generator (allocate-temporary-register! 'DATA)))))
-#| Alternate sequence which minimizes code size.
+ (decrement-frame-pointer-offset!
+ number-pushed
+ (LAP (MOVE/SIMPLE L (A 5) ,reg:enclose-result)
+ (MOVE/SIMPLE 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)))
+ (lambda (generator)
+ (generator (allocate-temporary-register! 'DATA)))))
+ #| Alternate sequence which minimizes code size. ;
DO NOT USE THIS! The `clear-registers!' call does not distinguish between
registers containing objects and registers containing unboxed things, and
as a result can write unboxed stuff to memory.
- `(,@(clear-registers! a0 a1 d0)
- (MOVE W (& ,number-pushed) (D 0))
- (JSR ,entry:compiler-enclose))
-|#
- ))
+ (LAP ,@(clear-registers! a0 a1 d0)
+ (MOVE/SIMPLE W (& ,number-pushed) (D 0))
+ (JSR ,entry:compiler-enclose))
+ |#
+ ))
\f
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
(let ((set-environment (expression->machine-register! environment a0)))
(let ((set-value (expression->machine-register! value a2)))
(let ((clear-map (clear-map!)))
- `(,@set-environment
- ,@set-value
- ,@clear-map
- ,(load-constant name '(A 1))
- (JSR ,entry)
- ,@(make-external-label (generate-label)))))))
+ (LAP ,@set-environment
+ ,@set-value
+ ,@clear-map
+ ,(load-constant name (INST-EA (A 1)))
+ (JSR ,entry)
+ ,@(make-external-label (generate-label)))))))
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name)
(let ((set-environment (expression->machine-register! environment a0)))
(let ((datum (coerce->any datum)))
(let ((clear-map (clear-map!)))
- `(,@set-environment
- (MOVE L ,datum ,reg:temp)
- (MOVE B (& ,type) ,reg:temp)
- ,@clear-map
- (MOVE L ,reg:temp (A 2))
- ,(load-constant name '(A 1))
- (JSR ,entry)
- ,@(make-external-label (generate-label)))))))
+ (LAP ,@set-environment
+ (MOVE/SIMPLE L ,datum ,reg:temp)
+ (MOVE/SIMPLE B (& ,type) ,reg:temp)
+ ,@clear-map
+ (MOVE/SIMPLE L ,reg:temp (A 2))
+ ,(load-constant name (INST-EA (A 1)))
+ (JSR ,entry)
+ ,@(make-external-label (generate-label)))))))
\f
(define-rule statement
(INTERPRETER-CALL:CACHE-REFERENCE (? extension) (? safe?))
(let ((set-extension (expression->machine-register! extension a0)))
(let ((clear-map (clear-map!)))
- `(,@set-extension
- ,@clear-map
- (JSR ,(if safe?
- entry:compiler-safe-reference-trap
- entry:compiler-reference-trap))
- ,@(make-external-label (generate-label))))))
+ (LAP ,@set-extension
+ ,@clear-map
+ (JSR ,(if safe?
+ entry:compiler-safe-reference-trap
+ entry:compiler-reference-trap))
+ ,@(make-external-label (generate-label))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value))
(let ((set-extension (expression->machine-register! extension a0)))
(let ((set-value (expression->machine-register! value a1)))
(let ((clear-map (clear-map!)))
- `(,@set-extension
- ,@set-value
- ,@clear-map
- (JSR ,entry:compiler-assignment-trap)
- ,@(make-external-label (generate-label)))))))
+ (LAP ,@set-extension
+ ,@set-value
+ ,@clear-map
+ (JSR ,entry:compiler-assignment-trap)
+ ,@(make-external-label (generate-label)))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension)
(let ((set-extension (expression->machine-register! extension a0)))
(let ((datum (coerce->any datum)))
(let ((clear-map (clear-map!)))
- `(,@set-extension
- (MOVE L ,datum ,reg:temp)
- (MOVE B (& ,type) ,reg:temp)
- ,@clear-map
- (MOVE L ,reg:temp (A 1))
- (JSR ,entry:compiler-assignment-trap)
- ,@(make-external-label (generate-label)))))))
+ (LAP ,@set-extension
+ (MOVE/SIMPLE L ,datum ,reg:temp)
+ (MOVE/SIMPLE B (& ,type) ,reg:temp)
+ ,@clear-map
+ (MOVE/SIMPLE L ,reg:temp (A 1))
+ (JSR ,entry:compiler-assignment-trap)
+ ,@(make-external-label (generate-label)))))))
\f
;;;; Poppers
(define-rule statement
(MESSAGE-RECEIVER:CLOSURE (? frame-size))
(record-push!
- `((MOVE L (& ,(* frame-size 4)) (@-A 7)))))
+ (LAP (MOVE/SIMPLE L (& ,(* frame-size 4)) (@-A 7)))))
(define-rule statement
(MESSAGE-RECEIVER:STACK (? frame-size))
(record-push!
- `((MOVE L (& ,(+ #x00100000 (* frame-size 4))) (@-A 7)))))
+ (LAP (MOVE/SIMPLE L
+ (& ,(+ #x00100000 (* frame-size 4)))
+ (@-A 7)))))
(define-rule statement
(MESSAGE-RECEIVER:SUBPROBLEM (? label))
(record-continuation-frame-pointer-offset! label)
- (increment-frame-pointer-offset! 2
- `((PEA (@PCR ,label))
- (MOVE B (& ,type-code:return-address) (@A 7))
- (MOVE L (& #x00200000) (@-A 7)))))
+ (increment-frame-pointer-offset!
+ 2
+ (LAP (PEA (@PCR ,label))
+ (MOVE/SIMPLE B (& ,type-code:return-address) (@A 7))
+ (MOVE/SIMPLE L (& #x00200000) (@-A 7)))))
(define (apply-closure-sequence frame-size receiver-offset label)
- `(,(load-dnw frame-size 1)
- (LEA (@AO 7 ,(* (+ receiver-offset (frame-pointer-offset)) 4)) (A 0))
- (LEA (@PCR ,label) (A 1))
- (JMP ,popper:apply-closure)))
+ (LAP ,(load-dnw frame-size 1)
+ (LEA (@AO 7 ,(* (+ receiver-offset (frame-pointer-offset)) 4))
+ (A 0))
+ (LEA (@PCR ,label) (A 1))
+ (JMP ,popper:apply-closure)))
(define (apply-stack-sequence frame-size receiver-offset n-levels label)
- `((MOVEQ (& ,n-levels) (D 0))
- ,(load-dnw frame-size 1)
- (LEA (@AO 7 ,(* (+ receiver-offset (frame-pointer-offset)) 4)) (A 0))
- (LEA (@PCR ,label) (A 1))
- (JMP ,popper:apply-stack)))
+ (LAP (MOVEQ (& ,n-levels) (D 0))
+ ,(load-dnw frame-size 1)
+ (LEA (@AO 7 ,(* (+ receiver-offset (frame-pointer-offset)) 4))
+ (A 0))
+ (LEA (@PCR ,label) (A 1))
+ (JMP ,popper:apply-stack)))
(define-rule statement
(MESSAGE-SENDER:VALUE (? receiver-offset))
(disable-frame-pointer-offset!
- `(,@(clear-map!)
- ,@(increment-anl 7 (+ receiver-offset (frame-pointer-offset)))
- (JMP ,popper:value))))
\ No newline at end of file
+ (LAP ,@(clear-map!)
+ ,@(increment-anl 7 (+ receiver-offset (frame-pointer-offset)))
+ (JMP ,popper:value))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff