;;;; 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)
(*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)
\f
(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))))
;;;; 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)
(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)
(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)))
\f
;;;; Edge Datatype
(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)))
\f
;;;; Previous Connections
(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))
\f
;;;; 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)))
(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!)
;;;; 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)
(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))
(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))))
;;;; 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)
(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)
(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))))))
\f
(define-open-coder car
(lambda (combination offset)
(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)))
(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))))))
(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
(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)))
\f
;;;; 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))
(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
)
;;;; 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)
\f
(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))
(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))))
\f
-(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)
(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)
(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))))
\f
-(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))))))
\f
(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))
(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
(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!
projects / mit-scheme.git / commitdiff