From: Chris Hanson Date: Sun, 21 Dec 1986 19:34:56 +0000 (+0000) Subject: *** empty log message *** X-Git-Tag: 20090517-FFI~13780 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=183a61c45770ba2f726237c40fbd74359f6c9e89;p=mit-scheme.git *** empty log message *** --- diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 4cf30089d..e269e3393 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -37,7 +37,7 @@ ;;;; LAP Code Generation -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.22 1986/12/21 14:52:04 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.23 1986/12/21 19:34:12 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -57,17 +57,17 @@ (*code-object-label*) (*code-object-entry*)) (for-each (lambda (quotation) - (cgen-cfg quotation quotation-rtl-entry)) + (cgen-entry quotation quotation-rtl-entry)) quotations) (for-each (lambda (procedure) - (cgen-cfg procedure procedure-rtl-entry)) + (cgen-entry procedure procedure-rtl-entry)) procedures) (for-each (lambda (continuation) - (cgen-cfg continuation continuation-rtl-entry)) + (cgen-entry continuation continuation-rtl-entry)) continuations) (receiver *interned-constants* *block-start-label*))))) -(define (cgen-cfg object extract-entry) +(define (cgen-entry object extract-entry) (set! *code-object-label* (code-object-label-initialize object)) (let ((rnode (extract-entry object))) (set! *code-object-entry* rnode) @@ -84,7 +84,7 @@ (define (cgen-rnode rnode) (define (cgen-right-node edge) - (let ((next (edge-right-node edge))) + (let ((next (edge-next-node edge))) (if (and next (not (node-marked? next))) (begin (if (node-previous>1? next) (let ((snode (statement->snode '(NOOP)))) diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index efbdadf7e..d5fa874d1 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -37,7 +37,7 @@ ;;;; Control Flow Graph Abstraction -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.145 1986/12/21 14:51:38 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.146 1986/12/21 19:33:44 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -59,9 +59,6 @@ (define (make-snode tag . extra) (list->vector (cons* tag false false '() '() false extra))) -(define-integrable (snode-next snode) - (edge-right-node (snode-next-edge snode))) - (define-vector-method snode-tag ':DESCRIBE (lambda (snode) (append! ((vector-tag-parent-method snode-tag ':DESCRIBE) snode) @@ -74,16 +71,22 @@ (define (make-pnode tag . extra) (list->vector (cons* tag false false '() '() false false extra))) -(define-integrable (pnode-consequent pnode) - (edge-right-node (pnode-consequent-edge pnode))) - -(define-integrable (pnode-alternative pnode) - (edge-right-node (pnode-alternative-edge pnode))) - (define-vector-method pnode-tag ':DESCRIBE (lambda (pnode) (append! ((vector-tag-parent-method pnode-tag ':DESCRIBE) pnode) (descriptor-list pnode consequent-edge alternative-edge)))) + +(define (edge-next-node edge) + (and edge (edge-right-node edge))) + +(define-integrable (snode-next snode) + (edge-next-node (snode-next-edge snode))) + +(define-integrable (pnode-consequent pnode) + (edge-next-node (pnode-consequent-edge pnode))) + +(define-integrable (pnode-alternative pnode) + (edge-next-node (pnode-alternative-edge pnode))) ;;;; Edge Datatype @@ -168,6 +171,14 @@ (edges-disconnect-right! previous-edges) (edges-connect-right! previous-edges snode) (create-edge! snode set-snode-next-edge! node))) + +(define (node->edge node) + (let ((edge (make-edge false false false))) + (edge-connect-right! edge node) + edge)) + +(define-integrable (cfg-entry-edge cfg) + (node->edge (cfg-entry-node cfg))) ;;;; Previous Connections @@ -377,14 +388,25 @@ (define (hook-connect! hook node) (create-edge! (hook-node hook) (hook-connect hook) node)) + +(define (scfg*node->node! scfg next-node) + (if (cfg-null? scfg) + next-node + (begin (if next-node + (hooks-connect! (scfg-next-hooks scfg) next-node)) + (cfg-entry-node scfg)))) + +(define (pcfg*node->node! pcfg consequent-node alternative-node) + (if (cfg-null? pcfg) + (error "PCFG*NODE->NODE!: Can't have null predicate")) + (if consequent-node + (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node)) + (if alternative-node + (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node)) + (cfg-entry-node pcfg)) ;;;; CFG Construction -(define (cfg-entry-edge cfg) - (let ((edge (make-edge false false false))) - (edge-connect-right! edge (cfg-entry-node cfg)) - edge)) - (define-integrable (scfg-next-connect! scfg cfg) (hooks-connect! (scfg-next-hooks scfg) (cfg-entry-node cfg))) @@ -397,8 +419,9 @@ (define (scfg*scfg->scfg! scfg scfg*) (cond ((not scfg) scfg*) ((not scfg*) scfg) - (else (scfg-next-connect! scfg scfg*) - (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*))))) + (else + (scfg-next-connect! scfg scfg*) + (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*))))) (package (scfg-append! scfg*->scfg!) diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index 096d38d92..7528951fa 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -37,7 +37,7 @@ ;;;; Compiler CFG Datatypes -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.38 1986/12/21 14:51:50 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.39 1986/12/21 19:33:58 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -87,9 +87,9 @@ (define-snode continuation rtl-edge delta label) (define *continuations*) -(define-integrable (make-continuation rtl delta) +(define-integrable (make-continuation delta) (let ((continuation - (make-snode continuation-tag (cfg-entry-edge rtl) delta + (make-snode continuation-tag false delta (generate-label 'CONTINUATION)))) (set! *continuations* (cons continuation *continuations*)) continuation)) @@ -97,6 +97,9 @@ (define-integrable (continuation-rtl-entry continuation) (edge-right-node (continuation-rtl-edge continuation))) +(define-integrable (set-continuation-rtl-entry! continuation node) + (set-continuation-rtl-edge! continuation (node->edge node))) + (define-unparser continuation-tag (lambda (continuation) (write (continuation-label continuation)))) diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index bd150e28f..a20922bdc 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -37,7 +37,7 @@ ;;;; RTL Generation: Combinations -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.2 1986/12/20 23:48:42 cph Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.3 1986/12/21 19:34:42 cph Exp $ (declare (usual-integrations)) (using-syntax (access compiler-syntax-table compiler-package) @@ -64,7 +64,9 @@ (if (not (eq? 'VALUE type*)) (error "COMBINATION:NORMAL: bad temporary type" type*)) (set-temporary-type! value 'VALUE))))) - ((if (snode-next combination) combination:subproblem combination:reduction) + ((if (generate:next-is-null? (snode-next combination)) + combination:reduction + combination:subproblem) combination offset)) (define (combination:constant combination offset) @@ -116,14 +118,14 @@ (define (open-code:type-test combination offset type operand) (let ((next (snode-next combination)) (operand (list-ref (combination-operands combination) operand))) - (scfg*pcfg->pcfg! - (generate:cfg (subproblem-cfg operand) offset) - (pcfg*scfg->pcfg! - (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: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)))))) (define-open-coder car (lambda (combination offset) @@ -158,15 +160,17 @@ (define (open-code-expression-1 combination offset receiver) (let ((operand (car (combination-operands combination)))) - (scfg*scfg->scfg! - (generate:cfg (subproblem-cfg operand) offset) - (rvalue->sexpression (subproblem-value operand) - (lambda (expression) - (generate-assignment (combination-block combination) - (combination-value combination) - (receiver expression) - (snode-next combination) - offset)))))) + (generate:subproblem operand offset + (lambda (offset) + (generate-assignment (combination-block combination) + (combination-value combination) + (subproblem-value operand) + (snode-next combination) + offset + (lambda (rvalue offset receiver*) + (rvalue->sexpression rvalue offset + (lambda (expression) + (receiver* (receiver expression)))))))))) (define (operand->index combination n receiver) (let ((operand (list-ref (combination-operands combination) n))) @@ -185,13 +189,15 @@ (let ((block (combination-block combination)) (finish (lambda (offset delta call-prefix continuation-prefix) - (let ((continuation - (make-continuation - (scfg*scfg->scfg! continuation-prefix - (generate:next (snode-next combination) - offset)) - delta))) - (scfg*scfg->scfg! (call-prefix continuation) + (let ((continuation (make-continuation delta))) + (set-continuation-rtl-entry! + continuation + (scfg*node->node! + (scfg*scfg->scfg! + (rtl:make-continuation-heap-check continuation) + continuation-prefix) + (generate:next (snode-next combination) offset))) + (scfg*node->node! (call-prefix continuation) (combination:subproblem-body combination (+ offset delta) continuation)))))) @@ -408,7 +414,7 @@ (define (make-call:stack-with-link combination offset invocation-prefix continuation) - (scfg*scfg->scfg! + (scfg*node->node! (rtl:make-push (rtl:make-address (block-ancestor-or-self->locative @@ -418,7 +424,7 @@ (make-call:stack combination (1+ offset) invocation-prefix continuation))) (define (make-call:child combination offset make-receiver receiver-size) - (scfg*scfg->scfg! + (scfg*node->node! (make-receiver (block-frame-size (combination-block combination))) (make-call:stack-with-link combination (+ offset (receiver-size)) invocation-prefix:null false))) @@ -455,23 +461,26 @@ ;;;; Call Sequence Kernels -(define (make-call-maker operator-cfg wrap-n) +(package (make-call:dont-push-operator make-call:push-operator) + +(define (make-call-maker generate:operator wrap-n) (lambda (combination offset make-invocation) (let ((operator (combination-known-operator combination)) (operands (combination-operands combination))) (let ((n-operands (length operands)) (finish (lambda (n offset) - (scfg*->scfg! - (let operand-loop - ((operands (reverse operands)) - (offset offset)) - (if (null? operands) - (list - (operator-cfg (combination-operator combination) offset) - (make-invocation (wrap-n n))) - (cons (subproblem->push (car operands) offset) - (operand-loop (cdr operands) (1+ offset))))))))) + (let operand-loop + ((operands (reverse operands)) + (offset offset)) + (if (null? operands) + (generate:operator (combination-operator combination) + offset + (lambda (offset) + (cfg-entry-node (make-invocation (wrap-n n))))) + (subproblem->push (car operands) offset + (lambda (offset) + (operand-loop (cdr operands) offset)))))))) (if (and operator (procedure? operator) (not (procedure-rest operator)) @@ -490,17 +499,22 @@ (cons (rtl:make-push (rtl:make-unassigned)) (push-n-unassigned (-1+ n))))) -(define (subproblem->push subproblem offset) - (scfg*scfg->scfg! (generate:cfg (subproblem-cfg subproblem) offset) - (rvalue->sexpression (subproblem-value subproblem) offset - rtl:make-push))) +(define (subproblem->push subproblem offset receiver) + (generate:subproblem subproblem offset + (lambda (offset) + (scfg*node->node! + (rvalue->sexpression (subproblem-value subproblem) offset + rtl:make-push) + (receiver (1+ offset)))))) -(define make-call:dont-push-operator - (make-call-maker subproblem-cfg identity-procedure)) +(define-export make-call:dont-push-operator + (make-call-maker generate:subproblem identity-procedure)) -(define make-call:push-operator +(define-export make-call:push-operator (make-call-maker subproblem->push 1+)) +) + ;;; end USING-SYNTAX ) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index b9d9c8b83..5ee302d26 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -37,26 +37,39 @@ ;;;; RTL Generation -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.2 1986/12/21 14:52:34 cph Exp $ +;;; $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 $ (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* '())) + (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:cfg cfg offset) - (generate:node (cfg-entry-node cfg) offset)) +(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) + (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))))) (define (generate:next node offset) - (cond ((not node) (make-null-cfg)) + (cond ((not node) (*generate-next* offset)) ((node-marked? node) (let ((memo (node-property-get node generate:node))) (if (not (= (car memo) offset)) @@ -78,36 +91,38 @@ (define-vector-method tag generate:node generator)) (define (generate:quotation quotation) - (set-quotation-rtl! quotation - (generate:cfg (quotation-fg-entry quotation) 0))) + (set-quotation-rtl-entry! quotation + (generate:node (quotation-fg-entry quotation) 0))) (define (generate:procedure procedure) - (set-procedure-rtl! + (set-procedure-rtl-entry! procedure - ((cond ((ic-procedure? procedure) identity-procedure) - ((closure-procedure? procedure) generate:closure-procedure) - ((stack-procedure? procedure) generate:stack-procedure) - (else (error "Unknown procedure type" procedure))) - procedure - (generate:cfg (procedure-fg-entry procedure) 0)))) + (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 (generate:closure-procedure procedure cfg) - (scfg-append! (if (or (not (null? (procedure-optional procedure))) - (procedure-rest procedure)) - ((if (closure-procedure-needs-operator? procedure) - rtl:make-setup-closure-lexpr - rtl:make-setup-stack-lexpr) - procedure) - (rtl:make-procedure-heap-check procedure)) - (setup-stack-frame procedure) - cfg)) - -(define (generate:stack-procedure procedure cfg) - (scfg-append! (if (procedure-rest procedure) - (rtl:make-setup-stack-lexpr procedure) - (rtl:make-procedure-heap-check procedure)) - (setup-stack-frame procedure) - cfg)) +(define (generate:ic-procedure procedure) + (make-null-cfg)) + +(define (generate:closure-procedure procedure) + (scfg*scfg->scfg! (if (or (not (null? (procedure-optional procedure))) + (procedure-rest procedure)) + ((if (closure-procedure-needs-operator? procedure) + rtl:make-setup-closure-lexpr + rtl:make-setup-stack-lexpr) + procedure) + (rtl:make-procedure-heap-check procedure)) + (setup-stack-frame procedure))) + +(define (generate:stack-procedure procedure) + (scfg*scfg->scfg! (if (procedure-rest procedure) + (rtl:make-setup-stack-lexpr procedure) + (rtl:make-procedure-heap-check procedure)) + (setup-stack-frame procedure))) (define (setup-stack-frame procedure) (define (loop variables pushes) @@ -145,18 +160,17 @@ (define-generator definition-tag (lambda (definition offset) - (scfg-append! (rvalue->sexpression (definition-rvalue definition) offset - (lambda (expression) - (find-variable (definition-block definition) - (definition-lvalue definition) - offset - (lambda (locative) - (error "Definition of compiled variable")) - (lambda (environment name) - (rtl:make-interpreter-call:define environment - name - expression))))) - (generate:next (snode-next definition) offset)))) + (scfg*node->node! + (rvalue->sexpression (definition-rvalue definition) offset + (lambda (expression) + (find-variable (definition-block definition) + (definition-lvalue definition) + offset + (lambda (locative) + (error "Definition of compiled variable")) + (lambda (environment name) + (rtl:make-interpreter-call:define environment name expression))))) + (generate:next (snode-next definition) offset)))) (define-generator assignment-tag (lambda (assignment offset) @@ -164,76 +178,81 @@ (assignment-lvalue assignment) (assignment-rvalue assignment) (snode-next assignment) - offset))) + offset + rvalue->sexpression))) -(define (generate-assignment block lvalue rvalue next offset) - ((vector-method lvalue generate-assignment) block lvalue rvalue next offset)) +(define (generate-assignment block lvalue rvalue next offset + rvalue->sexpression) + ((vector-method lvalue generate-assignment) + block lvalue rvalue next offset rvalue->sexpression)) (define (define-assignment tag generator) (define-vector-method tag generate-assignment generator)) (define-assignment variable-tag - (lambda (block variable rvalue next offset) - (scfg-append! (if (integrated-vnode? variable) - (make-null-cfg) - (rvalue->sexpression rvalue offset - (lambda (expression) - (find-variable block variable offset - (lambda (locative) - (rtl:make-assignment locative expression)) - (lambda (environment name) - (rtl:make-interpreter-call:set! - environment - (intern-scode-variable! block name) - expression)))))) - (generate:next next offset)))) + (lambda (block variable rvalue next offset rvalue->sexpression) + (scfg*node->node! (if (integrated-vnode? variable) + (make-null-cfg) + (rvalue->sexpression rvalue offset + (lambda (expression) + (find-variable block variable offset + (lambda (locative) + (rtl:make-assignment locative expression)) + (lambda (environment name) + (rtl:make-interpreter-call:set! + environment + (intern-scode-variable! block name) + expression)))))) + (generate:next next offset)))) -(define (assignment:value-register block value-register rvalue next offset) - (if next (error "Return node has next")) - (scfg-append! (if (or (value-register? rvalue) - (value-temporary? rvalue)) - (make-null-cfg) - (rvalue->sexpression rvalue offset - (lambda (expression) - (rtl:make-assignment register:value expression)))) - (if (stack-procedure-block? block) - (rtl:make-message-sender:value - (+ offset (block-frame-size block))) - (scfg-append! - (if (closure-procedure-block? block) - (rtl:make-pop-frame (block-frame-size block)) - (make-null-cfg)) - (rtl:make-return))))) +(define (assignment:value-register block value-register rvalue next offset + rvalue->sexpression) + (if (not (generate:next-is-null? next)) (error "Return node has next")) + (scfg*node->node! + (scfg*scfg->scfg! (if (or (value-register? rvalue) + (value-temporary? rvalue)) + (make-null-cfg) + (rvalue->sexpression rvalue offset + (lambda (expression) + (rtl:make-assignment register:value expression)))) + (if (stack-procedure-block? block) + (rtl:make-message-sender:value + (+ offset (block-frame-size block))) + (scfg-append! + (if (closure-procedure-block? block) + (rtl:make-pop-frame (block-frame-size block)) + (make-null-cfg)) + (rtl:make-return)))) + (generate:next next offset))) (define-assignment value-register-tag assignment:value-register) (define-assignment value-push-tag - (lambda (block value-push rvalue next offset) - (rvalue->sexpression rvalue offset - (lambda (expression) - (scfg-append! (rtl:make-push expression) - (generate:next next (1+ offset))))))) + (lambda (block value-push rvalue next offset rvalue->sexpression) + (scfg*node->node! (rvalue->sexpression rvalue offset rtl:make-push) + (generate:next next (1+ offset))))) (define-assignment value-ignore-tag - (lambda (block value-ignore rvalue next offset) - (if next (error "Return node has next")) - (make-null-cfg))) + (lambda (block value-ignore rvalue next offset rvalue->sexpression) + (if (not (generate:next-is-null? next)) (error "Return node has next")) + false)) (define-assignment temporary-tag - (lambda (block temporary rvalue next offset) + (lambda (block temporary rvalue next offset rvalue->sexpression) (let ((type (temporary-type temporary))) (case type ((#F) - (scfg-append! + (scfg*node->node! (if (integrated-vnode? temporary) (make-null-cfg) (rvalue->sexpression rvalue offset - (lambda (expression) - (rtl:make-assignment temporary expression)))) + (lambda (expression) + (rtl:make-assignment temporary expression)))) (generate:next next offset))) ((VALUE) - (assignment:value-register block temporary rvalue next offset)) + (assignment:value-register block temporary rvalue next offset + rvalue->sexpression)) (else (error "Unknown temporary type" type)))))) @@ -241,7 +260,7 @@ (define-generator true-test-tag (lambda (test offset) - (pcfg*scfg->pcfg! + (pcfg*node->node! (let ((rvalue (true-test-rvalue test))) (if (rvalue-known-constant? rvalue) (constant->pcfg (rvalue-constant-value rvalue)) @@ -251,7 +270,7 @@ (define-generator unassigned-test-tag (lambda (test offset) - (pcfg*scfg->pcfg! + (pcfg*node->node! (find-variable (unassigned-test-block test) (unassigned-test-variable test) offset @@ -266,7 +285,7 @@ (define-generator unbound-test-tag (lambda (test offset) - (pcfg*scfg->pcfg! + (pcfg*node->node! (let ((variable (unbound-test-variable test))) (if (ic-block? (variable-block variable)) (scfg*pcfg->pcfg!