#| -*-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
;;;; Machine Model for 68020
(declare (usual-integrations))
-\f(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)
+\f(define-integrable (stack->memory-offset offset)
offset)
(define ic-block-first-parameter-offset
;; 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
((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))))
\f
(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))
(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)
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)))
\f
(define register-type
(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))
(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))
\f
;;;; 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
--- /dev/null
+#| -*-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))
+\f
+(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))))
+\f
+(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*)))))
+\f
+(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)))
+\f
+(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
--- /dev/null
+#| -*-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))
+\f
+(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))))))))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+;;;; 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))
+\f
+;;;; 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)))))))
+\f
+(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)))))))
+\f
+(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
#| -*-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
(declare (usual-integrations))
\f
-(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)))))))
-\f
-(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))
-\f
-(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))
-\f
-(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))))))
-\f
-(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)))))))
\f
-;;;; 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))
-\f
-(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)))))))))))))
-\f
-(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))))
+\f
+(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)))))
+\f
+(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
)
\f
-(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)))))
\f
-;;;; 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
#| -*-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
\f
(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))))
\f
(define (setup-stack-frame procedure)
(let ((block (procedure-block procedure)))
(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
(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))))))
\f
(define (setup-bindings names values pushes)
(if (null? names)
(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 '())))
(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))
(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
--- /dev/null
+#| -*-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))
+\f
+(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)))
+\f
+(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))))))
+\f
+(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)))))))))))
+\f
+(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
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
;;;; 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)
+\f
+(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
\f
-(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))))))))
+\f
(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)))
(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)
+\f
(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
(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)
(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
(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
(else
(error "Unknown block type" block)))))
+;;; end GENERATE/RVALUE
+)
+\f
+(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))))))
#| -*-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
(declare (usual-integrations))
\f
-;;;; 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))
-\f
-(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)))
(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)))))))
+\f
+;;;; 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))))
+\f
+(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))))
+\f
+;;;; 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))
+\f
+(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
#| -*-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
(declare (usual-integrations))
\f
-(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*)))))
\f
-(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))
\f
-(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)))
+\f
+(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))))
\f
-(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
projects / mit-scheme.git / commitdiff