#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.13 1989/04/15 18:05:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.14 1989/04/21 17:04:12 markf Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
normal-offset ;offset of variable within `block'
declarations ;list of declarations for this variable
closed-over? ;true iff a closure references it freely.
+ register ;register for parameters passed in registers
+ stack-overwrite-target?
+ ;true iff variable is the target of a stack overwrite
)
(define continuation-variable/type variable-in-cell?)
(define set-continuation-variable/type! set-variable-in-cell?!)
(define (make-variable block name)
- (make-lvalue variable-tag block name '() false false '() false))
+ (make-lvalue variable-tag block name '() false false '() false false
+ false))
(define variable-assoc
(association-procedure eq? variable-name))
(EQ? (VARIABLE-NAME LVALUE) ',symbol))))))))
(define-named-variable continuation)
(define-named-variable value))
+
+(define-integrable (variable/register variable)
+ (let ((maybe-delayed-register (variable-register variable)))
+ (if (promise? maybe-delayed-register)
+ (force maybe-delayed-register)
+ maybe-delayed-register)))
\f
;;;; Linking
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.11 1989/04/17 17:06:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.12 1989/04/21 17:05:12 markf Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(and (not (null? reasons))
(or (memq (caar reasons)
'(PASSED-OUT ARGUMENT ASSIGNMENT APPLY-COMPATIBILITY))
- (loop (cdr reasons))))))
\ No newline at end of file
+ (loop (cdr reasons))))))
+
+(define (procedure-maybe-registerizable? procedure)
+;;; yields true if the procedure might be able to have some of its
+;;; parameters in registers. Note: This does not mean that the
+;;; procedure WILL have its parameters in registers, or that ALL its
+;;; parameters will be in registers. Which parameters will actually be
+;;; in registers depends on the procedure's argument subproblems, as
+;;; well as the parameter lvalues themselves.
+ (and
+ (procedure-always-known-operator? procedure)
+ (procedure-application-unique? procedure)
+ (procedure/virtually-open? procedure)
+ (not (block-layout-frozen? (procedure-block procedure)))))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.14 1988/12/30 07:02:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.15 1989/04/21 17:06:51 markf Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(phase/continuation-analysis)
(phase/setup-frame-adjustments)
(phase/subproblem-analysis)
- (phase/design-environment-frames)
+ (phase/delete-integrated-parameters)
(phase/subproblem-ordering)
+ (phase/delete-integrated-parameters)
+ (phase/design-environment-frames)
(phase/connectivity-analysis)
(phase/compute-node-offsets)
(phase/info-generation-1)
(simplicity-analysis *parallels*)
(compute-subproblem-free-variables *parallels*))))
+(define (phase/delete-integrated-parameters)
+ (compiler-subphase "Integrated Parameter Deletion"
+ (lambda ()
+ (delete-integrated-parameters *blocks*))))
+
(define (phase/subproblem-ordering)
(compiler-subphase "Subproblem Ordering"
(lambda ()
(define (phase/design-environment-frames)
(compiler-subphase "Environment Frame Design"
- (lambda ()
- (design-environment-frames! *blocks*))))
+ (lambda ()
+ (design-environment-frames! *blocks*))))
(define (phase/compute-node-offsets)
(compiler-subphase "Stack Frame Offset Determination"
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.15 1989/01/06 20:50:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.16 1989/04/21 17:10:28 markf Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(scode/make-conditional expression #T #F))))
(define (find-name block name)
- (define (search block)
+ (define (search block if-non-local)
(or (variable-assoc name (block-bound-variables block))
(variable-assoc name (block-free-variables block))
(let ((variable
(if (block-parent block)
- (search (block-parent block))
+ (search (block-parent block)
+ (lambda (bl var) bl var))
(make-variable block name))))
(set-block-free-variables! block
(cons variable
(block-free-variables block)))
+ (if-non-local block variable)
variable)))
- (search block))
+ (search block
+ (lambda (block variable)
+ (set-block-variables-nontransitively-free!
+ block
+ (cons variable
+ (block-variables-nontransitively-free block))))))
\f
(define (generate/lambda block continuation expression)
(generate/lambda* block continuation expression false false))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.10 1988/12/30 07:11:57 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.11 1989/04/21 17:09:37 markf Rel $
Copyright (c) 1987, 1988 Massachusetts Institute of Technology
(define (close-procedure! block)
(let ((procedure (block-procedure block))
(current-parent (block-parent block)))
+
+ (define (uninteresting-variable? variable)
+ (or (lvalue-integrated? variable)
+ ;; Some of this is redundant
+ (let ((value (lvalue-known-value variable)))
+ (and value
+ (or (eq? value procedure)
+ (and (rvalue/procedure? value)
+ (procedure/trivial-or-virtual? value)))))))
+
(let ((previously-trivial? (procedure/trivial-closure? procedure))
(parent (or (procedure-target-block procedure) current-parent)))
;; Note: this should be innocuous if there is already a closure block.
parent
(list-transform-negative (block-free-variables block)
(lambda (lvalue)
- (or (lvalue-integrated? lvalue)
- ;; Some of this is redundant
- (let ((value (lvalue-known-value lvalue)))
- (and value
- (or (eq? value procedure)
- (and (rvalue/procedure? value)
- (procedure/trivial-or-virtual? value)))))
+ (or (uninteresting-variable? lvalue)
(begin
(set-variable-closed-over?! lvalue true)
false))))
- '()))
+ '()
+ (list-transform-negative (block-variables-nontransitively-free
+ block)
+ uninteresting-variable?)))
(lambda (closure-frame-block size)
(set-block-parent! block closure-frame-block)
(set-procedure-closure-size! procedure size)))
procedure))))
(disown-block-child! current-parent block)))
\f
-(define (find-closure-bindings block free-variables bound-variables)
+(define (find-closure-bindings block free-variables bound-variables
+ variables-nontransitively-free)
(if (or (not block) (ic-block? block))
(let ((grandparent (and (not (null? free-variables)) block)))
(if (null? bound-variables)
(values grandparent (if grandparent 1 0))
(make-closure-block grandparent
free-variables
- bound-variables)))
+ bound-variables
+ variables-nontransitively-free)))
(with-values
(lambda ()
(filter-bound-variables (block-bound-variables block)
(lambda (free-variables bound-variables)
(find-closure-bindings (original-block-parent block)
free-variables
- bound-variables)))))
+ bound-variables
+ variables-nontransitively-free)))))
(define (filter-bound-variables bindings free-variables bound-variables)
(cond ((null? bindings)
;; This may have to change if we ever do simultaneous closing of multiple
;; procedures sharing structure.
-(define (make-closure-block parent free-variables bound-variables)
+(define (make-closure-block parent free-variables bound-variables
+ variables-nontransitively-free)
(let ((block (make-block parent 'CLOSURE)))
(set-block-free-variables! block free-variables)
(set-block-bound-variables! block bound-variables)
+ (set-block-variables-nontransitively-free!
+ block
+ variables-nontransitively-free)
(do ((variables (block-bound-variables block) (cdr variables))
(size (if (and parent (ic-block/use-lookup? parent)) 1 0) (1+ size))
(table '()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.1 1988/12/12 21:32:29 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.2 1989/04/21 17:09:50 markf Exp $
Copyright (c) 1988 Massachusetts Institute of Technology
(begin
(set-combination/reuse-existing-frame?! combination
overwritten-block)
- (linearize-subproblems!
- continuation-type/push
- extra-subproblems
- (order-subproblems/overwrite-block caller-block
- overwritten-block
- terminal-nodes
- non-terminal-nodes
- rest)))
+ (with-values
+ (lambda ()
+ (order-subproblems/overwrite-block
+ caller-block
+ overwritten-block
+ terminal-nodes
+ non-terminal-nodes
+ rest))
+ (lambda (cfg subproblem-ordering)
+ (let ((cfg (linearize-subproblems!
+ continuation-type/push
+ extra-subproblems
+ cfg)))
+ (values
+ cfg
+ (append extra-subproblems subproblem-ordering))))))
(if-no-overwrite))))
(if-no-overwrite)))))
(lambda ()
(let ((n-subproblems (length subproblems)))
(let ((targets
- (overwritten-objects caller-block
- overwritten-block
- n-subproblems)))
+ (overwritten-objects! caller-block
+ overwritten-block
+ n-subproblems)))
(let ((n-targets (length targets))
(make-nodes
(lambda (subproblems)
(lambda (terminal-nodes non-terminal-nodes)
(values terminal-nodes non-terminal-nodes extra-subproblems))))))
-(define (overwritten-objects caller-block overwritten-block overwriting-size)
+(define (overwritten-objects! caller-block overwritten-block overwriting-size)
(let ((stack-layout
(let loop ((block caller-block))
+ (set-block-layout-frozen?! block true)
(if (eq? block overwritten-block)
(block-layout block)
(append! (block-layout block) (loop (block-parent block)))))))
(closure-procedure-needs-operator? procedure))
(list block)
'())
- (cdr (procedure-required procedure))
+ (list-transform-negative
+ (cdr (procedure-required procedure))
+ (lambda (variable)
+ (or (lvalue-integrated? variable)
+ (variable-register variable))))
(procedure-optional procedure)
(if (procedure-rest procedure) (list (procedure-rest procedure)) '())
(if (and (not (procedure/closure? procedure))
terminal-nodes
non-terminal-nodes
rest)
- (let ((node
- (trivial-assignments
- terminal-nodes
- (generate-assignments (reorder-assignments non-terminal-nodes)
- rest))))
+ (let* ((reordered-non-terms (reorder-assignments non-terminal-nodes))
+ (node
+ (trivial-assignments
+ terminal-nodes
+ (generate-assignments reordered-non-terms rest))))
(if (not (eq? caller-block overwritten-block))
(modify-reference-contexts! node rest
(let ((blocks
(block-partial-ancestry caller-block overwritten-block)))
(lambda (context)
(add-reference-context/adjacent-parents! context blocks)))))
- node))
+ (values node
+ (map node-value
+ (list-transform-negative
+ (append terminal-nodes reordered-non-terms)
+ node/noop?)))))
(define (generate-assignments nodes rest)
(cond ((null? nodes)
(generate-assignments (cdr nodes) rest)))))
(define (trivial-assignments nodes rest)
- (let loop ((nodes nodes))
+ (let loop ((nodes
+ (order-nodes-per-current-constraints nodes)))
(if (null? nodes)
rest
(trivial-assignment (car nodes) (loop (cdr nodes))))))
(define (trivial-assignment node rest)
(if (node/noop? node)
- rest
+ (begin
+ (let ((target (node-target node)))
+ (and (lvalue? target)
+ (lvalue/variable? target)
+ (set-variable-stack-overwrite-target?! target
+ true)))
+ rest)
(linearize-subproblem! continuation-type/register
(node-value node)
(overwrite node rest))))
(else false))))))
(define (overwrite node rest)
- (let ((subproblem (node-value node)))
+ (let ((subproblem (node-value node))
+ (target (node-target node)))
+ (if (and (lvalue? target)
+ (lvalue/variable? target))
+ (set-variable-stack-overwrite-target?! target
+ true))
(scfg*node->node!
(make-stack-overwrite (subproblem-context subproblem)
- (node-target node)
+ target
(subproblem-continuation subproblem))
- rest)))
\ No newline at end of file
+ rest)))
+
+(define (order-nodes-per-current-constraints nodes)
+ (if *current-constraints*
+ (order-per-constraints/extracted
+ nodes
+ *current-constraints*
+ node-value)
+ nodes))
+
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.19 1989/01/18 19:44:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.20 1989/04/21 17:14:14 markf Exp $
Copyright (c) 1988, 1989 Massachusetts Institute of Technology
filenames))))
(file-dependency/syntax/join
(append (filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "ctypes"
- "debug" "enumer" "infnew" "lvalue" "object"
- "pmerly" "proced" "refctx" "rvalue" "scode"
- "sets" "subprb" "switch" "toplev" "utils")
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "ctypes" "debug" "enumer" "infnew"
+ "lvalue" "object" "pmerly" "proced" "refctx"
+ "rvalue" "scode" "sets" "subprb" "switch"
+ "toplev" "utils")
(filename/append "back"
"asmmac" "bittop" "bitutl" "insseq" "lapgn1"
"lapgn2" "lapgn3" "linear" "regmap" "symtab"
(filename/append "fggen"
"declar" "fggen" "canon")
(filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "desenv"
- "envopt" "folcon" "offset" "operan" "order"
- "outer" "reord" "reuse" "sideff" "simapp"
- "simple" "subfre")
+ "blktyp" "closan" "conect" "contan" "delint"
+ "desenv" "envopt" "folcon" "offset" "operan"
+ "order" "outer" "param" "reord" "reuse"
+ "sideff" "simapp" "simple" "subfre")
(filename/append "rtlbase"
"regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp"
"rtline" "rtlobj" "rtlreg" "rtlty1" "rtlty2")
(define (initialize/integration-dependencies!)
(let ((front-end-base
(filename/append "base"
- "blocks" "cfg1" "cfg2" "cfg3" "contin" "ctypes"
- "enumer" "lvalue" "object" "proced" "rvalue"
+ "blocks" "cfg1" "cfg2" "cfg3" "constr"
+ "contin" "ctypes" "enumer" "lvalue"
+ "object" "proced" "rvalue"
"scode" "subprb" "utils"))
(bobcat-base
(filename/append "machines/bobcat" "machin"))
(filename/append "fggen"
"declar" "fggen") ; "canon" needs no integrations
(filename/append "fgopt"
- "blktyp" "closan" "conect" "contan" "desenv"
- "envopt" "folcon" "offset" "operan" "order"
+ "blktyp" "closan" "conect" "contan" "delint" "desenv"
+ "envopt" "folcon" "offset" "operan" "order" "param"
"outer" "reuse" "sideff" "simapp" "simple" "subfre"))
(append bobcat-base front-end-base))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.1 1988/12/12 21:33:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndvar.scm,v 1.2 1989/04/21 17:10:02 markf Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(procedure-block rvalue)
0
(procedure-closure-offset rvalue))))
- (find-block/variable context variable
- (lambda (offset-locative)
- (lambda (block locative)
- (if-compiler
- (offset-locative locative (variable-offset block variable)))))
- if-ic))))
-\f
+ (let ((register (variable/register variable)))
+ (if register
+ (if-compiler (register-locative register))
+ (find-block/variable context variable
+ (lambda (offset-locative)
+ (lambda (block locative)
+ (if-compiler
+ (offset-locative locative (variable-offset block variable)))))
+ if-ic))))))\f
(define (find-definition-variable context lvalue)
(find-block/variable context lvalue
(lambda (offset-locative)
(stack-locative-offset
(rtl:make-fetch register:stack-pointer)
(+ (procedure-closure-offset (reference-context/procedure context))
- (reference-context/offset context))))
\ No newline at end of file
+ (reference-context/offset context))))
+
+(define (register-locative register)
+ register)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.7 1988/12/30 07:11:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.8 1989/04/21 17:10:15 markf Rel $
Copyright (c) 1988 Massachusetts Institute of Technology
(define (cellify-variable variable)
(if (variable-in-cell? variable)
(let ((locative
- (stack-locative-offset (rtl:make-fetch register:stack-pointer)
- (variable-offset block variable))))
+ (let ((register (variable/register variable)))
+ (or register
+ (stack-locative-offset (rtl:make-fetch register:stack-pointer)
+ (variable-offset block variable))))))
(rtl:make-assignment
locative
(rtl:make-cell-cons (rtl:make-fetch locative))))
projects / mit-scheme.git / commitdiff