From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Thu, 3 Sep 1987 05:17:16 +0000 (+0000)
Subject: Add a few special utilities for generic arithmetic.
X-Git-Tag: 20090517-FFI~13096
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b8f278f87fe82b0d32f408a28edd65dfa8985940;p=mit-scheme.git

Add a few special utilities for generic arithmetic.
---

diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm
index 86395cc06..2f3a67cac 100644
--- a/v7/src/compiler/machines/bobcat/decls.scm
+++ b/v7/src/compiler/machines/bobcat/decls.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.23 1987/08/23 03:34:41 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.24 1987/09/03 05:17:16 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -90,7 +90,8 @@ MIT in each case. |#
 			   "ralloc" "rcseep" "rdeath" "rdebug" "rgcomb"
 			   "rgpcom" "rgpred" "rgproc" "rgrval" "rgstmt" "rlife"
 			   "rtlgen")
-	  (filename/append "back-end" "lapgn1" "lapgn2" "lapgn3")))
+	  (filename/append "back-end" "lapgn1" "lapgn2" "lapgn3")
+	  (filename/append "machines/bobcat" "rgspcm")))
 
 (define filenames/dependency-chain/bits
   (filename/append "back-end" "symtab" "bitutl" "bittop"))
diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm
index 2c83cf0e4..03c906374 100644
--- a/v7/src/compiler/machines/bobcat/lapgen.scm
+++ b/v7/src/compiler/machines/bobcat/lapgen.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.188 1987/07/30 21:44:13 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.189 1987/09/03 05:14:16 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -280,7 +280,7 @@ MIT in each case. |#
     assignment-trap)
   (define-entries #x0228 uuo-link uuo-link-trap cache-reference-apply
     safe-reference-trap unassigned?-trap cache-variable-multiple
-    uuo-link-multiple))
+    uuo-link-multiple &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative?))
 
 (define-integrable reg:compiled-memtop (INST-EA (@A 6)))
 (define-integrable reg:environment (INST-EA (@AO 6 #x000C)))
diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index f82de3a3f..af0bd0603 100644
--- a/v7/src/compiler/machines/bobcat/make.scm-68040
+++ b/v7/src/compiler/machines/bobcat/make.scm-68040
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.42 1987/08/07 17:13:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.43 1987/09/03 05:13:32 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -46,11 +46,11 @@ MIT in each case. |#
     (make-environment
       (define :name "Liar (Bobcat 68020)")
       (define :version 3)
-      (define :modification 0)
+      (define :modification 1)
       (define :files)
 
 ;      (parse-rcs-header
-;       "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.42 1987/08/07 17:13:18 cph Exp $"
+;       "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.43 1987/09/03 05:13:32 jinx Exp $"
 ;       (lambda (filename version date time zone author state)
 ;	 (set! :version (car version))
 ;	 (set! :modification (cadr version))))
@@ -129,6 +129,7 @@ MIT in each case. |#
 		 "front-end/rgrval.bin"	;RTL generator: RValues
 		 "front-end/rgcomb.bin"	;RTL generator: Combinations
 		 "front-end/rgpcom.bin"	;RTL generator: Primitive open-coding
+		 "machines/bobcat/rgspcm.bin" ;RTL generator: primitives treated specially.
 		 ))
 
 	 (cons rtl-cse-package
diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm
index 10cfe98a8..b68c3015a 100644
--- a/v7/src/compiler/machines/bobcat/rules3.scm
+++ b/v7/src/compiler/machines/bobcat/rules3.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.13 1987/07/30 21:44:51 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.14 1987/09/03 05:14:52 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -125,6 +125,33 @@ MIT in each case. |#
 	(AND L (D 7) (D 1))
 	(MOV L (D 1) (A 0))
 	(JMP (@A 0)))))
