From 3052c0807061a4d64b39eff3ff67c67482a8d35f Mon Sep 17 00:00:00 2001 From: Mark Friedman Date: Fri, 21 Apr 1989 17:14:14 +0000 Subject: [PATCH] Support for passing arguments in registers. --- v7/src/compiler/base/lvalue.scm | 16 ++++- v7/src/compiler/base/proced.scm | 17 ++++- v7/src/compiler/base/toplev.scm | 15 ++-- v7/src/compiler/fggen/fggen.scm | 15 ++-- v7/src/compiler/fgopt/blktyp.scm | 40 +++++++---- v7/src/compiler/fgopt/reuse.scm | 88 ++++++++++++++++------- v7/src/compiler/machines/bobcat/decls.scm | 28 ++++---- v7/src/compiler/rtlgen/fndvar.scm | 23 +++--- v7/src/compiler/rtlgen/rgproc.scm | 8 ++- 9 files changed, 174 insertions(+), 76 deletions(-) diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index f85e6ca31..668c24f81 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.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 @@ -83,13 +83,17 @@ MIT in each case. |# 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)) @@ -121,6 +125,12 @@ MIT in each case. |# (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))) ;;;; Linking diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index 6d4aff334..5e969b11f 100644 --- a/v7/src/compiler/base/proced.scm +++ b/v7/src/compiler/base/proced.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -311,4 +311,17 @@ MIT in each case. |# (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))))) diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 9a70de92f..d6ae1bf54 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -450,8 +450,10 @@ MIT in each case. |# (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) @@ -524,6 +526,11 @@ MIT in each case. |# (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 () @@ -536,8 +543,8 @@ MIT in each case. |# (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" diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index 31d79ea4d..4298b111a 100644 --- a/v7/src/compiler/fggen/fggen.scm +++ b/v7/src/compiler/fggen/fggen.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -303,18 +303,25 @@ MIT in each case. |# (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)))))) (define (generate/lambda block continuation expression) (generate/lambda* block continuation expression false false)) diff --git a/v7/src/compiler/fgopt/blktyp.scm b/v7/src/compiler/fgopt/blktyp.scm index 7f4e2a38b..798c62d05 100644 --- a/v7/src/compiler/fgopt/blktyp.scm +++ b/v7/src/compiler/fgopt/blktyp.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -66,6 +66,16 @@ MIT in each case. |# (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. @@ -82,17 +92,14 @@ MIT in each case. |# 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))) @@ -103,14 +110,16 @@ MIT in each case. |# procedure)))) (disown-block-child! current-parent block))) -(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) @@ -119,7 +128,8 @@ MIT in each case. |# (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) @@ -138,10 +148,14 @@ MIT in each case. |# ;; 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 '() diff --git a/v7/src/compiler/fgopt/reuse.scm b/v7/src/compiler/fgopt/reuse.scm index 33a2a22d6..dc9f1849d 100644 --- a/v7/src/compiler/fgopt/reuse.scm +++ b/v7/src/compiler/fgopt/reuse.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -100,14 +100,22 @@ MIT in each case. |# (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))))) @@ -118,9 +126,9 @@ MIT in each case. |# (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) @@ -149,9 +157,10 @@ MIT in each case. |# (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))))))) @@ -171,7 +180,11 @@ MIT in each case. |# (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)) @@ -229,18 +242,22 @@ MIT in each case. |# 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) @@ -260,14 +277,21 @@ MIT in each case. |# (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)))) @@ -287,9 +311,23 @@ MIT in each case. |# (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)) + diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 9d495daed..dfbab326b 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.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 @@ -331,10 +331,11 @@ MIT in each case. |# 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" @@ -344,10 +345,10 @@ MIT in each case. |# (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") @@ -372,8 +373,9 @@ MIT in each case. |# (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")) @@ -479,8 +481,8 @@ MIT in each case. |# (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)) diff --git a/v7/src/compiler/rtlgen/fndvar.scm b/v7/src/compiler/rtlgen/fndvar.scm index bfff64ea7..0fcea9888 100644 --- a/v7/src/compiler/rtlgen/fndvar.scm +++ b/v7/src/compiler/rtlgen/fndvar.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -91,13 +91,15 @@ MIT in each case. |# (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)))) - + (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)))))) (define (find-definition-variable context lvalue) (find-block/variable context lvalue (lambda (offset-locative) @@ -170,4 +172,7 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/rtlgen/rgproc.scm b/v7/src/compiler/rtlgen/rgproc.scm index 1b62ac79e..0e9655337 100644 --- a/v7/src/compiler/rtlgen/rgproc.scm +++ b/v7/src/compiler/rtlgen/rgproc.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -104,8 +104,10 @@ MIT in each case. |# (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)))) -- 2.25.1