incorrectly) about half of the runtime library.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/lapopt.scm,v 1.9 1995/01/12 19:42:02 ssmith Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/machines/i386/lapopt.scm,v 1.10 1995/01/20 20:16:36 ssmith Exp $
Copyright (c) 1992 Massachusetts Institute of Technology
(declare (usual-integrations))
+
+(define (lap:mark-preferred-branch! pblock cn an)
+ ;; This can leave pblock unchanged
+ (define (single-instruction bblock other)
+ (and (sblock? bblock)
+ (let ((next (snode-next bblock)))
+ (or (not next)
+ (eq? next other)))
+ (let find-first ((instrs (bblock-instructions bblock)))
+ (and (not (null? instrs))
+ (let ((instr (car instrs)))
+ (if (eq? 'COMMENT (car instr))
+ (find-first (cdr instrs))
+ (and (let find-next ((instrs (cdr instrs)))
+ (or (null? instrs)
+ (and (eq? 'COMMENT (car (car instrs)))
+ (find-next (cdr instrs)))))
+ instr)))))))
+
+ (define (try branch bblock other)
+ (let ((instr (single-instruction bblock other)))
+ (and instr
+ (not (instr-expands? instr))
+ (pnode/prefer-branch! pblock branch)
+ true)))
+
+ (let ((branch-instr
+ (car (last-pair ((pblock-consequent-lap-generator pblock) 'FOO)))))
+ (and (memq (car branch-instr)
+ '(COMB COMBT COMBF COMIB COMIBT COMIBF COMBN COMIBTN COMIBFN))
+ (or (try 'CONSEQUENT cn an)
+ (try 'ALTERNATIVE an cn)))))
+
(define (optimize-linear-lap instructions)
+#|
;; The following returns a list of information about the instruction:
;; 1. timing -- how many cycles
;; 2. pipelining -- which pipes 1 - first pipe, 2 - second pipe, 12 - both pipes, #f - unpipable
(#f #f () () () block-offset ?)
(#f #f () () () entry-point ?)
(#f #f () () () word ? ?)))
-
+ (define (find-var v)
+ (let loop ((data ins-vars))
+ (if (null? data)
+ #f
+ (if (eq? (car (car data))
+ v)
+ (cdr (car data))
+ (loop (cdr data))))))
+
;; Given a list of registers/variables from the instruction data,
;; this procedure creates a list containing all the registers referenced
;; If the list specifies a variable, then that variable is looked up to
;; about registers). A register can also be explicitly stated in the
;; list passed to make-reg-list
(define (make-reg-list a)
- (define (find-var v)
- (let loop ((data ins-vars))
- (if (null? data)
- #f
- (if (eq? (car (car data))
- v)
- (cdr (car data))
- (loop (cdr data))))))
(if (pair? a)
(if (number? (car a))
(cons (car a)
()))))
a))
+ (define (make-ea-list a inst)
+ (define (get-regs-from-ea ea)
+ (if (pair? ea)
+ (cond ((eq? '@R (car ea))
+ (list (second ea)))
+ ((eq? '@RI (car ea))
+ (list (second ea) (third ea)))
+ ((eq? '@ROI (car ea))
+ (list (third ea) (fifth ea)))
+ ((eq? '@RO (car ea))
+ (list (third ea)))
+ (else ()))
+ ()))
+ (if (pair? inst)
+ (append (get-regs-from-ea (car inst))
+ (make-ea-list a
+ (cdr inst)))
+ (if (pair? a)
+ (if (number? (car a))
+ (cons (car a)
+ (make-ea-list (cdr a) inst))
+ (let ((data (find-var (car a))))
+ (if data
+ (append (get-regs-from-ea data)
+ (make-ea-list (cdr a) inst))
+ (begin
+ (pp (car a))
+ ()))))
+ ())))
+
;; Checks to see if the the pattern matches given data
(define (is-all-match? pattern data)
(define (is-match? pattern data)
'(0 0 () () ()))
(if (is-all-match? (cdr (cdr (cdr (cdr (cdr (car data))))))
inst)
- (list (car (car data))
- (cadr (car data))
- (make-reg-list (caddr (car data)))
- (make-reg-list (cadddr (car data)))
- ())
+ (list (timing-of-inst (car data))
+ (piping-of-inst (car data))
+ (make-reg-list (regs-mod-of-inst (car data)))
+ (make-reg-list (regs-use-of-inst (car data)))
+ (make-ea-list (regs-addr-of-inst (car data))
+ inst))
(loop (cdr data))))))
-
-
+
+
(define (get-pentium-timing instructions)
(let loop ((inst instructions)
(time 0)
last-mod-regs))))))))
(pp (get-pentium-timing instructions))
+|#
instructions)
#| -*-Scheme-*-
-$Id: machin.scm,v 1.5 1995/01/12 14:45:48 ssmith Exp $
+$Id: machin.scm,v 1.6 1995/01/20 20:16:50 ssmith Exp $
Copyright (c) 1992-1995 Massachusetts Institute of Technology
(define-integrable regnum:regs-pointer esi)
(define-integrable regnum:free-pointer edi)
(define-integrable regnum:hook eax)
+(define-integrable regnum:first-arg ecx)
+(define-integrable regnum:second-arg edx)
(define-integrable (machine-register-known-value register)
register ; ignored
(define-integrable register-block/lexpr-primitive-arity-offset 7)
(define-integrable register-block/utility-arg4-offset 9) ; closure free
(define-integrable register-block/stack-guard-offset 11)
+(define-integrable register-block/empty-list 14)
(define-integrable (fits-in-signed-byte? value)
(and (>= value -128) (< value 128)))
;; Disabled for now. The F2XM1 instruction is
;; broken on the 387 (or at least some of them).
FLONUM-EXP
- VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))
\ No newline at end of file
+ VECTOR-CONS STRING-ALLOCATE FLOATING-VECTOR-CONS))
+
+;; Copied from Spectrum's so I could see it compile
+
+(define (rtlgen/interpreter-call/argument-home index)
+ (case index
+ ((1) `(REGISTER ,ecx))
+ ((2) `(REGISTER ,edx))
+ (else
+ (internal-error "Unexpected interpreter-call argument index" index))))
+
+(define #|-integrable|# quad-mask-value
+ (cond ((= scheme-type-width 5) #b01000)
+ ((= scheme-type-width 6) #b010000)
+ ((= scheme-type-width 8) #b01000000)
+ (else (error "machin.scm: weird type width:" scheme-type-width))))
+
+(define (machine/indexed-loads? type)
+ type ; for all types
+ #T)
+
+(define (machine/indexed-stores? type)
+ type ; for all types
+ #T)
#| -*-Scheme-*-
-$Id: rules1.scm,v 1.1 1995/01/10 20:53:04 adams Exp $
+$Id: rules1.scm,v 1.2 1995/01/20 20:17:04 ssmith Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
(ASSIGN (REGISTER (? target))
(CONS-POINTER (REGISTER (? type)) (REGISTER (? datum))))
(let ((temp (standard-move-to-temporary! type)))
- (LAP (ROR W ,temp (&U ,scheme-type-width))
+ (LAP (ROR W ,temp (& ,scheme-type-width))
(OR W ,(standard-move-to-target! datum target) ,temp))))
(define-rule statement
#| -*-Scheme-*-
-$Id: rules2.scm,v 1.1 1995/01/10 20:53:05 adams Exp $
+$Id: rules2.scm,v 1.2 1995/01/20 20:17:17 ssmith Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
(lambda (label)
(LAP (JNE (@PCR ,label))))))
+(define (set-specific-branches! truejump falsejump)
+ (set-current-branches! (lambda (label)
+ (LAP (,truejump (@PCR ,label))))
+ (lambda (label)
+ (LAP (,falsejump (@PCR ,label))))))
+
(define-rule predicate
(TYPE-TEST (REGISTER (? register)) (? type))
(set-equal-branches!)
(LAP (CMP W ,(source-register-reference register)
,(offset->reference! expression))))
+
+
+(define-rule predicate
+ (PRED-1-ARG GENERIC-ADDITIVE-TEST (REGISTER (? source)))
+ (let ((temp (allocate-temporary-register! 'GENERAL))
+ (src (standard-source! source))
+ (osize (if (> scheme-datum-width 7)
+ 'W
+ 'B)))
+ (set-equal-branches!)
+ (LAP (LEA (R ,temp) (@RO ,osize ,src ,(expt 2 (-1+ scheme-datum-width))))
+ (SHR W (R ,temp) ,scheme-datum-width))))
+
+(define-rule predicate
+ (PRED-1-ARG FIXNUM? (REGISTER (? source)))
+ (let ((temp (allocate-temporary-register! 'GENERAL))
+ (src (standard-source! source))
+ (osize (if (> scheme-datum-width 6)
+ 'W
+ 'B)))
+ (set-equal-branches!)
+ (LAP (LEA (R ,temp) (@RO ,osize ,src ,(expt 2 scheme-datum-width)))
+ (SHR W (R ,temp) (& ,(1+ scheme-datum-width))))))
+
+(define-rule predicate
+ (PRED-1-ARG FALSE? (REGISTER (? source)))
+ (if compiler:generate-trap-on-null-valued-conditional?
+ (error "unsupported compiler option: generate-trap-on-null-valued-conditional?")
+ (begin
+ (set-equal-branches!)
+ (LAP (CMP W (R ,(standard-source! source))
+ (& ,(make-non-pointer-literal (object-type #f)
+ (object-datum #f))))))))
+
+(define-rule predicate
+ (PRED-1-ARG NULL? (REGISTER (? source)))
+ (set-equal-branches!)
+ (LAP (CMP W (R ,(standard-source! source)) (@RO B ,regnum:regs-pointer
+ ,register-block/empty-list))))
+
+(define-rule predicate
+ (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED?
+ (REGISTER (? smaller))
+ (REGISTER (? larger)))
+ (set-special-branches! 'JB 'JAE)
+ (LAP (CMP W (R ,(standard-source! smaller)) (R ,(standard-source! larger)))))
+
+(define-rule predicate
+ (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED?
+ (CONSTANT (? smaller))
+ (REGISTER (? larger)))
+ (set-special-branches! 'JB 'JAE)
+ (LAP (CMP W (& ,smaller) (R ,(standard-source! larger)))))
+
+(define-rule predicate
+ (PRED-2-ARGS WORD-LESS-THAN-UNSIGNED?
+ (REGISTER (? smaller))
+ (CONSTANT (? larger)))
+ (set-special-branches! 'JB 'JAE)
+ (LAP (CMP W (R ,(standard-source! smaller)) (& ,larger))))
+
+(define-rule predicate
+ (PRED-2-ARGS SMALL-FIXNUM?
+ (REGISTER (? source))
+ (MACHINE-CONSTANT (? nbits)))
+ (let* ((src (standard-source! source))
+ (temp (allocate-temporary-register! 'GENERAL))
+ (osize (if (> (- scheme-datum-width nbits) 6)
+ 'W
+ 'B)))
+ (set-equal-branches!)
+ ;; There are several ways to do this:
+ ;; assuming you want to check that the number is 16 bits + sign extension:
+
+ ;; lea eax,[ebx+32768]
+ ;; shr eax,16
+ ;; jz blat
+ ;; This is good because it is two instructions and will execute quickly,
+ ;; but be careful for stalling because of the addressing mode!
+ ;; Also, it is about 6+3=9 bytes (for the arithmetic)
+
+ ;; Or:
+ ;; mov eax,ebx
+ ;; sar eax,16
+ ;; adc eax,0
+ ;; jz blat
+ ;; This is good because it doesn't use [ebx] in addressing, plus it is
+ ;; only 2+3+3=8 bytes. NOTE: We originally thought that you could do
+ ;; an ADC AL,0; but realize there are 16 bits you are testing. Besides,
+ ;; that would only gain you a byte, assuming you got the EAX register
+ ;; This is also good because it can pull from memory or from a register
+
+ (LAP (LEA (R ,temp) (@RO ,osize ,src ,(expt 2 (- scheme-datum-width nbits))))
+ (SHR W (R ,temp) (& ,(- (+ scheme-datum-width 1) nbits))))))
+
+
(define-rule predicate
(EQ-TEST (? expression rtl:simple-offset?) (REGISTER (? register)))
(set-equal-branches!)
-#| -*-Scheme-*-
+t#| -*-Scheme-*-
-$Id: rules3.scm,v 1.8 1995/01/12 19:51:19 ssmith Exp $
+$Id: rules3.scm,v 1.9 1995/01/20 20:17:29 ssmith Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
(define-primitive-invocation positive?)
(define-primitive-invocation negative?)
(define-primitive-invocation quotient)
- (define-primitive-invocation remainder)))
-
+ (define-primitive-invocation remainder)
+ (define-primitive-invocation vector-cons)
+ (define-primitive-invocation string-allocate)
+ (define-primitive-invocation floating-vector-cons)))
+
+(define (preserving-regs clobbered-regs gen-suffix)
+ ;; THIS IS ***NOT*** GENERAL PURPOSE CODE.
+ ;; It assumes a bunch of things, like "the pseudo-registers
+ ;; currently assigned to the clobbered registers aren't going to be
+ ;; referenced before their contents are restored."
+ ;; It is intended only for preserving registers around in-line calls
+ ;; that may need to back in to the interpreter in rare cases.
+ (define *comments* '())
+ (define (delete-clobbered-aliases-for-recomputable-pseudo-registers preserved)
+ (let* ((how (cadr preserved))
+ (reg (car preserved)))
+ (if (eq? how 'RECOMPUTE)
+ (let ((entry (map-entries:find-home *register-map* reg)))
+ (if entry
+ (let* ((aliases (map-entry-aliases entry))
+ (new-entry
+ (make-map-entry
+ (map-entry-home entry)
+ false ; Not in home anymore
+ (list-transform-negative aliases
+ (lambda (alias) (memq alias clobbered-regs)))
+ ; No clobbered regs. for aliases
+ (map-entry-label entry))))
+ (set! *comments*
+ (append
+ *comments*
+ `((COMMENT CLOBBERDATA: (,reg ,how ,entry ,new-entry)))))
+ (set! *register-map*
+ (make-register-map
+ (map-entries:replace *register-map* entry new-entry)
+ (map-registers *register-map*)))))))))
+ (for-each delete-clobbered-aliases-for-recomputable-pseudo-registers
+ *preserved-registers*)
+ (let ((clean (apply require-registers! clobbered-regs)))
+ (LAP ,@clean
+ ,@*comments*
+ ,@(call-with-values
+ clear-map!/preserving
+ (lambda (machine-regs pseudo-regs)
+ (cond ((and (null? machine-regs) (null? pseudo-regs))
+ (gen-suffix false))
+ ((null? pseudo-regs)
+ (gen-suffix (->mask machine-regs false false)))
+ (else
+ (call-with-values
+ (lambda () (->bytes pseudo-regs))
+ (lambda (gen-int-regs gen-float-regs)
+ (gen-suffix (->mask machine-regs
+ gen-int-regs
+ gen-float-regs)))))))))))
+
+
+(define (bytes->uwords bytes)
+ (let walk ((bytes bytes))
+ (if (null? bytes)
+ (LAP)
+ (LAP (BYTE U ,(car bytes))
+ ,@(walk (cdr bytes))))))
+
+(define (->bytes pseudo-regs)
+ ;; (values gen-int-regs gen-float-regs)
+ (define (do-regs regs)
+ (LAP (COMMENT (PSEUDO-REGISTERS . ,regs))
+ ,@(bytes->uwords
+ (let* ((l (length regs))
+ (bytes (reverse (cons l
+ (map register-renumber regs)))))
+ (append (let ((r (remainder (+ l 1) 4)))
+ (if (zero? r)
+ '()
+ (make-list (- 4 r) 0)))
+ bytes)))))
+
+ (call-with-values
+ (lambda ()
+ (list-split pseudo-regs
+ (lambda (reg)
+ (value-class=float? (pseudo-register-value-class reg)))))
+ (lambda (float-regs int-regs)
+ (values (and (not (null? int-regs))
+ (lambda () (do-regs int-regs)))
+ (and (not (null? float-regs))
+ (lambda () (do-regs float-regs)))))))
+
+(define (->mask machine-regs gen-int-regs gen-float-regs)
+ (let ((int-mask (make-bit-string 8 false))
+ (flo-mask (make-bit-string 8 false)))
+ (if gen-int-regs
+ (bit-string-set! int-mask 7))
+ (if gen-float-regs
+ (bit-string-set! int-mask 6))
+ (let loop ((regs machine-regs))
+ (cond ((not (null? regs))
+ (let ((reg (car regs)))
+ (if (< reg 8)
+ (if (< reg 4)
+ (bit-string-set! int-mask reg)
+ (error "Register number too high to preserve:" reg))
+ (bit-string-set! flo-mask (- reg 8)))
+ (loop (cdr regs))))
+ ((bit-string-zero? flo-mask)
+ (lambda ()
+ (LAP ,@(if gen-float-regs (gen-float-regs) (LAP))
+ ,@(if gen-int-regs (gen-int-regs) (LAP))
+ (COMMENT (MACHINE-REGS . ,machine-regs))
+ (BYTE U ,(bit-string->unsigned-integer int-mask)))))
+ (else
+ (bit-string-set! int-mask 5)
+ (lambda ()
+ (LAP ,@(if gen-float-regs (gen-float-regs) (LAP))
+ (COMMENT (MACHINE-REGS . ,machine-regs))
+ (BYTE U ,(bit-string->unsigned-integer flo-mask))
+ ,@(if gen-int-regs (gen-int-regs) (LAP))
+ (COMMENT (MACHINE-REGS . ,machine-regs))
+ (BYTE U ,(bit-string->unsigned-integer int-mask)))))))))
+
+(define *optimized-clobbered-regs*
+ (list eax ebx ecx edx))
+#|
(define (special-primitive-invocation code)
- (LAP ,@(clear-map!)
+ (LAP ,@(clear-map!/preserving)
,@(invoke-interface code)))
(define (optimized-primitive-invocation entry)
- (LAP ,@(clear-map!)
+ (LAP ,@(clear-map!/preserving)
,@(invoke-hook entry)))
+|#
+(define (optimized-primitive-invocation hook)
+ (preserving-regs
+ *optimized-clobbered-regs*
+ (lambda (gen-preservation-info)
+ (if (not gen-preservation-info)
+ (LAP ,@(invoke-hook hook))
+ (let ((label1 (generate-label))
+ (label2 (generate-label)))
+ (LAP ,@(invoke-hook hook)
+ (LABEL ,label1)
+ ,@(gen-preservation-info)
+ (LABEL ,label2)))))))
+
+
+
+
+
+(define-rule statement
+ (RETURN-ADDRESS (? label)
+ (? dbg-info)
+ (MACHINE-CONSTANT (? frame-size))
+ (MACHINE-CONSTANT (? nregs)))
+ dbg-info nregs ; ignored
+ (begin
+ (restore-registers!)
+ (make-external-label
+ (frame-size->code-word frame-size internal-continuation-code-word)
+ label)))
+
+
;;; Invocation Prefixes
;; NOTE that make-external-label is in i386/lapgen, but in spectrum/rules3
;; also, there are some differences ** potential bug
;;
+
+(define (%invocation:apply frame-size)
+ (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-immediate frame-size regnum:second-arg)
+ (JMP ,entry:compiler-shortcircuit-apply)))))
+
+(define-rule statement
+ (PROCEDURE (? label) (? dbg-info) (MACHINE-CONSTANT (? frame-size)))
+ dbg-info ; ignored
+ (make-external-label (frame-size->code-word frame-size
+ internal-continuation-code-word)
+ label))
(define-rule statement
(TRIVIAL-CLOSURE (? label)
(? dbg-info)
(let ((ret-add-label (generate-label)))
(LAP (LABEL ,interrupt-label)
(MOV B (R ,regnum:hook) (& ,(- frame-size 1)))
- ,@(invoke-hook hook:compiler-interrupt-procedure/new)
+ ,@(invoke-hook entry:compiler-interrupt-procedure/new)
(LABEL ,ret-add-label)
- (WORD () (- (- ,label ,ret-add-label) ,*privilege-level*)))))))
+ (WORD S (- (- ,label ,ret-add-label) ,*privilege-level*)))))))
(define-rule statement
(INTERRUPT-CHECK:CONTINUATION (? intrpt) (? heap) (? stack) (? label)
code:compiler-interrupt-procedure
code:compiler-interrupt-continuation)
28) |#
- ,@(invoke-hook hook:compiler-interrupt-continuation/new)
+ ,@(invoke-hook entry:compiler-interrupt-continuation/new)
(LABEL ,ret-add-label)
- (WORD () (- (- ,label ,ret-add-label) ,*privilege-level*)))))))
+ (WORD S (- (- ,label ,ret-add-label) ,*privilege-level*)))))))
(define-rule statement
(INTERRUPT-CHECK:CLOSURE (? intrpt) (? heap) (? stack)
(MOV B (R ,regnum:hook) (& ,(- frame-size 2))) ; Continuation and self
; register are saved by other
; means.
- ,@(invoke-hook hook:compiler-interrupt-closure/new)))))
+ ,@(invoke-hook entry:compiler-interrupt-closure/new)))))
(define-rule statement
(INTERRUPT-CHECK:SIMPLE-LOOP (? intrpt) (? heap) (? stack)
(let ((ret-add-label (generate-label)))
(LAP (LABEL ,interrupt-label)
(MOV B (R regnum:hook) (& ,(- frame-size 1)))
- ,@(invoke-hook hook:compiler-interrupt-procedure/new)
+ ,@(invoke-hook entry:compiler-interrupt-procedure/new)
(LABEL ,ret-add-label)
- (WORD () (- (- ,header-label ,ret-add-label)
+ (WORD S (- (- ,header-label ,ret-add-label)
,*privilege-level*)))))))
delete-dead-registers!)))
(obj* (or obj regnum:first-arg)))
(need-register! obj*)
- (if continuation
- (need-register! 19))
- (let ((addr (if untagged-entries? obj* (standard-temporary!)))
- (temp (standard-temporary!))
- (label (generate-label))
- (load-continuation
- (if continuation
- (load-pc-relative-address continuation 19 'CODE)
- '())))
+ (let* ((temp (standard-temporary!))
+ (addr (if untagged-entries? obj* temp)) ; by sharing temp, we save a reg
+ (label (generate-label))
+ (label2 (generate-label))
+ (label3 (generate-label))
+ (label4 (generate-label)))
(LAP ,@prefix
,@(clear-map!)
- ,@load-continuation
- ,@(object->type obj* temp)
+ (MOV W (R ,temp) (R ,obj*))
+ ,@(object->type (INST-EA (R ,temp)))
,@(let ((tag (ucode-type compiled-entry)))
- (LAP (CMP W ,temp (& ,tag))
+ (LAP (CMP W (R ,temp) (& ,tag))
(JNE (@PCR ,label))))
,@(if untagged-entries?
(LAP)
,@(adjust-type (ucode-type compiled-entry)
quad-mask-value
addr)))
- (CMP B (@RO B ,addr -3) 0)
+ (CMP B (@RO B ,addr -3) (& ,frame-size))
;; This is ugly - oh well
- (JNE (@PCR ,label))
- (JMP (R ,addr))
+ (JE (@PCR ,label2))
(LABEL ,label)
,@(copy obj* regnum:first-arg)
- ,@(%invocation:apply frame-size)))))
+ ,@(if continuation
+ (LAP (CALL (@PCR ,label4))
+ (LABEL ,label4)
+ ;; There's something up with instr1.scm -- It calls IMMEDIATE to determine
+ ;; (I think) if it's a byte or a word, and this is too complex for it
+ ;; However, I don't see any rules to handle signed bytes vs. words!
+ ;; (ADD W (@R ,esp) (& (OFFSET (- ,label3 ,label4)))))
+ (ADD W (@R ,esp) (& ,(+ 3 3 2))))
+ (LAP))
+ ,@(%invocation:apply frame-size)
+ (LABEL ,label2)
+ ,@(if continuation
+ (LAP (CALL (R ,addr)))
+ (LAP (JMP (R ,addr))))
+ (LABEL ,label3)))))
\f
;;; Local Variables: ***
#| -*-Scheme-*-
-$Id: rules4.scm,v 1.1 1995/01/10 20:53:06 adams Exp $
+$Id: rules4.scm,v 1.2 1995/01/20 20:17:41 ssmith Exp $
Copyright (c) 1992 Massachusetts Institute of Technology
\f
;;;; Variable cache trap handling.
+(define regnum:third-arg eax)
+(define regnum:fourth-arg ebx)
+(define (%load-interface-args! first second third fourth)
+ (let* ((load-reg
+ (lambda (arg reg)
+ (if arg
+ (interpreter-call-argument->machine-register! arg reg)
+ (clean-registers! reg))))
+ (load-one (load-reg first regnum:first-arg))
+ (load-two (load-reg second regnum:second-arg))
+ (load-three (load-reg third regnum:third-arg))
+ (load-four (load-reg fourth regnum:fourth-arg)))
+ (LAP ,@load-one
+ ,@load-two
+ ,@load-three
+ ,@load-four)))
+
+(define *interpreter-call-clobbered-regs* (list eax ebx ecx edx))
+
+(define (interpreter-call code extension extra)
+ (let ((start (%load-interface-args! false extension extra false)))
+ (LAP (COMMENT >> %interface-load-args)
+ ,@start
+ (COMMENT << %interface-load-args)
+ ,@(preserving-regs
+ *interpreter-call-clobbered-regs*
+ (lambda (gen-preservation-info)
+ (if (not gen-preservation-info)
+ (invoke-hook/call code)
+ (let ((label1 (generate-label))
+ (label2 (generate-label)))
+ (LAP ,@(invoke-hook/call code)
+ (LABEL ,label1)
+ ,@(gen-preservation-info)
+ (LABEL ,label2)))))))))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?))
+ (QUALIFIER (interpreter-call-argument? extension))
+ cont ; ignored
+ (interpreter-call (if safe?
+ entry:compiler-safe-reference-trap
+ entry:compiler-reference-trap)
+ extension false))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-ASSIGNMENT (? cont) (? extension) (? value))
+ (QUALIFIER (and (interpreter-call-argument? extension)
+ (interpreter-call-argument? value)))
+ cont ; ignored
+ (interpreter-call entry:compiler-assignment-trap extension value))
+
+(define-rule statement
+ (INTERPRETER-CALL:CACHE-UNASSIGNED? (? cont) (? extension))
+ (QUALIFIER (interpreter-call-argument? extension))
+ cont ; ignored
+ (interpreter-call entry:compiler-unassigned?-trap extension false))
+
+#|
(define-rule statement
(INTERPRETER-CALL:CACHE-REFERENCE (? cont) (? extension) (? safe?))
(QUALIFIER (interpreter-call-argument? extension))
(LAP ,@set-extension
,@(clear-map!)
,@(invoke-interface/call code:compiler-unassigned?-trap))))
+|#
\f
;;;; Interpreter Calls
#| -*-Scheme-*-
-$Id: rulfix.scm,v 1.1 1995/01/10 20:53:06 adams Exp $
+$Id: rulfix.scm,v 1.2 1995/01/20 20:17:52 ssmith Exp $
Copyright (c) 1992-1993 Massachusetts Institute of Technology
#f))
(fixnum-1-arg target source
(lambda (target)
- (multiply-fixnum-constant target (* n fixnum-1) false))))
+ (multiply-fixnum-constant target n false))))
(define-rule statement
(ASSIGN (REGISTER (? target))
#f))
(fixnum-1-arg target source
(lambda (target)
- (multiply-fixnum-constant target (* n fixnum-1) false))))
+ (multiply-fixnum-constant target n false))))
\f
;;;; Fixnum Predicates
(OBJECT->FIXNUM (CONSTANT (? constant))))
(fixnum-branch! predicate)
(LAP (CMP W ,(source-register-reference register)
- (& ,(* constant fixnum-1)))))
+ (& ,constant))))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(REGISTER (? register)))
(fixnum-branch! (commute-fixnum-predicate predicate))
(LAP (CMP W ,(source-register-reference register)
- (& ,(* constant fixnum-1)))))
+ (& ,constant))))
\f
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(OBJECT->FIXNUM (CONSTANT (? constant))))
(fixnum-branch! predicate)
(LAP (CMP W ,(offset->reference! expression)
- (& ,(* constant fixnum-1)))))
+ (& ,constant))))
(define-rule predicate
(FIXNUM-PRED-2-ARGS (? predicate)
(? expression rtl:simple-offset?))
(fixnum-branch! (commute-fixnum-predicate predicate))
(LAP (CMP W ,(offset->reference! expression)
- (& ,(* constant fixnum-1)))))
+ (& ,constant))))
;; This assumes that the immediately preceding instruction sets the
;; condition code bits correctly.
\f
;;;; Utilities
-(define (object->fixnum target)
+#| The following is now broken/obsolete in 8.x
+
+ (define (object->fixnum target)
(LAP (SAL W ,target (& ,scheme-type-width))))
;; Clearly wrong for the split typecodes:
(define (load-fixnum-constant constant target)
(if (zero? constant)
(LAP (XOR W ,target ,target))
- (LAP (MOV W ,target (& ,(* constant fixnum-1))))))
+ (LAP (MOV W ,target (& ,constant)))))
(define (add-fixnum-constant target constant overflow?)
(let ((value (* constant fixnum-1)))
(else
;; target must be a register!
(LAP (IMUL W ,target ,target (& ,constant))))))
+End of stuff broken during conversion to 8.x
+|#
+
\f
;;;; Operation tables
target source1 source2)
(let* ((worst-case
(lambda (target source1 source2)
+ (if (and (equal? target source2)
+ (not (equal? target source1)))
+ (error "two-arg-register-operation: about to overwrite source1 with source2"))
(LAP (MOV W ,target ,source1)
,@(operate target source2))))
(new-target-alias!
(if (not (eq? (register-type target) 'GENERAL))
(error "two-arg-register-operation: Wrong type register"
target 'GENERAL)
- (worst-case (register-reference target)
- (any-reference source1)
- (any-reference source2))))
+ (begin
+ (require-register! target)
+ (worst-case (target-register-reference target)
+ (any-reference source1)
+ (any-reference source2)))))
((register-copy-if-available source1 'GENERAL target)
=>
(lambda (get-alias-ref)
(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
(lambda (target)
- (LAP (NOT W ,target)
- ,@(word->fixnum target))))
+ (LAP (NOT W ,target))))
(define-arithmetic-method 'FIXNUM-NEGATE fixnum-methods/1-arg
(lambda (target)
false
(lambda (target source2)
(cond ((not (equal? target source2))
- (LAP (SAR W ,target (& ,scheme-type-width))
- (IMUL W ,target ,source2)))
+ (LAP (IMUL W ,target ,source2)))
((even? scheme-type-width)
+ (display "fixnum test failed")
+ (display target)
+ (display source2)
(LAP (SAR W ,target (& ,(quotient scheme-type-width 2)))
(IMUL W ,target ,target)))
(else
(let ((temp (temporary-register-reference)))
+ (display "fixnum test failed")
+ (display target)
+ (display source2)
(LAP (MOV W ,temp ,target)
(SAR W ,target (& ,scheme-type-width))
(IMUL W ,target ,temp))))))))
(let ((jlabel (generate-label 'SHIFT-JOIN))
(slabel (generate-label 'SHIFT-NEGATIVE)))
(LAP (MOV W (R ,ecx) ,source2)
- (SAR W (R ,ecx) (& ,scheme-type-width))
+ (OR W (R ,ecx) (R ,ecx))
(JS B (@PCR ,slabel))
(SHL W ,target (R ,ecx))
(JMP B (@PCR ,jlabel))
(LABEL ,slabel)
(NEG W (R ,ecx))
(SHR W ,target (R ,ecx))
- ,@(word->fixnum target)
(LABEL ,jlabel))))))
(if (not (equal? target (INST-EA (R ,ecx))))
overflow? ; ignored
(if (= source2 source1)
(load-fixnum-constant 1 (target-register-reference target))
- (LAP ,@(do-division target source1 source2 eax)
- (SAL W (R ,eax) (& ,scheme-type-width))))))
+ (do-division target source1 source2 eax))))
(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
(lambda (target source1 source2 overflow?)
((= n -1)
(load-fixnum-constant -1 target))
(else
- (LAP (OR W ,target (& ,(* n fixnum-1))))))))
+ (LAP (OR W ,target (& ,n)))))))
(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args-constant
(lambda (target n overflow?)
(cond ((zero? n)
(LAP))
((= n -1)
- (LAP (NOT W ,target)
- ,@(word->fixnum target)))
+ (LAP (NOT W ,target)))
+ ((<= 0 n 255)
+ (LAP (XOR B ,target (& ,n))))
(else
- (LAP (XOR W ,target (& ,(* n fixnum-1))))))))
+ (LAP (XOR W ,target (& ,n)))))))
(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args-constant
(lambda (target n overflow?)
((= n -1)
(LAP))
(else
- (LAP (AND W ,target (& ,(* n fixnum-1))))))))
+ (LAP (AND W ,target (& ,n)))))))
\f
(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
(lambda (target n overflow?)
((= n -1)
(load-fixnum-constant 0 target))
(else
- (LAP (AND W ,target (& ,(* (fix:not n) fixnum-1))))))))
+ (LAP (AND W ,target (& ,(fix:not n))))))))
(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args-constant
(lambda (target n overflow?)
((not (negative? n))
(LAP (SHL W ,target (& ,n))))
(else
- (LAP (SHR W ,target (& ,(- 0 n)))
- ,@(word->fixnum target))))))
+ (LAP (SHR W ,target (& ,(- 0 n))))))))
(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
(lambda (target n overflow?)
(absn (if (negative? n) (- 0 n) n)))
(LAP (CMP W ,target (& 0))
(JGE B (@PCR ,label))
- (ADD W ,target (& ,(* (-1+ absn) fixnum-1)))
+ (ADD W ,target (& ,(-1+ absn)))
(LABEL ,label)
(SAR W ,target (& ,expt-of-2))
- ,@(word->fixnum target)
,@(if (negative? n)
(LAP (NEG W ,target))
(LAP))))))
;; This may produce a branch to a branch, but a
;; peephole optimizer should be able to fix this.
(LAP (MOV W ,sign ,target)
- (AND W ,target (& ,(* (-1+ n) fixnum-1)))
+ (AND W ,target (& ,(-1+ n)))
(JZ B (@PCR ,label))
- (SAR W ,sign (& ,(-1+ scheme-object-width)))
- (AND W ,sign (& ,(* n (- 0 fixnum-1))))
+ (SAR W ,sign (& ,scheme-object-width))
+ (AND W ,sign (& ,(- 0 n)))
(OR W ,target ,sign)
(LABEL ,label))))
(else
projects / mit-scheme.git / commitdiff