- Move interrupt test on continuation invocation to return point (from

  continuation entry point).

- Share return sequences in a single compiled code block.

- Share closure interrupt code.

diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm
index 712a6675082599691e8db7c0c67a5eff9f1bab59..9dab19a60b01065267d22982ced3b36e1dd67359 100644 (file)
--- a/v7/src/compiler/back/lapgn1.scm
+++ b/v7/src/compiler/back/lapgn1.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: lapgn1.scm,v 4.14 1992/12/30 14:13:35 gjr Exp $
+$Id: lapgn1.scm,v 4.15 1993/08/26 05:47:34 gjr Exp $
 
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -279,4 +279,44 @@ MIT in each case. |#
             (assq (rtl:expression-type (rtl:assign-address rtl))
                   *assign-rules*)))
        (or (and rules (pattern-lookup (cdr rules) rtl))
-           (pattern-lookup *assign-variable-rules* rtl)))))
\ No newline at end of file
+           (pattern-lookup *assign-variable-rules* rtl)))))
+\f
+;;; Instruction sequence sharing mechanisms
+
+(define *block-associations*)
+
+(define (block-association token)
+  (let ((place (assq token *block-associations*)))
+    (and place (cdr place))))
+
+(define (block-associate! token frob)
+  (set! *block-associations*
+       (cons (cons token frob)
+             *block-associations*))
+  unspecific)
+
+;; This can only be used when the instruction sequences are bit-wise identical.
+;; In other words, no variable registers, constants, etc.
+
+(define (share-instruction-sequence! name if-shared generator)
+  (cond ((block-association name)
+        => if-shared)
+       (else
+        (let ((label (generate-label name)))
+          (block-associate! name label)
+          (generator label)))))
+
+(define (make-new-sblock instructions)
+  (let ((bblock (make-sblock instructions)))
+    (node-mark! bblock)
+    bblock))
+
+(define (current-bblock-continue! bblock)
+  (let ((current-bblock *current-bblock*))
+    (if (sblock-continuation current-bblock)
+       (error "current-bblock-continue! bblock already has a continuation"
+              current-bblock)
+       (begin
+         (create-edge! current-bblock set-snode-next-edge! bblock)
+         (set-bblock-continuations! current-bblock (list bblock))
+         (set-sblock-continuation! current-bblock bblock)))))
\ No newline at end of file

diff --git a/v7/src/compiler/base/asstop.scm b/v7/src/compiler/base/asstop.scm
index 54d29a1d6c64e4f199a1fe735f3639d6dfc0a7f3..4fcc2d4d7586eb50b28166b2660d08ccc59ce4c5 100644 (file)
--- a/v7/src/compiler/base/asstop.scm
+++ b/v7/src/compiler/base/asstop.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: asstop.scm,v 1.4 1993/08/22 20:23:22 gjr Exp $
+$Id: asstop.scm,v 1.5 1993/08/26 05:48:53 gjr Exp $
 
 Copyright (c) 1988-1993 Massachusetts Institute of Technology
 
