From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Fri, 26 Jul 1996 23:43:03 +0000 (+0000)
Subject: Avoid interrupt checks due solely to tailing into an ordinary
X-Git-Tag: 20090517-FFI~5420
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=23389576080badc1146e031f6f46c2a45804ce0d;p=mit-scheme.git

Avoid interrupt checks due solely to tailing into an ordinary
(i.e. not apply-like) primitive.
---

diff --git a/v8/src/compiler/midend/rtlgen.scm b/v8/src/compiler/midend/rtlgen.scm
index 19fcd59f7..f5df969b5 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.48 1996/07/22 16:24:01 adams Exp $
+$Id: rtlgen.scm,v 1.49 1996/07/26 23:43:03 adams Exp $
 
 Copyright (c) 1994-96 Massachusetts Institute of Technology
 
@@ -245,22 +245,27 @@ MIT in each case. |#
 
 (define (rtlgen/wrap-trivial-closure label dbg-form body lambda-list saved-size)
   saved-size				; only continuations have this
-  (let ((frame-size (lambda-list/count-names lambda-list)))
-    (cons `(TRIVIAL-CLOSURE ,label
-			    ,(new-dbg-procedure->old-dbg-procedure
-			      label
-			      'TRIVIAL-CLOSURE
-			      (rtlgen/debugging-info dbg-form))
-			    ,@(map
-			       (lambda (value)
-				 `(MACHINE-CONSTANT ,value))
-			       (lambda-list/arity-info lambda-list)))
-	  (rtlgen/wrap-with-interrupt-check/procedure
-	   true
-	   body
-	   `(INTERRUPT-CHECK:PROCEDURE
-	     ,label
-	     (MACHINE-CONSTANT ,frame-size))))))
+  (let ((frame-size (lambda-list/count-names lambda-list))
+	(procedure-header
+	 `(TRIVIAL-CLOSURE ,label
+			   ,(new-dbg-procedure->old-dbg-procedure
+			     label
+			     'TRIVIAL-CLOSURE
+			     (rtlgen/debugging-info dbg-form))
+			   ,@(map
+			      (lambda (value)
+				`(MACHINE-CONSTANT ,value))
+			      (lambda-list/arity-info lambda-list)))))
+    (if (rtlgen/omit-interrupt-check? label)
+	(cons procedure-header
+	      body)
+	(cons procedure-header
+	      (rtlgen/wrap-with-interrupt-check/procedure
+	       true
+	       body
+	       `(INTERRUPT-CHECK:PROCEDURE
+		 ,label
+		 (MACHINE-CONSTANT ,frame-size)))))))
 
 (define (rtlgen/wrap-procedure label dbg-form body lambda-list saved-size)
   saved-size				; only continuations have this
@@ -616,10 +621,20 @@ MIT in each case. |#
 
 (define (rtlgen/wrap-with-interrupt-check/procedure external? body desc)
   external?				;ignored
+
+  #|
+  (pp `((desc , desc)
+	(external? , external?)
+	(*rtlgen/form-calls-external?* , *rtlgen/form-calls-external?*)
+	(*rtlgen/form-calls-internal?* , *rtlgen/form-calls-internal?*)
+	(*rtlgen/words-allocated* , *rtlgen/words-allocated*)
+	(*rtlgen/max-stack-depth* , *rtlgen/max-stack-depth*)))
+  |#
+
   (rtlgen/wrap-with-intrpt-check
    ;;  This change is required since the internal procedures are being
    ;;  compiled as external procedures (trivial closures) at the
-   ;;  moment (this so that they can share entry points).
+   ;;  moment (this so that they can share entry points).  Old code:
    ;;(and (rtlgen/generate-interrupt-checks?)
    ;;	(or *rtlgen/form-calls-external?*
    ;;	    (and (not external?)
@@ -1767,7 +1782,8 @@ MIT in each case. |#
 				       (cddr rands))) ; exprs
 	((eq? rator* %primitive-apply/compatible)
 	 (verify-rands 2)		; arity, primitive
-	 (set! *rtlgen/form-calls-external?* true)
+	 (if (rtlgen/primitive-is-apply-like? (second rands))
+	     (set! *rtlgen/form-calls-external?* true))
 	 (rtlgen/invoke-primitive/compatible state
 					     (first rands)  ; nargs
 					     (second rands) ; prim
@@ -4458,6 +4474,17 @@ MIT in each case. |#
 
 ;; Kludges
 
+(define rtlgen/primitive-is-apply-like?
+  (let ((apply-like-primitives
+	 (map make-primitive-procedure
+	      '(apply
+		within-control-point scode-eval force
+		execute-at-new-state-point return-to-application
+		with-stack-marker with-interrupt-mask
+		with-interrupts-reduced with-history-disabled))))
+    (lambda (primitive)
+      (memq primitive apply-like-primitives))))
+
 (define *rtlgen/omit-internal-interrupt-checks?* #T)
 
 (define (rtlgen/omit-interrupt-check? procedure-name)