Added flonum cells.

diff --git a/v8/src/compiler/midend/dbgred.scm b/v8/src/compiler/midend/dbgred.scm
index 1eb19835b59a0cf94f1b38a95d126dd3bf279a6e..9b00042aab873a552968d12e9c95e8576199d969 100644 (file)
--- a/v8/src/compiler/midend/dbgred.scm
+++ b/v8/src/compiler/midend/dbgred.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: dbgred.scm,v 1.14 1995/08/19 01:34:04 adams Exp $
+$Id: dbgred.scm,v 1.15 1995/08/23 14:07:05 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -614,6 +614,18 @@ reachable.
                           (vector-index (quote/text layout)
                                         (quote/text name)))
                          cell-path))))
+           ((CALL/%flo:multicell-ref? expr)
+            (let ((cell-path
+                   (reconstruct-expression (call/%flo:multicell-ref/cell expr)))
+                  (layout  (call/%flo:multicell-ref/layout expr))
+                  (name    (call/%flo:multicell-ref/name expr)))
+              (and cell-path
+                   (QUOTE/? layout)
+                   (QUOTE/? name)
+                   (cons (dbgred/FLONUM-CELL 
+                          (vector-index (quote/text layout)
+                                        (quote/text name)))
+                         cell-path))))
            ((or (CALL/%stack-closure-ref? expr)
                 (CALL/%heap-closure-ref? expr))
             (internal-error "DBG expression should have been compressed" expr))
