Added %compiled-entry? and %compiled-entry-maximum-arity?

diff --git a/v8/src/compiler/midend/fakeprim.scm b/v8/src/compiler/midend/fakeprim.scm
index 533b11b3f5adb47c047a8f1b9f45fde76594336f..f1ce7c9bb8455bbe267caaed348e260f66de9e34 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.7 1995/03/09 22:15:14 adams Exp $
+$Id: fakeprim.scm,v 1.8 1995/03/13 23:23:45 adams Exp $
 
 Copyright (c) 1994 Massachusetts Institute of Technology
 
@@ -738,6 +738,16 @@ MIT in each case. |#
 
 (cookie-call %small-fixnum? '#F value 'precision-bits)
 
+(define %compiled-entry?
+  (make-operator/simple "#[compiled-entry?]"  '(PROPER-PREDICATE)))
+
+(define %compiled-entry-maximum-arity?
+  ;; (call ',%compiled-entry-maximum-arity? '#F 'count value)
+  ;;  Tests if the compiled entry has the specified maximum arity.
+  (make-operator/simple "#[compiled-entry-maximum-arity?]"
+                       '(PROPER-PREDICATE)))
+
+(cookie-call %compiled-entry-maximum-arity? '#F 'n entry)
 
 (define %profile-data
   ;; (CALL ',%profile-data '#F '<data>)
@@ -905,6 +915,18 @@ MIT in each case. |#
                          '(SIDE-EFFECT-INSENSITIVE)
                          '(OUT-OF-LINE-HOOK))))
  '(&+ &- &* &/ quotient remainder))
+
+(for-each
+    (lambda (prim-name)
+      (let ((prim  (make-primitive-procedure prim-name)))
+       (set! compiler:primitives-with-no-open-coding
+             (cons prim-name compiler:primitives-with-no-open-coding))
+       (hash-table/put! *operator-properties*
+                        prim
+                        (list ;;'(SIMPLE)
+                              '(SIDE-EFFECT-FREE)
+                              '(SIDE-EFFECT-INSENSITIVE)))))
+  '(COERCE-TO-COMPILED-PROCEDURE))
 \f
 ;;;; Compatibility operators
 

diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm
index 87bd961a28a3a647c651aa90cbdf5dad81dcedb5..2f40ef836184837b4942d6ec54022805b844d1ee 100644 (file)
--- a/v8/src/compiler/midend/rtlgen.scm
+++ b/v8/src/compiler/midend/rtlgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rtlgen.scm,v 1.16 1995/03/13 06:59:28 adams Exp $
+$Id: rtlgen.scm,v 1.17 1995/03/13 23:25:49 adams Exp $
 
 Copyright (c) 1994 Massachusetts Institute of Technology
 
@@ -3051,7 +3051,8 @@ MIT in each case. |#
   (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)))
+  (define-simple-tag-test 'FLONUM?     (machine-tag 'FLONUM))
+  (define-simple-tag-test %compiled-entry? (machine-tag 'COMPILED-ENTRY)))
 \f
 (define-open-coder/pred 'EQ? 2
   (lambda (state rands open-coder)
@@ -3102,6 +3103,18 @@ MIT in each case. |#
               (rtlgen/assign! tag** `(OBJECT->DATUM ,tag*))
               (rtlgen/branch/likely state `(EQ-TEST ,obj* ,tag**))))))))
 
+
+(define-open-coder/pred %compiled-entry-maximum-arity?
+  (lambda (state rands open-coder)
+    open-coder
+    (let* ((arity  (rtlgen/->register (first rands)))
+          (obj    (rtlgen/->register (second rands)))
+          (obj*   (rtlgen/new-reg))
+          (arity* (rtlgen/new-reg)))
+      (rtlgen/assign! obj* `(OBJECT->ADDRESS ,obj))
+      (rtlgen/assign! arity* `(BYTE-OFFSET ,obj* (MACHINE-CONSTANT -3)))
+      (rtlgen/branch/likely state `(EQ-TEST ,arity* ,arity)))))
+
 (define-integrable (rtlgen/constant? syllable)
   (and (pair? syllable)
        (eq? (car syllable) 'CONSTANT)))