More changes.

diff --git a/v7/src/compiler/machines/i386/insmac.scm b/v7/src/compiler/machines/i386/insmac.scm
index 6db10f57c675c68ad46781e0565b22e3a56cc274..a554921968a9d595454a7848fcea54d707f13319 100644 (file)
--- a/v7/src/compiler/machines/i386/insmac.scm
+++ b/v7/src/compiler/machines/i386/insmac.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/insmac.scm,v 1.6 1992/02/13 05:43:25 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/insmac.scm,v 1.7 1992/02/13 07:47:07 jinx Exp $
 $Vax-Header: insmac.scm,v 1.12 89/05/17 20:29:15 GMT jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
@@ -81,6 +81,11 @@ MIT in each case. |#
                    (and (memq ',restriction (ea/categories ea))
                         ea))))))))
 \f
+;; *** We can't really handle switching these right now. ***
+
+(define-integrable *ADDRESS-SIZE* 32)
+(define-integrable *OPERAND-SIZE* 32)
+
 (define (parse-instruction opcode tail early?)
   (process-fields (cons opcode tail) early?))
 
@@ -173,6 +178,7 @@ MIT in each case. |#
                                 'SIGNED
                                 (cadddr field))))
                 `(CONS-SYNTAX
+                  #|
                   (COERCE-TO-TYPE ,value
                                   ,(case mode
                                      ((OPERAND)
@@ -182,6 +188,17 @@ MIT in each case. |#
                                      (else
                                       (error "Unknown IMMEDIATE mode" mode)))
                                   ,domain)
+                  |#
+                  ,(integer-syntaxer
+                    value
+                    domain
+                    (case mode
+                      ((OPERAND)
+                       *operand-size*)
+                      ((ADDRESS)
+                       *address-size*)
+                      (else
+                       (error "Unknown IMMEDIATE mode" mode))))
                   ,tail)))
             tail-size))
           (else

diff --git a/v7/src/compiler/machines/i386/instr1.scm b/v7/src/compiler/machines/i386/instr1.scm
index e82f252f1e7205dad8ff28ba896c06c825c3b8ef..6fe9a9db6a14da6aa24bdc38f99e6d97132b406b 100644 (file)
--- a/v7/src/compiler/machines/i386/instr1.scm
+++ b/v7/src/compiler/machines/i386/instr1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/instr1.scm,v 1.6 1992/02/13 03:22:20 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/instr1.scm,v 1.7 1992/02/13 07:47:52 jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -201,11 +201,11 @@ MIT in each case. |#
 (define-instruction CALL
   (((@PCR (? dest)))
    (BYTE (8 #xe8))
-   (IMMEDIATE `(- ,dest (+ *PC* ,*ADDRESS-SIZE*)) ADDRESS))
+   (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
 
   (((@PCRO (? dest) (? offset)))
    (BYTE (8 #xe8))
-   (IMMEDIATE `(- (+ ,dest ,offset) (+ *PC* ,*ADDRESS-SIZE*)) ADDRESS))
+   (IMMEDIATE `(- (+ ,dest ,offset) (+ *PC* 4)) ADDRESS)); fcn(*ADDRESS-SIZE*)
 
   (((@PCO (? displ)))
    (BYTE (8 #xe8))
@@ -290,11 +290,11 @@ MIT in each case. |#
         `(define-instruction ,mnemonic
            ((W (R 0) (? operand r/mW))
             (BYTE (8 #xf7))
-            (ModR/M digit operand))
+            (ModR/M ,digit operand))
 
            ((B (R 0) (? operand r/mB))
             (BYTE (8 #xf6))
-            (ModR/M digit operand))))))
+            (ModR/M ,digit operand))))))
 
   (define-mul/div DIV 6)
   (define-mul/div IDIV 7)
@@ -392,7 +392,7 @@ MIT in each case. |#
            ((W (@PCR (? dest)))
             (BYTE (8 #x0f)
                   (8 ,opcode2))
-            (IMMEDIATE `(- ,dest (+ *PC* ,*ADDRESS-SIZE*)) ADDRESS))
+            (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
 
            ((B (@PCO (? displ)))
             (BYTE (8 ,opcode1)
@@ -486,7 +486,7 @@ MIT in each case. |#
 
   ((W (@PCR (? dest)))
    (BYTE (8 #xe9))
-   (IMMEDIATE `(- ,dest (+ *PC* ,*ADDRESS-SIZE*)) ADDRESS))
+   (IMMEDIATE `(- ,dest (+ *PC* 4)) ADDRESS)) ; fcn(*ADDRESS-SIZE*)
 
   ((B (@PCO (? displ)))
    (BYTE (8 #xeb)
@@ -527,7 +527,7 @@ MIT in each case. |#
            (((? operand mW))
             (BYTE (8 #x0f)
                   (8 ,opcode))
-            (ModR/M digit operand))))))
+            (ModR/M ,digit operand))))))
 
   (define-load/store-state INVLPG #x01 7)      ; 486 only
   (define-load/store-state LGDT   #x01 2)

diff --git a/v7/src/compiler/machines/i386/instrf.scm b/v7/src/compiler/machines/i386/instrf.scm
index 820da6180fe1fb595f96306020c686ddcd994771..75b366b60a49e5d7828cfbeb866058275aa5dd8b 100644 (file)
--- a/v7/src/compiler/machines/i386/instrf.scm
+++ b/v7/src/compiler/machines/i386/instrf.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/instrf.scm,v 1.6 1992/02/13 06:01:59 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/instrf.scm,v 1.7 1992/02/13 07:48:08 jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -52,11 +52,11 @@ MIT in each case. |#
        (macro (mnemonic pmnemonic imnemonic digit opcode1 opcode2)
         `(begin
            (define-instruction ,mnemonic
-             (((ST 0) (ST i))
+             (((ST 0) (ST (? i)))
               (BYTE (8 #xd8)
                     (8 (+ ,opcode1 i))))
 
-             (((ST i) (ST 0))
+             (((ST (? i)) (ST 0))
               (BYTE (8 #xdc)
                     (8 (+ ,opcode2 i))))
 
@@ -73,7 +73,7 @@ MIT in each case. |#
               (ModR/M ,digit source)))
 
            (define-instruction ,pmnemonic
-             (((ST i) (ST 0))
+             (((ST (? i)) (ST 0))
               (BYTE (8 #xde)
                     (8 (+ #xc0 i)))))
 
@@ -177,7 +177,7 @@ MIT in each case. |#
   (define-flonum-integer-memory FISTP 3 7))
 
 (define-trivial-instruction FINCSTP #xd9 #xf7)
-(define-trivial-instruction FINIT   #x9b #xdb #xe3) = (FWAIT) (FNINT)
+(define-trivial-instruction FINIT   #x9b #xdb #xe3) ; = (FWAIT) (FNINT)
 (define-trivial-instruction FNINIT  #xdb #xe3)
 
 (let-syntax

diff --git a/v7/src/compiler/machines/i386/insutl.scm b/v7/src/compiler/machines/i386/insutl.scm
index 608e289c8b65126bb213c86157d6cf68370d4387..1811725c9018f8f66d7703708d6e31e7eb5dee26 100644 (file)
--- a/v7/src/compiler/machines/i386/insutl.scm
+++ b/v7/src/compiler/machines/i386/insutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/insutl.scm,v 1.6 1992/02/13 03:03:10 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/insutl.scm,v 1.7 1992/02/13 07:48:52 jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -38,11 +38,6 @@ MIT in each case. |#
 \f
 ;;;; Addressing modes
 
-;; *** We can't really handle switching these right now. ***
-
-(define-integrable *ADDRESS-SIZE* 32)
-(define-integrable *OPERAND-SIZE* 32)
-
 ;; r/m part of ModR/M byte and SIB byte.
 ;; These are valid only for 32-bit addressing.
 

diff --git a/v7/src/compiler/machines/i386/lapgen.scm b/v7/src/compiler/machines/i386/lapgen.scm
index 5adf0665b0cec6e45f8186673df30789bf3fb8ef..f19245ca0b58dce17ad8b5493a484d552124c750 100644 (file)
--- a/v7/src/compiler/machines/i386/lapgen.scm
+++ b/v7/src/compiler/machines/i386/lapgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.9 1992/02/13 05:52:58 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/lapgen.scm,v 1.10 1992/02/13 07:46:53 jinx Exp $
 $MC68020-Header: /scheme/compiler/bobcat/RCS/lapgen.scm,v 4.42 1991/05/28 19:14:26 jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
@@ -222,7 +222,7 @@ MIT in each case. |#
 
 (define (non-pointer->literal object)
   (make-non-pointer-literal (object-type object)
-                           (careful-objct-datum object)))
+                           (careful-object-datum object)))
 
 (define (load-immediate target value)
   (if (zero? value)
@@ -238,7 +238,7 @@ MIT in each case. |#
 (define (load-constant target obj)
   (if (non-pointer-object? obj)
       (load-non-pointer target (object-type obj) (careful-object-datum obj))
-      (load-pc-relative target (free-constant-label obj))))
+      (load-pc-relative target (constant->label obj))))
 
 (define (load-pc-relative target label-expr)
   (with-pc
@@ -255,13 +255,19 @@ MIT in each case. |#
     (lambda (label reg)
       (if label
          (recvr label reg)
-         (let ((temporary (allocate-temporary-register! 'GENERAL))
-               (label (generate-label 'GET-PC)))
-           (cache-label! label temporary)
-           (LAP (CALL (@PCR ,label))
-                (LABEL ,label)
-                (POP (R ,(register-reference temporary)))
-                ,@(recvr label temporary)))))))
+         (let ((temporary (allocate-temporary-register! 'GENERAL)))
+           (pc->reg temporary
+                    (lambda (label prefix)
+                      (cache-label! label temporary)
+                      (LAP ,@prefix
+                           ,@(recvr label temporary)))))))))
+
+(define (pc->reg reg recvr)
+  (let ((label (generate-label 'GET-PC)))
+    (recvr label
+          (LAP (CALL (@PCR ,label))
+               (LABEL ,label)
+               (POP ,(register-reference reg))))))
 
 (define-integrable (get-cached-label)
   (register-map-label *register-map* 'GENERAL))
@@ -469,4 +475,17 @@ MIT in each case. |#
     error
     primitive-error
     |#
-    ))
\ No newline at end of file
+    ))
+
+;; Operation tables
+
+(define (define-arithmetic-method operator methods method)
+  (let ((entry (assq operator (cdr methods))))
+    (if entry
+       (set-cdr! entry method)
+       (set-cdr! methods (cons (cons operator method) (cdr methods)))))
+  operator)
+
+(define (lookup-arithmetic-method operator methods)
+  (cdr (or (assq operator (cdr methods))
+          (error "Unknown operator" operator))))
\ No newline at end of file

diff --git a/v7/src/compiler/machines/i386/rules1.scm b/v7/src/compiler/machines/i386/rules1.scm
index a62a5df67a0930ff2b40e61c7b83f4878c0dc151..4654fe1f13577c815be90ba9d3d548ad91eff212 100644 (file)
--- a/v7/src/compiler/machines/i386/rules1.scm
+++ b/v7/src/compiler/machines/i386/rules1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules1.scm,v 1.7 1992/02/11 14:48:05 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules1.scm,v 1.8 1992/02/13 07:46:35 jinx Exp $
 $MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rules1.scm,v 4.36 1991/10/25 06:49:58 cph Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
@@ -250,6 +250,10 @@ MIT in each case. |#
            ,(indirect-byte-reference! address offset)
            (& ,(char->signed-8-bit-immediate character)))))
 
+(define (char->signed-8-bit-immediate character)
+  (let ((ascii (char->ascii character)))
+    (if (< ascii 128) ascii (- ascii 256))))
+
 (define-rule statement
   (ASSIGN (BYTE-OFFSET (REGISTER (? address)) (? offset))
          (REGISTER (? source)))
@@ -299,4 +303,10 @@ MIT in each case. |#
          |#
          (else
           (LAP ,@(load-non-pointer target type 0)
-               (MOV B ,target ,source))))))
\ No newline at end of file
+               (MOV B ,target ,source))))))
+
+(define (indirect-char/ascii-reference! register offset)
+  (indirect-byte-reference! register (* offset 4)))
+
+(define (indirect-byte-reference! register offset)
+  (byte-offset-reference (allocate-indirection-register! register) offset))
\ No newline at end of file

diff --git a/v7/src/compiler/machines/i386/rules2.scm b/v7/src/compiler/machines/i386/rules2.scm
index 65fdccba05230958d215afd84a67ca064afa8ac5..f2f291d2c24c66a3857de0888fd045e9c53638e4 100644 (file)
--- a/v7/src/compiler/machines/i386/rules2.scm
+++ b/v7/src/compiler/machines/i386/rules2.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules2.scm,v 1.2 1992/01/30 06:32:47 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rules2.scm,v 1.3 1992/02/13 07:48:34 jinx Exp $
 $MC68020-Header: rules2.scm,v 4.12 90/01/18 22:44:04 GMT cph Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
@@ -71,14 +71,14 @@ MIT in each case. |#
   (QUALIFIER (non-pointer-object? constant))
   (set-equal-branches!)
   (LAP (CMP W ,(any-reference register)
-           (&U ,(non-pointer->immediate constant)))))
+           (&U ,(non-pointer->literal constant)))))
 
 (define-rule predicate
   (EQ-TEST (REGISTER (? register)) (CONSTANT (? constant)))
   (QUALIFIER (non-pointer-object? constant))
   (set-equal-branches!)
   (LAP (CMP W ,(any-reference register)
-           (&U ,(non-pointer->immediate constant)))))
+           (&U ,(non-pointer->literal constant)))))
 \f
 (define-rule predicate
   (EQ-TEST (CONSTANT (? constant)) (OFFSET (REGISTER (? address)) (? offset)))

diff --git a/v7/src/compiler/machines/i386/rulfix.scm b/v7/src/compiler/machines/i386/rulfix.scm
index ea3ec9ac556bcdd08676806639fbc785f9ea6229..5d8986d9adc689ba3b25e7f45d6f60ce4903fbf9 100644 (file)
--- a/v7/src/compiler/machines/i386/rulfix.scm
+++ b/v7/src/compiler/machines/i386/rulfix.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulfix.scm,v 1.15 1992/02/13 06:40:36 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulfix.scm,v 1.16 1992/02/13 07:47:37 jinx Exp $
 $MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rules1.scm,v 4.36 1991/10/25 06:49:58 cph Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
@@ -185,7 +185,7 @@ MIT in each case. |#
                      (OBJECT->FIXNUM (CONSTANT (? constant))))
   (fixnum-branch! predicate)
   (LAP (CMP W ,(source-register-reference register)
-           (& ,(fixnum-object->fixnum-word constant)))))
+           (& ,(* constant fixnum-1)))))
 
 (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)
-           (& ,(fixnum-object->fixnum-word constant)))))
+           (& ,(* constant fixnum-1)))))
 \f
 (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 ,(source-indirect-reference! address offset)
-           (& ,(fixnum-object->fixnum-word constant)))))
+           (& ,(* constant fixnum-1)))))
 
 (define-rule predicate
   (FIXNUM-PRED-2-ARGS (? predicate)
@@ -209,7 +209,7 @@ MIT in each case. |#
                      (OFFSET (REGISTER (? address)) (? offset)))
   (fixnum-branch! (commute-fixnum-predicate predicate))
   (LAP (CMP W ,(source-indirect-reference! address offset)
-           (& ,(fixnum-object->fixnum-word constant)))))
+           (& ,(* constant fixnum-1)))))
 
 ;; This assumes that the immediately preceding instruction sets the
 ;; condition code bits correctly.
@@ -288,24 +288,13 @@ MIT in each case. |#
        (else
         (LAP (IMUL W ,target (& ,constant))))))
 \f
-;;;; Fixnum operation dispatch
-
-(define (define-fixnum-method operator methods method)
-  (let ((entry (assq operator (cdr methods))))
-    (if entry
-       (set-cdr! entry method)
-       (set-cdr! methods (cons (cons operator method) (cdr methods)))))
-  operator)
-
-(define (lookup-fixnum-method operator methods)
-  (cdr (or (assq operator (cdr methods))
-          (error "Unknown operator" operator))))
+;;;; Operation tables
 
 (define fixnum-methods/1-arg
   (list 'FIXNUM-METHODS/1-ARG))
 
 (define-integrable (fixnum-1-arg/operate operator)
-  (lookup-fixnum-method operator fixnum-methods/1-arg))
+  (lookup-arithmetic-method operator fixnum-methods/1-arg))
 
 (define-integrable (fixnum-1-arg target source operation)
   (operation (standard-move-to-target! source target)))
@@ -314,13 +303,13 @@ MIT in each case. |#
   (list 'FIXNUM-METHODS/2-ARGS))
 
 (define-integrable (fixnum-2-args/operate operator)
-  (lookup-fixnum-method operator fixnum-methods/2-args))
+  (lookup-arithmetic-method operator fixnum-methods/2-args))
 
 (define fixnum-methods/2-args-constant
   (list 'FIXNUM-METHODS/2-ARGS-CONSTANT))
 
 (define-integrable (fixnum-2-args/operate-constant operator)
-  (lookup-fixnum-method operator fixnum-methods/2-args-constant))
+  (lookup-arithmetic-method operator fixnum-methods/2-args-constant))
 
 (define (fixnum-2-args/commutative? operator)
   (memq operator '(PLUS-FIXNUM
@@ -340,7 +329,7 @@ MIT in each case. |#
                                    target source1 source2)
   (let* ((worst-case
          (lambda (target source1 source2)
-           (LAP (LAP (MOV W ,target ,source1))
+           (LAP (MOV W ,target ,source1)
                 ,@(operate target source2))))
         (new-target-alias!
          (lambda ()
@@ -390,27 +379,27 @@ MIT in each case. |#
 \f
 ;;;; Arithmetic operations
 
-(define-fixnum-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
+(define-arithmetic-method 'ONE-PLUS-FIXNUM fixnum-methods/1-arg
   (lambda (target)
     (add-fixnum-constant target 1 false)))
 
-(define-fixnum-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
+(define-arithmetic-method 'MINUS-ONE-PLUS-FIXNUM fixnum-methods/1-arg
   (lambda (target)
     (add-fixnum-constant target -1 false)))
 
-(define-fixnum-method 'FIXNUM-NOT fixnum-methods/1-arg
+(define-arithmetic-method 'FIXNUM-NOT fixnum-methods/1-arg
   (lambda (target)
     (LAP (NOT W ,target)
         ,@(word->fixnum target))))
 
-(define-fixnum-method 'FIXNUM-NEGATE fixnum-methods/1-arg
+(define-arithmetic-method 'FIXNUM-NEGATE fixnum-methods/1-arg
   (lambda (target)
     (LAP (NEG W ,target))))
 
 (let-syntax
     ((binary-operation
       (macro (name instr commutative? idempotent?)
-       `(define-fixnum-method ',name fixnum-methods/2-args
+       `(define-arithmetic-method ',name fixnum-methods/2-args
           (fixnum-2-args/standard
            ,commutative?
            (lambda (target source2)
@@ -424,7 +413,7 @@ MIT in each case. |#
   (binary-operation FIXNUM-OR OR true true)
   (binary-operation FIXNUM-XOR XOR true false))
 
-(define-fixnum-method 'FIXNUM-ANDC fixnum-methods/2-args
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args
   (fixnum-2-args/standard
    false
    (lambda (target source2)
@@ -437,7 +426,7 @@ MIT in each case. |#
                (NOT W ,temp)
                (AND W ,target ,temp)))))))
 \f
-(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args
   (fixnum-2-args/standard
    false
    (lambda (target source2)
@@ -453,7 +442,7 @@ MIT in each case. |#
                   (SAR W ,target (& ,scheme-type-width))
                   (IMUL W ,target ,temp))))))))
 
-(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args
   (let ((operate
         (lambda (target source2)
           ;; SOURCE2 is guaranteed not to be ECX because of the
@@ -489,7 +478,7 @@ MIT in each case. |#
                                  source1
                                  source2))))
 \f
-(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args
   (lambda (target source1 source2)
     (if (= source2 source1)
        (load-fixnum-constant 1 (target-register-reference target))
@@ -503,7 +492,7 @@ MIT in each case. |#
                 (IDIV W (R ,eax) ,source2)
                 (SAL W (R ,eax) (& ,scheme-type-width))))))))
 
-(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args
   (lambda (target source1 source2)
     (if (= source2 source1)
        (load-fixnum-constant 0 (target-register-reference target))
@@ -517,15 +506,15 @@ MIT in each case. |#
                 (IDIV W (R ,eax) ,source2)
                 (SAL W (R ,edx) (& ,scheme-type-width))))))))
 
-(define-fixnum-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
+(define-arithmetic-method 'PLUS-FIXNUM fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     (add-fixnum-constant target n overflow?)))
 
-(define-fixnum-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
+(define-arithmetic-method 'MINUS-FIXNUM fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     (add-fixnum-constant target (- 0 n) overflow?)))
 
-(define-fixnum-method 'FIXNUM-OR fixnum-methods/2-args-constant
+(define-arithmetic-method 'FIXNUM-OR fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     overflow?                          ; ignored
     (cond ((zero? n)
@@ -535,7 +524,7 @@ MIT in each case. |#
          (else
           (LAP (OR W ,target (& ,(* n fixnum-1))))))))
 
-(define-fixnum-method 'FIXNUM-XOR fixnum-methods/2-args-constant
+(define-arithmetic-method 'FIXNUM-XOR fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     overflow?                          ; ignored
     (cond ((zero? n)
@@ -546,7 +535,7 @@ MIT in each case. |#
          (else
           (LAP (XOR W ,target (& ,(* n fixnum-1))))))))
 
-(define-fixnum-method 'FIXNUM-AND fixnum-methods/2-args-constant
+(define-arithmetic-method 'FIXNUM-AND fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     overflow?                          ; ignored
     (cond ((zero? n)
@@ -556,7 +545,7 @@ MIT in each case. |#
          (else
           (LAP (AND W ,target (& ,(* n fixnum-1))))))))
 \f
-(define-fixnum-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
+(define-arithmetic-method 'FIXNUM-ANDC fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     overflow?                          ; ignored
     (cond ((zero? n)
@@ -566,7 +555,7 @@ MIT in each case. |#
          (else
           (LAP (AND W ,target (& ,(* (fix:not n) fixnum-1))))))))
 
-(define-fixnum-method 'FIXNUM-LSH fixnum-methods/2-args-constant
+(define-arithmetic-method 'FIXNUM-LSH fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     overflow?                          ; ignored
     (cond ((zero? n)
@@ -579,11 +568,11 @@ MIT in each case. |#
           (LAP (SHR W ,target (& ,(- 0 n)))
                ,@(word->fixnum target))))))
 
-(define-fixnum-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
+(define-arithmetic-method 'MULTIPLY-FIXNUM fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     (multiply-fixnum-constant target n overflow?)))
 
-(define-fixnum-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant
+(define-arithmetic-method 'FIXNUM-QUOTIENT fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     overflow?                          ; ignored
     (cond ((= n 1)
@@ -600,14 +589,14 @@ MIT in each case. |#
                    (ADD W ,target (& ,(* (-1+ absn) fixnum-1)))
                    (LABEL ,label)
                    (SAR W ,target (& ,expt-of-2))
-                   ,@(word->fixnum ,target)
+                   ,@(word->fixnum target)
                    ,@(if (negative? n)
                          (LAP (NEG W ,target))
                          (LAP))))))
          (else
           (error "Fixnum-quotient/constant: Bad value" n)))))
 \f
-(define-fixnum-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant
+(define-arithmetic-method 'FIXNUM-REMAINDER fixnum-methods/2-args-constant
   (lambda (target n overflow?)
     ;; (remainder x y) is 0 or has the sign of x.
     ;; Thus we can always "divide" by (abs y) to make things simpler.

diff --git a/v7/src/compiler/machines/i386/rulflo.scm b/v7/src/compiler/machines/i386/rulflo.scm
index 6b60b87142ec4b5a52ed927fcc5c98d6c4b6341f..d040c38cd527dc370a54f64f5cff973abf474a46 100644 (file)
--- a/v7/src/compiler/machines/i386/rulflo.scm
+++ b/v7/src/compiler/machines/i386/rulflo.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulflo.scm,v 1.11 1992/02/13 06:09:45 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulflo.scm,v 1.12 1992/02/13 07:47:21 jinx Exp $
 $MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rules1.scm,v 4.36 1991/10/25 06:49:58 cph Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
@@ -109,7 +109,7 @@ MIT in each case. |#
   (ASSIGN (REGISTER (? target))
          (FLONUM-1-ARG (? operation) (REGISTER (? source)) (? overflow?)))
   overflow?                            ;ignore
-  ((flonm-1-arg/operator operation) target source))
+  ((flonum-1-arg/operator operation) target source))
 
 (define ((flonum-unary-operation/general operate) target source)
   (let* ((source (flonum-source! source))
@@ -132,7 +132,7 @@ MIT in each case. |#
            (flonum-unary-operation/general
             (lambda (target source)
               (if (and (zero? target) (zero? source))
-                  (,opcode)
+                  (LAP (,opcode))
                   (LAP (FLD (ST ,', source))
                        (,opcode)
                        (FSTP (ST ,',(1+ target)))))))))))
@@ -269,7 +269,7 @@ MIT in each case. |#
              (operate (flonum-target! target) sti1 sti2)))))
     (cond ((pseudo-register? target)
           (reuse-pseudo-register-alias
-           source1 target-type
+           source1 'FLOAT
            (lambda (alias)
              (let* ((sti1 (floreg->sti alias))
                     (sti2 (if (= source1 source2)
@@ -278,10 +278,10 @@ MIT in each case. |#
                (delete-register! alias)
                (delete-dead-registers!)
                (add-pseudo-register-alias! target alias)
-               (operate< sti1 sti1 sti2)))
+               (operate sti1 sti1 sti2)))
            (lambda ()
              (reuse-pseudo-register-alias
-              source2 target-type
+              source2 'FLOAT
               (lambda (alias2)
                 (let ((sti1 (flonum-source! source1))
                       (sti2 (floreg->sti alias2)))
@@ -290,9 +290,9 @@ MIT in each case. |#
                   (add-pseudo-register-alias! target alias2)
                   (operate sti2 sti1 sti2)))
               default))))
-         ((not (eq? target-type (register-type target)))
+         ((not (eq? (register-type target) 'FLOAT))
           (error "flonum-2-args: Wrong type register"
-                 target target-type))
+                 target 'FLOAT))
          (else
           (default)))))
 

diff --git a/v7/src/compiler/machines/i386/rulrew.scm b/v7/src/compiler/machines/i386/rulrew.scm
index 9871c2f60871c35862359a992d0ad6c719c079ce..165caa0d2370726146975967b8b16028269ab172 100644 (file)
--- a/v7/src/compiler/machines/i386/rulrew.scm
+++ b/v7/src/compiler/machines/i386/rulrew.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulrew.scm,v 1.5 1992/02/13 06:38:36 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/i386/rulrew.scm,v 1.6 1992/02/13 07:48:20 jinx Exp $
 $MC68020-Header: /scheme/src/compiler/machines/bobcat/RCS/rulrew.scm,v 1.4 1991/10/25 06:50:06 cph Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
@@ -168,7 +168,7 @@ MIT in each case. |#
    (and (memq operator '(FIXNUM-QUOTIENT FIXNUM-REMAINDER))
        (rtl:constant-fixnum-test operand-2
          (lambda (n)
-           (integer-log-base-2? (abs n))))))
+           (integer-power-of-2? (abs n))))))
   (rtl:make-fixnum-2-args operator operand-1 operand-2 overflow?))
 
 (define (rtl:constant-fixnum? expression)