From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 13 Jan 1993 00:18:46 +0000 (+0000)
Subject: Implement calls to SET-INTERRUPT-ENABLES! by jumping to
X-Git-Tag: 20090517-FFI~8589
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=38f68476dfbef6b20a137ce6dee216e2f9e20e71;p=mit-scheme.git

Implement calls to SET-INTERRUPT-ENABLES! by jumping to
assembly-language hook in compiled code interface.
---

diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index e2a7bab47..5f3a99b9f 100644
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: lapgen.scm,v 4.46 1992/09/25 01:18:08 cph Exp $
+$Id: lapgen.scm,v 4.47 1993/01/13 00:18:46 cph Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -1144,17 +1144,17 @@ MIT in each case. |#
     stack-and-interrupt-check-18 ; This doesn't have a code: counterpart.
     stack-and-interrupt-check-22 ; This doesn't have a code: counterpart.
     stack-and-interrupt-check-24 ; This doesn't have a code: counterpart.
+    set-interrupt-enables	; This doesn't have a code: counterpart.
     ))
 
 (define-integrable (invoke-interface code)
   (LAP (MOVEQ (& ,code) (D 0))
        (JMP ,entry:compiler-scheme-to-interface)))
 
-#|
 ;; If the entry point scheme-to-interface-jsr were not available,
 ;; this code should replace the definition below.
 ;; The others can be handled similarly.
-
+#|
 (define-integrable (invoke-interface-jsr code)
   (LAP (MOVEQ (& ,code) (D 0))
        (LEA (@PCO 12) (A 0))
diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm
index d4f45874f..a61bc7dd8 100644
--- a/v7/src/compiler/machines/bobcat/rules3.scm
+++ b/v7/src/compiler/machines/bobcat/rules3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: rules3.scm,v 4.36 1992/09/30 21:06:02 cph Exp $
+$Id: rules3.scm,v 4.37 1993/01/13 00:18:40 cph Exp $
 
-Copyright (c) 1988-92 Massachusetts Institute of Technology
+Copyright (c) 1988-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -153,23 +153,26 @@ MIT in each case. |#
   (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive))
   continuation
   (LAP ,@(clear-map!)
-       ,@(if (eq? primitive compiled-error-procedure)
-	     (LAP ,@(load-dnl frame-size 1)
-		  (JMP ,entry:compiler-error))
-	     (let ((arity (primitive-procedure-arity primitive)))
-	       (cond ((not (negative? arity))
-		      (LAP (MOV L (@PCR ,(constant->label primitive)) (D 1))
-			   (JMP ,entry:compiler-primitive-apply)))
-		     ((= arity -1)
-		      (LAP (MOV L (& ,(-1+ frame-size))
-				,reg:lexpr-primitive-arity)
-			   (MOV L (@PCR ,(constant->label primitive)) (D 1))
-			   (JMP ,entry:compiler-primitive-lexpr-apply)))
-		     (else
-		      ;; Unknown primitive arity.  Go through apply.
-		      (LAP ,@(load-dnl frame-size 2)
-			   (MOV L (@PCR ,(constant->label primitive)) (D 1))
-			   ,@(invoke-interface code:compiler-apply))))))))
+       ,@(cond ((eq? primitive compiled-error-procedure)
+		(LAP ,@(load-dnl frame-size 1)
+		     (JMP ,entry:compiler-error)))
+	       ((eq? primitive (ucode-primitive set-interrupt-enables! 1))
+		(LAP (JMP ,entry:set-interrupt-enables)))
+	       (else
+		(let ((arity (primitive-procedure-arity primitive)))
+		  (cond ((not (negative? arity))
+			 (LAP (MOV L (@PCR ,(constant->label primitive)) (D 1))
+			      (JMP ,entry:compiler-primitive-apply)))
+			((= arity -1)
+			 (LAP (MOV L (& ,(-1+ frame-size))
+				   ,reg:lexpr-primitive-arity)
+			      (MOV L (@PCR ,(constant->label primitive)) (D 1))
+			      (JMP ,entry:compiler-primitive-lexpr-apply)))
+			(else
+			 ;; Unknown primitive arity.  Go through apply.
+			 (LAP ,@(load-dnl frame-size 2)
+			      (MOV L (@PCR ,(constant->label primitive)) (D 1))
+			      ,@(invoke-interface code:compiler-apply)))))))))
 
 (let-syntax
     ((define-special-primitive-invocation