From: Chris Hanson Date: Fri, 2 Feb 1990 18:40:04 +0000 (+0000) Subject: * Add new operations to register allocator that determine whether X-Git-Tag: 20090517-FFI~11549 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=958b689218a6395bd53a9e21b59c2493adbad168;p=mit-scheme.git * Add new operations to register allocator that determine whether allocation will cause unloading or spilling of registers. Change the operation `standard-register-reference' to use these operations when deciding whether or not to refer to a register's home rather than allocation a new alias for it. * For an inline-coded procedure (e.g. LET), create an association between each parameter of that procedure and the FG node that supplies that parameter's value in the call. This association is used to optimize the initialization of variables that will be stored in cells: the cell for such a variable is created during the call rather than after it. Previously, a stack-allocated parameter was initialized by pushing its initial value, and then the contents of the stack location were removed, placed in a new cell, and the cell stored back into the stack location. Now, the parameter's value is wrapped in a cell before being pushed. * RTL output files have been changed to print uninterned symbols by name. * The code generated for assignments in value position has been slightly changed to guarantee the correct order of events. Previously, the order of the computation of the new value and the fetching of the old value was indeterminate; now it is guaranteed that the new value is computed before the old value is fetched. * The bit-string representation of register sets has been restored. This has a time penalty for small register sets, but guarantees that access to the register sets is independent of the number of registers. Certain programs with large numbers of registers were being unreasonably penalized by the list-based representation. Also, the dependencies for the file "rtlbase/regset" were adjusted to reflect the files that actually refer to it. * The RTL generated for cached variable assignments has been changed to precompute the value of the assignment and store it in a pseudo register. Previously, the code was replicated. --- diff --git a/v7/src/compiler/back/lapgn2.scm b/v7/src/compiler/back/lapgn2.scm index aa7c4b359..e5a581445 100644 --- a/v7/src/compiler/back/lapgn2.scm +++ b/v7/src/compiler/back/lapgn2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.17 1990/01/22 03:01:34 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn2.scm,v 1.18 1990/02/02 18:37:22 cph Rel $ Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology @@ -312,8 +312,12 @@ MIT in each case. |# ;; desirable because the register will be used again. ;; Otherwise, this is the last use of this register, so we ;; might as well just use the register's home. - (if (and (dead-register? register) - (register-saved-into-home? register)) + (if (and (register-saved-into-home? register) + (or (dead-register? register) + (not (allocate-register-without-unload? + *register-map* + preferred-type + *needed-registers*)))) (pseudo-register-home register) (reference-alias-register! register preferred-type))))) (let ((no-preference diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm index 56018da71..3f6a8086d 100644 --- a/v7/src/compiler/back/regmap.scm +++ b/v7/src/compiler/back/regmap.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.9 1990/01/18 22:42:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.10 1990/02/02 18:37:27 cph Rel $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -260,7 +260,8 @@ registers into some interesting sorting order. (make-register-map (map-entries:replace map entry (let ((home (map-entry-home entry))) - (make-map-entry home (not home) + (make-map-entry home + (not home) (list alias)))) (map-registers:add* map ;; **** Kludge -- again, EQ? is @@ -389,6 +390,42 @@ registers into some interesting sorting order. (and (map-entry-home entry) (map-entry-saved-into-home? entry) (reallocate-alias entry)))))) + +(define (allocate-register-without-spill? map type needed-registers) + ;; True iff a register of `type' can be allocated without saving any + ;; registers into their homes. + (or (free-register-exists? map type needed-registers) + (map-entries:search map + (lambda (entry) + (let ((alias (map-entry:find-alias entry type needed-registers))) + (and alias + (free-register-exists? + map + (if (register-types-compatible? type false) false type) + (cons alias needed-registers)))))))) + +(define (free-register-exists? map type needed-registers) + ;; True iff a register of `type' can be allocated without first + ;; saving its contents. + (or (allocate-register-without-unload? map type needed-registers) + (map-entries:search map + (lambda (entry) + (and (map-entry-home entry) + (map-entry-saved-into-home? entry) + (map-entry:find-alias entry type needed-registers)))))) + +(define (allocate-register-without-unload? map type needed-registers) + ;; True iff a register of `type' can be allocated without displacing + ;; any pseudo-registers from the register map. + (or (list-search-positive (map-registers map) + (lambda (alias) + (and (register-type? alias type) + (not (memv alias needed-registers))))) + (map-entries:search map + (lambda (entry) + (and (map-entry:find-alias entry type needed-registers) + (or (not (map-entry-home entry)) + (not (null? (cdr (map-entry-aliases entry)))))))))) ;;;; Allocator Operations diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index b32dfe530..92d70e3d5 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.14 1989/10/26 07:35:44 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.15 1990/02/02 18:38:09 cph Rel $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -255,6 +255,15 @@ MIT in each case. |# (define-integrable (node/virtual-return? node) (eq? (tagged-vector/tag node) virtual-return-tag)) +(define-integrable (virtual-return/target-lvalue return) + (cfg-node-get return virtual-return/target-lvalue/tag)) + +(define-integrable (set-virtual-return/target-lvalue! return lvalue) + (cfg-node-put! return virtual-return/target-lvalue/tag lvalue)) + +(define virtual-return/target-lvalue/tag + "target-lvalue") + (define (make-push block rvalue) (make-virtual-return block (virtual-continuation/make block continuation-type/push) diff --git a/v7/src/compiler/base/debug.scm b/v7/src/compiler/base/debug.scm index 105255d0b..155903ac2 100644 --- a/v7/src/compiler/base/debug.scm +++ b/v7/src/compiler/base/debug.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.12 1990/01/18 22:42:45 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.13 1990/02/02 18:38:12 cph Rel $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -112,13 +112,15 @@ MIT in each case. |# (define (write-instructions thunk) (fluid-let ((*show-instruction* write) - (*unparser-radix* 16)) + (*unparser-radix* 16) + (*unparse-uninterned-symbols-by-name?* true)) (thunk))) (define (pp-instructions thunk) (fluid-let ((*show-instruction* pretty-print) (*pp-primitives-by-name* false) - (*unparser-radix* 16)) + (*unparser-radix* 16) + (*unparse-uninterned-symbols-by-name?* true)) (thunk))) (define *show-instruction*) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index 2dd4a7ba9..a9b08967f 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.16 1989/10/26 07:35:56 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.17 1990/02/02 18:38:16 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -87,6 +87,7 @@ MIT in each case. |# stack-overwrite-target? ;true iff variable is the target of a stack overwrite indirection ;alias for this variable [variable or #f] + source-node ;virtual-return that initializes this variable, or #f ) (define continuation-variable/type variable-in-cell?) @@ -94,7 +95,7 @@ MIT in each case. |# (define (make-variable block name) (make-lvalue variable-tag block name '() false false '() false false - false false)) + false false false)) (define variable-assoc (association-procedure eq? variable-name)) diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index ab214d757..94de27973 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.23 1989/10/26 07:36:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.24 1990/02/02 18:38:34 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -623,20 +623,26 @@ MIT in each case. |# (scode/assignment-components expression (lambda (name value) (if (continuation/effect? continuation) - (generate/assignment* make-assignment find-name 'ASSIGNMENT-CONTINUE - block continuation expression name value) + (generate/assignment* make-assignment + find-name + 'ASSIGNMENT-CONTINUE + block + continuation + expression + name + value) (generate/combination block continuation - (let ((old-value-temp (generate-uninterned-symbol)) - (new-value-temp (generate-uninterned-symbol))) - (scode/make-let (list old-value-temp new-value-temp) - (list (scode/make-safe-variable name) value) - (scode/make-assignment - name - (scode/make-variable new-value-temp)) - (scode/make-variable old-value-temp)))))))) - + (let ((old-value (generate-uninterned-symbol)) + (new-value (generate-uninterned-symbol))) + (scode/make-let (list new-value) + (list value) + (scode/make-let (list old-value) + (list (scode/make-safe-variable name)) + (scode/make-assignment name (scode/make-variable new-value)) + (scode/make-variable old-value))))))))) + (define (generate/definition block continuation expression) (scode/definition-components expression (lambda (name value) diff --git a/v7/src/compiler/fgopt/order.scm b/v7/src/compiler/fgopt/order.scm index c3db3b17b..9122111b6 100644 --- a/v7/src/compiler/fgopt/order.scm +++ b/v7/src/compiler/fgopt/order.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.13 1989/10/26 07:36:55 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.14 1990/02/02 18:38:54 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -72,27 +72,30 @@ MIT in each case. |# (order-subproblems/out-of-line application subproblems rest))) ((RETURN) (values - (linearize-subproblems! continuation-type/effect subproblems rest) + (linearize-subproblems! continuation-type/effect subproblems '() rest) subproblems)) (else (error "Unknown application type" application)))) -(define (linearize-subproblems! continuation-type subproblems rest) +(define (linearize-subproblems! continuation-type subproblems alist rest) (set-subproblem-types! subproblems continuation-type) - (linearize-subproblems subproblems rest)) + (linearize-subproblems subproblems alist rest)) -(define (linearize-subproblem! continuation-type subproblem rest) +(define (linearize-subproblem! continuation-type subproblem lvalue rest) (set-subproblem-type! subproblem continuation-type) - (linearize-subproblem subproblem rest)) + (linearize-subproblem subproblem lvalue rest)) -(define (linearize-subproblems subproblems rest) +(define (linearize-subproblems subproblems alist rest) (let loop ((subproblems subproblems)) (if (null? subproblems) rest (linearize-subproblem (car subproblems) + (let ((entry (assq (car subproblems) alist))) + (and entry + (cdr entry))) (loop (cdr subproblems)))))) -(define (linearize-subproblem subproblem rest) +(define (linearize-subproblem subproblem lvalue rest) (let ((continuation (subproblem-continuation subproblem)) (prefix (subproblem-prefix subproblem))) (if (subproblem-canonical? subproblem) @@ -113,9 +116,16 @@ MIT in each case. |# (if (eq? continuation-type/effect (virtual-continuation/type continuation)) (make-null-cfg) - (make-virtual-return (virtual-continuation/context continuation) - continuation - (subproblem-rvalue subproblem))) + (let ((cfg + (make-virtual-return + (virtual-continuation/context continuation) + continuation + (subproblem-rvalue subproblem)))) + (if lvalue + (let ((node (cfg-entry-node cfg))) + (set-variable-source-node! lvalue node) + (set-virtual-return/target-lvalue! node lvalue))) + cfg)) rest))))) (define (order-subproblems/inline combination subproblems rest) @@ -137,7 +147,10 @@ MIT in each case. |# (values (linearize-subproblem! continuation-type/effect operator - (linearize-subproblems simple rest)) + false + (linearize-subproblems simple + '() + rest)) (cons operator simple))) (let ((push-set (cdr complex)) (value-set (cons (car complex) simple))) @@ -151,10 +164,13 @@ MIT in each case. |# (linearize-subproblem! continuation-type/effect operator + false (linearize-subproblems push-set + '() (linearize-subproblems value-set + '() (scfg*node->node! (scfg*->scfg! (reverse! @@ -186,28 +202,75 @@ MIT in each case. |# subproblems)) (define (order-subproblems/out-of-line combination subproblems rest) - (with-values - (combination-ordering (combination/context combination) - (car subproblems) - (cdr subproblems) - (combination/model combination)) - (lambda (effect-subproblems push-subproblems) - (set-combination/frame-size! combination (length push-subproblems)) - (with-values - (lambda () - (order-subproblems/maybe-overwrite-block - combination push-subproblems rest - (lambda () - (values (linearize-subproblems! continuation-type/push - push-subproblems - rest) - push-subproblems)))) - (lambda (cfg push-subproblem-order) - (values (linearize-subproblems! continuation-type/effect - effect-subproblems - cfg) - (append effect-subproblems push-subproblem-order))))))) + (let ((alist (add-defaulted-subproblems! combination subproblems))) + (with-values + (combination-ordering (combination/context combination) + (car subproblems) + (cdr subproblems) + (combination/model combination)) + (lambda (effect-subproblems push-subproblems) + (set-combination/frame-size! combination (length push-subproblems)) + (with-values + (lambda () + (order-subproblems/maybe-overwrite-block + combination push-subproblems rest alist + (lambda () + (values (linearize-subproblems! continuation-type/push + push-subproblems + alist + rest) + push-subproblems)))) + (lambda (cfg push-subproblem-order) + (values (linearize-subproblems! continuation-type/effect + effect-subproblems + alist + cfg) + (append effect-subproblems push-subproblem-order)))))))) +(define (add-defaulted-subproblems! combination subproblems) + (let ((model (combination/model combination))) + (if (and model + (rvalue/procedure? model) + (stack-block? (procedure-block model)) + (or (procedure-always-known-operator? model) + (not (procedure-rest model)))) + (let ((n-unassigned + (let ((n-supplied (length (cdr subproblems))) + (n-required + (length (cdr (procedure-original-required model))))) + (let ((n-expected + (+ n-required + (length (procedure-original-optional model))))) + (if (or (< n-supplied n-required) + (and (> n-supplied n-expected) + (not (procedure-rest model)))) + (warn "wrong number of arguments" + n-supplied + (error-irritant/noise char:newline) + (error-irritant/noise "in call to procedure") + (procedure-name model) + (error-irritant/noise char:newline) + (error-irritant/noise + "minimum/maximum number of arguments:") + n-required + n-expected)) + (- n-expected n-supplied)))) + (parallel (application-parallel-node combination))) + (if (positive? n-unassigned) + (set-parallel-subproblems! + parallel + (append! subproblems + (make-unassigned-subproblems + (combination/context combination) + n-unassigned + '())))) + (map (lambda (variable subproblem) + (cons subproblem variable)) + (append (cdr (procedure-original-required model)) + (procedure-original-optional model)) + (cdr (parallel-subproblems parallel)))) + '()))) + (define (combination-ordering context operator operands model) (let ((standard (lambda () @@ -256,14 +319,12 @@ MIT in each case. |# (with-values (lambda () (sort-subproblems/out-of-line operands callee)) - (lambda (n-unassigned integrated non-integrated) + (lambda (integrated non-integrated) (handle-operator context operator (operator-needed? (subproblem-rvalue operator)) integrated - (make-unassigned-subproblems context - n-unassigned - non-integrated))))) + non-integrated)))) (define (known-combination-ordering context operator operands procedure) (if (and (not (procedure/closure? procedure)) @@ -276,18 +337,7 @@ MIT in each case. |# (and (procedure/closure? procedure) (closure-procedure-needs-operator? procedure))) '() - (make-unassigned-subproblems - context - (let ((n-supplied (length operands)) - (n-required - (length (cdr (procedure-original-required procedure)))) - (n-optional (length (procedure-original-optional procedure)))) - (let ((n-expected (+ n-required n-optional))) - (if (or (< n-supplied n-required) (> n-supplied n-expected)) - (error "known-combination-ordering: wrong number of arguments" - procedure n-supplied n-expected)) - (- n-expected n-supplied))) - (reverse operands)))) + (reverse operands))) (define (handle-operator context operator operator-needed? effect push) (if operator-needed? @@ -328,63 +378,34 @@ MIT in each case. |# all-subproblems '() '())) - (lambda (required subproblems integrated non-integrated) - (let ((unassigned-count 0)) - (if (not (null? required)) - (begin - ;; This is a wrong number of arguments case, so the code - ;; we generate will not be any good. - ;; The missing arguments are defaulted. - (error "sort-subproblems/out-of-line: Too few arguments" - callee all-subproblems) - ;; This does not take into account potential integrated - ;; required parameters, but they better not be integrated - ;; if they are not always provided! - (set! unassigned-count (length required)))) - (with-values - (lambda () - (sort-integrated (procedure-original-optional callee) - subproblems - integrated - non-integrated)) - (lambda (optional subproblems integrated non-integrated) - (let ((rest (procedure-original-rest callee))) - (cond ((not (null? optional)) - (values (if rest - 0 ; unassigned-count might work too - ;; In this case the caller will - ;; make slots for the optionals. - (+ unassigned-count - (length - (list-transform-negative optional - lvalue-integrated?)))) - integrated - non-integrated)) - ((and (not (null? subproblems)) (not rest)) - (error "sort-subproblems/out-of-line: Too many arguments" - callee all-subproblems) - ;; This is a wrong number of arguments case, so - ;; the code we generate will not be any good. - ;; The extra arguments are dropped! Note that in - ;; this case unassigned-count should be 0, since - ;; we cannot have both too many and too few - ;; arguments simultaneously. - (values unassigned-count + (lambda (subproblems integrated non-integrated) + (with-values + (lambda () + (sort-integrated (procedure-original-optional callee) + subproblems integrated non-integrated)) - ((and rest (variable-unused? rest)) - (values unassigned-count - (append! (reverse subproblems) integrated) - non-integrated)) - (else - (values unassigned-count - integrated - (append! (reverse subproblems) - non-integrated))))))))))) + (lambda (subproblems integrated non-integrated) + (let ((rest (procedure-original-rest callee))) + (cond ((and (not (null? subproblems)) (not rest)) + ;; This is a wrong number of arguments case, so + ;; the code we generate will not be any good. + ;; The extra arguments are dropped! + (values integrated + non-integrated)) + ((and rest (variable-unused? rest)) + (values (append! (reverse subproblems) integrated) + non-integrated)) + (else + (values integrated + (append! (reverse subproblems) + non-integrated)))))))))) (define (sort-integrated lvalues subproblems integrated non-integrated) - (cond ((or (null? lvalues) (null? subproblems)) - (values lvalues subproblems integrated non-integrated)) + (cond ((null? lvalues) + (values subproblems integrated non-integrated)) + ((null? subproblems) + (error "sort-integrated: not enough subproblems" lvalues)) ((variable-unused? (car lvalues)) (sort-integrated (cdr lvalues) (cdr subproblems) diff --git a/v7/src/compiler/fgopt/reuse.scm b/v7/src/compiler/fgopt/reuse.scm index c996c4245..2ccbc1ca6 100644 --- a/v7/src/compiler/fgopt/reuse.scm +++ b/v7/src/compiler/fgopt/reuse.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.4 1989/10/26 07:37:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/reuse.scm,v 1.5 1990/02/02 18:38:59 cph Exp $ -Copyright (c) 1988, 1989 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -80,7 +80,7 @@ MIT in each case. |# applications)) (define (order-subproblems/maybe-overwrite-block combination subproblems rest - if-no-overwrite) + alist if-no-overwrite) (let ((caller-block (combination/block combination)) ;; This reduces code size. (if-no-overwrite (lambda () (if-no-overwrite)))) @@ -109,13 +109,12 @@ MIT in each case. |# 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)))))) + (values + (linearize-subproblems! continuation-type/push + extra-subproblems + alist + cfg) + (append extra-subproblems subproblem-ordering))))) (if-no-overwrite)))) (if-no-overwrite))))) @@ -270,6 +269,7 @@ MIT in each case. |# continuation-type/register continuation-type/push) (node-value (car nodes)) + false (generate-assignments (cdr nodes) (overwrite (car nodes) rest)))) (else @@ -293,6 +293,7 @@ MIT in each case. |# rest) (linearize-subproblem! continuation-type/register (node-value node) + false (overwrite node rest)))) (define (node/noop? node) diff --git a/v7/src/compiler/machines/bobcat/compiler.pkg b/v7/src/compiler/machines/bobcat/compiler.pkg index b93954aea..c7f8655fc 100644 --- a/v7/src/compiler/machines/bobcat/compiler.pkg +++ b/v7/src/compiler/machines/bobcat/compiler.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.27 1990/01/22 23:45:02 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/compiler.pkg,v 1.28 1990/02/02 18:39:20 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -194,7 +194,9 @@ MIT in each case. |# show-rtl write-rtl-instructions) (import (runtime pretty-printer) - *pp-primitives-by-name*)) + *pp-primitives-by-name*) + (import (runtime unparser) + *unparse-uninterned-symbols-by-name?*)) (define-package (compiler pattern-matcher/lookup) (files "base/pmlook") diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 2a77bf34d..d7ff1ad31 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.25 1990/01/18 22:43:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.26 1990/02/02 18:39:26 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -394,8 +394,8 @@ MIT in each case. |# (filename/append "machines/bobcat" "machin")) (rtl-base (filename/append "rtlbase" - "regset" "rgraph" "rtlcfg" "rtlobj" - "rtlreg" "rtlty1" "rtlty2")) + "rgraph" "rtlcfg" "rtlobj" "rtlreg" "rtlty1" + "rtlty2")) (cse-base (filename/append "rtlopt" "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr")) @@ -463,7 +463,6 @@ MIT in each case. |# (define-integration-dependencies "machines/bobcat" "machin" "rtlbase" "rtlreg" "rtlty1" "rtlty2") - (define-integration-dependencies "rtlbase" "regset" "base") (define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2") (define-integration-dependencies "rtlbase" "rgraph" "machines/bobcat" "machin") @@ -518,8 +517,14 @@ MIT in each case. |# (file-dependency/integration/join cse-base cse-base) - (define-integration-dependencies "rtlopt" "rcseht" "base" "object") - (define-integration-dependencies "rtlopt" "rcserq" "base" "object") + (file-dependency/integration/join + (filename/append "rtlopt" "ralloc" "rcompr" "rdebug" "rlife") + (filename/append "rtlbase" "regset")) + + (file-dependency/integration/join + (filename/append "rtlopt" "rcseht" "rcserq") + (filename/append "base" "object")) + (define-integration-dependencies "rtlopt" "rlife" "base" "cfg2") (let ((dependents @@ -541,7 +546,7 @@ MIT in each case. |# (define-integration-dependencies "back" "lapgn1" "base" "cfg1" "cfg2" "utils") (define-integration-dependencies "back" "lapgn1" "rtlbase" - "regset" "rgraph" "rtlcfg") + "rgraph" "rtlcfg") (define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg") (define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg") (define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2") diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index c61e72164..ad89dd25f 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.65 1990/01/22 23:45:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.66 1990/02/02 18:39:31 cph Exp $ Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar (Motorola MC68020)" 4 65 '())) \ No newline at end of file +(add-system! (make-system "Liar (Motorola MC68020)" 4 66 '())) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/regset.scm b/v7/src/compiler/rtlbase/regset.scm index c9b810de1..8e34f1573 100644 --- a/v7/src/compiler/rtlbase/regset.scm +++ b/v7/src/compiler/rtlbase/regset.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/regset.scm,v 1.2 1988/06/14 08:36:51 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/regset.scm,v 1.3 1990/02/02 18:39:46 cph Rel $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,6 +36,51 @@ MIT in each case. |# (declare (usual-integrations)) +(define-integrable (make-regset n-registers) + (make-bit-string n-registers false)) + +(define (for-each-regset-member regset procedure) + (let ((end (bit-string-length regset))) + (let loop ((start 0)) + (let ((register (bit-substring-find-next-set-bit regset start end))) + (if register + (begin + (procedure register) + (loop (1+ register)))))))) + +(define (regset->list regset) + (let ((end (bit-string-length regset))) + (let loop ((start 0)) + (let ((register (bit-substring-find-next-set-bit regset start end))) + (if register + (cons register (loop (1+ register))) + '()))))) + +(define-integrable (regset-clear! regset) + (bit-string-fill! regset false)) + +(define-integrable (regset-disjoint? x y) + (regset-null? (regset-intersection x y))) + +(define-integrable regset-allocate bit-string-allocate) +(define-integrable regset-adjoin! bit-string-set!) +(define-integrable regset-delete! bit-string-clear!) +(define-integrable regset-member? bit-string-ref) +(define-integrable regset=? bit-string=?) +(define-integrable regset-null? bit-string-zero?) + +(define-integrable regset-copy! bit-string-move!) +(define-integrable regset-union! bit-string-or!) +(define-integrable regset-difference! bit-string-andc!) +(define-integrable regset-intersection! bit-string-and!) + +(define-integrable regset-copy bit-string-copy) +(define-integrable regset-union bit-string-or) +(define-integrable regset-difference bit-string-andc) +(define-integrable regset-intersection bit-string-and) + +#| Alternate representation. + (define-integrable (make-regset n-registers) n-registers (list 'REGSET)) @@ -50,8 +95,6 @@ MIT in each case. |# (define-integrable (regset->list regset) (list-copy (cdr regset))) -(define-integrable regset-copy list-copy) - (define-integrable (regset-clear! regset) (set-cdr! regset '())) @@ -86,6 +129,8 @@ MIT in each case. |# (define (regset-intersection! destination source) (set-cdr! destination (eq-set-intersection (cdr source) (cdr destination)))) +(define-integrable regset-copy list-copy) + (define-integrable (regset-union x y) (cons 'REGSET (eq-set-union (cdr x) (cdr y)))) @@ -94,64 +139,5 @@ MIT in each case. |# (define-integrable (regset-intersection x y) (cons 'REGSET (eq-set-intersection (cdr x) (cdr y)))) - -#| Alternate representation. - -(define-integrable (make-regset n-registers) - (make-bit-string n-registers false)) - -(define (for-each-regset-member regset procedure) - (let ((end (bit-string-length regset))) - (define (loop register) - (if register - (begin (procedure register) - (loop (bit-substring-find-next-set-bit regset - (1+ register) - end))))) - (loop (bit-substring-find-next-set-bit regset 0 end)))) - -(define (regset->list regset) - (let ((end (bit-string-length regset))) - (define (loop register) - (if register - (cons register - (loop (bit-substring-find-next-set-bit regset - (1+ register) - end))) - '())) - (loop (bit-substring-find-next-set-bit regset 0 end)))) - -(define (regset-copy regset) - (let ((result (bit-string-allocate (bit-string-length regset)))) - (regset-copy! result regset) - result)) - -(define-integrable (regset-clear! regset) - (bit-string-fill! regset false)) - -(define-integrable (regset-disjoint? x y) - (regset-null? (regset-intersection x y))) - -(define-integrable regset-allocate bit-string-allocate) -(define-integrable regset-adjoin! bit-string-set!) -(define-integrable regset-delete! bit-string-clear!) -(define-integrable regset-member? bit-string-ref) -(define-integrable regset=? bit-string=?) -(define-integrable regset-null? bit-string-zero?) -(define-integrable regset-copy! bit-string-move!) -(define-integrable regset-union! bit-string-or!) -(define-integrable regset-difference! bit-string-andc!) -(define-integrable regset-intersection! bit-string-and!) - -(package (regset-union regset-difference regset-intersection) - (let ((wrap-operator - (lambda (operator) - (lambda (x y) - (let ((result (regset-copy x))) - (operator result y) - result))))) - (define-export regset-union (wrap-operator regset-union!)) - (define-export regset-difference (wrap-operator regset-difference!)) - (define-export regset-intersection (wrap-operator regset-intersection!)))) |# \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgproc.scm b/v7/src/compiler/rtlgen/rgproc.scm index 91476d3e4..60b925708 100644 --- a/v7/src/compiler/rtlgen/rgproc.scm +++ b/v7/src/compiler/rtlgen/rgproc.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.9 1989/11/21 22:21:12 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgproc.scm,v 4.10 1990/02/02 18:40:00 cph Exp $ -Copyright (c) 1988 Massachusetts Institute of Technology +Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -74,8 +74,10 @@ MIT in each case. |# (lambda (min max) (if (open-procedure-needs-dynamic-link? procedure) (scfg*scfg->scfg! - (rtl:make-procedure-header (procedure-label procedure) - (1+ min) (-1+ max)) + (rtl:make-procedure-header + (procedure-label procedure) + (1+ min) + (-1+ max)) (rtl:make-pop-link)) (rtl:make-procedure-header (procedure-label procedure) min max))))) @@ -107,12 +109,15 @@ MIT in each case. |# (scfg*->scfg! (map cellify-variable variables))) (define (cellify-variable variable) - (if (variable-in-cell? variable) + (if (and (variable-in-cell? variable) + (not (and (variable-source-node variable) + (procedure-inline-code? procedure)))) (let ((locative (let ((register (variable/register variable))) (or register - (stack-locative-offset (rtl:make-fetch register:stack-pointer) - (variable-offset block variable)))))) + (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)))) diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index a5494a10d..486d85e7e 100644 --- a/v7/src/compiler/rtlgen/rgstmt.scm +++ b/v7/src/compiler/rtlgen/rgstmt.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.11 1990/01/18 22:47:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.12 1990/02/02 18:40:04 cph Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -77,27 +77,28 @@ MIT in each case. |# (load-temporary-register scfg*scfg->scfg! (rtl:make-assignment-cache name) (lambda (cell) - (let ((contents (rtl:make-fetch cell))) - (let ((n2 (rtl:make-type-test (rtl:make-object->type contents) - (ucode-type reference-trap))) - (n3 (rtl:make-unassigned-test contents)) - (n4 (rtl:make-assignment cell value)) - (n5 - (load-temporary-register scfg*scfg->scfg! value - (lambda (value) + (load-temporary-register scfg*scfg->scfg! value + (lambda (value) + (let ((contents (rtl:make-fetch cell))) + (let ((n2 (rtl:make-type-test (rtl:make-object->type contents) + (ucode-type reference-trap))) + (n3 (rtl:make-unassigned-test contents)) + (n4 (rtl:make-assignment cell value)) + (n5 (wrap-with-continuation-entry context - (rtl:make-interpreter-call:cache-assignment cell value))))) - ;; Copy prevents premature control merge which confuses CSE - (n6 (rtl:make-assignment cell value))) - (pcfg-consequent-connect! n2 n3) - (pcfg-alternative-connect! n2 n4) - (pcfg-consequent-connect! n3 n6) - (pcfg-alternative-connect! n3 n5) - (make-scfg (cfg-entry-node n2) - (hooks-union (scfg-next-hooks n4) - (hooks-union (scfg-next-hooks n5) - (scfg-next-hooks n6))))))))) + (rtl:make-interpreter-call:cache-assignment cell value))) + ;; Copy prevents premature control merge which confuses CSE + (n6 (rtl:make-assignment cell value))) + (pcfg-consequent-connect! n2 n3) + (pcfg-alternative-connect! n2 n4) + (pcfg-consequent-connect! n3 n6) + (pcfg-alternative-connect! n3 n5) + (make-scfg (cfg-entry-node n2) + (hooks-union + (scfg-next-hooks n4) + (hooks-union (scfg-next-hooks n5) + (scfg-next-hooks n6))))))))))) (define (generate/definition definition) (let ((context (definition-context definition)) @@ -157,6 +158,14 @@ MIT in each case. |# ((rvalue/continuation? operand) ;; This is a pun set up by the FG generator. (generate/continuation-cons operand)) + ((let ((variable (virtual-return/target-lvalue return))) + (and variable + (variable-in-cell? variable) + (procedure-inline-code? + (block-procedure (variable-block variable))))) + (generate/rvalue operand scfg*scfg->scfg! + (lambda (expression) + (rtl:make-push (rtl:make-cell-cons expression))))) (else (operand->push operand)))) (else @@ -169,7 +178,7 @@ MIT in each case. |# (generate/rvalue operand scfg*scfg->scfg! (lambda (expression) (rtl:make-assignment register expression)))) - + (define (load-temporary-register receiver expression generator) (let ((temporary (rtl:make-pseudo-register))) ;; Force assignment to be made before `generator' is called. This @@ -191,7 +200,7 @@ MIT in each case. |# (scfg*scfg->scfg! extra (rtl:make-push-return (continuation/label continuation))))))) - + (define (generate/pop pop) (rtl:make-pop (continuation*/register (pop-continuation pop))))