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 86395cc0634a380d18ab3cd946d910bade31794b..2f3a67cac90fd061e183ea68df778c63ef67c0cd 100644 (file)
--- 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 2c83cf0e483c17c39ec1b7cff496f0448c8d7ecf..03c906374a2f431b6af11c940801ae2b56928ed9 100644 (file)
--- 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 f82de3a3f1538e8ecd20fc5f17192cc39b7d5f83..af0bd0603e0d3ae8b9571b09123e5f6bb2621aa7 100644 (file)
--- 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 10cfe98a87941c8811d094aa1f42c8a67842f7cf..b68c3015a9235ec7401ffd7a06d2783c62ee779e 100644 (file)
--- 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)))))
+\f
+(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 ab1d1fbc136949bd2c20476ed10f7617f598cf8e..356be32af547fae39463c10c3c28b7afee388d32 100644 (file)
--- 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 53cd687b0057163d84fa26d075afdb1df5a26389..d98d6099eac957d4e5deae6e3e93b47483b46044 100644 (file)
--- 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 13fb9d96d6538f45613549275280a95d9013ce89..b7275de880ff246ab7a608584753b52a7763745a 100644 (file)
--- 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 9d9a2a2c7506932db6a7539ff4d39f40096be1c1..af9172d129912a553abb58fc9fc0abe0a4332976 100644 (file)
--- 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))
 \f
 (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))
 \f
 (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 89efbb150812a0b5b7101b3dcbdf5cb5aa4c3763..b96aefb87cd1d8af95d2b37a9420d759d397488e 100644 (file)
--- 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)