From e4df33da5a4ea8edf722c8358f4685fe5ab73f33 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 4 Dec 1987 20:35:52 +0000 Subject: [PATCH] Major redesign of front end of compiler. Continuations are now modeled more exactly by means of a CPS-style analysis. Poppers have been flushed in favor of dynamic links, and optimizations have been added that eliminate the use of static and dynamic links in many cases. --- v7/src/compiler/machines/bobcat/machin.scm | 40 +- v7/src/compiler/rtlgen/fndblk.scm | 190 ++++++ v7/src/compiler/rtlgen/opncod.scm | 327 ++++++++++ v7/src/compiler/rtlgen/rgcomb.scm | 662 ++++++++------------- v7/src/compiler/rtlgen/rgproc.scm | 112 ++-- v7/src/compiler/rtlgen/rgretn.scm | 195 ++++++ v7/src/compiler/rtlgen/rgrval.scm | 197 +++--- v7/src/compiler/rtlgen/rgstmt.scm | 247 +++++--- v7/src/compiler/rtlgen/rtlgen.scm | 318 +++++----- 9 files changed, 1489 insertions(+), 799 deletions(-) create mode 100644 v7/src/compiler/rtlgen/fndblk.scm create mode 100644 v7/src/compiler/rtlgen/opncod.scm create mode 100644 v7/src/compiler/rtlgen/rgretn.scm diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index 079364c74..e289c2961 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 1.51 1987/10/05 20:35:26 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.1 1987/12/04 20:35:52 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -35,11 +35,7 @@ MIT in each case. |# ;;;; Machine Model for 68020 (declare (usual-integrations)) - (define (rtl:message-receiver-size:closure) 1) -(define (rtl:message-receiver-size:stack) 1) -(define (rtl:message-receiver-size:subproblem) 2) - -(define-integrable (stack->memory-offset offset) + (define-integrable (stack->memory-offset offset) offset) (define ic-block-first-parameter-offset @@ -50,6 +46,7 @@ MIT in each case. |# ;; For simplicity, we try to estimate the actual number of cycles ;; that a typical code sequence would produce. (case (rtl:expression-type expression) + ((ASSIGNMENT-CACHE VARIABLE-CACHE) 16) ;move.l d(pc),reg ((CONS-POINTER) ;; Best case = 12 cycles, worst = 44 ;; move.l reg,d(reg) = 16 @@ -82,14 +79,12 @@ MIT in each case. |# ((PRE-INCREMENT) 14) ;move.l -(reg),reg ((REGISTER) 4) ;move.l reg,reg ((UNASSIGNED) 12) ;move.l #data,reg - ((VARIABLE-CACHE) 16) ;move.l d(pc),reg - ((ASSIGNMENT-CACHE) 16) ;move.l d(pc),reg (else (error "Unknown expression type" expression)))) (define (rtl:machine-register? rtl-register) (case rtl-register - ((FRAME-POINTER) (interpreter-frame-pointer)) ((STACK-POINTER) (interpreter-stack-pointer)) + ((DYNAMIC-LINK) (interpreter-dynamic-link)) ((INTERPRETER-CALL-RESULT:ACCESS) (interpreter-register:access)) ((INTERPRETER-CALL-RESULT:CACHE-REFERENCE) (interpreter-register:cache-reference)) @@ -132,7 +127,7 @@ MIT in each case. |# (define-integrable a7 15) (define number-of-machine-registers 16) -(define-integrable regnum:frame-pointer a4) +(define-integrable regnum:dynamic-link a4) (define-integrable regnum:free-pointer a5) (define-integrable regnum:regs-pointer a6) (define-integrable regnum:stack-pointer a7) @@ -141,12 +136,12 @@ MIT in each case. |# registers) (define available-machine-registers - (list d0 d1 d2 d3 d4 d5 d6 a0 a1 a2 a3 a4)) + (list d0 d1 d2 d3 d4 d5 d6 a0 a1 a2 a3)) -(define-integrable (register-contains-address? register) - (memv register '(12 13 14 15))) +(define initial-address-registers + (list a4 a5 a6 a7)) -(define (pseudo-register=? x y) +(define-integrable (pseudo-register=? x y) (= (register-renumber x) (register-renumber y))) (define register-type @@ -191,12 +186,6 @@ MIT in each case. |# (define-integrable (interpreter-register:unbound?) (rtl:make-machine-register d0)) -(define-integrable (interpreter-frame-pointer) - (rtl:make-machine-register regnum:frame-pointer)) - -(define-integrable (interpreter-frame-pointer? register) - (= (rtl:register-number register) regnum:frame-pointer)) - (define-integrable (interpreter-free-pointer) (rtl:make-machine-register regnum:free-pointer)) @@ -214,9 +203,18 @@ MIT in each case. |# (define-integrable (interpreter-stack-pointer? register) (= (rtl:register-number register) regnum:stack-pointer)) + +(define-integrable (interpreter-dynamic-link) + (rtl:make-machine-register regnum:dynamic-link)) + +(define-integrable (interpreter-dynamic-link? register) + (= (rtl:register-number register) regnum:dynamic-link)) ;;;; Exports from machines/lapgen (define lap:make-label-statement) (define lap:make-unconditional-branch) -(define lap:make-entry-point) \ No newline at end of file +(define lap:make-entry-point) + +(define special-primitive-handlers + '()) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/fndblk.scm b/v7/src/compiler/rtlgen/fndblk.scm new file mode 100644 index 000000000..06ca71688 --- /dev/null +++ b/v7/src/compiler/rtlgen/fndblk.scm @@ -0,0 +1,190 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.1 1987/12/04 20:30:26 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Generation: Environment Locatives + +(declare (usual-integrations)) + +(define (find-variable start-block variable offset if-compiler if-ic if-cached) + (find-block/variable start-block variable offset + (lambda (offset-locative) + (lambda (block locative) + (if-compiler + (let ((locative + (offset-locative locative (variable-offset block variable)))) + (if (variable-in-cell? variable) + (rtl:make-fetch locative) + locative))))) + (lambda (block locative) + (cond ((variable-in-known-location? start-block variable) + (if-compiler + (rtl:locative-offset locative (variable-offset block variable)))) + ((ic-block/use-lookup? block) + (if-ic locative (variable-name variable))) + (else + (if-cached (variable-name variable))))))) + +(define (find-closure-variable block variable offset) + (find-block/variable block variable offset + (lambda (offset-locative) + (lambda (block locative) + (offset-locative locative (variable-offset block variable)))) + (lambda (block locative) + (error "Closure variable in IC frame" variable)))) + +(define (find-definition-variable block lvalue offset) + (find-block/variable block lvalue offset + (lambda (offset-locative) + (lambda (block locative) + (error "Definition of compiled variable" lvalue))) + (lambda (block locative) + (return-2 locative (variable-name lvalue))))) + +(define (find-block/variable block variable offset if-known if-ic) + (find-block block + offset + (lambda (block) + (or (memq variable (block-bound-variables block)) + (and (not (block-parent block)) + (memq variable (block-free-variables block))))) + (lambda (block locative) + ((enumeration-case block-type (block-type block) + ((STACK) (if-known stack-locative-offset)) + ((CLOSURE) (if-known rtl:locative-offset)) + ((IC) if-ic) + (else (error "Illegal result type" block))) + block locative)))) + +(define (nearest-ic-block-expression block offset) + (find-block block offset (lambda (block) (not (block-parent block))) + (lambda (block locative) + (if (ic-block? block) + locative + (error "NEAREST-IC-BLOCK-EXPRESSION: No IC block"))))) + +(define (closure-ic-locative closure-block block offset) + (find-block closure-block offset (lambda (block*) (eq? block* block)) + (lambda (block locative) + (if (ic-block? block) + locative + (error "Closure parent not IC block"))))) + +(define (block-ancestor-or-self->locative block block* offset) + (find-block block offset (lambda (block) (eq? block block*)) + (lambda (block locative) + (if (eq? block block*) + locative + (error "Block is not an ancestor" block*))))) + +(define (popping-limit/locative block offset block* extra) + (rtl:make-address + (stack-locative-offset (block-ancestor-or-self->locative block + block* + offset) + (+ extra (block-frame-size block*))))) + +(package (find-block) + +(define-export (find-block block offset end-block? receiver) + (transmit-values + (find-block/loop block end-block? (find-block/initial block offset)) + receiver)) + +(define (find-block/initial block offset) + (enumeration-case block-type (block-type block) + ((STACK) + (stack-locative-offset (rtl:make-fetch register:stack-pointer) offset)) + ((IC) + (rtl:make-fetch register:environment)) + (else + (error "Illegal initial block type" block)))) + +(define (find-block/loop block end-block? locative) + (if (or (end-block? block) + (ic-block? block)) + (return-2 block locative) + (find-block/loop (block-parent block) + end-block? + ((find-block/parent-procedure block) block locative)))) + +(define (find-block/parent-procedure block) + (enumeration-case block-type (block-type block) + ((STACK) + (let ((parent (block-parent block))) + (if parent + (enumeration-case block-type (block-type parent) + ((STACK) internal-block/parent-locative) + ((CLOSURE) stack-block/closure-parent-locative) + ((IC) stack-block/static-link-locative) + (else (error "Illegal procedure parent" parent))) + (error "Block has no parent" block)))) + ((CLOSURE) closure-block/parent-locative) + (else (error "Illegal parent block type" block)))) + +(define (find-block/same-block? block) + (lambda (block*) + (eq? block block*))) + +(define (find-block/specific start-block end-block locative) + (transmit-values + (find-block/loop start-block (find-block/same-block? end-block) locative) + (lambda (end-block locative) + locative))) + +(define (internal-block/parent-locative block locative) + (let ((links (block-stack-link block))) + (if (null? links) + (stack-block/static-link-locative block locative) + (find-block/specific + (car links) + (block-parent block) + (stack-locative-offset locative (block-frame-size block)))))) + +(define (stack-block/static-link-locative block locative) + (rtl:make-fetch + (stack-locative-offset locative (-1+ (block-frame-size block))))) + +(define (stack-block/closure-parent-locative block locative) + (rtl:make-fetch + (rtl:locative-offset + (rtl:make-fetch + (stack-locative-offset + locative + (procedure-closure-offset (block-procedure block)))) + 1))) + +(define (closure-block/parent-locative block locative) + (rtl:make-fetch (rtl:locative-offset locative 1))) + +) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm new file mode 100644 index 000000000..55b95ae83 --- /dev/null +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -0,0 +1,327 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.1 1987/12/04 20:30:30 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Generation: Inline Combinations + +(declare (usual-integrations)) + +(package (open-coding-analysis combination/inline) + +;;;; Analysis + +(define-export (open-coding-analysis applications) + (for-each (if compiler:open-code-primitives? + (lambda (application) + (if (eq? (application-type application) 'COMBINATION) + (set-combination/inliner! + application + (analyze-combination application)))) + (lambda (application) + (if (eq? (application-type application) 'COMBINATION) + (set-combination/inliner! application false)))) + applications)) + +(define (analyze-combination combination) + (let ((callee (rvalue-known-value (combination/operator combination)))) + (and callee + (rvalue/constant? callee) + (let ((value (constant-value callee))) + (and (scode/primitive-procedure? value) + (let ((entry + (assq (primitive-procedure-name value) + name->open-coders))) + (and entry + (try-handler combination value (cdr entry))))))))) + +(define (try-handler combination primitive entry) + (let ((operands (combination/operands combination))) + (and (primitive-arity-correct? primitive (length operands)) + (let ((result ((vector-ref entry 0) operands))) + (and result + (transmit-values result + (lambda (generator indices) + (make-inliner entry generator indices)))))))) + +;;;; Code Generator + +(define-export (combination/inline combination offset) + (generate/return* (combination/block combination) + (combination/continuation combination) + (let ((inliner (combination/inliner combination))) + (let ((handler (inliner/handler inliner)) + (generator (inliner/generator inliner)) + (expressions + (map (lambda (continuation) + (rtl:make-fetch + (continuation*/register continuation))) + (inliner/operands inliner)))) + (make-return-operand + (lambda (offset) + ((vector-ref handler 1) generator expressions)) + (lambda (offset finish) + ((vector-ref handler 2) generator + expressions + finish)) + (lambda (offset finish) + ((vector-ref handler 3) generator + expressions + finish)) + false))) + offset)) + +(define (invoke/effect->effect generator expressions) + (generator expressions false)) + +(define (invoke/predicate->value generator expressions finish) + (generator expressions + (lambda (pcfg) + (let ((temporary (rtl:make-pseudo-register))) + (scfg*scfg->scfg! + (pcfg*scfg->scfg! + pcfg + (rtl:make-assignment temporary (rtl:make-constant true)) + (rtl:make-assignment temporary (rtl:make-constant false))) + (finish (rtl:make-fetch temporary))))))) + +(define (invoke/value->effect generator expressions) + (make-null-cfg)) + +(define (invoke/value->predicate generator expressions finish) + (generator expressions + (lambda (expression) + (finish (rtl:make-true-test expression))))) + +(define (invoke/value->value generator expressions finish) + (generator expressions finish)) + +;;;; Definers + +(define (open-coder-definer ->effect ->predicate ->value) + (let ((per-name + (lambda (name handler) + (let ((entry (assq name name->open-coders)) + (item (vector handler ->effect ->predicate ->value))) + (if entry + (set-cdr! entry item) + (set! name->open-coders + (cons (cons name item) name->open-coders))))))) + (lambda (name handler) + (if (pair? name) + (for-each (lambda (name) + (per-name name handler)) + name) + (per-name name handler)) + name))) + +(define name->open-coders + '()) + +(define define-open-coder/effect + (open-coder-definer invoke/effect->effect + invoke/value->predicate + invoke/value->value)) + +(define define-open-coder/predicate + (open-coder-definer invoke/value->effect + invoke/value->value + invoke/predicate->value)) + +(define define-open-coder/value + (open-coder-definer invoke/value->effect + invoke/value->predicate + invoke/value->value)) + +;;;; Operand Filters + +(define (filter/constant rvalue predicate generator) + (let ((operand (rvalue-known-value rvalue))) + (and operand + (rvalue/constant? operand) + (let ((value (constant-value operand))) + (and (predicate value) + (generator value)))))) + +(define (filter/nonnegative-integer operand generator) + (filter/constant operand + (lambda (value) + (and (integer? value) + (not (negative? value)))) + generator)) + +(define (filter/positive-integer operand generator) + (filter/constant operand + (lambda (value) + (and (integer? value) + (positive? value))) + generator)) + +;;;; Open Coders + +(let ((open-code/type-test + (lambda (type) + (lambda (expressions finish) + (finish + (rtl:make-type-test (rtl:make-object->type (car expressions)) + type)))))) + + (let ((define/type-test + (lambda (name type) + (define-open-coder/predicate name + (lambda (operands) + (return-2 (open-code/type-test type) '(0))))))) + (define/type-test 'PAIR? (ucode-type pair)) + (define/type-test 'STRING? (ucode-type string)) + (define/type-test 'BIT-STRING? (ucode-type vector-1b))) + + (define-open-coder/predicate 'PRIMITIVE-TYPE? + (lambda (operands) + (filter/nonnegative-integer (car operands) + (lambda (type) + (return-2 (open-code/type-test type) '(1))))))) + +(let ((open-code/eq-test + (lambda (expressions finish) + (finish (rtl:make-eq-test (car expressions) (cadr expressions)))))) + (define-open-coder/predicate 'EQ? + (lambda (operands) + (return-2 open-code/eq-test '(0 1))))) + +(let ((open-code/pair-cons + (lambda (type) + (lambda (expressions finish) + (finish + (rtl:make-typed-cons:pair (rtl:make-constant type) + (car expressions) + (cadr expressions))))))) + + (define-open-coder/value 'CONS + (lambda (operands) + (return-2 (open-code/pair-cons (ucode-type pair)) '(0 1)))) + + (define-open-coder/value 'SYSTEM-PAIR-CONS + (lambda (operands) + (filter/nonnegative-integer (car operands) + (lambda (type) + (return-2 (open-code/pair-cons type) '(1 2))))))) + +(let ((open-code/memory-length + (lambda (index) + (lambda (expressions finish) + (finish + (rtl:make-cons-pointer + (rtl:make-constant (ucode-type fixnum)) + (rtl:make-fetch + (rtl:locative-offset (car expressions) index)))))))) + (let ((define/length + (lambda (name index) + (define-open-coder/value name + (lambda (operands) + (return-2 (open-code/memory-length index) '(0))))))) + (define/length '(VECTOR-LENGTH SYSTEM-VECTOR-SIZE) 0) + (define/length '(STRING-LENGTH BIT-STRING-LENGTH) 1))) + +(let ((open-code/memory-ref + (lambda (index) + (lambda (expressions finish) + (finish + (rtl:make-fetch (rtl:locative-offset (car expressions) index))))))) + + (let ((define/ref + (lambda (name index) + (define-open-coder/value name + (lambda (operands) + (return-2 (open-code/memory-ref 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)) + + (define-open-coder/value '(VECTOR-REF SYSTEM-VECTOR-REF) + (lambda (operands) + (filter/nonnegative-integer (cadr operands) + (lambda (index) + (return-2 (open-code/memory-ref index) '(0))))))) + +(let ((open-code/general-car-cdr + (lambda (pattern) + (lambda (expressions finish) + (finish + (let loop ((pattern pattern) (expression (car expressions))) + (if (= pattern 1) + expression + (let ((qr (integer-divide pattern 2))) + (loop (integer-divide-quotient qr) + (rtl:make-fetch + (rtl:locative-offset + expression + (- 1 (integer-divide-remainder qr))))))))))))) + (define-open-coder/value 'GENERAL-CAR-CDR + (lambda (operands) + (filter/positive-integer (cadr operands) + (lambda (pattern) + (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))) + (let ((assignment + (rtl:make-assignment locative (cadr expressions)))) + (if finish + (let ((temporary (rtl:make-pseudo-register))) + (scfg-append! + (rtl:make-assignment temporary (rtl:make-fetch locative)) + assignment + (finish (rtl:make-fetch temporary)))) + assignment))))))) + + (let ((define/set! + (lambda (name index) + (define-open-coder/effect name + (lambda (operands) + (return-2 (open-code/memory-assignment index) '(0 1))))))) + (define/set! '(SET-CAR! SYSTEM-PAIR-SET-CAR! + SET-CELL-CONTENTS! + SYSTEM-HUNK3-SET-CXR0!) + 0) + (define/set! '(SET-CDR! SYSTEM-PAIR-SET-CDR! SYSTEM-HUNK3-SET-CXR1!) 1) + (define/set! 'SYSTEM-HUNK3-SET-CXR2! 2)) + + (define-open-coder/effect '(VECTOR-SET! SYSTEM-VECTOR-SET!) + (lambda (operands) + (filter/nonnegative-integer (cadr operands) + (lambda (index) + (return-2 (open-code/memory-assignment index) '(0 2))))))) + +;;; end COMBINATION/INLINE +) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index af9172d12..a01bb62e4 100644 --- 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.34 1987/09/03 05:10:05 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.1 1987/12/04 20:30:36 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,444 +36,256 @@ MIT in each case. |# (declare (usual-integrations)) -(define-generator combination-tag - (lambda (combination subproblem?) - (if (combination-constant? combination) - (combination/constant combination subproblem?) - (let ((callee (combination-known-operator combination))) - (let ((operator - (generate/subproblem-cfg (combination-operator combination))) - (operands - (if (and callee - (procedure? callee) - (not (procedure-externally-visible? callee))) - (generate-operands (procedure-original-required callee) - (procedure-original-optional callee) - (procedure-original-rest callee) - (combination-operands combination)) - (map generate/operand - (combination-operands combination))))) - (or (and callee - (normal-primitive-constant? callee) - (let ((open-coder - (assq (constant-value callee) - (cdr primitive-open-coders)))) - (and open-coder - ((cdr open-coder) combination - subproblem? - operator - operands)))) - (combination/normal combination - subproblem? - operator - operands))))))) - -(define combination/constant - (normal-statement-generator - (lambda (combination subproblem?) - (let ((value (combination-value combination))) - (cond ((temporary? value) - (transmit-values (generate/rvalue (vnode-known-value value)) - (lambda (prefix expression) - (scfg*scfg->scfg! - prefix - (generate/assignment (combination-block combination) - value - expression - subproblem?))))) - ((value-ignore? value) - (make-null-cfg)) - (else - (error "Unknown combination value" value))))))) - -(define (generate-operands required optional rest operands) - (define (required-loop required operands) - (if (null? required) - (optional-loop optional operands) - (cons ((if (integrated-vnode? (car required)) - generate/operand-no-value - generate/operand) - (car operands)) - (required-loop (cdr required) (cdr operands))))) - - (define (optional-loop optional operands) - (cond ((null? operands) '()) - ((null? optional) - (if (not rest) - '() - (map (if (integrated-vnode? rest) - generate/operand-no-value - generate/operand) - operands))) - (else - (cons ((if (integrated-vnode? (car optional)) - generate/operand-no-value - generate/operand) - (car operands)) - (optional-loop (cdr optional) (cdr operands)))))) - - (required-loop required operands)) - -(define (generate/operand-no-value operand) - (return-3 (generate/subproblem-cfg operand) (make-null-cfg) false)) - -(define (combination/normal combination subproblem? operator operands) - ;; For the time being, all close-coded combinations will return - ;; their values in the value register. - (generate/normal-statement combination subproblem? - (lambda (combination subproblem?) - (let ((value (combination-value combination))) - (cond ((temporary? value) - (if (not subproblem?) - (error "Reduction targeted to temporary!" combination)) - (scfg*scfg->scfg! - (combination/subproblem combination operator operands) - (rtl:make-assignment value (rtl:make-fetch register:value)))) - ((or (value-register? value) - (value-ignore? value)) - ((if subproblem? combination/subproblem combination/reduction) - combination - operator - operands)) +(package (generate/combination) + +(define (generate/combination combination offset) + (if (combination/inline? combination) + (combination/inline combination offset) + (combination/normal combination offset))) + +(define (combination/normal combination offset) + (let ((block (combination/block combination)) + (operator (combination/operator combination)) + (frame-size (combination/frame-size combination)) + (continuation (combination/continuation combination))) + (let ((callee (rvalue-known-value operator))) + (let ((finish + (lambda (invocation callee-external?) + (if (return-operator/subproblem? continuation) + (invocation operator + offset + frame-size + (continuation/label continuation) + invocation-prefix/null) + (invocation operator + offset + frame-size + false + (generate/invocation-prefix + block + offset + callee + continuation + callee-external?)))))) + (cond ((not callee) + (finish (if (reference? operator) + invocation/reference + invocation/apply) + true)) + ((rvalue/constant? callee) + (finish + (if (normal-primitive-procedure? (constant-value callee)) + invocation/primitive + invocation/apply) + true)) + ((rvalue/procedure? callee) + (case (procedure/type callee) + ((OPEN-EXTERNAL) (finish invocation/jump true)) + ((OPEN-INTERNAL) (finish invocation/jump false)) + ((CLOSURE) (finish invocation/jump true)) + ((IC) (finish invocation/ic true)) + (else (error "Unknown procedure type" callee)))) (else - (error "Unknown combination value" value))))))) - -(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)) - -(define (combination/subproblem combination operator operands) - (let ((block (combination-block combination))) - (define (finish call-prefix continuation-prefix) - (let ((continuation (make-continuation block *current-rgraph*))) - (let ((continuation-cfg - (scfg*scfg->scfg! - (rtl:make-continuation-heap-check continuation) - continuation-prefix))) - (set-continuation-rtl-edge! - continuation - (node->edge (cfg-entry-node continuation-cfg))) - (make-scfg - (cfg-entry-node - (scfg*scfg->scfg! - (call-prefix continuation) - ((let ((callee (combination-known-operator combination))) - (cond ((normal-primitive-constant? callee) - make-call/primitive) - ((or (not callee) (not (procedure? callee))) - make-call/unknown) - (else - (case (procedure/type callee) - ((OPEN-INTERNAL) make-call/stack-with-link) - ((OPEN-EXTERNAL) make-call/stack-with-link) - ((CLOSURE) make-call/closure) - ((IC) make-call/ic) - (else (error "Unknown callee type" callee)))))) - combination operator operands invocation-prefix/null - continuation))) - (scfg-next-hooks continuation-cfg))))) - - (cond ((ic-block? block) - ;; **** Actually, should only do this if the environment - ;; will be needed by the continuation. - (finish (lambda (continuation) - (scfg*scfg->scfg! - (rtl:make-push (rtl:make-fetch register:environment)) - (rtl:make-push-return continuation))) - (rtl:make-pop register:environment))) - ((and (stack-block? block) - (let ((callee (combination-known-operator combination))) - (and callee - (procedure? callee) - (procedure/open-internal? callee)))) - (finish rtl:make-message-receiver:subproblem (make-null-cfg))) - (else - (finish rtl:make-push-return (make-null-cfg)))))) - -(define (combination/reduction combination operator operands) - (let ((block (combination-block combination)) - (callee (combination-known-operator combination))) - (let ((caller (block-procedure block)) - (generator - (cond ((normal-primitive-constant? callee) - make-call/primitive) - ((or (not callee) - (not (procedure? callee))) - make-call/unknown) - (else - (case (procedure/type callee) - ((IC) make-call/ic) - ((CLOSURE) make-call/closure) - ((OPEN-EXTERNAL) make-call/stack-with-link) - ((OPEN-INTERNAL) false) - (else (error "Unknown callee type" callee))))))) - (cond ((or (not caller) (procedure/ic? caller)) - (if generator - (generator combination operator operands - invocation-prefix/null false) - (error "Calling internal procedure from IC procedure"))) - ((procedure/external? caller) - (if generator - (generator combination operator operands - invocation-prefix/move-frame-up false) - (make-call/child combination operator operands - rtl:make-message-receiver:closure))) - (else - (if generator - (generator combination operator operands - invocation-prefix/internal->closure false) - (let ((block* (procedure-block callee))) - (cond ((block-child? block block*) - (make-call/child combination operator operands - rtl:make-message-receiver:stack)) - ((block-sibling? block block*) - (make-call/stack combination operator operands - invocation-prefix/internal->sibling - false)) - (else - (make-call/stack-with-link - combination operator operands - invocation-prefix/internal->ancestor - false)))))))))) + (finish invocation/apply true))))))) -;;;; Calls - -(define (make-call/apply combination operator operands prefix continuation) - (make-call true combination operator operands - (lambda (frame-size) - (rtl:make-invocation:apply frame-size - (prefix combination frame-size) - continuation)))) - -(define (make-call/unknown combination operator operands prefix - continuation) - (let ((callee (subproblem-value (combination-operator combination)))) - ((if (reference? callee) - make-call/reference - make-call/apply) - combination operator operands prefix continuation))) - -;;; For now, use apply. Later we can optimize for the cases where -;;; the callee's closing frame is easily available, such as calling a -;;; sibling, self-recursion, or an ancestor. - -(define make-call/ic make-call/apply) - -(define (make-call/primitive combination operator operands prefix continuation) - (make-call false combination operator operands - (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) +;;;; Invocations + +(define (invocation/jump operator offset frame-size continuation prefix) + (let ((callee (rvalue-known-value operator))) + (scfg*scfg->scfg! + (prefix frame-size) + (if (procedure-inline-code? callee) + (generate/procedure-entry/inline callee) + (begin + (enqueue-procedure! callee) + ((if (procedure-rest callee) + rtl:make-invocation:lexpr + rtl:make-invocation:jump) + frame-size continuation - prim)))))) - -(define special-primitive-handlers - (list 'SPECIAL-PRIMITIVE-HANDLERS)) + (procedure-label callee))))))) -(define define-special-primitive-handler - (define-primitive-handler special-primitive-handlers)) - -(define (make-call/reference combination operator operands prefix continuation) - (make-call false combination operator operands - (lambda (number-pushed) - (let ((operator (subproblem-value (combination-operator combination))) - (frame-size (1+ number-pushed))) - (let ((variable (reference-variable operator)) - (make-application - (lambda (operator) - (scfg*scfg->scfg! - (rtl:make-push operator) - (rtl:make-invocation:apply - frame-size - (prefix combination frame-size) - continuation))))) - (find-variable (reference-block operator) variable - (lambda (locative) - (make-application (rtl:make-fetch locative))) - (lambda (environment name) - (rtl:make-invocation:lookup - frame-size - (prefix combination number-pushed) - continuation - environment - (intern-scode-variable! (reference-block operator) name))) - (lambda (name) - (if (memq 'UUO-LINK (variable-declarations variable)) - (rtl:make-invocation:uuo-link - frame-size - (prefix combination number-pushed) - continuation - name) - (let* ((temp (make-temporary)) - (cell (rtl:make-fetch temp)) - (contents (rtl:make-fetch cell))) - (let ((n1 - (rtl:make-assignment - temp - (rtl:make-variable-cache name))) - (n2 - (rtl:make-type-test (rtl:make-object->type contents) - (ucode-type reference-trap))) - (n3 (make-application contents)) - (n4 - (rtl:make-invocation:cache-reference - frame-size - (prefix combination number-pushed) - continuation - cell))) - (scfg-next-connect! n1 n2) - (pcfg-consequent-connect! n2 n4) - (pcfg-alternative-connect! n2 n3) - (make-scfg (cfg-entry-node n1) - (hooks-union (scfg-next-hooks n3) - (scfg-next-hooks n4))))))))))))) - -(define (make-call/child combination operator operands make-receiver) - (scfg*scfg->scfg! - (make-receiver (block-frame-size (combination-block combination))) - (make-call/stack-with-link combination operator operands - invocation-prefix/null false))) +(define (invocation/apply operator offset frame-size continuation prefix) + (invocation/apply* frame-size continuation prefix)) -(package (make-call/closure make-call/stack make-call/stack-with-link) +(define (invocation/apply* frame-size continuation prefix) + (scfg*scfg->scfg! (prefix frame-size) + (rtl:make-invocation:apply frame-size continuation))) -(define-export (make-call/closure combination operator operands prefix - continuation) - (make-call true combination operator operands - (internal-call combination prefix continuation 0))) +(define invocation/ic + ;; For now, use apply. Later we can optimize for the cases where + ;; the callee's closing frame is easily available, such as calling a + ;; sibling, self-recursion, or an ancestor. + invocation/apply) -(define-export (make-call/stack combination operator operands prefix - continuation) - (stack-call combination operator operands prefix continuation 0)) - -(define-export (make-call/stack-with-link combination operator operands prefix - continuation) +(define (invocation/primitive operator offset frame-size continuation prefix) (scfg*scfg->scfg! - (rtl:make-push - (rtl:make-address - (block-ancestor-or-self->locative - (combination-block combination) - (block-parent - (procedure-block (combination-known-operator combination)))))) - (stack-call combination operator operands prefix continuation 1))) - -(define (stack-call combination operator operands prefix continuation extra) - (make-call false combination operator operands - (internal-call combination prefix continuation extra))) - -(define (internal-call combination prefix continuation extra) - (lambda (number-pushed) - (let ((operator (combination-known-operator combination))) - ((if (procedure-rest operator) - rtl:make-invocation:lexpr - rtl:make-invocation:jump) - number-pushed - (prefix combination (+ number-pushed extra)) - continuation - operator)))) - + (prefix frame-size) + (let ((primitive + (let ((primitive (constant-value (rvalue-known-value operator)))) + (if (eq? primitive compiled-error-procedure) + primitive + (primitive-procedure-name primitive))))) + ((if (memq primitive special-primitive-handlers) + rtl:make-invocation:special-primitive + rtl:make-invocation:primitive) + (1+ frame-size) + continuation + primitive)))) + +(package (invocation/reference) + +(define-export (invocation/reference operator offset frame-size continuation + prefix) + (let ((block (reference-block operator)) + (variable (reference-lvalue operator))) + (find-variable block variable offset + (lambda (locative) + (scfg*scfg->scfg! + (rtl:make-push (rtl:make-fetch locative)) + (invocation/apply* (1+ frame-size) continuation prefix))) + (lambda (environment name) + (invocation/lookup frame-size + continuation + (prefix frame-size) + environment + (intern-scode-variable! block name))) + (lambda (name) + (if (memq 'UUO-LINK (variable-declarations variable)) + (invocation/uuo-link frame-size + continuation + (prefix frame-size) + name) + (invocation/cache-reference frame-size + continuation + prefix + name)))))) + +(define (invocation/lookup frame-size + continuation + prefix + environment + variable) + (let ((make-invocation + (lambda (environment) + (expression-simplify-for-statement environment + (lambda (environment) + (rtl:make-invocation:lookup (1+ frame-size) + continuation + environment + variable)))))) + (if (cfg-null? prefix) + (make-invocation environment) + (scfg-append! (rtl:make-assignment register:environment environment) + prefix + (make-invocation register:environment))))) + +(define (invocation/uuo-link frame-size continuation prefix name) + (scfg*scfg->scfg! prefix + (rtl:make-invocation:uuo-link (1+ frame-size) + continuation + name))) + +(define (invocation/cache-reference frame-size continuation prefix name) + (let* ((temp (rtl:make-pseudo-register)) + (cell (rtl:make-fetch temp)) + (contents (rtl:make-fetch cell))) + (let ((n1 (rtl:make-assignment temp (rtl:make-variable-cache name))) + (n2 + (rtl:make-type-test (rtl:make-object->type contents) + (ucode-type reference-trap))) + (n3 + (scfg*scfg->scfg! + (rtl:make-push contents) + (invocation/apply* (1+ frame-size) continuation prefix))) + (n4 + (scfg*scfg->scfg! + (prefix frame-size) + (expression-simplify-for-statement cell + (lambda (cell) + (rtl:make-invocation:cache-reference (1+ frame-size) + continuation + cell)))))) + (scfg-next-connect! n1 n2) + (pcfg-consequent-connect! n2 n4) + (pcfg-alternative-connect! n2 n3) + (make-scfg (cfg-entry-node n1) + (hooks-union (scfg-next-hooks n3) + (scfg-next-hooks n4)))))) + +;;; end INVOCATION/REFERENCE ) -(define (make-call push-operator? combination operator operands generator) - (let ((callee (combination-known-operator combination)) - (n-operands (count-operands operands)) - (finish - (lambda (frame-size) - (scfg-append! - (scfg*->scfg! - (map (lambda (operand) - (transmit-values operand - (lambda (cfg prefix expression) - (if expression - (scfg-append! cfg - prefix - (rtl:make-push expression)) - cfg)))) - (reverse operands))) - operator - (if push-operator? - (transmit-values - (generate/rvalue - (subproblem-value (combination-operator combination))) - (lambda (prefix expression) - (scfg-append! prefix - (rtl:make-push expression) - (generator (1+ frame-size))))) - (generator frame-size)))))) - (if (and callee - (procedure? callee) - (not (procedure-rest callee)) - (stack-block? (procedure-block callee))) - (let ((n-parameters (+ (length (procedure-required callee)) - (length (procedure-optional callee))))) - (scfg*scfg->scfg! - (scfg*->scfg! - (let loop ((n (- n-parameters n-operands))) - (if (zero? n) - '() - (cons (rtl:make-push (rtl:make-unassigned)) - (loop (-1+ n)))))) - (finish n-parameters))) - (finish n-operands)))) +;;;; Prefixes -(define (count-operands operands) - (cond ((null? operands) - 0) - ((transmit-values (car operands) - (lambda (cfg prefix expression) - expression)) - (1+ (count-operands (cdr operands)))) - (else - (count-operands (cdr operands))))) +(package (generate/invocation-prefix invocation-prefix/null) + +(define-export (generate/invocation-prefix block + offset + callee + continuation + callee-external?) + (let ((caller (block-procedure block))) + (cond ((or (not (rvalue/procedure? caller)) + (procedure/ic? caller)) + invocation-prefix/null) + ((procedure/external? caller) + (if callee-external? + (invocation-prefix/move-frame-up block offset block) + invocation-prefix/null)) + (callee-external? + (invocation-prefix/erase-to block + offset + continuation + (stack-block/external-ancestor block))) + (else + (let ((block* (procedure-block callee))) + (cond ((block-child? block block*) + invocation-prefix/null) + ((block-sibling? block block*) + (invocation-prefix/move-frame-up block offset block)) + (else + (invocation-prefix/erase-to + block + offset + continuation + (block-farthest-uncommon-ancestor block block*))))))))) + +(define (invocation-prefix/erase-to block offset continuation callee-limit) + (let ((popping-limit (reduction-continuation/popping-limit continuation))) + (if popping-limit + (invocation-prefix/move-frame-up block + offset + (if (block-ancestor? callee-limit + popping-limit) + callee-limit + popping-limit)) + (invocation-prefix/dynamic-link + (popping-limit/locative block offset callee-limit 0))))) -;;;; Prefixes +;;; The invocation prefix is always one of the following: -(define (invocation-prefix/null combination frame-size) - '(NULL)) +(define-export (invocation-prefix/null frame-size) + (make-null-cfg)) -(define (invocation-prefix/move-frame-up combination frame-size) - `(MOVE-FRAME-UP ,frame-size - ,(block-frame-size (combination-block combination)))) +(define (invocation-prefix/move-frame-up block offset block*) + (invocation-prefix/move-frame-up* + (popping-limit/locative block offset block* 0))) -(define (invocation-prefix/internal->closure combination frame-size) - ;; The message sender will shift the new stack frame down to the - ;; correct position when it is done, then reset the stack pointer. - `(APPLY-CLOSURE ,frame-size - ,(block-frame-size (combination-block combination)))) +(define (invocation-prefix/move-frame-up* locative) + (lambda (frame-size) + (expression-simplify-for-statement locative + (lambda (locative) + (rtl:make-invocation-prefix:move-frame-up frame-size locative))))) -(define (invocation-prefix/internal->ancestor combination frame-size) - (let ((block (combination-block combination))) - `(APPLY-STACK ,frame-size - ,(block-frame-size block) - ,(-1+ - (block-ancestor-distance - block - (block-parent - (procedure-block - (combination-known-operator combination)))))))) +(define (invocation-prefix/dynamic-link locative) + (lambda (frame-size) + (expression-simplify-for-statement locative + (lambda (locative) + (rtl:make-invocation-prefix:dynamic-link frame-size locative))))) + +;;; end GENERATE/INVOCATION-PREFIX +) -(define (invocation-prefix/internal->sibling combination frame-size) - `(MOVE-FRAME-UP ,frame-size - ;; -1+ means reuse the existing static link. - ,(-1+ (block-frame-size (combination-block combination))))) \ No newline at end of file +;;; end GENERATE/COMBINATION +) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgproc.scm b/v7/src/compiler/rtlgen/rgproc.scm index 940b8759e..ca41440a0 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 1.5 1987/06/23 03:31:43 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.1 1987/12/04 20:31:27 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,38 +38,38 @@ MIT in each case. |# (package (generate/procedure-header) -(define-export (generate/procedure-header procedure body) +(define-export (generate/procedure-header procedure body inline?) (scfg*scfg->scfg! (if (procedure/ic? procedure) - (setup-ic-frame procedure) (scfg*scfg->scfg! - ((if (or (procedure-rest procedure) - (and (procedure/closure? procedure) - (not (null? (procedure-optional procedure))))) - rtl:make-setup-lexpr - rtl:make-procedure-heap-check) - procedure) + (if inline? + (make-null-cfg) + (rtl:make-procedure-heap-check (procedure-label procedure))) + (setup-ic-frame procedure)) + (scfg*scfg->scfg! + (cond ((or (procedure-rest procedure) + (and (procedure/closure? procedure) + (not (null? (procedure-optional procedure))))) + (rtl:make-setup-lexpr (procedure-label procedure))) + (inline? + (make-null-cfg)) + (else + (rtl:make-procedure-heap-check (procedure-label procedure)))) (setup-stack-frame procedure))) body)) (define (setup-ic-frame procedure) - (scfg-append! - (rtl:make-procedure-heap-check procedure) - (rtl:make-assignment register:frame-pointer - (rtl:make-fetch register:stack-pointer)) - (scfg*->scfg! - (map (let ((block (procedure-block procedure))) - (lambda (name value) - (transmit-values (generate/rvalue value) - (lambda (prefix expression) - (scfg*scfg->scfg! - prefix - (rtl:make-interpreter-call:set! - (rtl:make-fetch register:environment) - (intern-scode-variable! block (variable-name name)) - expression)))))) - (procedure-names procedure) - (procedure-values procedure))))) + (scfg*->scfg! + (map (let ((block (procedure-block procedure))) + (lambda (name value) + (generate/rvalue value 0 scfg*scfg->scfg! + (lambda (expression) + (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) (let ((block (procedure-block procedure))) @@ -79,7 +79,7 @@ MIT in each case. |# (define (cellify-variable variable) (if (variable-in-cell? variable) (let ((locative - (stack-locative-offset (rtl:make-fetch register:frame-pointer) + (stack-locative-offset (rtl:make-fetch register:stack-pointer) (variable-offset block variable)))) (rtl:make-assignment locative @@ -88,24 +88,22 @@ MIT in each case. |# (let ((names (procedure-names procedure)) (values (procedure-values procedure))) - (scfg-append! (setup-bindings names values '()) - (setup-auxiliary (procedure-auxiliary procedure) '()) - (rtl:make-assignment - register:frame-pointer - (rtl:make-fetch register:stack-pointer)) - (cellify-variables (procedure-required procedure)) - (cellify-variables (procedure-optional procedure)) - (let ((rest (procedure-rest procedure))) - (if rest - (cellify-variable rest) - (make-null-cfg))) - (scfg*->scfg! - (map (lambda (name value) - (if (and (procedure? value) - (procedure/closure? value)) - (letrec-close block name value) - (make-null-cfg))) - names values)))))) + (scfg-append! + (setup-bindings names values '()) + (cellify-variables (procedure-required-arguments procedure)) + (cellify-variables (procedure-optional procedure)) + (let ((rest (procedure-rest procedure))) + (if rest + (cellify-variable rest) + (make-null-cfg))) + (scfg*->scfg! + (map (lambda (name value) + (if (and (procedure? value) + (procedure/closure? value) + (procedure-closing-block value)) + (letrec-close block name value) + (make-null-cfg))) + names values)))))) (define (setup-bindings names values pushes) (if (null? names) @@ -116,10 +114,16 @@ MIT in each case. |# (letrec-value (car values))) pushes)))) +(define (make-auxiliary-push variable value) + (rtl:make-push (if (variable-in-cell? variable) + (rtl:make-cell-cons value) + value))) + (define (letrec-value value) (cond ((constant? value) (rtl:make-constant (constant-value value))) ((procedure? value) + (enqueue-procedure! value) (case (procedure/type value) ((CLOSURE) (make-closure-cons value (rtl:make-constant '()))) @@ -133,12 +137,12 @@ MIT in each case. |# (error "Unknown letrec binding value" value)))) (define (letrec-close block variable value) - (transmit-values (make-closure-environment value) + (transmit-values (make-closure-environment value 0) (lambda (prefix environment) (scfg*scfg->scfg! prefix (rtl:make-assignment (closure-procedure-environment-locative - (find-variable block variable + (find-variable block variable 0 (lambda (locative) locative) (lambda (nearest-ic-locative name) (error "Missing closure variable" variable)) @@ -146,18 +150,8 @@ MIT in each case. |# (error "Missing closure variable" variable)))) environment))))) -(define (setup-auxiliary variables pushes) - (if (null? variables) - (scfg*->scfg! pushes) - (setup-auxiliary (cdr variables) - (cons (make-auxiliary-push (car variables) - (rtl:make-unassigned)) - pushes)))) - -(define (make-auxiliary-push variable value) - (rtl:make-push (if (variable-in-cell? variable) - (rtl:make-cell-cons value) - value))) +(define-integrable (closure-procedure-environment-locative locative) + (rtl:locative-offset (rtl:make-fetch locative) 1)) ;;; end GENERATE/PROCEDURE-HEADER ) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgretn.scm b/v7/src/compiler/rtlgen/rgretn.scm new file mode 100644 index 000000000..be67b165e --- /dev/null +++ b/v7/src/compiler/rtlgen/rgretn.scm @@ -0,0 +1,195 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.1 1987/12/04 20:31:36 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; RTL Generation: Return Statements + +(declare (usual-integrations)) + +(define (generate/return return offset) + (generate/return* (return/block return) + (return/operator return) + (trivial-return-operand (return/operand return)) + offset)) + +(define (trivial-return-operand operand) + (make-return-operand + (lambda (offset) + (make-null-cfg)) + (lambda (offset finish) + (generate/rvalue operand offset scfg*scfg->scfg! + (lambda (expression) + (finish (rtl:make-true-test expression))))) + (lambda (offset finish) + (generate/rvalue operand offset scfg*scfg->scfg! finish)) + (rvalue-known-value operand))) + +(define-structure (return-operand (conc-name return-operand/)) + (effect-generator false read-only true) + (predicate-generator false read-only true) + (value-generator false read-only true) + (known-value false read-only true)) + +(package (generate/return*) + +(define-export (generate/return* block operator operand offset) + (let ((continuation (rvalue-known-value operator))) + (if (and continuation + (continuation/always-known-operator? continuation)) + ((method-table-lookup simple-methods (continuation/type continuation)) + block + operator + operand + offset + continuation) + (scfg-append! + (if (and continuation (continuation/effect? continuation)) + (scfg*scfg->scfg! + (effect-prefix operand offset) + (rtl:make-assignment register:value (rtl:make-constant false))) + ((return-operand/value-generator operand) + offset + (lambda (expression) + (rtl:make-assignment register:value expression)))) + (return-operator/pop-frames block operator offset 0) + (rtl:make-pop-return))))) + +(define-integrable (continuation/effect? continuation) + (eq? continuation-type/effect (continuation/type continuation))) + +(define simple-methods + (make-method-table continuation-types false)) + +(define-method-table-entry 'EFFECT simple-methods + (lambda (block operator operand offset continuation) + (scfg-append! + (effect-prefix operand offset) + (common-prefix block operator offset continuation) + (generate/node/memoize (continuation/entry-node continuation) + (continuation/offset continuation))))) + +(define-method-table-entries '(REGISTER VALUE) simple-methods + (lambda (block operator operand offset continuation) + (scfg-append! + (if (lvalue-integrated? (continuation/parameter continuation)) + (effect-prefix operand offset) + (value-prefix operand offset continuation)) + (common-prefix block operator offset continuation) + (generate/node/memoize (continuation/entry-node continuation) + (continuation/offset continuation))))) + +(define-method-table-entry 'PUSH simple-methods + (lambda (block operator operand offset continuation) + (scfg*scfg->scfg! + (let ((prefix (common-prefix block operator offset continuation))) + (if (cfg-null? prefix) + ((return-operand/value-generator operand) + offset + (lambda (expression) + (rtl:make-push expression))) + (scfg-append! + (value-prefix operand offset continuation) + prefix + (rtl:make-push + (rtl:make-fetch (continuation/register continuation)))))) + (generate/node/memoize (continuation/entry-node continuation) + (1+ (continuation/offset continuation)))))) + +(define-method-table-entry 'PREDICATE simple-methods + (lambda (block operator operand offset continuation) + (let ((node (continuation/entry-node continuation)) + (offset* (continuation/offset continuation)) + (value (return-operand/known-value operand)) + (prefix (common-prefix block operator offset continuation))) + (if value + (scfg-append! + (effect-prefix operand offset) + prefix + (generate/node/memoize (if (and (rvalue/constant? value) + (false? (constant-value value))) + (pnode-alternative node) + (pnode-consequent node)) + offset*)) + (let ((finish + (lambda (pcfg) + (pcfg*scfg->scfg! + pcfg + (generate/node/memoize (pnode-consequent node) offset*) + (generate/node/memoize (pnode-alternative node) + offset*))))) + (if (cfg-null? prefix) + ((return-operand/predicate-generator operand) offset finish) + (scfg-append! + (value-prefix operand offset continuation) + prefix + (finish + (rtl:make-true-test + (rtl:make-fetch + (continuation/register continuation))))))))))) + +(define (return-operator/pop-frames block operator offset extra) + (if (or (ic-block? block) + (return-operator/subproblem? operator)) + (make-null-cfg) + (let ((popping-limit (reduction-continuation/popping-limit operator))) + (if popping-limit + (rtl:make-assignment register:stack-pointer + (popping-limit/locative block + offset + popping-limit + extra)) + (scfg*scfg->scfg! + (rtl:make-pop-link) + (if (zero? extra) + (make-null-cfg) + (rtl:make-assignment register:stack-pointer + (rtl:make-address + (stack-locative-offset + (rtl:make-fetch register:stack-pointer) + extra))))))))) + +(define (value-prefix operand offset continuation) + ((return-operand/value-generator operand) + offset + (lambda (expression) + (rtl:make-assignment (continuation/register continuation) expression)))) + +(define-integrable (effect-prefix operand offset) + ((return-operand/effect-generator operand) offset)) + +(define (common-prefix block operator offset continuation) + (scfg*scfg->scfg! + (return-operator/pop-frames block operator offset 0) + (generate/continuation-entry/ic-block continuation))) + +) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index 49d72274c..c35d8701d 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 1.13 1987/07/26 22:06:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.1 1987/12/04 20:31:40 cph Exp $ #| -*-Scheme-*- Copyright (c) 1987 Massachusetts Institute of Technology -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 1.13 1987/07/26 22:06:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.1 1987/12/04 20:31:40 cph Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -36,56 +36,91 @@ promotional, or sales literature without prior written consent from ;;;; RTL Generation: RValues ;;; package: (compiler rtl-generator generate/rvalue) -(define (generate/rvalue rvalue) - ((vector-method rvalue generate/rvalue) rvalue)) +(package (generate/rvalue make-closure-environment) -(define (define-rvalue-generator tag generator) - (define-vector-method tag generate/rvalue generator)) +(define-export (generate/rvalue operand offset scfg*cfg->cfg! generator) + (transmit-values (generate/rvalue* operand offset) + +(define (generate/rvalue operand scfg*cfg->cfg! generator) (with-values (lambda () (generate/rvalue* operand)) +(define (generate/rvalue* operand offset) + ((method-table-lookup rvalue-methods (tagged-vector/index operand)) + operand + offset)) + +(define (generate/rvalue* operand) + ((method-table-lookup rvalue-methods (tagged-vector/index operand)) operand)) + (define rvalue-methods (return-2 (make-null-cfg) expression)) +(define-integrable (expression-value/simple expression) + (let ((register (rtl:make-pseudo-register))) + (return-2 (scfg*scfg->scfg! prefix (rtl:make-assignment register result)) + (rtl:make-fetch register)))) + (values (scfg*scfg->scfg! prefix assignment) reference)) (define-integrable (expression-value/transform expression-value transform) (transmit-values expression-value (lambda (prefix expression) (return-2 prefix (transform expression))))) -(define (expression-value/temporary prefix result) - (let ((temporary (make-temporary))) - (return-2 (scfg*scfg->scfg! prefix (rtl:make-assignment temporary result)) - (rtl:make-fetch temporary)))) + result + (lambda (constant offset) + (generate/constant constant))) (define-method-table-entry 'CONSTANT rvalue-methods (define (generate/constant constant) (expression-value/simple (rtl:make-constant (constant-value constant)))) -(define-rvalue-generator constant-tag - generate/constant) - -(define-rvalue-generator block-tag - (lambda (block) + (lambda (constant) + (lambda (block offset) (define-method-table-entry 'BLOCK rvalue-methods -(define-rvalue-generator reference-tag + block ;; ignored + (lambda (reference offset) + (let ((block (reference-block reference)) +(define-method-table-entry 'REFERENCE rvalue-methods (lambda (reference) - (if (vnode-known-constant? (reference-variable reference)) - (generate/constant (vnode-known-value (reference-variable reference))) - (find-variable (reference-block reference) - (reference-variable reference) - (lambda (locative) - (expression-value/simple (rtl:make-fetch locative))) - (lambda (environment name) - (expression-value/temporary - (rtl:make-interpreter-call:lookup - environment - (intern-scode-variable! (reference-block reference) name) - (reference-safe? reference)) - (rtl:interpreter-call-result:lookup))) - (lambda (name) - (generate/cached-reference name (reference-safe? reference))))))) - + (let ((standard-case + (lambda () + (if (value-variable? lvalue) + (expression-value/simple + (rtl:make-fetch + (let ((continuation (block-procedure block))) + (if (continuation/always-known-operator? continuation) + (continuation/register continuation) + register:value)))) + (find-variable block lvalue offset + (lambda (locative) + (expression-value/simple (rtl:make-fetch locative))) + (lambda (environment name) + (expression-value/temporary + (rtl:make-interpreter-call:lookup + environment + (intern-scode-variable! block name) + safe?) + (rtl:interpreter-call-result:lookup))) + (lambda (name) + (generate/cached-reference name safe?))))))) + (let ((value (lvalue-known-value lvalue))) + (cond ((not value) + (standard-case)) + ((not (rvalue/procedure? value)) + (generate/rvalue* value offset)) + ((and (procedure/closure? value) + (block-ancestor-or-self? block (procedure-block value))) + (expression-value/simple + (rtl:make-fetch + (stack-locative-offset + (block-ancestor-or-self->locative block + (procedure-block value) + offset) + (procedure-closure-offset value))))) + (else + (standard-case)))))))) + (define (generate/cached-reference name safe?) - (let ((temp (make-temporary)) - (result (make-temporary))) + (let ((temp (rtl:make-pseudo-register)) + (result (rtl:make-pseudo-register))) (return-2 (let ((cell (rtl:make-fetch temp))) (let ((reference (rtl:make-fetch cell))) @@ -120,27 +155,12 @@ promotional, or sales literature without prior written consent from (scfg-next-hooks n5)))))))) (make-scfg (cfg-entry-node n2) (hooks-union (scfg-next-hooks n3) -(define-rvalue-generator temporary-tag - (lambda (temporary) - (if (vnode-known-constant? temporary) - (generate/constant (vnode-known-value temporary)) - (expression-value/simple (rtl:make-fetch temporary))))) - -(define-rvalue-generator access-tag - (lambda (*access) - (transmit-values (generate/rvalue (access-environment *access)) - (lambda (prefix expression) - (expression-value/temporary - (scfg*scfg->scfg! - prefix - (rtl:make-interpreter-call:access expression (access-name *access))) - (rtl:interpreter-call-result:access)))))) - -(define-rvalue-generator procedure-tag - (lambda (procedure) + (scfg-next-hooks n5))))))))) + (lambda (procedure offset) + (define-method-table-entry 'PROCEDURE rvalue-methods (case (procedure/type procedure) - (expression-value/transform (make-closure-environment procedure) + (expression-value/transform (make-closure-environment procedure offset) (lambda (environment) (make-closure-cons procedure environment)))) (else @@ -149,33 +169,9 @@ promotional, or sales literature without prior written consent from (error "Reference to open procedure" procedure)) (if (not (procedure-virtual-closure? procedure)) (error "Reference to open procedure" procedure)) - -(define (make-ic-cons procedure) - ;; IC procedures have their entry points linked into their headers - ;; at load time by the linker. - (let ((header - (scode/make-lambda (variable-name (procedure-name procedure)) - (map variable-name (procedure-required procedure)) - (map variable-name (procedure-optional procedure)) - (let ((rest (procedure-rest procedure))) - (and rest (variable-name rest))) - (map variable-name - (append (procedure-auxiliary procedure) - (procedure-names procedure))) - '() - false))) - (set! *ic-procedure-headers* - (cons (cons header (procedure-external-label procedure)) - *ic-procedure-headers*)) - (rtl:make-typed-cons:pair - (rtl:make-constant (scode/procedure-type-code header)) - (rtl:make-constant header) - ;; Is this right if the procedure is being closed - ;; inside another IC procedure? - (rtl:make-fetch register:environment)))) ;; inside another IC procedure? -(define (make-closure-environment procedure) - (let ((block (block-parent (procedure-block procedure)))) +(define (make-closure-environment procedure offset) + (let ((block (procedure-closing-block procedure))) (define (make-non-trivial-closure-cons procedure block**) (expression-value/simple (rtl:make-constant false))) ((ic-block? block) @@ -184,19 +180,20 @@ promotional, or sales literature without prior written consent from (let ((closure-block (procedure-closure-block procedure))) (if (ic-block? closure-block) (rtl:make-fetch register:environment) - (closure-ic-locative closure-block block))) + (closure-ic-locative closure-block block offset))) (rtl:make-constant false)))) ((closure-block? block) (let ((closure-block (procedure-closure-block procedure))) (define (loop variables) (cond ((null? variables) '()) - ((integrated-vnode? (car variables)) + ((lvalue-integrated? (car variables)) (loop (cdr variables))) (else (cons (rtl:make-push (rtl:make-fetch (find-closure-variable closure-block - (car variables)))) + (car variables) + offset))) (loop (cdr variables)))))) (let ((pushes @@ -205,7 +202,8 @@ promotional, or sales literature without prior written consent from (if (and parent (ic-block/use-lookup? parent)) (cons (rtl:make-push (closure-ic-locative closure-block - parent)) + parent + offset)) pushes) pushes)))) (expression-value/temporary @@ -217,10 +215,37 @@ promotional, or sales literature without prior written consent from (else (error "Unknown block type" block))))) +;;; end GENERATE/RVALUE +) + +(define (make-ic-cons procedure) + ;; IC procedures have their entry points linked into their headers + ;; at load time by the linker. + (let ((header + (scode/make-lambda (variable-name (procedure-name procedure)) + (map variable-name + (procedure-required-arguments procedure)) + (map variable-name (procedure-optional procedure)) + (let ((rest (procedure-rest procedure))) + (and rest (variable-name rest))) + (map variable-name (procedure-names procedure)) + '() + false))) + (set! *ic-procedure-headers* + (cons (cons header (procedure-label procedure)) + *ic-procedure-headers*)) + (rtl:make-typed-cons:pair + (rtl:make-constant (scode/procedure-type-code header)) + (rtl:make-constant header) + ;; Is this right if the procedure is being closed + ;; inside another IC procedure? + (rtl:make-fetch register:environment)))) + (define (make-closure-cons procedure environment) - (rtl:make-typed-cons:pair (rtl:make-constant type-code:compiled-procedure) - (rtl:make-entry:procedure procedure) - environment)) (find-closure-variable context variable))))) + (rtl:make-typed-cons:pair + (rtl:make-constant type-code:compiled-procedure) + (rtl:make-entry:procedure (procedure-label procedure)) + environment)) (find-closure-variable context variable))))) code))))) (error "Unknown block type" block)))))) (error "Unknown block type" block)))))) diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index ede0e7dd5..cc54b7e13 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 1.9 1987/10/05 20:21:05 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.1 1987/12/04 20:31:53 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,77 +36,29 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Statements - -(define-statement-generator definition-tag - (lambda (node subproblem?) - (transmit-values (generate/rvalue (definition-rvalue node)) - (lambda (prefix expression) - (scfg*scfg->scfg! - prefix - (transmit-values (find-definition-variable node) - (lambda (environment name) - (rtl:make-interpreter-call:define environment name - expression)))))))) - -(define-statement-generator assignment-tag - (lambda (node subproblem?) - (let ((lvalue (assignment-lvalue node))) - (if (and (integrated-vnode? lvalue) - (not (value-register? lvalue))) - (make-null-cfg) - (transmit-values (generate/rvalue (assignment-rvalue node)) - (lambda (prefix expression) - (scfg*scfg->scfg! - prefix - (generate/assignment (assignment-block node) - lvalue - expression - subproblem?)))))))) - -(define (generate/assignment block lvalue expression subproblem?) - ((vector-method lvalue generate/assignment) - block lvalue expression subproblem?)) - -(define (define-assignment tag generator) - (define-vector-method tag generate/assignment generator)) - -(define-assignment temporary-tag - (lambda (block lvalue expression subproblem?) - (rtl:make-assignment lvalue expression))) - -(define-assignment value-register-tag - (lambda (block lvalue expression subproblem?) - (if subproblem? (error "Return node has next")) - (scfg*scfg->scfg! - (rtl:make-assignment register:value expression) - (if (stack-block? block) - (if (stack-parent? block) - (rtl:make-message-sender:value (block-frame-size block)) - (scfg*scfg->scfg! - (rtl:make-pop-frame (block-frame-size block)) - (rtl:make-return))) - (rtl:make-return))))) - -(define-assignment value-ignore-tag - (lambda (block lvalue rvalue subproblem?) - (if subproblem? (error "Return node has next")) - (make-null-cfg))) - -(define-assignment variable-tag - (lambda (block lvalue expression subproblem?) - (find-variable block lvalue - (lambda (locative) - (rtl:make-assignment locative expression)) - (lambda (environment name) - (rtl:make-interpreter-call:set! environment - (intern-scode-variable! block name) - expression)) - (lambda (name) - (generate/cached-assignment name expression))))) +;;;; Assignments + +(define (generate/assignment assignment offset) + (let ((block (assignment-block assignment)) + (lvalue (assignment-lvalue assignment)) + (rvalue (assignment-rvalue assignment))) + (if (lvalue-integrated? lvalue) + (make-null-cfg) + (generate/rvalue rvalue offset scfg*scfg->scfg! + (lambda (expression) + (find-variable block lvalue offset + (lambda (locative) + (rtl:make-assignment locative expression)) + (lambda (environment name) + (rtl:make-interpreter-call:set! + environment + (intern-scode-variable! block name) + expression)) + (lambda (name) + (generate/cached-assignment name expression)))))))) (define (generate/cached-assignment name value) - (let ((temp (make-temporary))) + (let ((temp (rtl:make-pseudo-register))) (let ((cell (rtl:make-fetch temp))) (let ((contents (rtl:make-fetch cell))) (let ((n1 (rtl:make-assignment temp (rtl:make-assignment-cache name))) @@ -124,4 +76,157 @@ MIT in each case. |# (make-scfg (cfg-entry-node n1) (hooks-union (scfg-next-hooks n4) (hooks-union (scfg-next-hooks n5) - (scfg-next-hooks n6))))))))) \ No newline at end of file + (scfg-next-hooks n6))))))))) + +(define (generate/definition definition offset) + (let ((block (definition-block definition)) + (lvalue (definition-lvalue definition)) + (rvalue (definition-rvalue definition))) + (generate/rvalue rvalue offset scfg*scfg->scfg! + (lambda (expression) + (transmit-values (find-definition-variable block lvalue offset) + (lambda (environment name) + (rtl:make-interpreter-call:define environment + name + expression))))))) + +;;;; Virtual Returns + +(define (generate/virtual-return return offset) + (let ((operator (virtual-return-operator return)) + (operand (virtual-return-operand return))) + (enumeration-case continuation-type (virtual-continuation/type operator) + ((EFFECT) + (return-2 (make-null-cfg) offset)) + ((REGISTER VALUE) + (return-2 (operand->register operand + offset + (virtual-continuation/register operator)) + offset)) + ((PUSH) + (let ((block (virtual-continuation/block operator))) + (cond ((rvalue/block? operand) + (return-2 + (rtl:make-push + (rtl:make-environment + (block-ancestor-or-self->locative block + operand + offset))) + (1+ offset))) + ((rvalue/continuation? operand) + ;; This is a pun set up by the FG generator. + (generate/continuation-cons block operand offset)) + (else + (return-2 (operand->push operand offset) (1+ offset)))))) + (else + (error "Unknown continuation type" return))))) + +(define (operand->push operand offset) + (generate/rvalue operand offset scfg*scfg->scfg! rtl:make-push)) + +(define (operand->register operand offset register) + (generate/rvalue operand offset scfg*scfg->scfg! + (lambda (expression) + (rtl:make-assignment register expression)))) + +(package (generate/continuation-cons) + +(define-export (generate/continuation-cons block continuation offset) + (set-continuation/offset! continuation offset) + (let ((values + (let ((values + (if (continuation/dynamic-link? continuation) + (return-2 (rtl:make-push-link) (1+ offset)) + (return-2 (make-null-cfg) offset)))) + (if (continuation/always-known-operator? continuation) + values + (begin + (enqueue-continuation! continuation) + (push-prefix values + (rtl:make-push-return + (continuation/label continuation)))))))) + (if (ic-block? (continuation/closing-block continuation)) + (push-prefix values + (rtl:make-push (rtl:make-fetch register:environment))) + values))) + +(define (push-prefix values prefix) + (transmit-values values + (lambda (scfg offset) + (return-2 (scfg*scfg->scfg! prefix scfg) (1+ offset))))) + +) + +(define (generate/pop pop offset) + (rtl:make-pop (continuation*/register (pop-continuation pop)))) + +;;;; Predicates + +(define (generate/true-test true-test offset) + (generate/predicate (true-test-rvalue true-test) + (pnode-consequent true-test) + (pnode-alternative true-test) + offset)) + +(define (generate/predicate rvalue consequent alternative offset) + (if (rvalue/unassigned-test? rvalue) + (generate/unassigned-test rvalue consequent alternative offset) + (let ((value (rvalue-known-value rvalue))) + (if value + (generate/known-predicate value consequent alternative offset) + (pcfg*scfg->scfg! + (generate/rvalue rvalue offset scfg*pcfg->pcfg! + rtl:make-true-test) + (generate/node consequent offset) + (generate/node alternative offset)))))) + +(define (generate/known-predicate value consequent alternative offset) + (generate/node (if (and (constant? value) (false? (constant-value value))) + alternative + consequent) + offset)) + +(define (generate/unassigned-test rvalue consequent alternative offset) + (let ((block (unassigned-test-block rvalue)) + (lvalue (unassigned-test-lvalue rvalue))) + (let ((value (lvalue-known-value lvalue))) + (cond ((not value) + (pcfg*scfg->scfg! + (find-variable block lvalue offset + (lambda (locative) + (rtl:make-unassigned-test (rtl:make-fetch locative))) + (lambda (environment name) + (scfg*pcfg->pcfg! + (rtl:make-interpreter-call:unassigned? environment name) + (rtl:make-true-test + (rtl:interpreter-call-result:unassigned?)))) + generate/cached-unassigned?) + (generate/node consequent offset) + (generate/node alternative offset))) + ((and (rvalue/constant? value) + (scode/unassigned-object? (constant-value value))) + (generate/node consequent offset)) + (else + (generate/node alternative offset)))))) + +(define (generate/cached-unassigned? name) + (let ((temp (rtl:make-pseudo-register))) + (let ((cell (rtl:make-fetch temp))) + (let ((reference (rtl:make-fetch cell))) + (let ((n1 (rtl:make-assignment temp (rtl:make-variable-cache name))) + (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)) + (n5 + (rtl:make-true-test + (rtl:interpreter-call-result:cache-unassigned?)))) + (scfg-next-connect! n1 n2) + (pcfg-consequent-connect! n2 n3) + (pcfg-alternative-connect! n3 n4) + (scfg-next-connect! n4 n5) + (make-pcfg (cfg-entry-node n1) + (hooks-union (pcfg-consequent-hooks n3) + (pcfg-consequent-hooks n5)) + (hooks-union (pcfg-alternative-hooks n2) + (pcfg-alternative-hooks n5)))))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index f2db11b73..1bd43a077 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 1.20 1987/08/31 21:19:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.1 1987/12/04 20:32:02 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,143 +36,187 @@ MIT in each case. |# (declare (usual-integrations)) -(define (generate-rtl quotation procedures) - (generate/rgraph - (quotation-rgraph quotation) +(define *generation-queue*) +(define *queued-procedures*) +(define *queued-continuations*) +(define *memoizations*) + +(define (generate/top-level expression) + (with-machine-register-map (lambda () - (scfg*scfg->scfg! - (rtl:make-assignment register:frame-pointer - (rtl:make-fetch register:stack-pointer)) - (generate/node (let ((entry (quotation-fg-entry quotation))) - (if (not compiler:preserve-data-structures?) - (unset-quotation-fg-entry! quotation)) - entry) - false)))) - (for-each (lambda (procedure) - (generate/rgraph - (procedure-rgraph procedure) - (lambda () - (generate/procedure-header - procedure - (generate/node - (let ((entry (procedure-fg-entry procedure))) - (if (not compiler:preserve-data-structures?) - (unset-procedure-fg-entry! procedure)) - entry) - false))))) - procedures)) + (fluid-let ((*generation-queue* (make-queue)) + (*queued-procedures* '()) + (*queued-continuations* '()) + (*memoizations* '())) + (set! *rtl-expression* (generate/expression expression)) + (queue-map! *generation-queue* (lambda (thunk) (thunk))) + (set! *rtl-graphs* + (list-transform-positive (reverse! *rtl-graphs*) + (lambda (rgraph) + (not (null? (rgraph-entry-edges rgraph)))))) + (for-each rgraph/compress! *rtl-graphs*) + (set! *rtl-procedures* (reverse! *rtl-procedures*)) + (set! *rtl-continuations* (reverse! *rtl-continuations*)))))) + +(define (enqueue-procedure! procedure) + (if (not (memq procedure *queued-procedures*)) + (begin + (enqueue! *generation-queue* + (lambda () + (set! *rtl-procedures* + (cons (generate/procedure procedure) + *rtl-procedures*)))) + (set! *queued-procedures* (cons procedure *queued-procedures*))))) + +(define (enqueue-continuation! continuation) + (if (not (memq continuation *queued-continuations*)) + (begin + (enqueue! *generation-queue* + (lambda () + (set! *rtl-continuations* + (cons (generate/continuation continuation) + *rtl-continuations*)))) + (set! *queued-continuations* + (cons continuation *queued-continuations*))))) -(define (generate/rgraph rgraph generator) - (fluid-let ((*current-rgraph* rgraph) - (*next-pseudo-number* number-of-machine-registers) - (*temporary->register-map* '()) - (*memoizations* '())) - (set-rgraph-edge! - rgraph - (node->edge - (cfg-entry-node - (cleanup-noop-nodes - (lambda () - (with-new-node-marks generator)))))) - (set-rgraph-n-registers! rgraph *next-pseudo-number*)) - (with-new-node-marks - (lambda () - (for-each (lambda (edge) - (bblock-compress! (edge-right-node edge))) - (rgraph-initial-edges rgraph)))) - (set-rgraph-bblocks! - rgraph - (with-new-node-marks - (lambda () - (define (loop bblock) - (node-mark! bblock) - (cons bblock - (if (sblock? bblock) - (next (snode-next bblock)) - (append! (next (pnode-consequent bblock)) - (next (pnode-alternative bblock)))))) - - (define (next bblock) - (if (and bblock (not (node-marked? bblock))) - (loop bblock) - '())) - - (mapcan (lambda (edge) - (loop (edge-right-node edge))) - (rgraph-initial-edges rgraph)))))) +(define (generate/expression expression) + (transmit-values + (generate/rgraph + (lambda () + (generate/node (expression-entry-node expression) 0))) + (lambda (rgraph entry-edge) + (make-rtl-expr rgraph (expression-label expression) entry-edge)))) + +(define (generate/procedure procedure) + (transmit-values + (generate/rgraph + (lambda () + (generate/procedure-header + procedure + (generate/node (procedure-entry-node procedure) 0) + false))) + (lambda (rgraph entry-edge) + (make-rtl-procedure + rgraph + (procedure-label procedure) + entry-edge + (length (procedure-original-required procedure)) + (length (procedure-original-optional procedure)) + (and (procedure-original-rest procedure) true) + (and (procedure/closure? procedure) true))))) + +(define (generate/procedure-entry/inline procedure) + (generate/procedure-header procedure + (generate/node (procedure-entry-node procedure) 0) + true)) -(define *memoizations*) - -(define (generate/node node subproblem?) - ;; This won't work when there are loops in the FG. - (cond ((or (null? (node-previous-edges node)) - (null? (cdr (node-previous-edges node)))) - (node-mark! node) - ((vector-method node generate/node) node subproblem?)) - ((not (node-marked? node)) - (node-mark! node) - (let ((result ((vector-method node generate/node) node subproblem?))) - (set! *memoizations* - (cons (cons* node subproblem? result) - *memoizations*)) - result)) - (else - (let ((memoization - (cdr (or (assq node *memoizations*) - (error "Marked node lacking memoization" node))))) - (if (not (boolean=? (car memoization) subproblem?)) - (error "Node regenerated with different arguments" node)) - (cdr memoization))))) - -(define (define-generator tag generator) - (define-vector-method tag generate/node generator)) - -(define (define-statement-generator tag generator) - (define-generator tag (normal-statement-generator generator))) - -(define (normal-statement-generator generator) - (lambda (node subproblem?) - (generate/normal-statement node subproblem? generator))) - -(define (generate/normal-statement node subproblem? generator) - (let ((next (snode-next node))) - (if next - (scfg*scfg->scfg! (generator node true) - (generate/node next subproblem?)) - (generator node subproblem?)))) - -(define (define-predicate-generator tag generator) - (define-generator tag (normal-predicate-generator generator))) - -(define (normal-predicate-generator generator) - (lambda (node subproblem?) - (pcfg*scfg->scfg! - (generator node) - (let ((consequent (pnode-consequent node))) - (and consequent - (generate/node consequent subproblem?))) - (let ((alternative (pnode-alternative node))) - (and alternative - (generate/node alternative subproblem?)))))) +(define (generate/continuation continuation) + (let ((label (continuation/label continuation)) + (node (continuation/entry-node continuation)) + (offset (continuation/offset continuation))) + (transmit-values + (generate/rgraph + (lambda () + (scfg-append! + (rtl:make-continuation-heap-check label) + (generate/continuation-entry/ic-block continuation) + (enumeration-case continuation-type + (continuation/type continuation) + ((PUSH) + (scfg*scfg->scfg! + (rtl:make-push (rtl:make-fetch register:value)) + (generate/node node (1+ offset)))) + ((REGISTER) + (scfg*scfg->scfg! + (rtl:make-assignment (continuation/register continuation) + (rtl:make-fetch register:value)) + (generate/node node offset))) + (else + (generate/node node offset)))))) + (lambda (rgraph entry-edge) + (make-rtl-continuation rgraph label entry-edge))))) + +(define (generate/continuation-entry/ic-block continuation) + (if (ic-block? (continuation/closing-block continuation)) + (rtl:make-pop register:environment) + (make-null-cfg))) + +(define (generate/node/memoize node offset) + (let ((entry (assq node *memoizations*))) + (cond ((not entry) + (let ((entry (cons node false))) + (set! *memoizations* (cons entry *memoizations*)) + (let ((result (generate/node node offset))) + (set-cdr! entry (cons offset result)) + result))) + ((not (cdr entry)) + (error "GENERATE/NODE/MEMOIZE: loop" node)) + ((not (= offset (cadr entry))) + (error "GENERATE/NODE/MEMOIZE: mismatched offsets" node)) + (else (cddr entry))))) + +(define (generate/node node offset) + (cfg-node-case (tagged-vector/tag node) + ((APPLICATION) + (if (snode-next node) + (error "Application node has next" node)) + (case (application-type node) + ((COMBINATION) (generate/combination node offset)) + ((RETURN) (generate/return node offset)) + (else (error "Unknown application type" node)))) + ((VIRTUAL-RETURN) + (transmit-values (generate/virtual-return node offset) + (lambda (scfg offset) + (scfg*scfg->scfg! scfg + (generate/node (snode-next node) offset))))) + ((POP) + (scfg*scfg->scfg! (generate/pop node offset) + (generate/node (snode-next node) offset))) + ((ASSIGNMENT) + (scfg*scfg->scfg! (generate/assignment node offset) + (generate/node (snode-next node) offset))) + ((DEFINITION) + (scfg*scfg->scfg! (generate/definition node offset) + (generate/node (snode-next node) offset))) + ((TRUE-TEST) + (generate/true-test node offset)))) -(define (generate/subproblem-cfg subproblem) - (if (cfg-null? (subproblem-cfg subproblem)) - (make-null-cfg) - (generate/node (cfg-entry-node (subproblem-cfg subproblem)) true))) - -(define (generate/operand subproblem) - (transmit-values (generate/rvalue (subproblem-value subproblem)) - (lambda (prefix expression) - (return-3 (generate/subproblem-cfg subproblem) - prefix - expression)))) - -(define (generate/subproblem subproblem) - (transmit-values (generate/operand subproblem) - (lambda (cfg prefix expression) - (return-2 (scfg*scfg->scfg! cfg prefix) expression)))) - -(define (generate/subproblem-push subproblem) - (transmit-values (generate/subproblem subproblem) - (lambda (cfg expression) - (scfg*scfg->scfg! cfg (rtl:make-push expression))))) \ No newline at end of file +(define (generate/rgraph generator) + (let ((rgraph (make-rgraph number-of-machine-registers))) + (set! *rtl-graphs* (cons rgraph *rtl-graphs*)) + (let ((entry-node + (cfg-entry-node + (fluid-let ((*current-rgraph* rgraph)) + (with-new-node-marks generator))))) + (add-rgraph-entry-node! rgraph entry-node) + (return-2 rgraph (node->edge entry-node))))) + +(define (rgraph/compress! rgraph) + (with-new-node-marks + (lambda () + (for-each (lambda (edge) + (bblock-compress! (edge-right-node edge))) + (rgraph-initial-edges rgraph)))) + (set-rgraph-bblocks! rgraph (collect-rgraph-bblocks rgraph))) + +(define collect-rgraph-bblocks + (let () + (define (loop bblock) + (node-mark! bblock) + (cons bblock + (if (sblock? bblock) + (next (snode-next bblock)) + (append! (next (pnode-consequent bblock)) + (next (pnode-alternative bblock)))))) + + (define (next bblock) + (if (and bblock (not (node-marked? bblock))) + (loop bblock) + '())) + + (lambda (rgraph) + (with-new-node-marks + (lambda () + (mapcan (lambda (edge) + (loop (edge-right-node edge))) + (rgraph-initial-edges rgraph))))))) \ No newline at end of file -- 2.25.1