From f57d02f64a7973484b6c256454ba73cf006da670 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 1 Jan 1987 18:50:17 +0000 Subject: [PATCH] Pass `rest-generator' as argument to all the generator quanta rather than fluid-binding it to prevent infinite recursion problem. --- v7/src/compiler/rtlgen/rgcomb.scm | 92 ++++++------ v7/src/compiler/rtlgen/rtlgen.scm | 226 +++++++++++++++--------------- 2 files changed, 163 insertions(+), 155 deletions(-) diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index ba3431767..75763c021 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -37,22 +37,22 @@ ;;;; RTL Generation: Combinations -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.4 1986/12/22 23:52:13 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.5 1987/01/01 18:49:25 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) (define-generator combination-tag - (lambda (combination offset) + (lambda (combination offset rest-generator) ((cond ((combination-constant? combination) combination:constant) ((let ((operator (combination-known-operator combination))) (and operator (normal-primitive-constant? operator))) combination:primitive) (else combination:normal)) - combination offset))) + combination offset rest-generator))) -(define (combination:normal combination offset) +(define (combination:normal combination offset rest-generator) ;; For the time being, all close-coded combinations will return ;; their values in the value register. If the value of a ;; combination is not a temporary, it is either a value-register @@ -62,14 +62,13 @@ (let ((type* (temporary-type value))) (if type* (if (not (eq? 'VALUE type*)) - (error "COMBINATION:NORMAL: bad temporary type" type*)) + (error "COMBINATION:NORMAL: Bad temporary type" type*)) (set-temporary-type! value 'VALUE))))) - ((if (generate:next-is-null? (snode-next combination)) - combination:reduction - combination:subproblem) - combination offset)) + (if (generate:next-is-null? (snode-next combination) rest-generator) + (combination:reduction combination offset) + (combination:subproblem combination offset rest-generator))) -(define (combination:constant combination offset) +(define (combination:constant combination offset rest-generator) (let ((value (combination-value combination)) (next (snode-next combination))) (cond ((or (value-register? value) @@ -78,18 +77,20 @@ value (combination-constant-value combination) next - offset)) + offset + rest-generator + rvalue->sexpression)) ((value-ignore? value) - (generate:next next)) + (generate:next next offset rest-generator)) (else (error "Unknown combination value" value))))) -(define (combination:primitive combination offset) +(define (combination:primitive combination offset rest-generator) (let ((open-coder (assq (constant-value (combination-known-operator combination)) primitive-open-coders))) (or (and open-coder - ((cdr open-coder) combination offset)) - (combination:normal combination offset)))) + ((cdr open-coder) combination offset rest-generator)) + (combination:normal combination offset rest-generator)))) (define (define-open-coder primitive open-coder) (let ((entry (assq primitive primitive-open-coders))) @@ -104,61 +105,66 @@ '()) (define-open-coder pair? - (lambda (combination offset) + (lambda (combination offset rest-generator) (and (combination-compiled-for-predicate? combination) - (open-code:type-test combination offset (ucode-type pair) 0)))) + (open-code:type-test combination offset rest-generator + (ucode-type pair) 0)))) (define-open-coder primitive-type? - (lambda (combination offset) + (lambda (combination offset rest-generator) (and (combination-compiled-for-predicate? combination) (operand->index combination 0 (lambda (type) - (open-code:type-test combination offset type 1)))))) + (open-code:type-test combination offset rest-generator + type 1)))))) -(define (open-code:type-test combination offset type operand) +(define (open-code:type-test combination offset rest-generator type operand) (let ((next (snode-next combination)) (operand (list-ref (combination-operands combination) operand))) (generate:subproblem operand offset (lambda (offset) - (pcfg*node->node! - (rvalue->pexpression (subproblem-value operand) offset - (lambda (expression) - (rtl:make-type-test (rtl:make-object->type expression) type))) - (generate:next (pnode-consequent next) offset) - (generate:next (pnode-alternative next) offset)))))) + (generate:predicate next offset rest-generator + (rvalue->pexpression (subproblem-value operand) offset + (lambda (expression) + (rtl:make-type-test (rtl:make-object->type expression) + type)))))))) + +(define-integrable (combination-compiled-for-predicate? combination) + (eq? 'PREDICATE (combination-compilation-type combination))) (define-open-coder car - (lambda (combination offset) - (open-code:memory-reference combination offset 0))) + (lambda (combination offset rest-generator) + (open-code:memory-reference combination offset rest-generator 0))) (define-open-coder cdr - (lambda (combination offset) - (open-code:memory-reference combination offset 1))) + (lambda (combination offset rest-generator) + (open-code:memory-reference combination offset rest-generator 1))) (define-open-coder cell-contents - (lambda (combination offset) - (open-code:memory-reference combination offset 0))) + (lambda (combination offset rest-generator) + (open-code:memory-reference combination offset rest-generator 0))) (define-open-coder vector-length - (lambda (combination offset) - (open-code-expression-1 combination offset + (lambda (combination offset rest-generator) + (open-code-expression-1 combination offset rest-generator (lambda (operand) (rtl:make-cons-pointer (rtl:make-constant (ucode-type fixnum)) (rtl:make-fetch (rtl:locative-offset operand 0))))))) (define-open-coder vector-ref - (lambda (combination offset) + (lambda (combination offset rest-generator) (operand->index combination 1 (lambda (index) - (open-code:memory-reference combination offset index))))) + (open-code:memory-reference combination offset rest-generator + index))))) (define (open-code:memory-reference combination offset index) - (open-code-expression-1 combination offset + (open-code-expression-1 combination offset rest-generator (lambda (operand) (rtl:make-fetch (rtl:locative-offset operand index))))) -(define (open-code-expression-1 combination offset receiver) +(define (open-code-expression-1 combination offset rest-generator receiver) (let ((operand (car (combination-operands combination)))) (generate:subproblem operand offset (lambda (offset) @@ -167,6 +173,7 @@ (subproblem-value operand) (snode-next combination) offset + rest-generator (lambda (rvalue offset receiver*) (rvalue->sexpression rvalue offset (lambda (expression) @@ -179,13 +186,10 @@ (and (integer? value) (not (negative? value)) (receiver value)))))) - -(define-integrable (combination-compiled-for-predicate? combination) - (eq? 'PREDICATE (combination-compilation-type combination))) ;;;; Subproblems -(define (combination:subproblem combination offset) +(define (combination:subproblem combination offset rest-generator) (let ((block (combination-block combination)) (finish (lambda (offset delta call-prefix continuation-prefix) @@ -196,7 +200,7 @@ (scfg*scfg->scfg! (rtl:make-continuation-heap-check continuation) continuation-prefix) - (generate:next (snode-next combination) offset))) + (generate:next (snode-next combination) offset rest-generator))) (scfg*node->node! (call-prefix continuation) (combination:subproblem-body combination (+ offset delta) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index 5ee302d26..018b32e63 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ ;;; -*-Scheme-*- ;;; -;;; Copyright (c) 1986 Massachusetts Institute of Technology +;;; Copyright (c) 1987 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -37,73 +37,65 @@ ;;;; RTL Generation -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.3 1986/12/21 19:34:56 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.4 1987/01/01 18:50:17 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) (define *nodes*) -(define *generate-next*) (define (generate-rtl quotations procedures) (with-new-node-marks (lambda () - (fluid-let ((*nodes* '()) - (*generate-next* generate:null)) - (for-each generate:quotation quotations) - (for-each generate:procedure procedures) - (for-each generate:remove-memo *nodes*))))) - -(define (generate:null offset) - false) - -(define-integrable (generate:next-is-null? next) - (and (not next) - (eq? *generate-next* generate:null))) - -(define (generate:subproblem subproblem offset generate-next) + (fluid-let ((*nodes* '())) + (for-each (lambda (quotation) + (set-quotation-rtl-entry! + quotation + (generate:top-level (quotation-fg-entry quotation)))) + quotations) + (for-each + (lambda (procedure) + (set-procedure-rtl-entry! + procedure + (scfg*node->node! + ((cond ((ic-procedure? procedure) generate:ic-procedure) + ((closure-procedure? procedure) generate:closure-procedure) + ((stack-procedure? procedure) generate:stack-procedure) + (else (error "Unknown procedure type" procedure))) + procedure) + (generate:top-level (procedure-fg-entry procedure))))) + procedures) + (for-each (lambda (rnode) + (node-property-remove! rnode generate:node)) + *nodes*))))) + +(define-integrable (generate:top-level expression) + (generate:node expression 0 false)) + +(define (generate:subproblem subproblem offset rest-generator) (let ((cfg (subproblem-cfg subproblem))) (if (cfg-null? cfg) - (generate-next offset) - (fluid-let ((*generate-next* generate-next)) - (generate:node (cfg-entry-node cfg) offset))))) + (and rest-generator (rest-generator offset)) + (generate:node (cfg-entry-node cfg) offset rest-generator)))) -(define (generate:next node offset) - (cond ((not node) (*generate-next* offset)) +(define (generate:next node offset rest-generator) + (cond ((not node) (and rest-generator (rest-generator offset))) ((node-marked? node) (let ((memo (node-property-get node generate:node))) (if (not (= (car memo) offset)) (error "Node entered at different offsets" node)) (cdr memo))) - (else (generate:node node offset)))) + (else (generate:node node offset rest-generator)))) -(define (generate:node node offset) +(define (generate:node node offset rest-generator) (node-mark! node) - (let ((cfg ((vector-method node generate:node) node offset))) + (let ((cfg ((vector-method node generate:node) node offset rest-generator))) (node-property-put! node generate:node (cons offset cfg)) (set! *nodes* (cons node *nodes*)) cfg)) -(define (generate:remove-memo rnode) - (node-property-remove! rnode generate:node)) - -(define (define-generator tag generator) - (define-vector-method tag generate:node generator)) - -(define (generate:quotation quotation) - (set-quotation-rtl-entry! quotation - (generate:node (quotation-fg-entry quotation) 0))) - -(define (generate:procedure procedure) - (set-procedure-rtl-entry! - procedure - (scfg*node->node! - ((cond ((ic-procedure? procedure) generate:ic-procedure) - ((closure-procedure? procedure) generate:closure-procedure) - ((stack-procedure? procedure) generate:stack-procedure) - (else (error "Unknown procedure type" procedure))) - procedure) - (generate:node (procedure-fg-entry procedure) 0)))) +(define-integrable (generate:next-is-null? next rest-generator) + (and (not next) (not rest-generator))) (define (generate:ic-procedure procedure) (make-null-cfg)) @@ -158,8 +150,11 @@ ;;;; Statements +(define (define-generator tag generator) + (define-vector-method tag generate:node generator)) + (define-generator definition-tag - (lambda (definition offset) + (lambda (definition offset rest-generator) (scfg*node->node! (rvalue->sexpression (definition-rvalue definition) offset (lambda (expression) @@ -170,27 +165,29 @@ (error "Definition of compiled variable")) (lambda (environment name) (rtl:make-interpreter-call:define environment name expression))))) - (generate:next (snode-next definition) offset)))) + (generate:next (snode-next definition) offset rest-generator)))) (define-generator assignment-tag - (lambda (assignment offset) + (lambda (assignment offset rest-generator) (generate-assignment (assignment-block assignment) (assignment-lvalue assignment) (assignment-rvalue assignment) (snode-next assignment) offset + rest-generator rvalue->sexpression))) -(define (generate-assignment block lvalue rvalue next offset +(define (generate-assignment block lvalue rvalue next offset rest-generator rvalue->sexpression) ((vector-method lvalue generate-assignment) - block lvalue rvalue next offset rvalue->sexpression)) + block lvalue rvalue next offset rest-generator rvalue->sexpression)) (define (define-assignment tag generator) (define-vector-method tag generate-assignment generator)) (define-assignment variable-tag - (lambda (block variable rvalue next offset rvalue->sexpression) + (lambda (block variable rvalue next offset rest-generator + rvalue->sexpression) (scfg*node->node! (if (integrated-vnode? variable) (make-null-cfg) (rvalue->sexpression rvalue offset @@ -203,11 +200,12 @@ environment (intern-scode-variable! block name) expression)))))) - (generate:next next offset)))) + (generate:next next offset rest-generator)))) (define (assignment:value-register block value-register rvalue next offset - rvalue->sexpression) - (if (not (generate:next-is-null? next)) (error "Return node has next")) + rest-generator rvalue->sexpression) + (if (not (generate:next-is-null? next rest-generator)) + (error "Return node has next")) (scfg*node->node! (scfg*scfg->scfg! (if (or (value-register? rvalue) (value-temporary? rvalue)) @@ -223,79 +221,85 @@ (rtl:make-pop-frame (block-frame-size block)) (make-null-cfg)) (rtl:make-return)))) - (generate:next next offset))) + (generate:next next offset rest-generator))) (define-assignment value-register-tag assignment:value-register) (define-assignment value-push-tag - (lambda (block value-push rvalue next offset rvalue->sexpression) + (lambda (block value-push rvalue next offset rest-generator + rvalue->sexpression) (scfg*node->node! (rvalue->sexpression rvalue offset rtl:make-push) - (generate:next next (1+ offset))))) + (generate:next next (1+ offset) rest-generator)))) (define-assignment value-ignore-tag - (lambda (block value-ignore rvalue next offset rvalue->sexpression) - (if (not (generate:next-is-null? next)) (error "Return node has next")) - false)) + (lambda (block value-ignore rvalue next offset rest-generator + rvalue->sexpression) + (if (not (generate:next-is-null? next rest-generator)) + (error "Return node has next")) + (generate:next next offset rest-generator))) (define-assignment temporary-tag - (lambda (block temporary rvalue next offset rvalue->sexpression) - (let ((type (temporary-type temporary))) - (case type - ((#F) - (scfg*node->node! - (if (integrated-vnode? temporary) - (make-null-cfg) - (rvalue->sexpression rvalue offset - (lambda (expression) - (rtl:make-assignment temporary expression)))) - (generate:next next offset))) - ((VALUE) - (assignment:value-register block temporary rvalue next offset - rvalue->sexpression)) - (else - (error "Unknown temporary type" type)))))) + (lambda (block temporary rvalue next offset rest-generator + rvalue->sexpression) + (case (temporary-type temporary) + ((#F) + (scfg*node->node! + (if (integrated-vnode? temporary) + (make-null-cfg) + (rvalue->sexpression rvalue offset + (lambda (expression) + (rtl:make-assignment temporary expression)))) + (generate:next next offset rest-generator))) + ((VALUE) + (assignment:value-register block temporary rvalue next offset + rest-generator rvalue->sexpression)) + (else + (error "Unknown temporary type" temporary))))) ;;;; Predicates -(define-generator true-test-tag +(define (define-predicate-generator tag node-generator) + (define-generator tag + (lambda (pnode offset rest-generator) + (generate:predicate pnode offset rest-generator + (node-generator pnode offset))))) + +(define (generate:predicate pnode offset rest-generator pcfg) + (pcfg*node->node! + pcfg + (generate:next (pnode-consequent pnode) offset rest-generator) + (generate:next (pnode-alternative pnode) offset rest-generator))) + +(define-predicate-generator true-test-tag (lambda (test offset) - (pcfg*node->node! - (let ((rvalue (true-test-rvalue test))) - (if (rvalue-known-constant? rvalue) - (constant->pcfg (rvalue-constant-value rvalue)) - (rvalue->pexpression rvalue offset rtl:make-true-test))) - (generate:next (pnode-consequent test) offset) - (generate:next (pnode-alternative test) offset)))) - -(define-generator unassigned-test-tag + (let ((rvalue (true-test-rvalue test))) + (if (rvalue-known-constant? rvalue) + (constant->pcfg (rvalue-constant-value rvalue)) + (rvalue->pexpression rvalue offset rtl:make-true-test))))) + +(define-predicate-generator unassigned-test-tag (lambda (test offset) - (pcfg*node->node! - (find-variable (unassigned-test-block test) - (unassigned-test-variable test) - 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:next (pnode-consequent test) offset) - (generate:next (pnode-alternative test) offset)))) - -(define-generator unbound-test-tag + (find-variable (unassigned-test-block test) + (unassigned-test-variable test) + 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?))))))) + +(define-predicate-generator unbound-test-tag (lambda (test offset) - (pcfg*node->node! - (let ((variable (unbound-test-variable test))) - (if (ic-block? (variable-block variable)) - (scfg*pcfg->pcfg! - (rtl:make-interpreter-call:unbound? - (nearest-ic-block-expression (unbound-test-block test) offset) - (variable-name variable)) - (rtl:make-true-test (rtl:interpreter-call-result:unbound?))) - (make-false-pcfg))) - (generate:next (pnode-consequent test) offset) - (generate:next (pnode-alternative test) offset)))) + (let ((variable (unbound-test-variable test))) + (if (ic-block? (variable-block variable)) + (scfg*pcfg->pcfg! + (rtl:make-interpreter-call:unbound? + (nearest-ic-block-expression (unbound-test-block test) offset) + (variable-name variable)) + (rtl:make-true-test (rtl:interpreter-call-result:unbound?))) + (make-false-pcfg))))) ;;;; Expressions -- 2.25.1