From 93a6411c280fecd392f84f3ddc904dfa0432a1e1 Mon Sep 17 00:00:00 2001 From: ssmith Date: Fri, 20 Jan 1995 20:17:52 +0000 Subject: [PATCH] Made a lot of additions and bugfixes. Now compiles (probably incorrectly) about half of the runtime library. --- v8/src/compiler/machines/i386/lapopt.scm | 100 ++++++++-- v8/src/compiler/machines/i386/machin.scm | 30 ++- v8/src/compiler/machines/i386/rules1.scm | 4 +- v8/src/compiler/machines/i386/rules2.scm | 104 +++++++++- v8/src/compiler/machines/i386/rules3.scm | 242 ++++++++++++++++++++--- v8/src/compiler/machines/i386/rules4.scm | 62 +++++- v8/src/compiler/machines/i386/rulfix.scm | 77 ++++---- 7 files changed, 534 insertions(+), 85 deletions(-) diff --git a/v8/src/compiler/machines/i386/lapopt.scm b/v8/src/compiler/machines/i386/lapopt.scm index e78a45777..db9501c4e 100644 --- a/v8/src/compiler/machines/i386/lapopt.scm +++ b/v8/src/compiler/machines/i386/lapopt.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,7 +36,41 @@ MIT in each case. |# (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 @@ -74,7 +108,15 @@ MIT in each case. |# (#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 @@ -82,14 +124,6 @@ MIT in each case. |# ;; 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) @@ -105,6 +139,36 @@ MIT in each case. |# ())))) 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) @@ -142,14 +206,15 @@ MIT in each case. |# '(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) @@ -206,6 +271,7 @@ MIT in each case. |# last-mod-regs)))))))) (pp (get-pentium-timing instructions)) +|# instructions) diff --git a/v8/src/compiler/machines/i386/machin.scm b/v8/src/compiler/machines/i386/machin.scm index 07b7c52c4..2966e5628 100644 --- a/v8/src/compiler/machines/i386/machin.scm +++ b/v8/src/compiler/machines/i386/machin.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -191,6 +191,8 @@ MIT in each case. |# (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 @@ -221,6 +223,7 @@ MIT in each case. |# (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))) @@ -403,4 +406,27 @@ MIT in each case. |# ;; 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) diff --git a/v8/src/compiler/machines/i386/rules1.scm b/v8/src/compiler/machines/i386/rules1.scm index 01fa13594..5be4c5523 100644 --- a/v8/src/compiler/machines/i386/rules1.scm +++ b/v8/src/compiler/machines/i386/rules1.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -109,7 +109,7 @@ MIT in each case. |# (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 diff --git a/v8/src/compiler/machines/i386/rules2.scm b/v8/src/compiler/machines/i386/rules2.scm index a508b68c9..282c85e62 100644 --- a/v8/src/compiler/machines/i386/rules2.scm +++ b/v8/src/compiler/machines/i386/rules2.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -43,6 +43,12 @@ MIT in each case. |# (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!) @@ -59,6 +65,102 @@ MIT in each case. |# (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!) diff --git a/v8/src/compiler/machines/i386/rules3.scm b/v8/src/compiler/machines/i386/rules3.scm index d1408fed8..512012857 100644 --- a/v8/src/compiler/machines/i386/rules3.scm +++ b/v8/src/compiler/machines/i386/rules3.scm @@ -1,6 +1,6 @@ -#| -*-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 @@ -256,15 +256,168 @@ MIT in each case. |# (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 @@ -823,6 +976,27 @@ MIT in each case. |# ;; 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) @@ -855,9 +1029,9 @@ MIT in each case. |# (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) @@ -876,9 +1050,9 @@ MIT in each case. |# 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) @@ -890,7 +1064,7 @@ MIT in each case. |# (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) @@ -904,9 +1078,9 @@ MIT in each case. |# (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*))))))) @@ -996,21 +1170,18 @@ MIT in each case. |# 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) @@ -1018,13 +1189,26 @@ MIT in each case. |# ,@(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))))) ;;; Local Variables: *** diff --git a/v8/src/compiler/machines/i386/rules4.scm b/v8/src/compiler/machines/i386/rules4.scm index ebf54eead..16071a566 100644 --- a/v8/src/compiler/machines/i386/rules4.scm +++ b/v8/src/compiler/machines/i386/rules4.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -39,6 +39,65 @@ MIT in each case. |# ;;;; 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)) @@ -82,6 +141,7 @@ MIT in each case. |# (LAP ,@set-extension ,@(clear-map!) ,@(invoke-interface/call code:compiler-unassigned?-trap)))) +|# ;;;; Interpreter Calls diff --git a/v8/src/compiler/machines/i386/rulfix.scm b/v8/src/compiler/machines/i386/rulfix.scm index fb240e783..34fd25251 100644 --- a/v8/src/compiler/machines/i386/rulfix.scm +++ b/v8/src/compiler/machines/i386/rulfix.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -125,7 +125,7 @@ MIT in each case. |# #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)) @@ -135,7 +135,7 @@ MIT in each case. |# #f)) (fixnum-1-arg target source (lambda (target) - (multiply-fixnum-constant target (* n fixnum-1) false)))) + (multiply-fixnum-constant target n false)))) ;;;; Fixnum Predicates @@ -185,7 +185,7 @@ MIT in each case. |# (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) @@ -193,7 +193,7 @@ MIT in each case. |# (REGISTER (? register))) (fixnum-branch! (commute-fixnum-predicate predicate)) (LAP (CMP W ,(source-register-reference register) - (& ,(* constant fixnum-1))))) + (& ,constant)))) (define-rule predicate (FIXNUM-PRED-2-ARGS (? predicate) @@ -201,7 +201,7 @@ MIT in each case. |# (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) @@ -209,7 +209,7 @@ MIT in each case. |# (? 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. @@ -225,7 +225,9 @@ MIT in each case. |# ;;;; 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: @@ -261,7 +263,7 @@ MIT in each case. |# (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))) @@ -293,6 +295,9 @@ MIT in each case. |# (else ;; target must be a register! (LAP (IMUL W ,target ,target (& ,constant)))))) +End of stuff broken during conversion to 8.x +|# + ;;;; Operation tables @@ -337,6 +342,9 @@ MIT in each case. |# 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! @@ -351,9 +359,11 @@ MIT in each case. |# (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) @@ -391,8 +401,7 @@ MIT in each case. |# (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) @@ -458,13 +467,18 @@ MIT in each case. |# 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)))))))) @@ -481,14 +495,13 @@ MIT in each case. |# (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)))) @@ -521,8 +534,7 @@ MIT in each case. |# 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?) @@ -547,7 +559,7 @@ MIT in each case. |# ((= 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?) @@ -555,10 +567,11 @@ MIT in each case. |# (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?) @@ -568,7 +581,7 @@ MIT in each case. |# ((= n -1) (LAP)) (else - (LAP (AND W ,target (& ,(* n fixnum-1)))))))) + (LAP (AND W ,target (& ,n))))))) (define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args-constant (lambda (target n overflow?) @@ -578,7 +591,7 @@ MIT in each case. |# ((= 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?) @@ -590,8 +603,7 @@ MIT in each case. |# ((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?) @@ -611,10 +623,9 @@ MIT in each case. |# (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)))))) @@ -635,10 +646,10 @@ MIT in each case. |# ;; 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 -- 2.25.1