+
+(let-syntax
+    ((define-special-primitive-invocation
+       (macro (name)
+	 `(define-rule statement
+	    (INVOCATION:SPECIAL-PRIMITIVE ,name (? frame-size)
+					  (? prefix) (? continuation))
+	    (disable-frame-pointer-offset!
+	     ,(list 'LAP
+		    (list 'UNQUOTE-SPLICING
+			  '(generate-invocation-prefix prefix '()))
+		    (list 'JMP
+			  (list 'UNQUOTE
+				(symbol-append 'ENTRY:COMPILER- name)))))))))
+
+  (define-special-primitive-invocation &+)
+  (define-special-primitive-invocation &-)
+  (define-special-primitive-invocation &*)
+  (define-special-primitive-invocation &/)
+  (define-special-primitive-invocation &=)
+  (define-special-primitive-invocation &<)
+  (define-special-primitive-invocation &>)
+  (define-special-primitive-invocation 1+)
+  (define-special-primitive-invocation -1+)
+  (define-special-primitive-invocation zero?)
+  (define-special-primitive-invocation positive?)
+  (define-special-primitive-invocation negative?))
 
 (define-rule statement
   (RETURN)
diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm
index ab1d1fbc1..356be32af 100644
--- a/v7/src/compiler/rtlbase/rtlcon.scm
+++ b/v7/src/compiler/rtlbase/rtlcon.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 1.12 1987/07/31 00:51:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 1.13 1987/09/03 05:15:47 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -178,6 +178,12 @@ MIT in each case. |#
    frame-size prefix (and continuation (continuation-label continuation))
    procedure))
 
+(define (rtl:make-invocation:special-primitive name frame-size
+					       prefix continuation)
+  (%make-invocation:special-primitive
+   name frame-size prefix
+   (and continuation (continuation-label continuation))))
+
 (define (rtl:make-invocation:uuo-link frame-size prefix continuation name)
   (%make-invocation:uuo-link
    frame-size prefix (and continuation (continuation-label continuation))
diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm
index 53cd687b0..d98d6099e 100644
--- a/v7/src/compiler/rtlbase/rtlexp.scm
+++ b/v7/src/compiler/rtlbase/rtlexp.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 1.2 1987/05/28 17:58:38 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 1.3 1987/09/03 05:16:17 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -42,7 +42,9 @@ MIT in each case. |#
 	  INVOCATION:JUMP
 	  INVOCATION:LEXPR
 	  INVOCATION:LOOKUP
-	  INVOCATION:PRIMITIVE)))
+	  INVOCATION:PRIMITIVE
+	  INVOCATION:SPECIAL-PRIMITIVE
+	  INVOCATION:UUO-LINK)))
 
 (define (rtl:machine-register-expression? expression)
   (and (rtl:register? expression)
diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm
index 13fb9d96d..b7275de88 100644
--- a/v7/src/compiler/rtlbase/rtlty1.scm
+++ b/v7/src/compiler/rtlbase/rtlty1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.12 1987/07/03 18:56:20 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.13 1987/09/03 05:15:29 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -83,6 +83,8 @@ MIT in each case. |#
   environment name)
 (define-rtl-statement invocation:primitive % pushed prefix continuation
   procedure)
+(define-rtl-statement invocation:special-primitive % name pushed prefix
+  continuation)
 (define-rtl-statement invocation:uuo-link % pushed prefix continuation name)
 
 (define-rtl-statement message-sender:value rtl: size)
diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm
index 9d9a2a2c7..af9172d12 100644
--- a/v7/src/compiler/rtlgen/rgcomb.scm
+++ b/v7/src/compiler/rtlgen/rgcomb.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.33 1987/08/07 17:08:10 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.34 1987/09/03 05:10:05 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -57,7 +57,7 @@ MIT in each case. |#
 		     (normal-primitive-constant? callee)
 		     (let ((open-coder
 			    (assq (constant-value callee)
-				  primitive-open-coders)))
+				  (cdr primitive-open-coders))))
 		       (and open-coder
 			    ((cdr open-coder) combination
 					      subproblem?
@@ -138,22 +138,26 @@ MIT in each case. |#
 	      (else
 	       (error "Unknown combination value" value)))))))
 
-(define (define-open-coder primitive open-coder)
-  (let ((kernel
-	 (lambda (primitive)
-	   (let ((entry (assq primitive primitive-open-coders)))
-	     (if entry
-		 (set-cdr! entry open-coder)
-		 (set! primitive-open-coders
-		       (cons (cons primitive open-coder)
-			     primitive-open-coders)))))))
-    (if (pair? primitive)
-	(for-each kernel primitive)
-	(kernel primitive)))
-  primitive)
+(define (define-primitive-handler data-base)
+  (lambda (primitive handler)
+    (let ((kernel
+	   (lambda (primitive)
+	     (let ((entry (assq primitive (cdr data-base))))
+	       (if entry
+		   (set-cdr! entry handler)
+		   (set-cdr! data-base
+			     (cons (cons primitive handler)
+				   (cdr data-base))))))))
+      (if (pair? primitive)
+	  (for-each kernel primitive)
+	  (kernel primitive)))
+    primitive))
 
 (define primitive-open-coders
-  '())
+  (list 'PRIMITIVE-OPEN-CODERS))
+
+(define define-open-coder
+  (define-primitive-handler primitive-open-coders))
 
 (define (combination/subproblem combination operator operands)
   (let ((block (combination-block combination)))
@@ -274,12 +278,22 @@ MIT in each case. |#
 
 (define (make-call/primitive combination operator operands prefix continuation)
   (make-call false combination operator operands
-    (lambda (number-pushed)
-      (rtl:make-invocation:primitive
-       (1+ number-pushed)
-       (prefix combination number-pushed)
-       continuation
-       (constant-value (combination-known-operator combination))))))
+   (let* ((prim (constant-value (combination-known-operator combination)))
+	  (special-handler (assq prim (cdr special-primitive-handlers))))
+     (if special-handler
+	 ((cdr special-handler) combination prefix continuation)
+	 (lambda (number-pushed)
+	   (rtl:make-invocation:primitive
+	    (1+ number-pushed)
+	    (prefix combination number-pushed)
+	    continuation
+	    prim))))))
+
+(define special-primitive-handlers
+  (list 'SPECIAL-PRIMITIVE-HANDLERS))
+
+(define define-special-primitive-handler
+  (define-primitive-handler special-primitive-handlers))
 
 (define (make-call/reference combination operator operands prefix continuation)
   (make-call false combination operator operands
diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm
index 89efbb150..b96aefb87 100644
--- a/v7/src/compiler/rtlopt/rcse1.scm
+++ b/v7/src/compiler/rtlopt/rcse1.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.113 1987/08/07 17:07:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.114 1987/09/03 05:12:54 jinx Exp $
 
 Copyright (c) 1987 Massachusetts Institute of Technology
 
@@ -226,6 +226,7 @@ MIT in each case. |#
 (define-cse-method 'INVOCATION:JUMP method/noop)
 (define-cse-method 'INVOCATION:LEXPR method/noop)
 (define-cse-method 'INVOCATION:PRIMITIVE method/noop)
+(define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/noop)
 (define-cse-method 'INVOCATION:UUO-LINK method/noop)
 
 (define (method/invalidate-stack statement)