From 9b87e4d5fe0b656c2c9bbf4203c117423cda7f7a Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 30 Dec 1988 07:11:57 +0000 Subject: [PATCH] Flesh out debugging information. This goes along with changes introduced in runtime system version 14.31. --- v7/src/compiler/fgopt/blktyp.scm | 107 ++++++------ v7/src/compiler/rtlgen/opncod.scm | 269 ++++++++++++++++-------------- v7/src/compiler/rtlgen/rgproc.scm | 121 +++++++------- v7/src/compiler/rtlgen/rgrval.scm | 21 ++- v7/src/compiler/rtlgen/rgstmt.scm | 86 ++++++---- v7/src/compiler/rtlgen/rtlgen.scm | 77 +++++++-- 6 files changed, 384 insertions(+), 297 deletions(-) diff --git a/v7/src/compiler/fgopt/blktyp.scm b/v7/src/compiler/fgopt/blktyp.scm index 029f4c117..7f4e2a38b 100644 --- a/v7/src/compiler/fgopt/blktyp.scm +++ b/v7/src/compiler/fgopt/blktyp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.9 1988/12/16 16:19:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.10 1988/12/30 07:11:57 cph Exp $ Copyright (c) 1987, 1988 Massachusetts Institute of Technology @@ -76,24 +76,26 @@ MIT in each case. |# ;; the procedure is being "demoted" from first-class to closure. (set-procedure-closure-context! procedure (make-reference-context parent)) - (((find-closure-bindings - (lambda (closure-frame-block size) - (set-block-parent! block closure-frame-block) - (set-procedure-closure-size! procedure size))) - parent) - (list-transform-negative (block-free-variables block) - (lambda (lvalue) - (or (lvalue-integrated? lvalue) - ;; Some of this is redundant - (let ((value (lvalue-known-value lvalue))) - (and value - (or (eq? value procedure) - (and (rvalue/procedure? value) - (procedure/trivial-or-virtual? value))))) - (begin - (set-variable-closed-over?! lvalue true) - false)))) - '()) + (with-values + (lambda () + (find-closure-bindings + parent + (list-transform-negative (block-free-variables block) + (lambda (lvalue) + (or (lvalue-integrated? lvalue) + ;; Some of this is redundant + (let ((value (lvalue-known-value lvalue))) + (and value + (or (eq? value procedure) + (and (rvalue/procedure? value) + (procedure/trivial-or-virtual? value))))) + (begin + (set-variable-closed-over?! lvalue true) + false)))) + '())) + (lambda (closure-frame-block size) + (set-block-parent! block closure-frame-block) + (set-procedure-closure-size! procedure size))) (let ((new (procedure/trivial-closure? procedure))) (if (or (and previously-trivial? (not new)) (and (not previously-trivial?) new)) @@ -101,25 +103,23 @@ MIT in each case. |# procedure)))) (disown-block-child! current-parent block))) -(define (find-closure-bindings receiver) - (define (find-internal block) - (lambda (free-variables bound-variables) - (if (or (not block) (ic-block? block)) - (let ((grandparent (and (not (null? free-variables)) block))) - (if (null? bound-variables) - (receiver grandparent (if grandparent 1 0)) - (make-closure-block receiver - grandparent +(define (find-closure-bindings block free-variables bound-variables) + (if (or (not block) (ic-block? block)) + (let ((grandparent (and (not (null? free-variables)) block))) + (if (null? bound-variables) + (values grandparent (if grandparent 1 0)) + (make-closure-block grandparent + free-variables + bound-variables))) + (with-values + (lambda () + (filter-bound-variables (block-bound-variables block) free-variables - bound-variables - (and block (block-procedure block))))) - (with-values - (lambda () - (filter-bound-variables (block-bound-variables block) - free-variables - bound-variables)) - (find-internal (original-block-parent block)))))) - find-internal) + bound-variables)) + (lambda (free-variables bound-variables) + (find-closure-bindings (original-block-parent block) + free-variables + bound-variables))))) (define (filter-bound-variables bindings free-variables bound-variables) (cond ((null? bindings) @@ -138,28 +138,21 @@ MIT in each case. |# ;; This may have to change if we ever do simultaneous closing of multiple ;; procedures sharing structure. -(define (make-closure-block recvr parent free-variables bound-variables frame) - (let ((block (make-block parent 'CLOSURE)) - (extra (if (and parent (ic-block/use-lookup? parent)) 1 0))) +(define (make-closure-block parent free-variables bound-variables) + (let ((block (make-block parent 'CLOSURE))) (set-block-free-variables! block free-variables) (set-block-bound-variables! block bound-variables) - (let loop ((variables (block-bound-variables block)) - (offset (+ closure-block-first-offset extra)) - (table '()) - (size extra)) - (cond ((null? variables) - (set-block-closure-offsets! block table) - (recvr block size)) - ((lvalue-integrated? (car variables)) - (error "make-closure-block: Found integrated lvalue" - (car variables)) - (loop (cdr variables) offset table size)) - (else - (loop (cdr variables) - (1+ offset) - (cons (cons (car variables) offset) - table) - (1+ size))))))) + (do ((variables (block-bound-variables block) (cdr variables)) + (size (if (and parent (ic-block/use-lookup? parent)) 1 0) (1+ size)) + (table '() + (cons (cons (car variables) + (+ closure-block-first-offset size)) + table))) + ((null? variables) + (set-block-closure-offsets! block table) + (values block size)) + (if (lvalue-integrated? (car variables)) + (error "make-closure-block: integrated lvalue" (car variables)))))) (define (setup-closure-contexts! expression procedures) (with-new-node-marks diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index e86646478..5bcace211 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.24 1988/12/14 00:01:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.25 1988/12/30 07:10:49 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -86,10 +86,11 @@ MIT in each case. |# ;;;; Code Generator (define (combination/inline combination) - (generate/return* (combination/context combination) - (combination/continuation combination) - (combination/continuation-push combination) - (let ((inliner (combination/inliner combination))) + (let ((context (combination/context combination)) + (inliner (combination/inliner combination))) + (generate/return* context + (combination/continuation combination) + (combination/continuation-push combination) (let ((handler (inliner/handler inliner)) (generator (inliner/generator inliner)) (expressions @@ -97,13 +98,17 @@ MIT in each case. |# (inliner/operands inliner)))) (make-return-operand (lambda () - ((vector-ref handler 1) generator expressions)) + ((vector-ref handler 1) generator + context + expressions)) (lambda (finish) ((vector-ref handler 2) generator + context expressions finish)) (lambda (finish) ((vector-ref handler 3) generator + context expressions finish)) false))))) @@ -128,11 +133,11 @@ MIT in each case. |# (continuation*/register (subproblem-continuation subproblem)))))))) -(define (invoke/effect->effect generator expressions) - (generator expressions false)) +(define (invoke/effect->effect generator context expressions) + (generator context expressions false)) -(define (invoke/predicate->value generator expressions finish) - (generator expressions +(define (invoke/predicate->value generator context expressions finish) + (generator context expressions (lambda (pcfg) (let ((temporary (rtl:make-pseudo-register))) ;; Force assignments to be made first. @@ -144,17 +149,17 @@ MIT in each case. |# (pcfg*scfg->scfg! pcfg consequent alternative) (finish (rtl:make-fetch temporary)))))))) -(define (invoke/value->effect generator expressions) - generator expressions +(define (invoke/value->effect generator context expressions) + generator context expressions (make-null-cfg)) -(define (invoke/value->predicate generator expressions finish) - (generator expressions +(define (invoke/value->predicate generator context expressions finish) + (generator context expressions (lambda (expression) (finish (rtl:make-true-test expression))))) -(define (invoke/value->value generator expressions finish) - (generator expressions finish)) +(define (invoke/value->value generator context expressions finish) + (generator context expressions finish)) ;;;; Definers @@ -222,7 +227,7 @@ MIT in each case. |# (define-integrable (make-invocation operator operands) `(,operator ,@operands)) -(define (open-code:with-checks checks non-error-cfg error-finish +(define (open-code:with-checks context checks non-error-cfg error-finish prim-invocation) (let ((checks (list-transform-negative checks cfg-null?))) (if (null? checks) @@ -231,19 +236,17 @@ MIT in each case. |# ;; it creates some unreachable code which we can't easily ;; remove from the output afterwards. (let ((error-cfg - (let ((continuation-entry (generate-continuation-entry))) - (scfg-append! - (generate-primitive - (car prim-invocation) - (cdr prim-invocation) - (rtl:continuation-entry-continuation - (rinst-rtl - (bblock-instructions - (cfg-entry-node continuation-entry))))) - continuation-entry - (if error-finish - (error-finish (rtl:make-fetch register:value)) - (make-null-cfg)))))) + (with-values (lambda () (generate-continuation-entry context)) + (lambda (label setup cleanup) + (scfg-append! + setup + (generate-primitive (car prim-invocation) + (cdr prim-invocation) + label) + cleanup + (if error-finish + (error-finish (rtl:make-fetch register:value)) + (make-null-cfg))))))) (let loop ((checks checks)) (if (null? checks) non-error-cfg @@ -280,14 +283,6 @@ MIT in each case. |# identity-procedure) (make-null-cfg))) -(define (generate-continuation-entry) - (let* ((label (generate-label)) - (rtl (rtl:make-continuation-entry label)) - (rtl-continuation - (make-rtl-continuation *current-rgraph* label (cfg-entry-edge rtl)))) - (set! *extra-continuations* (cons rtl-continuation *extra-continuations*)) - rtl)) - (define (generate-primitive name arg-list continuation-label) (scfg*scfg->scfg! (let loop ((args arg-list)) @@ -319,13 +314,15 @@ MIT in each case. |# (define-open-coder/predicate 'NULL? (lambda (operands) operands - (return-2 (lambda (expressions finish) + (return-2 (lambda (context expressions finish) + context (finish (pcfg-invert (rtl:make-true-test (car expressions))))) '(0)))) (let ((open-code/type-test (lambda (type) - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (rtl:make-type-test (rtl:make-object->type (car expressions)) type)))))) @@ -347,7 +344,8 @@ MIT in each case. |# (return-2 (open-code/type-test type) '(1))))))) (let ((open-code/eq-test - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (rtl:make-eq-test (car expressions) (cadr expressions)))))) (define-open-coder/predicate 'EQ? (lambda (operands) @@ -356,7 +354,8 @@ MIT in each case. |# (let ((open-code/pair-cons (lambda (type) - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (rtl:make-typed-cons:pair (rtl:make-constant type) (car expressions) @@ -376,7 +375,8 @@ MIT in each case. |# (define-open-coder/value 'VECTOR (lambda (operands) (and (< (length operands) 32) - (return-2 (lambda (expressions finish) + (return-2 (lambda (context expressions finish) + context (finish (rtl:make-typed-cons:vector (rtl:make-constant (ucode-type vector)) @@ -391,7 +391,8 @@ MIT in each case. |# (let ((open-code/memory-length (lambda (index) - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (rtl:make-cons-pointer (rtl:make-constant (ucode-type fixnum)) @@ -423,17 +424,17 @@ MIT in each case. |# finish)) (let* ((open-code/memory-ref - (lambda (index) - (lambda (expressions finish) - (finish - (rtl:make-fetch - (rtl:locative-offset (car expressions) index)))))) + (lambda (expressions finish index) + (finish + (rtl:make-fetch + (rtl:locative-offset (car expressions) index))))) (open-code/vector-ref (lambda (name) - (lambda (expressions finish) + (lambda (context expressions finish) (let ((vector (car expressions)) (index (cadr expressions))) (open-code:with-checks + context (list (open-code:type-check vector 'VECTOR) (open-code:type-check index 'FIXNUM) @@ -444,22 +445,21 @@ MIT in each case. |# vector index (lambda (memory-locative) - ((open-code/memory-ref 1) - (list memory-locative) - finish))) + (open-code/memory-ref (list memory-locative) finish 1))) finish (make-invocation name expressions)))))) (open-code/constant-vector-ref (lambda (name index) - (lambda (expressions finish) + (lambda (context expressions finish) (let ((vector (car expressions))) (open-code:with-checks + context (list (open-code:type-check vector 'VECTOR) (open-code:limit-check (rtl:make-constant index) (rtl:make-fetch (rtl:locative-offset vector 0)))) - ((open-code/memory-ref (1+ index)) expressions finish) + (open-code/memory-ref expressions finish (1+ index)) finish (make-invocation name expressions))))))) (let ((define/ref @@ -467,7 +467,10 @@ MIT in each case. |# (define-open-coder/value name (lambda (operands) operands - (return-2 (open-code/memory-ref index) '(0))))))) + (return-2 (lambda (context expressions finish) + context + (open-code/memory-ref expressions finish index)) + '(0))))))) (define/ref '(CAR SYSTEM-PAIR-CAR CELL-CONTENTS SYSTEM-HUNK3-CXR0) 0) (define/ref '(CDR SYSTEM-PAIR-CDR SYSTEM-HUNK3-CXR1) 1) (define/ref 'SYSTEM-HUNK3-CXR2 2)) @@ -483,7 +486,8 @@ MIT in each case. |# (let ((open-code/general-car-cdr (lambda (pattern) - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (let loop ((pattern pattern) (expression (car expressions))) (if (= pattern 1) @@ -501,25 +505,25 @@ MIT in each case. |# (return-2 (open-code/general-car-cdr pattern) '(0))))))) (let* ((open-code/memory-assignment - (lambda (index) - (lambda (expressions finish) - (let* ((locative (rtl:locative-offset (car expressions) index)) - (assignment - (rtl:make-assignment locative - (car (last-pair expressions))))) - (if finish - (load-temporary-register scfg*scfg->scfg! - (rtl:make-fetch locative) - (lambda (temporary) - (scfg*scfg->scfg! assignment (finish temporary)))) - assignment))))) + (lambda (expressions finish index) + (let* ((locative (rtl:locative-offset (car expressions) index)) + (assignment + (rtl:make-assignment locative + (car (last-pair expressions))))) + (if finish + (load-temporary-register scfg*scfg->scfg! + (rtl:make-fetch locative) + (lambda (temporary) + (scfg*scfg->scfg! assignment (finish temporary)))) + assignment)))) (open-code/vector-set (lambda (name) - (lambda (expressions finish) + (lambda (context expressions finish) (let ((vector (car expressions)) (index (cadr expressions)) (newval-list (cddr expressions))) (open-code:with-checks + context (list (open-code:type-check vector 'VECTOR) (open-code:type-check index 'FIXNUM) @@ -530,22 +534,24 @@ MIT in each case. |# vector index (lambda (memory-locative) - ((open-code/memory-assignment 1) + (open-code/memory-assignment (cons memory-locative newval-list) - finish))) + finish + 1))) finish (make-invocation name expressions)))))) (open-code/constant-vector-set (lambda (name index) - (lambda (expressions finish) + (lambda (context expressions finish) (let ((vector (car expressions))) (open-code:with-checks + context (list (open-code:type-check vector 'VECTOR) (open-code:limit-check (rtl:make-constant index) (rtl:make-fetch (rtl:locative-offset vector 0)))) - ((open-code/memory-assignment index) expressions finish) + (open-code/memory-assignment expressions finish index) finish (make-invocation name expressions))))))) @@ -558,7 +564,11 @@ MIT in each case. |# (define-open-coder/effect name (lambda (operands) operands - (return-2 (open-code/memory-assignment index) '(0 1))))))) + (return-2 + (lambda (context expressions finish) + context + (open-code/memory-assignment expressions finish index)) + '(0 1))))))) (define/set! '(SET-CAR! SET-CELL-CONTENTS! #| SYSTEM-PAIR-SET-CAR! |# @@ -588,7 +598,8 @@ MIT in each case. |# (lambda (operands) operands (return-2 - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (rtl:make-fixnum->object (rtl:make-fixnum-2-args @@ -607,7 +618,8 @@ MIT in each case. |# (lambda (operand) operand (return-2 - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (rtl:make-fixnum->object (rtl:make-fixnum-1-arg @@ -621,7 +633,8 @@ MIT in each case. |# (lambda (operands) operands (return-2 - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (rtl:make-fixnum-pred-2-args fixnum-pred @@ -635,7 +648,8 @@ MIT in each case. |# (lambda (operand) operand (return-2 - (lambda (expressions finish) + (lambda (context expressions finish) + context (finish (rtl:make-fixnum-pred-1-arg fixnum-pred @@ -645,30 +659,26 @@ MIT in each case. |# ;;; Generic arithmetic -(define (generate-generic-binary expression finish is-pred?) - (let ((continuation-entry (generate-continuation-entry)) - (generic-op (rtl:generic-binary-operator expression)) +(define (generate-generic-binary context expression finish is-pred?) + (let ((generic-op (rtl:generic-binary-operator expression)) (fix-op (generic->fixnum-op (rtl:generic-binary-operator expression))) (op1 (rtl:generic-binary-operand-1 expression)) (op2 (rtl:generic-binary-operand-2 expression))) (let ((give-it-up (lambda () - (scfg-append! - (generate-primitive - generic-op - (cddr expression) - (rtl:continuation-entry-continuation - (rinst-rtl - (bblock-instructions - (cfg-entry-node continuation-entry))))) - continuation-entry - (if is-pred? - (finish - (rtl:make-true-test (rtl:make-fetch register:value))) - (expression-simplify-for-statement - (rtl:make-fetch register:value) - finish)))))) + (with-values (lambda () (generate-continuation-entry context)) + (lambda (label setup cleanup) + (scfg-append! + setup + (generate-primitive generic-op (cddr expression) label) + cleanup + (if is-pred? + (finish + (rtl:make-true-test (rtl:make-fetch register:value))) + (expression-simplify-for-statement + (rtl:make-fetch register:value) + finish)))))))) (if is-pred? (generate-binary-type-test 'FIXNUM op1 op2 give-it-up @@ -717,29 +727,25 @@ MIT in each case. |# (pcfg*scfg->scfg! test* (do-it) give-it-up) give-it-up))))))) -(define (generate-generic-unary expression finish is-pred?) - (let ((continuation-entry (generate-continuation-entry)) - (generic-op (rtl:generic-unary-operator expression)) +(define (generate-generic-unary context expression finish is-pred?) + (let ((generic-op (rtl:generic-unary-operator expression)) (fix-op (generic->fixnum-op (rtl:generic-unary-operator expression))) (op (rtl:generic-unary-operand expression))) (let ((give-it-up (lambda () - (scfg-append! - (generate-primitive - generic-op - (cddr expression) - (rtl:continuation-entry-continuation - (rinst-rtl - (bblock-instructions - (cfg-entry-node continuation-entry))))) - continuation-entry - (if is-pred? - (finish - (rtl:make-true-test (rtl:make-fetch register:value))) - (expression-simplify-for-statement - (rtl:make-fetch register:value) - finish)))))) + (with-values (lambda () (generate-continuation-entry context)) + (lambda (label setup cleanup) + (scfg-append! + setup + (generate-primitive generic-op (cddr expression) label) + cleanup + (if is-pred? + (finish + (rtl:make-true-test (rtl:make-fetch register:value))) + (expression-simplify-for-statement + (rtl:make-fetch register:value) + finish)))))))) (if is-pred? (generate-unary-type-test 'FIXNUM op give-it-up @@ -804,8 +810,9 @@ MIT in each case. |# (lambda (operands) operands (return-2 - (lambda (expressions finish) + (lambda (context expressions finish) (generate-generic-binary + context (rtl:make-generic-binary generic-op (car expressions) (cadr expressions)) @@ -816,12 +823,13 @@ MIT in each case. |# (for-each (lambda (generic-op) (define-open-coder/value generic-op - (lambda (operand) - operand + (lambda (operands) + operands (return-2 - (lambda (expression finish) + (lambda (context expressions finish) (generate-generic-unary - (rtl:make-generic-unary generic-op (car expression)) + context + (rtl:make-generic-unary generic-op (car expressions)) finish false)) '(0))))) @@ -832,8 +840,9 @@ MIT in each case. |# (lambda (operands) operands (return-2 - (lambda (expressions finish) + (lambda (context expressions finish) (generate-generic-binary + context (rtl:make-generic-binary generic-op (car expressions) (cadr expressions)) @@ -844,12 +853,13 @@ MIT in each case. |# (for-each (lambda (generic-op) (define-open-coder/predicate generic-op - (lambda (operand) - operand + (lambda (operands) + operands (return-2 - (lambda (expression finish) + (lambda (context expressions finish) (generate-generic-unary - (rtl:make-generic-unary generic-op (car expression)) + context + (rtl:make-generic-unary generic-op (car expressions)) finish true)) '(0))))) @@ -862,7 +872,8 @@ MIT in each case. |# (define-open-coder/value character->fixnum (lambda (operand) operand - (return-2 (lambda (expressions finish) + (return-2 (lambda (context expressions finish) + context (finish (rtl:make-cons-pointer (rtl:make-constant (ucode-type fixnum)) @@ -881,9 +892,10 @@ MIT in each case. |# (filter/nonnegative-integer (cadr operands) (lambda (index) (return-2 - (lambda (expressions finish) + (lambda (context expressions finish) (let ((string (car expressions))) (open-code:with-checks + context (list (open-code:type-check string 'STRING) (open-code:limit-check @@ -904,10 +916,11 @@ MIT in each case. |# (filter/nonnegative-integer (cadr operands) (lambda (index) (return-2 - (lambda (expressions finish) + (lambda (context expressions finish) (let ((string (car expressions)) (value (caddr expressions))) (open-code:with-checks + context (list (open-code:type-check string 'STRING) (open-code:limit-check diff --git a/v7/src/compiler/rtlgen/rgproc.scm b/v7/src/compiler/rtlgen/rgproc.scm index 75ef5130e..1b62ac79e 100644 --- a/v7/src/compiler/rtlgen/rgproc.scm +++ b/v7/src/compiler/rtlgen/rgproc.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.6 1988/12/12 21:52:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.7 1988/12/30 07:11:01 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -36,63 +36,67 @@ MIT in each case. |# (declare (usual-integrations)) -(package (generate/procedure-header) - -(define-export (generate/procedure-header procedure body inline?) +(define (generate/procedure-header procedure body inline?) (scfg*scfg->scfg! - (if (procedure/ic? procedure) - (scfg*scfg->scfg! - (if inline? - (make-null-cfg) - (rtl:make-ic-procedure-header (procedure-label procedure))) - (setup-ic-frame procedure)) - (scfg*scfg->scfg! - (cond (inline? - ;; Paranoia - (if (not (procedure/virtually-open? procedure)) - (error "Inlining a real closure!" procedure)) - (make-null-cfg)) - ((procedure/closure? procedure) - (cond ((not (procedure/trivial-closure? procedure)) - (rtl:make-closure-header (procedure-label procedure))) - ((or (procedure-rest procedure) - (closure-procedure-needs-external-descriptor? - procedure)) - (with-values - (lambda () (procedure-arity-encoding procedure)) - (lambda (min max) - (rtl:make-procedure-header - (procedure-label procedure) - min max)))) - (else - ;; It's not an open procedure but it looks like one - ;; at the rtl level. - (rtl:make-open-procedure-header - (procedure-label procedure))))) - ((procedure-rest procedure) - (with-values (lambda () (procedure-arity-encoding procedure)) - (lambda (min max) - (rtl:make-procedure-header (procedure-label procedure) - min max)))) - (else - (rtl:make-open-procedure-header (procedure-label procedure)))) - (setup-stack-frame procedure))) + (let ((context (make-reference-context (procedure-block procedure)))) + (set-reference-context/offset! context 0) + (if (procedure/ic? procedure) + (scfg*scfg->scfg! + (if inline? + (make-null-cfg) + (rtl:make-ic-procedure-header (procedure-label procedure))) + (setup-ic-frame procedure context)) + (scfg*scfg->scfg! + (cond (inline? + ;; Paranoia + (if (not (procedure/virtually-open? procedure)) + (error "Inlining a real closure!" procedure)) + (make-null-cfg)) + ((procedure/closure? procedure) + (cond ((not (procedure/trivial-closure? procedure)) + (rtl:make-closure-header (procedure-label procedure))) + ((or (procedure-rest procedure) + (closure-procedure-needs-external-descriptor? + procedure)) + (with-values + (lambda () (procedure-arity-encoding procedure)) + (lambda (min max) + (rtl:make-procedure-header + (procedure-label procedure) + min max)))) + (else + ;; It's not an open procedure but it looks like one + ;; at the rtl level. + (rtl:make-open-procedure-header + (procedure-label procedure))))) + ((procedure-rest procedure) + (with-values (lambda () (procedure-arity-encoding procedure)) + (lambda (min max) + (rtl:make-procedure-header (procedure-label procedure) + min max)))) + (else + (rtl:make-open-procedure-header (procedure-label procedure)))) + (setup-stack-frame procedure context)))) body)) - -(define (setup-ic-frame procedure) + +(define (setup-ic-frame procedure context) (scfg*->scfg! (map (let ((block (procedure-block procedure))) (lambda (name value) - (generate/rvalue value 0 scfg*scfg->scfg! + (generate/rvalue value scfg*scfg->scfg! (lambda (expression) - (rtl:make-interpreter-call:set! - (rtl:make-fetch register:environment) - (intern-scode-variable! block (variable-name name)) - expression))))) + (load-temporary-register scfg*scfg->scfg! expression + (lambda (expression) + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:set! + (rtl:make-fetch register:environment) + (intern-scode-variable! block (variable-name name)) + expression)))))))) (procedure-names procedure) (procedure-values procedure)))) - -(define (setup-stack-frame procedure) + +(define (setup-stack-frame procedure context) (let ((block (procedure-block procedure))) (define (cellify-variables variables) (scfg*->scfg! (map cellify-variable variables))) @@ -118,13 +122,11 @@ MIT in each case. |# (cellify-variable rest) (make-null-cfg))) (scfg*->scfg! - (map (let ((context (make-reference-context block))) - (set-reference-context/offset! context 0) - (lambda (name value) - (if (and (procedure? value) - (not (procedure/trivial-or-virtual? value))) - (letrec-close context name value) - (make-null-cfg)))) + (map (lambda (name value) + (if (and (procedure? value) + (not (procedure/trivial-or-virtual? value))) + (letrec-close context name value) + (make-null-cfg))) names values)))))) (define (setup-bindings names values pushes) @@ -178,7 +180,4 @@ MIT in each case. |# (error "Missing closure variable" variable)) (lambda (name) name ;; ignored - (error "Missing closure variable" variable))))) - -;;; end GENERATE/PROCEDURE-HEADER -) \ No newline at end of file + (error "Missing closure variable" variable))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index e24baaffa..9b28c5268 100644 --- a/v7/src/compiler/rtlgen/rgrval.scm +++ b/v7/src/compiler/rtlgen/rgrval.scm @@ -1,9 +1,9 @@ d3 1 a4 1 -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.12 1988/12/12 21:52:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.13 1988/12/30 07:11:06 cph Rel $ #| -*-Scheme-*- Copyright (c) 1988 Massachusetts Institute of Technology -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.12 1988/12/12 21:52:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.13 1988/12/30 07:11:06 cph Rel $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -79,11 +79,16 @@ promotional, or sales literature without prior written consent from (expression-value/simple (rtl:make-fetch locative))) (lambda (environment name) (expression-value/temporary - (rtl:make-interpreter-call:lookup - environment - (intern-scode-variable! (reference-context/block context) - name) - safe?) + (load-temporary-register scfg*scfg->scfg! environment + (lambda (environment) + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:lookup + environment + (intern-scode-variable! + (reference-context/block context) + name) + safe?)))) (rtl:interpreter-call-result:lookup))) (lambda (name) (if (memq 'IGNORE-REFERENCE-TRAPS @@ -91,7 +96,7 @@ promotional, or sales literature without prior written consent from (load-temporary-register values (rtl:make-variable-cache name) rtl:make-fetch) - (generate/cached-reference name safe?))))))) + (generate/cached-reference context name safe?))))))) (cond ((not value) (perform-fetch)) lvalue)) |# diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index 5769e409e..ebbf297b0 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.9 1988/12/12 21:52:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.10 1988/12/30 07:11:11 cph Rel $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -50,11 +50,18 @@ MIT in each case. |# (lambda (locative) (rtl:make-assignment locative expression)) (lambda (environment name) - (rtl:make-interpreter-call:set! - environment - (intern-scode-variable! (reference-context/block context) - name) - expression)) + (load-temporary-register scfg*scfg->scfg! environment + (lambda (environment) + (load-temporary-register scfg*scfg->scfg! expression + (lambda (expression) + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:set! + environment + (intern-scode-variable! + (reference-context/block context) + name) + expression))))))) (lambda (name) (if (memq 'IGNORE-ASSIGNMENT-TRAPS (variable-declarations lvalue)) @@ -62,9 +69,11 @@ MIT in each case. |# (rtl:make-assignment-cache name) (lambda (cell) (rtl:make-assignment cell expression))) - (generate/cached-assignment name expression))))))))) + (generate/cached-assignment context + name + expression))))))))) -(define (generate/cached-assignment name value) +(define (generate/cached-assignment context name value) (load-temporary-register scfg*scfg->scfg! (rtl:make-assignment-cache name) (lambda (cell) @@ -73,7 +82,12 @@ MIT in each case. |# (ucode-type reference-trap))) (n3 (rtl:make-unassigned-test contents)) (n4 (rtl:make-assignment cell value)) - (n5 (rtl:make-interpreter-call:cache-assignment cell value)) + (n5 + (load-temporary-register scfg*scfg->scfg! value + (lambda (value) + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:cache-assignment cell value))))) ;; Copy prevents premature control merge which confuses CSE (n6 (rtl:make-assignment cell value))) (pcfg-consequent-connect! n2 n3) @@ -93,9 +107,15 @@ MIT in each case. |# (lambda (expression) (with-values (lambda () (find-definition-variable context lvalue)) (lambda (environment name) - (rtl:make-interpreter-call:define environment - name - expression))))))) + (load-temporary-register scfg*scfg->scfg! environment + (lambda (environment) + (load-temporary-register scfg*scfg->scfg! expression + (lambda (expression) + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:define environment + name + expression)))))))))))) ;;;; Virtual Returns @@ -159,18 +179,14 @@ MIT in each case. |# (receiver setup (generator (rtl:make-fetch temporary)))))) (define (generate/continuation-cons continuation) - (let ((closing-block (continuation/closing-block continuation))) - (scfg-append! - (if (ic-block? closing-block) - (rtl:make-push (rtl:make-fetch register:environment)) - (make-null-cfg)) - (if (block/dynamic-link? closing-block) - (rtl:make-push-link) - (make-null-cfg)) - (if (continuation/always-known-operator? continuation) - (make-null-cfg) - (begin - (enqueue-continuation! continuation) + (let ((extra + (push-continuation-extra (continuation/closing-block continuation)))) + (if (continuation/always-known-operator? continuation) + extra + (begin + (enqueue-continuation! continuation) + (scfg*scfg->scfg! + extra (rtl:make-push-return (continuation/label continuation))))))) (define (generate/pop pop) @@ -242,19 +258,26 @@ MIT in each case. |# consequent))) (define (generate/unassigned-test rvalue consequent alternative) - (let ((lvalue (unassigned-test-lvalue rvalue))) + (let ((context (unassigned-test-context rvalue)) + (lvalue (unassigned-test-lvalue rvalue))) (let ((value (lvalue-known-value lvalue))) (cond ((not value) (pcfg*scfg->scfg! - (find-variable (unassigned-test-context rvalue) lvalue + (find-variable context lvalue (lambda (locative) (rtl:make-unassigned-test (rtl:make-fetch locative))) (lambda (environment name) (scfg*pcfg->pcfg! - (rtl:make-interpreter-call:unassigned? environment name) + (load-temporary-register scfg*scfg->scfg! environment + (lambda (environment) + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:unassigned? environment + name)))) (rtl:make-true-test (rtl:interpreter-call-result:unassigned?)))) - generate/cached-unassigned?) + (lambda (name) + (generate/cached-unassigned? context name))) (generate/node consequent) (generate/node alternative))) ((and (rvalue/constant? value) @@ -263,7 +286,7 @@ MIT in each case. |# (else (generate/node alternative)))))) -(define (generate/cached-unassigned? name) +(define (generate/cached-unassigned? context name) (load-temporary-register scfg*pcfg->pcfg! (rtl:make-variable-cache name) (lambda (cell) @@ -271,7 +294,10 @@ MIT in each case. |# (let ((n2 (rtl:make-type-test (rtl:make-object->type reference) (ucode-type reference-trap))) (n3 (rtl:make-unassigned-test reference)) - (n4 (rtl:make-interpreter-call:cache-unassigned? cell)) + (n4 + (wrap-with-continuation-entry + context + (rtl:make-interpreter-call:cache-unassigned? cell))) (n5 (rtl:make-true-test (rtl:interpreter-call-result:cache-unassigned?)))) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index c2d9e2072..0aa4db331 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.14 1988/12/16 13:37:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.15 1988/12/30 07:11:17 cph Exp $ Copyright (c) 1988 Massachusetts Institute of Technology @@ -160,20 +160,71 @@ MIT in each case. |# (error "Illegal continuation type" continuation))) (generate/node node))))) (lambda (rgraph entry-edge) - (make-rtl-continuation rgraph - label - entry-edge - (continuation/debugging-info continuation)))))) + (make-rtl-continuation + rgraph + label + entry-edge + (continuation/next-continuation-offset + (continuation/closing-block continuation) + (continuation/offset continuation)) + (continuation/debugging-info continuation)))))) + +(define (wrap-with-continuation-entry context scfg) + (with-values (lambda () (generate-continuation-entry context)) + (lambda (label setup cleanup) + label + (scfg-append! setup scfg cleanup)))) + +(define (generate-continuation-entry context) + (let ((label (generate-label)) + (closing-block (reference-context/block context))) + (let ((setup (push-continuation-extra closing-block)) + (cleanup + (scfg*scfg->scfg! + (rtl:make-continuation-entry label) + (pop-continuation-extra closing-block)))) + (set! *extra-continuations* + (cons (make-rtl-continuation + *current-rgraph* + label + (cfg-entry-edge cleanup) + (continuation/next-continuation-offset + closing-block + (reference-context/offset context)) + (generated-dbg-continuation context label)) + *extra-continuations*)) + (values label setup cleanup)))) + +(define (continuation/next-continuation-offset block offset) + (if (stack-block? block) + (let ((popping-limit (block-popping-limit block))) + (and popping-limit + (let loop ((block block) (offset offset)) + (let ((offset (+ offset (block-frame-size block)))) + (if (eq? block popping-limit) + offset + (loop (block-parent block) offset)))))) offset)) (define (generate/continuation-entry/pop-extra continuation) - (let ((block (continuation/closing-block continuation))) - (scfg*scfg->scfg! - (if (ic-block? block) - (rtl:make-pop register:environment) - (make-null-cfg)) - (if (block/dynamic-link? block) - (rtl:make-pop-link) - (make-null-cfg))))) + (pop-continuation-extra (continuation/closing-block continuation))) + +(define (push-continuation-extra closing-block) + (cond ((ic-block? closing-block) + (rtl:make-push (rtl:make-fetch register:environment))) + ((and (stack-block? closing-block) + (stack-block/dynamic-link? closing-block)) + (rtl:make-push-link)) + (else + (make-null-cfg)))) + +(define (pop-continuation-extra closing-block) + (cond ((ic-block? closing-block) + (rtl:make-pop register:environment)) + ((and (stack-block? closing-block) + (stack-block/dynamic-link? closing-block)) + (rtl:make-pop-link)) + (else + (make-null-cfg)))) (define (generate/node node) (let ((memoization (cfg-node-get node memoization-tag))) -- 2.25.1