@@ -683,6 +695,7 @@ reachable.
 (define dbgred/STACK           (dbg-reduce/indexed-path 'STACK))
 (define dbgred/CLOSURE         (dbg-reduce/indexed-path 'CLOSURE))
 (define dbgred/CELL            (dbg-reduce/indexed-path 'CELL))
+(define dbgred/FLONUM-CELL     (dbg-reduce/indexed-path 'FLONUM-CELL))
 
 (define dbg-reduce/equivalent-operators (make-monotonic-strong-eq-hash-table))
 

diff --git a/v8/src/compiler/midend/fakeprim.scm b/v8/src/compiler/midend/fakeprim.scm
index f35b9094b0ee9bb483f1ac8577a75411f66e8dae..542f1db9e5b789ca0edc5060e02fdad5d1ff8bcb 100644 (file)
--- a/v8/src/compiler/midend/fakeprim.scm
+++ b/v8/src/compiler/midend/fakeprim.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: fakeprim.scm,v 1.21 1995/08/19 01:36:13 adams Exp $
+$Id: fakeprim.scm,v 1.22 1995/08/23 14:07:44 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -696,7 +696,7 @@ MIT in each case. |#
 (define %make-multicell
   ;; (CALL ',%make-multicell '#F 'LAYOUT <value> <value> ...)
   (make-operator/simple "#[make-multicell]"))
-(cookie-call %make-multicell '#F 'LAYOUT #!rest values)
+;;(cookie-call %make-multicell '#F 'LAYOUT #!rest values)
 
 (define %multicell-ref
   ;; (CALL ',%multicell-ref '#F cell 'LAYOUT 'NAME)
@@ -708,7 +708,23 @@ MIT in each case. |#
   ;; Note:
   ;;   Always used in statement position - has no value.
   (make-operator/simple* "#[multicell-set!]" '(UNSPECIFIC-RESULT)))
-(cookie-call %multicell-set! '#F cell value 'LAYOUT 'NAME)
+;;(cookie-call %multicell-set! '#F cell value 'LAYOUT 'NAME)
+
+(define %flo:make-multicell
+  ;; (CALL ',%flo:make-multicell '#F 'LAYOUT <value> <value> ...)
+  (make-operator/simple "#[flo:make-multicell]"))
+;;(cookie-call %make-multicell '#F 'LAYOUT #!rest values)
+
+(define %flo:multicell-ref
+  ;; (CALL ',%flo:multicell-ref '#F cell 'LAYOUT 'NAME)
+  (make-operator/effect-sensitive "#[flo:multicell-ref]" '(RESULT-TYPE FLONUM))
+(cookie-call %multicell-ref '#F cell 'LAYOUT 'NAME)
+
+(define %flo:multicell-set!
+  ;; (CALL ',%flo:multicell-set! '#F cell value 'LAYOUT 'NAME)
+  ;; Note:
+  ;;   Always used in statement position - has no value.
+  (make-operator/simple* "#[flo:multicell-set!]" '(UNSPECIFIC-RESULT)))
 
 
 ;; Tuples are collections of values.  Each slot is named.  LAYOUT
@@ -1013,14 +1029,23 @@ MIT in each case. |#
        fix:-1+ fix:1+ fix:+ fix:- fix:*
        fix:quotient fix:remainder ; fix:gcd
        fix:andc fix:and fix:or fix:xor fix:not fix:lsh
-       flo:+ flo:- flo:* flo:/
-       flo:negate flo:abs flo:sqrt
-       flo:floor flo:ceiling flo:truncate flo:round
-       flo:exp flo:log flo:sin flo:cos flo:tan flo:asin
-       flo:acos flo:atan flo:atan2 flo:expt
        flo:floor->exact flo:ceiling->exact
        flo:truncate->exact flo:round->exact
        ascii->char integer->char char->ascii char-code char->integer))
+
+(for-each
+ (lambda (simple-operator)
+   (define-operator-properties
+     simple-operator
+     (list '(SIMPLE)
+          '(SIDE-EFFECT-INSENSITIVE)
+          '(SIDE-EFFECT-FREE)
+          '(RESULT-TYPE FLONUM))))
+ (list flo:+ flo:- flo:* flo:/
+       flo:negate flo:abs flo:sqrt
+       flo:floor flo:ceiling flo:truncate flo:round
+       flo:exp flo:log flo:sin flo:cos flo:tan flo:asin
+       flo:acos flo:atan flo:atan2 flo:expt))
 \f
 (for-each
  (lambda (simple-operator)
@@ -1031,12 +1056,21 @@ MIT in each case. |#
  (list cell-contents car cdr %record-ref
        vector-ref
        string-ref
-       string-length vector-8b-ref flo:vector-ref
+       string-length vector-8b-ref
        system-pair-car system-pair-cdr
        system-hunk3-cxr0 system-hunk3-cxr1 system-hunk3-cxr2
        (make-primitive-procedure 'PRIMITIVE-GET-FREE)
        (make-primitive-procedure 'PRIMITIVE-OBJECT-REF)))
 
+(for-each
+ (lambda (simple-operator)
+   (define-operator-properties
+     simple-operator
+     (list '(SIMPLE)
+          '(SIDE-EFFECT-FREE)
+          '(RESULT-TYPE FLONUM))))
+ (list flo:vector-ref))
+
 (for-each
  (lambda (operator)
    (define-operator-properties

diff --git a/v8/src/compiler/midend/laterew.scm b/v8/src/compiler/midend/laterew.scm
index ed0e1b650750e3d40a1051025f496defc428416f..b78ecf75d33ec66184b3d739b065333673251790 100644 (file)
--- a/v8/src/compiler/midend/laterew.scm
+++ b/v8/src/compiler/midend/laterew.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: laterew.scm,v 1.13 1995/08/19 15:30:43 adams Exp $
+$Id: laterew.scm,v 1.14 1995/08/23 14:07:19 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -365,6 +365,68 @@ MIT in each case. |#
         ((READ)        `(CALL ',%vector-ref '#F ,cell ,(index)))
         ((WRITE)       `(CALL ',%vector-set! '#F ,cell ,(index) ,value/s))
         ((MAKE)        `(CALL ',%vector '#F ,@value/s)))))))
+
+(define-rewrite/late %flo:make-multicell
+  (lambda (form rands)
+    (let ((cont    (first rands))
+         (layout  (second rands))
+         (values  (cddr rands)))
+      (let ((name (and (QUOTE/? layout)
+                      (= (vector-length (quote/text layout)) 1)
+                      `(QUOTE ,(vector-ref (quote/text layout) 0)))))
+       (laterew/flo:multicell-operation cont layout name 'MAKE #F values)))))
+
+(define-rewrite/late %flo:multicell-ref
+  (lambda (form rands)
+    (let ((cont    (first rands))
+         (cell    (second rands))
+         (layout  (third rands))
+         (name    (fourth rands)))
+      (laterew/flo:multicell-operation cont layout name 'READ cell #F))))
+
+(define-rewrite/late %flo:multicell-set!
+  (lambda (form rands)
+    (let ((cont    (first rands))
+         (cell    (second rands))
+         (value   (third rands))
+         (layout  (fourth rands))
+         (name    (fifth rands)))
+      (laterew/flo:multicell-operation cont layout name 'WRITE cell value))))
+
+(define (laterew/flo:multicell-operation cont layout name operation cell value/s)
+  (if (not (equal? cont '(QUOTE #F)))
+      (internal-error "Bad continuation for Multicell operation" cont))
+  (let ((layout
+        (if (QUOTE/? layout)
+            (quote/text layout)
+            (internal-error "Multicell operation needs constant LAYOUT"
+                            layout)))
+       (name
+        (cond ((eq? name #F)  #F)
+              ((QUOTE/? name) (quote/text name))
+              (else (internal-error "Multicell operation needs constant NAME"
+                                    name)))))
+    (define (index)
+      (let ((value  (vector-find-next-element layout name)))
+       (if value
+           `(QUOTE ,value)
+           (internal-error "Multicell operation: name not found"
+                           name layout))))
+    (case operation
+      ((READ)  `(CALL ',flo:vector-ref '#F ,cell ,(index)))
+      ((WRITE) `(CALL ',flo:vector-set! '#F ,cell ,(index) ,value/s))
+      ((MAKE)
+       (let ((cell (laterew/new-name 'FLONUM-VECTOR)))
+        `(LET ((,cell (CALL ',flo:vector-cons '#F ',(vector-length layout))))
+           (BEGIN
+             ,@(map (lambda (index value)
+                      `(CALL ',flo:vector-set! '#F
+                             (LOOKUP ,cell)
+                             (QUOTE ,index)
+                             ,value/s))
+                    (iota (length values))
+                    values)
+             (LOOKUP ,cell))))))))
 \f
 (define-rewrite/late %vector-check
   (let ((vector-tag (machine-tag 'VECTOR)))