From 6a137fbefaec94d0bcd552e8a4c623aa59180094 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Fri, 24 Aug 1990 20:20:30 +0000 Subject: [PATCH] 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. --- v7/src/compiler/fgopt/offset.scm | 28 +++++++-- .../compiler/machines/bobcat/make.scm-68040 | 4 +- v7/src/compiler/rtlgen/rgrval.scm | 62 +++++++++++-------- 3 files changed, 61 insertions(+), 33 deletions(-) diff --git a/v7/src/compiler/fgopt/offset.scm b/v7/src/compiler/fgopt/offset.scm index 2b15ee3f9..57e5125ea 100644 --- 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 7e7a0493c..750f2c920 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 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 9d57c0fdb..b9e4d4dcc 100644 --- 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 -- 2.25.1