Fix two bugs in multiclosure code:

- non-canonical multi-closure entries appearing in letrecs were
computed incorrectly.  The context offset is not the context after
binding since the code has not finished pushing.

- referencing a closure from within itself cannot bypass the variable
lookup code if the closure for environment is not the closure for
value.  This only affects machines where closures are canonicalized
for environment.

diff --git a/v7/src/compiler/fgopt/offset.scm b/v7/src/compiler/fgopt/offset.scm
index 2b15ee3f958b00f4a47227d6c13a25a2f02cc559..57e5125eaed0de2289c4e70789c9d7651b849000 100644 (file)
--- a/v7/src/compiler/fgopt/offset.scm
+++ b/v7/src/compiler/fgopt/offset.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.7 1990/05/03 15:09:17 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.8 1990/08/24 20:20:30 jinx Rel $
 
 Copyright (c) 1988, 1990 Massachusetts Institute of Technology
 
@@ -58,18 +58,26 @@ MIT in each case. |#
                             (continuation/offset procedure)))
              (begin
                (for-each
-                (lambda (value)
+                (lambda (value name)
                   (cond ((and (rvalue/procedure? value)
                               (not (procedure-continuation? value)))
                          (let ((context (procedure-closure-context value)))
                            (if (reference-context? context)
-                               (update-reference-context/offset! context 0)))
+                               (let ((closing-block
+                                      (procedure-closing-block value)))
+                                 (if (eq? closing-block
+                                          (block-shared-block closing-block))
+                                     (update-reference-context/offset! context
+                                                                       0)
+                                     (update-reference-context/fake-offset!
+                                      context name)))))
                          (walk-rvalue value 0))
                         ((rvalue/block? value)
                          (enqueue-grafted-procedures! value))
                         (else
                          (walk-rvalue value 0))))
-                (procedure-values procedure))
+                (procedure-values procedure)
+                (procedure-names procedure))
                (walk-next (procedure-entry-node procedure) 0)))))
        ;; This is a kludge.  If the procedure hasn't been encountered
        ;; elsewhere, tag it as closed when the letrec was done.
@@ -114,7 +122,17 @@ MIT in each case. |#
 
 (define (update-reference-context/offset! context offset)
   (let ((offset* (reference-context/offset context)))
-    (cond ((not offset*)          (set-reference-context/offset! context offset))
+    (cond ((not offset*)
+          (set-reference-context/offset! context offset))
+         ((not (= offset offset*))
+          (error "mismatched offsets" context)))))
+
+(define (update-reference-context/fake-offset! context name)
+  (let ((offset (- -1 (variable-normal-offset name)))
+       (offset* (reference-context/offset context)))
+    (cond ((or (not offset*)
+              (zero? offset*))
+          (set-reference-context/offset! context offset))
          ((not (= offset offset*))
           (error "mismatched offsets" context)))))
 

diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040
index 7e7a0493c507e308f615dead53d7d10108b9fb1d..750f2c920508777604c204f420938087bae106e0 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 4.75 1990/08/21 02:20:43 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.76 1990/08/24 20:19:45 jinx Exp $
 
 Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
 
@@ -41,4 +41,4 @@ MIT in each case. |#
            ((package/reference (find-package name) 'INITIALIZE-PACKAGE!)))
          '((COMPILER MACROS)
            (COMPILER DECLARATIONS)))
-(add-system! (make-system "Liar (Motorola MC68020)" 4 75 '()))
\ No newline at end of file
+(add-system! (make-system "Liar (Motorola MC68020)" 4 76 '()))
\ No newline at end of file

diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm
index 9d57c0fdb37c8927b9d8132c4bdaac8e83789b7a..b9e4d4dcc5dee412cbf973d8aede808ff97b14d9 100644 (file)
--- a/v7/src/compiler/rtlgen/rgrval.scm
+++ b/v7/src/compiler/rtlgen/rgrval.scm
@@ -1,9 +1,6 @@
-d3 1
-a4 1
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.16 1990/05/03 15:11:58 jinx Exp $
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.16 1990/05/03 15:11:58 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.17 1990/08/24 20:19:59 jinx Rel $
 
 Copyright (c) 1988, 1990 Massachusetts Institute of Technology
 
@@ -367,28 +364,41 @@ MIT in each case. |#
                  (code (load-closure-parent (block-parent block) false)))
               (if (null? entries)
                   code
+                  (loop
+                   (cdr entries)
+                   (scfg*scfg->scfg!
+                    (rtl:make-assignment
+                     (rtl:locative-offset closure-locative
+                                          (cdar entries))
+                     (let* ((variable (caar entries))
+                            (value (lvalue-known-value variable)))
+                       (cond
+                        ;; Paranoia.
+                        ((and value
+                              (rvalue/procedure? value)
+                              (procedure/trivial-or-virtual? value)
+                              (error "known ignorable procedure"
+                                     value variable))
+                         (make-trivial-closure-cons value))
+                        ((and (eq? value
                                    (reference-context/procedure context))
-                  (loop (cdr entries)
-                        (scfg*scfg->scfg!
-                         (rtl:make-assignment
-                          (rtl:locative-offset closure-locative
-                                               (cdar entries))
-                          (let* ((variable (caar entries))
-                                 (value (lvalue-known-value variable)))
-                            (cond
-                             ;; Paranoia.
-                             ((and value
-                                   (rvalue/procedure? value)
-                                   (procedure/trivial-or-virtual? value)
-                                   (error "known ignorable procedure"
-                                          value variable))
-                              (make-trivial-closure-cons value))
-                             ((eq? value
+                              (bypass-closure-reference? value))
+                         (rtl:make-fetch
+                          (block-closure-locative context)))
+                        (else
+                         (find-closure-variable context variable)))))
+                    code)))))
            (else
-                              (rtl:make-fetch
-                               (block-closure-locative context)))
-                             (else
-                              (find-closure-variable context variable)))))
-                         code)))))
-            (error "Unknown block type" block))))))
             (error "Unknown block type" block))))))
+
+(define (bypass-closure-reference? procedure)
+  ;; This checks whether the closure object at the top of the stack
+  ;; is the same as the value of a variable bound to the closure.
+  ;; It typically is, but is not on the 68k if the closure is not the
+  ;; first entry of the shared closure because the closure-for-environment
+  ;; is always the canonical entry point.
+  (let* ((closure-block (procedure-closing-block procedure))
+        (shared-block (block-shared-block closure-block)))
+    (zero? (closure-environment-adjustment
+           (block-number-of-entries shared-block)
+           (closure-block-entry-number closure-block)))))
\ No newline at end of file