From b1f38021a9475d7f87550d3b0994e18601a646e9 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Mon, 13 Mar 1995 23:25:49 +0000
Subject: [PATCH] Added %compiled-entry? and %compiled-entry-maximum-arity?

---
 v8/src/compiler/midend/fakeprim.scm | 24 +++++++++++++++++++++++-
 v8/src/compiler/midend/rtlgen.scm   | 17 +++++++++++++++--
 2 files changed, 38 insertions(+), 3 deletions(-)

diff --git a/v8/src/compiler/midend/fakeprim.scm b/v8/src/compiler/midend/fakeprim.scm
index 533b11b3f..f1ce7c9bb 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.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))
 
 ;;;; Compatibility operators
 
diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm
index 87bd961a2..2f40ef836 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.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)))
 
 (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)))
-- 
2.25.1