These changes require microcode 11.16 or later.
* Use BFEXTU instruction to extract type field. This instruction is
both faster and smaller than the previous sequence, for both 6 and 8
bit types. Use BFTST instruction to test for zero types.
Conditionalize use of the bit-field instructions on the new flag
`use-68020-instructions?'; I don't believe that we're using any other
68020-specific instructions besides these.
* Add rule for 1-arg fixnum predicates that tries to take advantage of
the preceding LSL.L instruction to test the number, rather than
emitting a redundant TST.L; this new rule is always used in generic
arithmetic expansions.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.15 1989/11/30 16:06:49 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.16 1989/12/11 06:16:42 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
'(scheme-to-interface
scheme-to-interface-jsr
trampoline-to-interface
- shortcircuit-apply))
+ shortcircuit-apply
+ shortcircuit-apply-size-1
+ shortcircuit-apply-size-2
+ shortcircuit-apply-size-3
+ shortcircuit-apply-size-4
+ shortcircuit-apply-size-5
+ shortcircuit-apply-size-6
+ shortcircuit-apply-size-7
+ shortcircuit-apply-size-8
+ primitive-apply
+ primitive-lexpr-apply
+ error
+ link
+ interrupt-closure
+ interrupt-dlink
+ interrupt-procedure
+ interrupt-continuation
+ assignment-trap
+ reference-trap
+ safe-reference-trap
+ &+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
+ ))
;; Compiled code temporaries
,@(let loop ((i 0) (index first-temp))
(if (= i 256)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.24 1989/12/05 20:39:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.25 1989/12/11 06:16:46 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
target))
(define (test-non-pointer type datum effective-address)
- (if (and (zero? type) (zero? datum)
+ (if (and (zero? type)
+ (zero? datum)
(effective-address/data&alterable? effective-address))
(INST (TST L ,effective-address))
(INST (CMPI L
(define scheme-type-mask
(-1+ (expt 2 scheme-type-width)))
-(define (object->type register-reference)
+(define use-68020-instructions? true)
+
+(define (object->type source target)
+ ;; `Source' must be a data register or non-volatile memory reference.
+ ;; `Target' must be a data register reference.
+ ;; Guarantees that the condition codes are set for a zero-compare.
(if (= scheme-type-width 8)
- (LAP (RO L L (& 8) ,register-reference))
- (LAP (RO L L (& ,scheme-type-width) ,register-reference)
- (AND B (& ,scheme-type-mask) ,register-reference))))
+ (cond ((equal? source target)
+ (LAP (RO L L (& ,scheme-type-width) ,target)))
+ (use-68020-instructions?
+ (LAP (BFEXTU ,source (& 0) (& ,scheme-type-width) ,target)))
+ (else
+ (LAP (MOVE L ,source ,target)
+ (RO L L (& ,scheme-type-width) ,target))))
+ (if use-68020-instructions?
+ (LAP (BFEXTU ,source (& 0) (& ,scheme-type-width) ,target))
+ (LAP ,@(if (equal? source target)
+ (LAP)
+ (LAP (MOVE L ,source ,target)))
+ (RO L L (& ,scheme-type-width) ,target)
+ (AND B (& ,scheme-type-mask) ,target)))))
;;;; CHAR->ASCII rules
scheme-to-interface-jsr ; Used by rules4, for convenience
trampoline-to-interface ; Used by trampolines, for convenience
shortcircuit-apply ; Used by rules3, for speed
+ shortcircuit-apply-size-1 ; Small frames, save time and space
+ shortcircuit-apply-size-2
+ shortcircuit-apply-size-3
+ shortcircuit-apply-size-4
+ shortcircuit-apply-size-5
+ shortcircuit-apply-size-6
+ shortcircuit-apply-size-7
+ shortcircuit-apply-size-8
+ primitive-apply ; Common entries to save space
+ primitive-lexpr-apply
+ error
+ link
+ interrupt-closure
+ interrupt-dlink
+ interrupt-procedure
+ interrupt-continuation
+ assignment-trap
+ reference-trap
+ safe-reference-trap
+ &+
+ &-
+ &*
+ &/
+ &=
+ &<
+ &>
+ 1+
+ -1+
+ zero?
+ positive?
+ negative?
))
(define-integrable (invoke-interface code)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.30 1989/12/05 20:52:00 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.31 1989/12/11 06:16:54 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(QUALIFIER (pseudo-register? target))
(convert-object/constant->register target constant address->fixnum))
+(define-rule statement
+ (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
+ (QUALIFIER (pseudo-register? target) (pseudo-register? source))
+ ;; See if we can reuse a source alias, because `object->type' can
+ ;; sometimes do a slightly better job when the source and target are
+ ;; the same register.
+ (reuse-pseudo-register-alias! source 'DATA
+ (lambda (source)
+ (delete-dead-registers!)
+ (add-pseudo-register-alias! target source)
+ (let ((source (register-reference source)))
+ (object->type source source)))
+ (lambda ()
+ (let ((source (standard-register-reference source 'DATA false)))
+ (delete-dead-registers!)
+ (object->type source (reference-target-alias! target 'DATA))))))
+
(define-integrable (convert-object/register->register target source conversion)
;; `conversion' often expands into multiple references to `target'.
(let ((target (move-to-alias-register! source 'DATA target)))
(conversion target)))
-(define-rule statement
- (ASSIGN (REGISTER (? target)) (OBJECT->TYPE (REGISTER (? source))))
- (QUALIFIER (pseudo-register? target))
- (convert-object/register->register target source object->type))
-
(define-rule statement
(ASSIGN (REGISTER (? target)) (OBJECT->DATUM (REGISTER (? source))))
(QUALIFIER (pseudo-register? target))
;;;; Fixnum Operations
(define-rule statement
- (ASSIGN (? target) (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
+ (ASSIGN (? target)
+ (FIXNUM-1-ARG (? operator) (REGISTER (? source)) (? overflow?)))
(QUALIFIER (and (machine-operation-target? target)
(pseudo-register? source)))
overflow? ; ignored
;;;; CHAR->ASCII/BYTE-OFFSET
(define (load-char-into-register type source target)
+ (delete-dead-registers!)
(let ((target (reference-target-alias! target 'DATA)))
- (delete-dead-registers!)
(LAP ,(load-non-pointer type 0 target)
(MOV B ,source ,target))))
(ASSIGN (REGISTER (? target))
(CHAR->ASCII (REGISTER (? source))))
(QUALIFIER (pseudo-register? target))
- (let ((source (machine-register-reference source 'DATA)))
- (delete-dead-registers!)
- (LAP (BFEXTU ,source (& 24) (& 8)
- ,(reference-target-alias! target 'DATA)))))
+ (load-char-into-register 0
+ (machine-register-reference source 'DATA)
+ target))
(define-rule statement
(ASSIGN (REGISTER (? target))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.10 1989/10/26 07:37:56 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.11 1989/12/11 06:16:59 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
0
(predicate/memory-operand-reference memory))))
-(define-rule predicate
- (TYPE-TEST (REGISTER (? register)) (? type))
- (QUALIFIER (pseudo-register? register))
- (set-standard-branches! 'EQ)
- (LAP ,(test-byte type (reference-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)))
- (LAP ,@(object->type reference)
- ,(test-byte type reference))))
-
-(define-rule predicate
- (TYPE-TEST (OBJECT->TYPE (? memory)) (? type))
- (QUALIFIER (predicate/memory-operand? memory))
- (set-standard-branches! 'EQ)
- (if (= scheme-type-width 8)
- (LAP ,(test-byte type (predicate/memory-operand-reference memory)))
- (let ((temp (reference-temporary-register! 'DATA)))
- (LAP (MOV L ,(predicate/memory-operand-reference memory) ,temp)
- ,@(object->type temp)
- ,(test-byte type temp)))))
-
(define-rule predicate
(UNASSIGNED-TEST (REGISTER (? register)))
(set-standard-branches! 'EQ)
(LAP ,(test-non-pointer (ucode-type unassigned)
0
- (standard-register-reference register 'DATA true))))
+ (standard-register-reference register false true))))
(define-rule predicate
(UNASSIGNED-TEST (? memory))
(predicate/memory-operand-reference memory))))
(define-rule predicate
- (OVERFLOW-TEST)
- (set-standard-branches! 'VS)
- (LAP))
+ (TYPE-TEST (REGISTER (? register)) (? type))
+ (QUALIFIER (pseudo-register? register))
+ (set-standard-branches! 'EQ)
+ (LAP ,(test-byte type (reference-alias-register! register 'DATA))))
+
+(define-rule predicate
+ (TYPE-TEST (OBJECT->TYPE (REGISTER (? register))) (? type))
+ (QUALIFIER (pseudo-register? register))
+ (set-standard-branches! 'EQ)
+ (if (and (zero? type) use-68020-instructions?)
+ (LAP (BFTST ,(standard-register-reference register 'DATA false)
+ (& 0)
+ (& ,scheme-type-width)))
+ ;; See if we can reuse a source alias, because `object->type'
+ ;; can sometimes do a slightly better job when the source and
+ ;; temp are the same register.
+ (reuse-pseudo-register-alias! register 'DATA
+ (lambda (source)
+ (delete-dead-registers!)
+ (need-register! source)
+ (let ((source (register-reference source)))
+ (normal-type-test source source type)))
+ (lambda ()
+ (let ((source (standard-register-reference register 'DATA false)))
+ (delete-dead-registers!)
+ (normal-type-test source
+ (reference-temporary-register! 'DATA)
+ type))))))
+
+(define-rule predicate
+ (TYPE-TEST (OBJECT->TYPE (OFFSET (REGISTER (? address)) (? offset)))
+ (? type))
+ (set-standard-branches! 'EQ)
+ (let ((source (indirect-reference! address offset)))
+ (cond ((= scheme-type-width 8)
+ (LAP ,(test-byte type source)))
+ ((and (zero? type) use-68020-instructions?)
+ (LAP (BFTST ,source (& 0) (& ,scheme-type-width))))
+ (else
+ (normal-type-test source
+ (reference-temporary-register! 'DATA)
+ type)))))
+
+(define (normal-type-test source target type)
+ (LAP ,@(object->type source target)
+ ,@(if (zero? type)
+ (LAP)
+ (LAP ,(test-byte type target)))))
\f
(define-rule predicate
(EQ-TEST (REGISTER (? register-1)) (REGISTER (? register-2)))
\f
;;;; Fixnum/Flonum Predicates
+(define-rule predicate
+ (OVERFLOW-TEST)
+ (set-standard-branches! 'VS)
+ (LAP))
+
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (REGISTER (? register)))
(QUALIFIER (pseudo-register? register))
(set-standard-branches! (fixnum-predicate->cc predicate))
(test-fixnum (standard-register-reference register 'DATA true)))
+(define-rule predicate
+ (FIXNUM-PRED-1-ARG (? predicate) (OBJECT->FIXNUM (REGISTER (? register))))
+ (QUALIFIER (pseudo-register? register))
+ (set-standard-branches! (fixnum-predicate->cc predicate))
+ (object->fixnum (move-to-temporary-register! register 'DATA)))
+
(define-rule predicate
(FIXNUM-PRED-1-ARG (? predicate) (? memory))
(QUALIFIER (predicate/memory-operand? memory))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.21 1989/12/05 21:01:21 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.22 1989/12/11 06:17:02 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(INVOCATION:APPLY (? frame-size) (? continuation))
continuation
(LAP ,@(clear-map!)
- ,(load-dnl frame-size 2)
- (JMP ,entry:compiler-shortcircuit-apply)))
+ ,@(case frame-size
+ ((1) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-1)))
+ ((2) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-2)))
+ ((3) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-3)))
+ ((4) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-4)))
+ ((5) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-5)))
+ ((6) (LAP (JMP ,entry:compiler-shortcircuit-apply-size-6)))
+ ((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)
+ (JMP ,entry:compiler-shortcircuit-apply))))))
(define-rule statement
(INVOCATION:JUMP (? frame-size) (? continuation) (? label))
;; (JMP (@@PCR ,(free-uuo-link-label name frame-size)))
;; and to have <entry> at label, but it is longer and slower.
(BRA (@PCR ,(free-uuo-link-label name frame-size)))))
-
+\f
(define-rule statement
(INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension))
continuation
,(load-constant name (INST-EA (D 2)))
,(load-dnl frame-size 3)
,@(invoke-interface code:compiler-lookup-apply))))
-\f
+
(define-rule statement
(INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
continuation
(LAP ,@(clear-map!)
,@(if (eq? primitive compiled-error-procedure)
(LAP ,(load-dnl frame-size 1)
- ,@(invoke-interface code:compiler-error))
+ (JMP ,entry:compiler-error))
(let ((arity (primitive-procedure-arity primitive)))
(cond ((not (negative? arity))
(LAP (MOV L (@PCR ,(constant->label primitive)) (D 1))
- ,@(invoke-interface code:compiler-primitive-apply)))
+ (JMP ,entry:compiler-primitive-apply)))
((= arity -1)
(LAP (MOV L (& ,(-1+ frame-size))
,reg:lexpr-primitive-arity)
(MOV L (@PCR ,(constant->label primitive)) (D 1))
- ,@(invoke-interface
- code:compiler-primitive-lexpr-apply)))
+ (JMP ,entry:compiler-primitive-lexpr-apply)))
(else
;; Unknown primitive arity. Go through apply.
(LAP ,(load-dnl frame-size 2)
frame-size continuation
,(list 'LAP
(list 'UNQUOTE-SPLICING '(clear-map!))
- (list 'UNQUOTE-SPLICING
- `(INVOKE-INTERFACE ,(symbol-append 'CODE:COMPILER-
- name))))))))
+ (list 'JMP
+ (list 'UNQUOTE
+ (symbol-append 'ENTRY:COMPILER- name))))))))
(define-special-primitive-invocation &+)
(define-special-primitive-invocation &-)
(define-special-primitive-invocation &*)
;;; contain a valid dynamic link, but the gc handler determines that
;;; and saves it as appropriate.
-(define-integrable (simple-procedure-header code-word label code)
+(define-integrable (simple-procedure-header code-word label entry)
(let ((gc-label (generate-label)))
(LAP (LABEL ,gc-label)
- ,@(invoke-interface-jsr code)
+ (JSR ,entry)
,@(make-external-label code-word label)
(CMP L ,reg:compiled-memtop (A 5))
(B GE B (@PCR ,gc-label)))))
(define-integrable (dlink-procedure-header code-word label)
(let ((gc-label (generate-label)))
(LAP (LABEL ,gc-label)
- (MOV L (A 4) (D 2)) ; Dynamic link -> D2
- ,@(invoke-interface-jsr code:compiler-interrupt-dlink)
+ (JSR ,entry:compiler-interrupt-dlink)
,@(make-external-label code-word label)
(CMP L ,reg:compiled-memtop (A 5))
(B GE B (@PCR ,gc-label)))))
(CONTINUATION-HEADER (? internal-label))
(simple-procedure-header (continuation-code-word internal-label)
internal-label
- code:compiler-interrupt-continuation))
+ entry:compiler-interrupt-continuation))
(define-rule statement
(IC-PROCEDURE-HEADER (? internal-label))
(let ((procedure (label->object internal-label)))
- (let ((external-label (rtl-procedure/external-label procedure)))
- (LAP
- (ENTRY-POINT ,external-label)
- (EQUATE ,external-label ,internal-label)
- ,@(simple-procedure-header expression-code-word
- internal-label
- code:compiler-interrupt-ic-procedure)))))
+ (let ((external-label (rtl-procedure/external-label procedure))
+ (gc-label (generate-label)))
+ (LAP (ENTRY-POINT ,external-label)
+ (EQUATE ,external-label ,internal-label)
+ (LABEL ,gc-label)
+ ,@(invoke-interface-jsr code:compiler-interrupt-ic-procedure)
+ ,@(make-external-label expression-code-word internal-label)
+ (CMP L ,reg:compiled-memtop (A 5))
+ (B GE B (@PCR ,gc-label))))))
(define-rule statement
(OPEN-PROCEDURE-HEADER (? internal-label))
dlink-procedure-header
(lambda (code-word label)
(simple-procedure-header code-word label
- code:compiler-interrupt-procedure)))
+ entry:compiler-interrupt-procedure)))
internal-entry-code-word
internal-label))))
,internal-label)
,@(simple-procedure-header (make-procedure-code-word min max)
internal-label
- code:compiler-interrupt-procedure)))
+ entry:compiler-interrupt-procedure)))
\f
;;;; Closures. These two statements are intertwined:
(let ((gc-label (generate-label))
(external-label (rtl-procedure/external-label procedure)))
(LAP (LABEL ,gc-label)
- ,@(invoke-interface code:compiler-interrupt-closure)
+ (JMP ,entry:compiler-interrupt-closure)
,@(make-external-label internal-entry-code-word external-label)
(ADD UL (& ,magic-closure-constant) (@A 7))
(LABEL ,internal-label)
(LEA (@PCR ,free-ref-label) (A 0))
(MOV L (A 0) (D 3))
,(load-dnl n-sections 4)
- ,@(invoke-interface-jsr code:compiler-link)
+ (JSR ,entry:compiler-link)
,@(make-external-label (continuation-code-word false)
(generate-label))))
,(load-offset free-ref-offset)
(MOV L (A 1) (D 3))
,(load-dnl n-sections 4)
- ,@(invoke-interface-jsr code:compiler-link)
+ (JSR ,entry:compiler-link)
,@(make-external-label (continuation-code-word false)
(generate-label)))))
\f
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.8 1989/11/30 16:06:28 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.9 1989/12/11 06:17:06 cph Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
(PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
,(memory-set-type type (INST-EA (@A 7)))
(MOV L (@A+ 7) (D 4))
+ ,(load-constant name (INST-EA (D 3)))
,@(invoke-interface-jsr code))))
\f
(define-rule statement
(let ((clear-map (clear-map!)))
(LAP ,@set-extension
,@clear-map
- ,@(invoke-interface-jsr
- (if safe?
- code:compiler-safe-reference-trap
- code:compiler-reference-trap))))))
+ (JSR ,(if safe?
+ entry:compiler-safe-reference-trap
+ entry:compiler-reference-trap))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension) (? value))
(LAP ,@set-extension
,@set-value
,@clear-map
- ,@(invoke-interface-jsr code:compiler-assignment-trap))))))
+ (JSR ,entry:compiler-assignment-trap))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT (? extension)
,(memory-set-type type reg:temp)
,@clear-map
(MOV L ,reg:temp (D 3))
- ,@(invoke-interface-jsr code:compiler-assignment-trap))))))
+ (JSR ,entry:compiler-assignment-trap))))))
(define-rule statement
(INTERPRETER-CALL:CACHE-ASSIGNMENT
(PEA (@PCR ,(rtl-procedure/external-label (label->object label))))
,(memory-set-type type (INST-EA (@A 7)))
(MOV L (@A+ 7) (D 3))
- ,@(invoke-interface-jsr code:compiler-assignment-trap))))
+ (JSR ,entry:compiler-assignment-trap))))
(define-rule statement
(INTERPRETER-CALL:CACHE-UNASSIGNED? (? extension))
projects / mit-scheme.git / commitdiff