;;; -*-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
;;;; 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)
\f
(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
(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)
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))))
\f
(define (define-open-coder primitive open-coder)
(let ((entry (assq primitive primitive-open-coders)))
'())
(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)))
\f
(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)
(subproblem-value operand)
(snode-next combination)
offset
+ rest-generator
(lambda (rvalue offset receiver*)
(rvalue->sexpression rvalue offset
(lambda (expression)
(and (integer? value)
(not (negative? value))
(receiver value))))))
-
-(define-integrable (combination-compiled-for-predicate? combination)
- (eq? 'PREDICATE (combination-compilation-type combination)))
\f
;;;; 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)
(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)
;;; -*-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
;;;; 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)
\f
(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)))
\f
(define (generate:ic-procedure procedure)
(make-null-cfg))
\f
;;;; 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)
(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
environment
(intern-scode-variable! block name)
expression))))))
- (generate:next next offset))))
+ (generate:next next offset rest-generator))))
\f
(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))
(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)))))
\f
;;;; 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)))))
\f
;;;; Expressions
projects / mit-scheme.git / commitdiff