From d870dc7893a2689cb870abefa4b758c32777e3d6 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Fri, 8 Mar 1996 17:16:12 +0000
Subject: [PATCH] Fixed bug in open-coding of VECTOR-CONS. Made several more
 primitives into known operators in order to enable their open-coders.

---
 v8/src/compiler/midend/fakeprim.scm | 17 ++++++++++++++---
 v8/src/compiler/midend/rtlgen.scm   | 10 ++++++----
 2 files changed, 20 insertions(+), 7 deletions(-)

diff --git a/v8/src/compiler/midend/fakeprim.scm b/v8/src/compiler/midend/fakeprim.scm
index 1832d7a42..329d94189 100644
--- a/v8/src/compiler/midend/fakeprim.scm
+++ b/v8/src/compiler/midend/fakeprim.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: fakeprim.scm,v 1.23 1995/09/05 18:59:19 adams Exp $
+$Id: fakeprim.scm,v 1.24 1996/03/08 17:16:12 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -1022,7 +1022,9 @@ MIT in each case. |#
 	      '(SIDE-EFFECT-FREE)
 	      '(PROPER-PREDICATE))))
   (list not eq? null? false?
-	boolean? cell? pair? vector? %record? string? bit-string?
+	boolean? cell? pair? string? bit-string?
+	;; these two no not exist as primitives (SF expands to OBJECT-TYPE?)
+	;;   vector? %record?
 	fixnum? index-fixnum? flo:flonum? object-type?
 	fix:= fix:> fix:< fix:<= fix:>=
 	fix:zero? fix:positive? fix:negative? 
@@ -1046,11 +1048,13 @@ MIT in each case. |#
 	   '(SIDE-EFFECT-INSENSITIVE)
 	   '(SIDE-EFFECT-FREE))))
  (list make-cell cons vector %record string-allocate flo:vector-cons
+       (make-primitive-procedure 'VECTOR-CONS)
        system-pair-cons
        ;;%record-length
        ;;vector-length
        ;;flo:vector-length
        object-type object-datum
+       (make-primitive-procedure 'PRIMITIVE-OBJECT-TYPE)
        ;;bit-string-length
        (make-primitive-procedure 'PRIMITIVE-OBJECT-SET-TYPE)
        fix:-1+ fix:1+ fix:+ fix:- fix:*
@@ -1072,7 +1076,9 @@ MIT in each case. |#
        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:acos flo:atan flo:atan2 flo:expt
+       (make-primitive-procedure 'FLONUM-NORMALIZE)
+       (make-primitive-procedure 'FLONUM-DENORMALIZE)))
 
 (for-each
  (lambda (simple-operator)
@@ -1087,6 +1093,10 @@ MIT in each case. |#
        ;;string-length vector-8b-ref
        system-pair-car system-pair-cdr
        system-hunk3-cxr0 system-hunk3-cxr1 system-hunk3-cxr2
+       (make-primitive-procedure 'SYSTEM-VECTOR-SIZE)
+       system-vector-ref
+       (make-primitive-procedure 'SYSTEM-VECTOR-SIZE)
+       (make-primitive-procedure 'GET-INTERRUPT-ENABLES)
        (make-primitive-procedure 'PRIMITIVE-GET-FREE)
        (make-primitive-procedure 'PRIMITIVE-OBJECT-REF)))
 
@@ -1105,6 +1115,7 @@ MIT in each case. |#
      operator
      (list '(SIMPLE) '(UNSPECIFIC-RESULT))))
  (list set-cell-contents!
+       set-string-length!
        ;;set-car! set-cdr! %record-set!
        ;;vector-set!
        ;;string-set! vector-8b-set! flo:vector-set!
diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm
index c7cd56f8e..1975bdd87 100644
--- a/v8/src/compiler/midend/rtlgen.scm
+++ b/v8/src/compiler/midend/rtlgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rtlgen.scm,v 1.42 1996/03/08 15:57:43 adams Exp $
+$Id: rtlgen.scm,v 1.43 1996/03/08 17:15:38 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -3169,8 +3169,9 @@ MIT in each case. |#
 		       (rtlgen/branch/false state)))))))))
   (define-simple-tag-test 'CELL?       (machine-tag 'CELL))
   (define-simple-tag-test 'PAIR?       (machine-tag 'PAIR))
-  (define-simple-tag-test 'VECTOR?     (machine-tag 'VECTOR))
-  (define-simple-tag-test '%RECORD?    (machine-tag 'RECORD))
+  ;; These two are not primitives (yet)
+  ;;(define-simple-tag-test 'VECTOR?     (machine-tag 'VECTOR))
+  ;;(define-simple-tag-test '%RECORD?    (machine-tag 'RECORD))
   (define-simple-tag-test 'STRING?     (machine-tag 'STRING))
   (define-simple-tag-test 'BIT-STRING? (machine-tag 'VECTOR-1B))
   (define-simple-tag-test 'FLONUM?     (machine-tag 'FLONUM))
@@ -3462,6 +3463,7 @@ MIT in each case. |#
 	  result)))))
 
 (define-open-coder/value 'FLOATING-VECTOR-CONS 1
+  ;; (flo:vector-cons <small-known-integer>)
   (let ((fv-tag  (machine-tag 'FLOATING-POINT-VECTOR))
 	(nmv-tag (machine-tag 'MANIFEST-NM-VECTOR)))
     (lambda (state rands open-coder)
@@ -3498,7 +3500,7 @@ MIT in each case. |#
 			    len))
 	(rtlgen/cons state
 		     (cons `(CONSTANT ,len) (make-list len fill))
-		     vector-tag)))))
+		     `(MACHINE-CONSTANT ,vector-tag))))))
 
 ;; *** STRING-ALLOCATE, FLOATING-VECTOR-CONS, and perhaps VECTOR-CONS
 ;; should always be in-lined, even when the length argument is not known.
-- 
2.25.1