@@ -88,6 +88,7 @@ MIT in each case. |#
   (fluid-let ((*block-label*)
              (*external-labels*)
              (*end-of-block-code*)
+             (*block-associations*)
              (*next-constant*)
              (*interned-constants*)
              (*interned-variables*)
@@ -103,6 +104,7 @@ MIT in each case. |#
 
 (define (assembler&linker-reset!)
   (set! *recursive-compilation-results* '())
+  (set! *block-associations*)
   (set! *block-label*)
   (set! *external-labels*)
   (set! *end-of-block-code*)
@@ -120,6 +122,7 @@ MIT in each case. |#
   unspecific)
 
 (define (initialize-back-end!)
+  (set! *block-associations* '())
   (set! *block-label* (generate-label))
   (set! *external-labels* '())
   (set! *end-of-block-code* (LAP))

diff --git a/v7/src/compiler/machines/i386/compiler.pkg b/v7/src/compiler/machines/i386/compiler.pkg
index c66dceac2ecb1a7f5bd36492e7269a501840452f..824b2ab28988f7037616b8184dea2ac81d541286 100644 (file)
--- a/v7/src/compiler/machines/i386/compiler.pkg
+++ b/v7/src/compiler/machines/i386/compiler.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: compiler.pkg,v 1.17 1993/08/11 23:36:59 cph Exp $
+$Id: compiler.pkg,v 1.18 1993/08/26 05:46:36 gjr Exp $
 
 Copyright (c) 1992-1993 Massachusetts Institute of Technology
 
@@ -612,6 +612,7 @@ MIT in each case. |#
          lap:make-unconditional-branch
          lap:syntax-instruction)
   (export (compiler top-level)
+         *block-associations*
          *interned-assignments*
          *interned-constants*
          *interned-global-links*

diff --git a/v7/src/compiler/machines/i386/rules3.scm b/v7/src/compiler/machines/i386/rules3.scm
index aee3be0c8b37b24729ce4735f735dffbbbf5b416..0bbffe7bb7b530914f078e095b64d626d5df4130 100644 (file)
--- a/v7/src/compiler/machines/i386/rules3.scm
+++ b/v7/src/compiler/machines/i386/rules3.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: rules3.scm,v 1.26 1993/07/16 19:27:55 gjr Exp $
+$Id: rules3.scm,v 1.27 1993/08/26 05:45:40 gjr Exp $
 
 Copyright (c) 1992-1993 Massachusetts Institute of Technology
 
@@ -44,9 +44,22 @@ MIT in each case. |#
 
 (define-rule statement
   (POP-RETURN)
-  (LAP ,@(clear-map!)
-       ,@(clear-continuation-type-code)
-       (RET)))
+  (cond ((block-association 'POP-RETURN)
+        => current-bblock-continue!)
+       (else
+        (let ((bblock
+               (make-new-sblock
+                (let ((interrupt-label (generate-label 'INTERRUPT)))
+                  (LAP (CMP W (R ,regnum:free-pointer) ,reg:compiled-memtop)
+                       (JGE (@PCR ,interrupt-label))
+                       ,@(clear-continuation-type-code)
+                       (RET)
+                       (LABEL ,interrupt-label)
+                       ,@(invoke-hook
+                          entry:compiler-interrupt-continuation-2))))))
+          (block-associate! 'POP-RETURN bblock)
+          (current-bblock-continue! bblock))))
+  (clear-map!))
 
 (define-rule statement
   (INVOCATION:APPLY (? frame-size) (? continuation))
@@ -412,9 +425,13 @@ MIT in each case. |#
 
 (define-rule statement
   (CONTINUATION-HEADER (? internal-label))
+  #|
   (simple-procedure-header (continuation-code-word internal-label)
                           internal-label
-                          entry:compiler-interrupt-continuation))
+                          entry:compiler-interrupt-continuation)
+  |#
+  (make-external-label (continuation-code-word internal-label)
+                      internal-label))
 
 (define-rule statement
   (IC-PROCEDURE-HEADER (? internal-label))
@@ -523,28 +540,47 @@ MIT in each case. |#
                                                  0)))
             (MOV W (@RO B ,regnum:free-pointer -4) ,temp))))))
 \f
+(define closure-share-names
+  '#(
+     closure-0-interrupt closure-1-interrupt closure-2-interrupt closure-3-interrupt
+     closure-4-interrupt closure-5-interrupt closure-6-interrupt closure-7-interrupt
+     ))
+
 (define (generate/closure-header internal-label nentries entry)
   nentries                             ; ignored
-  (let ((rtl-proc (label->object internal-label)))
-    (let ((gc-label (generate-label))
-         (external-label (rtl-procedure/external-label rtl-proc)))
-      (if (zero? nentries)
-         (LAP (EQUATE ,external-label ,internal-label)
-              ,@(simple-procedure-header
-                 (internal-procedure-code-word rtl-proc)
-                 internal-label
-                 entry:compiler-interrupt-procedure))
-         (LAP (LABEL ,gc-label)
-              ,@(if (zero? entry)
-                    (LAP)
-                    (LAP (ADD W (@R ,esp) (& ,(* 10 entry)))))
-              ,@(invoke-hook entry:compiler-interrupt-closure)
-              ,@(make-external-label internal-entry-code-word
-                                     external-label)
-              (ADD W (@R ,esp)
-                   (&U ,(generate/make-magic-closure-constant entry)))
-              (LABEL ,internal-label)
-              ,@(interrupt-check internal-label gc-label))))))
+  (let* ((rtl-proc (label->object internal-label))
+        (external-label (rtl-procedure/external-label rtl-proc)))
+    (if (zero? nentries)
+       (LAP (EQUATE ,external-label ,internal-label)
+            ,@(simple-procedure-header
+               (internal-procedure-code-word rtl-proc)
+               internal-label
+               entry:compiler-interrupt-procedure))
+       (let ((prefix
+              (lambda (gc-label)
+                (LAP (LABEL ,gc-label)
+                     ,@(if (zero? entry)
+                           (LAP)
+                           (LAP (ADD W (@R ,esp) (& ,(* 10 entry)))))
+                     ,@(invoke-hook entry:compiler-interrupt-closure))))
+             (suffix
+              (lambda (gc-label)
+                (LAP ,@(make-external-label internal-entry-code-word
+                                            external-label)
+                     (ADD W (@R ,esp)
+                          (&U ,(generate/make-magic-closure-constant entry)))
+                     (LABEL ,internal-label)
+                     ,@(interrupt-check internal-label gc-label)))))
+         (if (>= entry (vector-length closure-share-names))
+             (let ((gc-label (generate-label)))
+               (LAP ,@(prefix gc-label)
+                    ,@(suffix gc-label)))
+             (share-instruction-sequence!
+              (vector-ref closure-share-names entry)
+              suffix
+              (lambda (gc-label)
+                (LAP ,@(prefix gc-label)
+                     ,@(suffix gc-label)))))))))
 
 (define (generate/make-magic-closure-constant entry)
   (- (make-non-pointer-literal (ucode-type compiled-entry) 0)