From: Chris Hanson Date: Fri, 4 Dec 1987 20:18:28 +0000 (+0000) Subject: Major redesign of front end of compiler. Continuations are now X-Git-Tag: 20090517-FFI~13017 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1cea147379f8de02fff1c1a09b03262b066b1929;p=mit-scheme.git Major redesign of front end of compiler. Continuations are now modeled more exactly by means of a CPS-style analysis. Poppers have been flushed in favor of dynamic links, and optimizations have been added that eliminate the use of static and dynamic links in many cases. --- diff --git a/v7/src/compiler/rtlbase/rgraph.scm b/v7/src/compiler/rtlbase/rgraph.scm index f8d2960fc..ee446636c 100644 --- a/v7/src/compiler/rtlbase/rgraph.scm +++ b/v7/src/compiler/rtlbase/rgraph.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 1.2 1987/08/11 06:11:48 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rgraph.scm,v 4.1 1987/12/04 20:17:21 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,10 +38,10 @@ MIT in each case. |# (define-structure (rgraph (type vector) (copier false) - (constructor false)) - edge + (constructor make-rgraph (n-registers))) n-registers - continuations + (address-registers (reverse initial-address-registers)) + entry-edges bblocks register-bblock register-n-refs @@ -49,24 +49,22 @@ MIT in each case. |# register-live-length register-crosses-call? ) -(define (rgraph-allocate) - (make-vector 9 false)) +(define (add-rgraph-address-register! rgraph register) + (set-rgraph-address-registers! rgraph + (cons register + (rgraph-address-registers rgraph)))) + +(define (add-rgraph-entry-node! rgraph node) + (set-rgraph-entry-edges! rgraph + (cons (node->edge node) + (rgraph-entry-edges rgraph)))) (define-integrable rgraph-register-renumber rgraph-register-bblock) (define-integrable set-rgraph-register-renumber! set-rgraph-register-bblock!) (define *rgraphs*) (define *current-rgraph*) -(define (rgraph-entry-edges rgraph) - (cons (rgraph-edge rgraph) - (map continuation-rtl-edge (rgraph-continuations rgraph)))) - (define (rgraph-initial-edges rgraph) - (cons (rgraph-edge rgraph) - (let loop ((continuations (rgraph-continuations rgraph))) - (if (null? continuations) - '() - (let ((edge (continuation-rtl-edge (car continuations)))) - (if (node-previous=0? (edge-right-node edge)) - (cons edge (loop (cdr continuations))) - (loop (cdr continuations)))))))) \ No newline at end of file + (list-transform-positive (rgraph-entry-edges rgraph) + (lambda (edge) + (node-previous=0? (edge-right-node edge))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlcfg.scm b/v7/src/compiler/rtlbase/rtlcfg.scm index 068bec388..58e0027e9 100644 --- a/v7/src/compiler/rtlbase/rtlcfg.scm +++ b/v7/src/compiler/rtlbase/rtlcfg.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 1.5 1987/08/08 23:21:07 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 4.1 1987/12/04 20:17:27 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -41,11 +41,9 @@ MIT in each case. |# (define-vector-slots bblock 5 instructions - (live-at-entry - register-map) + (live-at-entry register-map) live-at-exit - (new-live-at-exit - frame-pointer-offset) + (new-live-at-exit frame-pointer-offset) label) (define (make-sblock instructions) @@ -78,17 +76,19 @@ MIT in each case. |# instructions register-map frame-pointer-offset)))) - (define-vector-method sblock-tag ':DESCRIBE - (lambda (sblock) - (append! ((vector-tag-method snode-tag ':DESCRIBE) sblock) - (bblock-describe sblock)))) - (define-vector-method pblock-tag ':DESCRIBE - (lambda (pblock) - (append! ((vector-tag-method pnode-tag ':DESCRIBE) pblock) - (bblock-describe pblock) - (descriptor-list pblock - consequent-lap-generator - alternative-lap-generator))))) + (set-vector-tag-description! + sblock-tag + (lambda (sblock) + (append! ((vector-tag-description snode-tag) sblock) + (bblock-describe sblock)))) + (set-vector-tag-description! + pblock-tag + (lambda (pblock) + (append! ((vector-tag-description pnode-tag) pblock) + (bblock-describe pblock) + (descriptor-list pblock + consequent-lap-generator + alternative-lap-generator))))) (define (rinst-dead-register? rinst register) (memq register (rinst-dead-registers rinst))) @@ -157,6 +157,6 @@ MIT in each case. |# (set-bblock-instructions! bblock instructions) (begin (snode-delete! bblock) - (let ((rgraph *current-rgraph*)) - (set-rgraph-bblocks! rgraph - (delq! bblock (rgraph-bblocks rgraph)))))))) \ No newline at end of file + (set-rgraph-bblocks! *current-rgraph* + (delq! bblock + (rgraph-bblocks *current-rgraph*))))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 356be32af..8f30fb765 100644 --- a/v7/src/compiler/rtlbase/rtlcon.scm +++ b/v7/src/compiler/rtlbase/rtlcon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 1.13 1987/09/03 05:15:47 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.1 1987/12/04 20:17:34 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -67,44 +67,83 @@ MIT in each case. |# (lambda (expression) (%make-unassigned-test expression)))) -;;; Some statements vanish, converted into lower-level patterns. - (define (rtl:make-pop locative) (locative-dereference-for-statement locative - (lambda (address) - (%make-assign address (stack-pop-address))))) - -(define (rtl:make-pop-frame n) - (rtl:make-assignment - register:stack-pointer - (rtl:make-address - (stack-locative-offset (rtl:make-fetch register:stack-pointer) n)))) + (lambda (locative) + (%make-assign locative (stack-pop-address))))) (define (rtl:make-push expression) (expression-simplify-for-statement expression (lambda (expression) (%make-assign (stack-push-address) expression)))) -(define (rtl:make-push-return continuation) - (%make-assign (stack-push-address) - (rtl:make-entry:continuation continuation))) +(define-integrable (rtl:make-address->environment address) + (rtl:make-cons-pointer (rtl:make-constant (ucode-type stack-environment)) + address)) + +(define (rtl:make-push-link) + (scfg*scfg->scfg! + (rtl:make-push + (rtl:make-cons-pointer (rtl:make-constant (ucode-type stack-environment)) + (rtl:make-fetch register:dynamic-link))) + (rtl:make-assignment register:dynamic-link + (rtl:make-fetch register:stack-pointer)))) + +(define-integrable (rtl:make-push-return continuation) + (rtl:make-push (rtl:make-entry:continuation continuation))) + +(define (rtl:make-unlink-return) + (scfg*scfg->scfg! + (rtl:make-pop-link) + (rtl:make-pop-return))) + +(define (rtl:make-pop-link) + (scfg*scfg->scfg! + (rtl:make-assignment register:stack-pointer + (rtl:make-fetch register:dynamic-link)) + (rtl:make-assignment register:dynamic-link + (rtl:make-object->address (stack-pop-address))))) ;;; Interpreter Calls -(define ((interpreter-lookup-maker %make) environment name) +(define rtl:make-interpreter-call:access) +(define rtl:make-interpreter-call:cache-unassigned?) +(define rtl:make-interpreter-call:unassigned?) +(define rtl:make-interpreter-call:unbound?) +(let ((interpreter-lookup-maker + (lambda (%make) + (lambda (environment name) + (expression-simplify-for-statement environment + (lambda (environment) + (%make environment name))))))) + (set! rtl:make-interpreter-call:access + (interpreter-lookup-maker %make-interpreter-call:access)) + (set! rtl:make-interpreter-call:cache-unassigned? + (interpreter-lookup-maker %make-interpreter-call:cache-unassigned?)) + (set! rtl:make-interpreter-call:unassigned? + (interpreter-lookup-maker %make-interpreter-call:unassigned?)) + (set! rtl:make-interpreter-call:unbound? + (interpreter-lookup-maker %make-interpreter-call:unbound?))) + +(define rtl:make-interpreter-call:define) +(define rtl:make-interpreter-call:set!) +(let ((interpreter-assignment-maker + (lambda (%make) + (lambda (environment name value) + (expression-simplify-for-statement value + (lambda (value) + (expression-simplify-for-statement environment + (lambda (environment) + (%make environment name value))))))))) + (set! rtl:make-interpreter-call:define + (interpreter-assignment-maker %make-interpreter-call:define)) + (set! rtl:make-interpreter-call:set! + (interpreter-assignment-maker %make-interpreter-call:set!))) + +(define (rtl:make-interpreter-call:lookup environment name safe?) (expression-simplify-for-statement environment (lambda (environment) - (%make environment name)))) - -(define ((interpreter-assignment-maker %make) environment name value) - (expression-simplify-for-statement value - (lambda (value) - (expression-simplify-for-statement environment - (lambda (environment) - (%make environment name value)))))) - -(define rtl:make-interpreter-call:access - (interpreter-lookup-maker %make-interpreter-call:access)) + (%make-interpreter-call:lookup environment name safe?)))) (define (rtl:make-interpreter-call:cache-assignment name value) (expression-simplify-for-statement name @@ -117,77 +156,6 @@ MIT in each case. |# (expression-simplify-for-statement name (lambda (name) (%make-interpreter-call:cache-reference name safe?)))) - -(define (rtl:make-interpreter-call:cache-unassigned? name) - (expression-simplify-for-statement name - (lambda (name) - (%make-interpreter-call:cache-unassigned? name)))) - -(define rtl:make-interpreter-call:define - (interpreter-assignment-maker %make-interpreter-call:define)) - -(define (rtl:make-interpreter-call:lookup environment name safe?) - (expression-simplify-for-statement environment - (lambda (environment) - (%make-interpreter-call:lookup environment name safe?)))) - -(define rtl:make-interpreter-call:set! - (interpreter-assignment-maker %make-interpreter-call:set!)) - -(define rtl:make-interpreter-call:unassigned? - (interpreter-lookup-maker %make-interpreter-call:unassigned?)) - -(define rtl:make-interpreter-call:unbound? - (interpreter-lookup-maker %make-interpreter-call:unbound?)) - -;;;; Invocations - -(define (rtl:make-invocation:apply frame-size prefix continuation) - (%make-invocation:apply - frame-size prefix (and continuation (continuation-label continuation)))) - -(define (rtl:make-invocation:cache-reference frame-size prefix continuation - extension) - (expression-simplify-for-statement extension - (lambda (extension) - (%make-invocation:cache-reference - frame-size prefix (and continuation (continuation-label continuation)) - extension)))) - -(define (rtl:make-invocation:jump frame-size prefix continuation procedure) - (%make-invocation:jump - frame-size prefix (and continuation (continuation-label continuation)) - (procedure-label procedure))) - -(define (rtl:make-invocation:lexpr frame-size prefix continuation procedure) - (%make-invocation:lexpr - frame-size prefix (and continuation (continuation-label continuation)) - (procedure-label procedure))) - -(define (rtl:make-invocation:lookup frame-size prefix continuation - environment name) - (expression-simplify-for-statement environment - (lambda (environment) - (%make-invocation:lookup - frame-size prefix (and continuation (continuation-label continuation)) - environment name)))) - -(define (rtl:make-invocation:primitive frame-size prefix continuation - procedure) - (%make-invocation:primitive - frame-size prefix (and continuation (continuation-label continuation)) - procedure)) - -(define (rtl:make-invocation:special-primitive name frame-size - prefix continuation) - (%make-invocation:special-primitive - name frame-size prefix - (and continuation (continuation-label continuation)))) - -(define (rtl:make-invocation:uuo-link frame-size prefix continuation name) - (%make-invocation:uuo-link - frame-size prefix (and continuation (continuation-label continuation)) - name)) ;;;; Expression Simplification @@ -213,26 +181,24 @@ MIT in each case. |# (if-register register) (if-memory (interpreter-regs-pointer) (rtl:interpreter-register->offset locative))))) - ((temporary? locative) - (if-register (temporary->register locative))) ((pair? locative) (case (car locative) + ((REGISTER) + (if-register locative)) ((FETCH) - (locative-fetch (cadr locative) scfg-append! - (lambda (register) - (if-memory register 0)))) + (locative-fetch (cadr locative) 0 scfg-append! if-memory)) ((OFFSET) (let ((fetch (cadr locative))) (if (and (pair? fetch) (eq? (car fetch) 'FETCH)) - (locative-fetch (cadr fetch) scfg-append! - (lambda (register) - (if-memory register (caddr locative)))) + (locative-fetch (cadr fetch) + (caddr locative) + scfg-append! + if-memory) (error "LOCATIVE-DEREFERENCE: Bad OFFSET" locative)))) ((CONSTANT) (assign-to-temporary locative scfg-append! (lambda (register) - (assign-to-temporary (rtl:make-object->address register) - scfg-append! + (assign-to-address-temporary register scfg-append! (lambda (register) (if-memory register 0)))))) (else @@ -240,22 +206,49 @@ MIT in each case. |# (else (error "LOCATIVE-DEREFERENCE: Illegal locative" locative)))) -(define (locative-fetch locative scfg-append! receiver) - (locative-fetch-1 locative scfg-append! - (lambda (register) - (if (register-contains-address? (rtl:register-number register)) - (receiver register) - (assign-to-temporary (rtl:make-object->address register) - scfg-append! - receiver))))) +(define (locative-fetch locative offset scfg-append! receiver) + (let ((receiver + (lambda (register) + (guarantee-address register scfg-append! + (lambda (address) + (receiver address offset)))))) + (locative-dereference locative scfg-append! + receiver + (lambda (register offset) + (assign-to-temporary (rtl:make-offset register offset) + scfg-append! + receiver))))) -(define (locative-fetch-1 locative scfg-append! receiver) +(define (locative-fetch-1 locative offset scfg-append! receiver) (locative-dereference locative scfg-append! - receiver - (lambda (register offset) - (assign-to-temporary (rtl:make-offset register offset) - scfg-append! - receiver)))) + (lambda (register) + (receiver register offset)) + (lambda (register offset*) + (receiver (rtl:make-offset register offset*) offset)))) + +(define (guarantee-address expression scfg-append! receiver) + (if (rtl:address-expression? expression) + (receiver expression) + (guarantee-register expression scfg-append! + (lambda (register) + (assign-to-address-temporary register scfg-append! receiver))))) + +(define (rtl:address-expression? expression) + (if (rtl:register? expression) + (register-contains-address? (rtl:register-number expression)) + (rtl:object->address? expression))) + +(define (guarantee-register expression scfg-append! receiver) + (if (rtl:register? expression) + (receiver expression) + (assign-to-temporary expression scfg-append! receiver))) + +(define (generate-offset-address expression offset scfg-append! receiver) + (guarantee-address expression scfg-append! + (lambda (address) + (guarantee-register address scfg-append! + (lambda (register) + (receiver (rtl:make-offset-address register offset))))))) (define-export (expression-simplify-for-statement expression receiver) (expression-simplify expression scfg*scfg->scfg! receiver)) @@ -263,23 +256,36 @@ MIT in each case. |# (define-export (expression-simplify-for-predicate expression receiver) (expression-simplify expression scfg*pcfg->pcfg! receiver)) -(define (expression-simplify expression scfg-append! receiver) - (let ((entry (assq (car expression) expression-methods)) - (receiver (expression-receiver scfg-append! receiver))) - (if entry - (apply (cdr entry) receiver scfg-append! (cdr expression)) - (receiver expression)))) +(define (expression-simplify* expression scfg-append! receiver) + (expression-simplify expression + scfg-append! + (expression-receiver scfg-append! receiver))) (define ((expression-receiver scfg-append! receiver) expression) - (if (memq (car expression) - '(REGISTER CONSTANT ENTRY:CONTINUATION ENTRY:PROCEDURE UNASSIGNED)) + (if (rtl:trivial-expression? expression) (receiver expression) (assign-to-temporary expression scfg-append! receiver))) +(define (expression-simplify expression scfg-append! receiver) + (let ((entry (assq (car expression) expression-methods))) + (if entry + (apply (cdr entry) receiver scfg-append! (cdr expression)) + (receiver expression)))) + (define (assign-to-temporary expression scfg-append! receiver) (let ((pseudo (rtl:make-pseudo-register))) + (if (rtl:object->address? expression) + (add-rgraph-address-register! *current-rgraph* + (rtl:register-number pseudo))) (scfg-append! (%make-assign pseudo expression) (receiver pseudo)))) +(define (assign-to-address-temporary expression scfg-append! receiver) + (let ((pseudo (rtl:make-pseudo-register))) + (add-rgraph-address-register! *current-rgraph* + (rtl:register-number pseudo)) + (scfg-append! (%make-assign pseudo (rtl:make-object->address expression)) + (receiver pseudo)))) + (define (define-expression-method name method) (let ((entry (assq name expression-methods))) (if entry @@ -289,20 +295,28 @@ MIT in each case. |# (define expression-methods '()) - -(define-expression-method 'ADDRESS + +(define (address-method generator) (lambda (receiver scfg-append! locative) (locative-dereference-1 locative scfg-append! locative-fetch-1 (lambda (register) (error "Can't take ADDRESS of a register" locative)) - (lambda (register offset) - (receiver (if (zero? offset) - register - (rtl:make-offset-address register offset))))))) - + (generator receiver scfg-append!)))) + +(define-expression-method 'ADDRESS + (address-method + (lambda (receiver scfg-append!) + (lambda (expression offset) + (if (zero? offset) + (guarantee-address expression scfg-append! receiver) + (generate-offset-address expression + offset + scfg-append! + receiver)))))) + (define-expression-method 'CELL-CONS (lambda (receiver scfg-append! expression) - (expression-simplify expression scfg-append! + (expression-simplify* expression scfg-append! (lambda (expression) (let ((free (interpreter-free-pointer))) (assign-to-temporary @@ -313,6 +327,21 @@ MIT in each case. |# (%make-assign (rtl:make-post-increment free 1) expression) (receiver temporary))))))))) +(define-expression-method 'ENVIRONMENT + (address-method + (lambda (receiver scfg-append!) + (lambda (expression offset) + (if (zero? offset) + (receiver + (if (rtl:address-expression? expression) + (rtl:make-address->environment expression) + expression)) + (generate-offset-address expression offset scfg-append! + (lambda (expression) + (assign-to-temporary expression scfg-append! + (lambda (register) + (receiver (rtl:make-address->environment register))))))))))) + (define-expression-method 'FETCH (lambda (receiver scfg-append! locative) (locative-dereference locative scfg-append! @@ -324,11 +353,11 @@ MIT in each case. |# (lambda (receiver scfg-append! type car cdr) (let ((free (interpreter-free-pointer))) (let ((target (rtl:make-post-increment free 1))) - (expression-simplify type scfg-append! + (expression-simplify* type scfg-append! (lambda (type) - (expression-simplify car scfg-append! + (expression-simplify* car scfg-append! (lambda (car) - (expression-simplify cdr scfg-append! + (expression-simplify* cdr scfg-append! (lambda (cdr) (assign-to-temporary (rtl:make-cons-pointer type free) scfg-append! @@ -338,19 +367,28 @@ MIT in each case. |# (scfg-append! (%make-assign target cdr) (receiver temporary))))))))))))))) -(define-expression-method 'OBJECT->TYPE +(define (object-selector make-object-selector) (lambda (receiver scfg-append! expression) - (expression-simplify expression scfg-append! + (expression-simplify* expression scfg-append! (lambda (expression) - (receiver (rtl:make-object->type expression)))))) + (receiver (make-object-selector expression)))))) + +(define-expression-method 'OBJECT->TYPE + (object-selector rtl:make-object->type)) + +(define-expression-method 'OBJECT->DATUM + (object-selector rtl:make-object->datum)) + +(define-expression-method 'OBJECT->ADDRESS + (object-selector rtl:make-object->address)) (define-expression-method 'CONS-POINTER (lambda (receiver scfg-append! type datum) - (expression-simplify type scfg-append! + (expression-simplify* type scfg-append! (lambda (type) - (expression-simplify datum scfg-append! + (expression-simplify* datum scfg-append! (lambda (datum) (receiver (rtl:make-cons-pointer type datum)))))))) ;;; end EXPRESSION-SIMPLIFY package -) +) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlexp.scm b/v7/src/compiler/rtlbase/rtlexp.scm index d98d6099e..a01a4568b 100644 --- a/v7/src/compiler/rtlbase/rtlexp.scm +++ b/v7/src/compiler/rtlbase/rtlexp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 1.3 1987/09/03 05:16:17 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlexp.scm,v 4.1 1987/12/04 20:17:56 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,7 +36,7 @@ MIT in each case. |# (declare (usual-integrations)) -(define (rtl:invocation? rtl) +(define-integrable (rtl:invocation? rtl) (memq (rtl:expression-type rtl) '(INVOCATION:APPLY INVOCATION:JUMP @@ -46,6 +46,15 @@ MIT in each case. |# INVOCATION:SPECIAL-PRIMITIVE INVOCATION:UUO-LINK))) +(define-integrable (rtl:trivial-expression? rtl) + (memq (rtl:expression-type rtl) + '(REGISTER + CONSTANT + ENTRY:CONTINUATION + ENTRY:PROCEDURE + UNASSIGNED + VARIABLE-CACHE))) + (define (rtl:machine-register-expression? expression) (and (rtl:register? expression) (machine-register? (rtl:register-number expression)))) @@ -69,19 +78,17 @@ MIT in each case. |# (define (rtl:any-subexpression? expression predicate) (and (not (rtl:constant? expression)) - ((there-exists? - (lambda (x) - (and (pair? x) - (predicate x)))) - (cdr expression)))) + (there-exists? (cdr expression) + (lambda (x) + (and (pair? x) + (predicate x)))))) (define (rtl:all-subexpressions? expression predicate) (or (rtl:constant? expression) - ((for-all? - (lambda (x) - (or (not (pair? x)) - (predicate x)))) - (cdr expression)))) + (for-all? (cdr expression) + (lambda (x) + (or (not (pair? x)) + (predicate x)))))) (define (rtl:reduce-subparts expression operator initial if-expression if-not) (let ((remap diff --git a/v7/src/compiler/rtlbase/rtline.scm b/v7/src/compiler/rtlbase/rtline.scm new file mode 100644 index 000000000..1df57e123 --- /dev/null +++ b/v7/src/compiler/rtlbase/rtline.scm @@ -0,0 +1,116 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.1 1987/12/04 20:18:04 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. |# + +;;;; Linearizer for CFG + +(declare (usual-integrations)) + +;;; The linearizer attaches labels to nodes under two conditions. The +;;; first is that the node in question has more than one previous +;;; neighboring node. The other is when a conditional branch requires +;;; such a label. It is assumed that if one encounters a node that +;;; has already been linearized, that it has a label, since this +;;; implies that it has more than one previous neighbor. + +;;;; RTL linearizer + +(package (bblock-linearize-rtl) + +(define-export (bblock-linearize-rtl bblock) + (node-mark! bblock) + (if (and (not (bblock-label bblock)) + (node-previous>1? bblock)) + (bblock-label! bblock)) + (let ((kernel + (lambda () + (let loop ((rinst (bblock-instructions bblock))) + (cond ((rinst-next rinst) + (cons (rinst-rtl rinst) + (loop (rinst-next rinst)))) + ((sblock? bblock) + (cons (rinst-rtl rinst) + (linearize-sblock-next (snode-next bblock)))) + (else + (linearize-pblock bblock + (rinst-rtl rinst) + (pnode-consequent bblock) + (pnode-alternative bblock)))))))) + (if (bblock-label bblock) + `(,(rtl:make-label-statement (bblock-label bblock)) ,@(kernel)) + (kernel)))) + +(define (linearize-sblock-next bblock) + (cond ((not bblock) '()) + ((node-marked? bblock) + `(,(rtl:make-jump-statement (bblock-label! bblock)))) + (else (bblock-linearize-rtl bblock)))) + +(define (linearize-pblock pblock predicate cn an) + (if (node-marked? cn) + (if (node-marked? an) + `(,(rtl:make-jumpc-statement predicate (bblock-label! cn)) + ,(rtl:make-jump-statement (bblock-label! an))) + `(,(rtl:make-jumpc-statement predicate (bblock-label! cn)) + ,@(bblock-linearize-rtl an))) + (if (node-marked? an) + `(,(rtl:make-jumpc-statement (rtl:negate-predicate predicate) + (bblock-label! an)) + ,@(bblock-linearize-rtl cn)) + (let ((label (bblock-label! cn)) + (alternative (bblock-linearize-rtl an))) + `(,(rtl:make-jumpc-statement predicate label) + ,@alternative + ,@(if (node-marked? cn) + '() + (bblock-linearize-rtl cn))))))) + +) + +;;;; Linearizers + +(define (make-linearizer map-inst bblock-linearize) + (lambda (rgraphs) + (with-new-node-marks + (lambda () + (map-inst (lambda (rgraph) + (map-inst (lambda (edge) + (let ((bblock (edge-right-node edge))) + (if (node-marked? bblock) + '() + (bblock-linearize bblock)))) + (rgraph-entry-edges rgraph))) + rgraphs))))) + +(define linearize-rtl + (make-linearizer mapcan bblock-linearize-rtl)) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlobj.scm b/v7/src/compiler/rtlbase/rtlobj.scm new file mode 100644 index 000000000..fe2fdbc8f --- /dev/null +++ b/v7/src/compiler/rtlbase/rtlobj.scm @@ -0,0 +1,112 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.1 1987/12/04 20:18:09 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. |# + +;;;; Register Transfer Language: Object Datatypes + +(declare (usual-integrations)) + +(define-structure (rtl-expr + (conc-name rtl-expr/) + (constructor make-rtl-expr (rgraph label entry-edge)) + (print-procedure + (standard-unparser 'RTL-EXPR + (lambda (expression) + (write (rtl-expr/label expression)))))) + (rgraph false read-only true) + (label false read-only true) + (entry-edge false read-only true)) + +(set-type-object-description! + rtl-expr + (lambda (expression) + `((RTL-EXPR/RGRAPH ,(rtl-expr/rgraph expression)) + (RTL-EXPR/LABEL ,(rtl-expr/label expression)) + (RTL-EXPR/ENTRY-EDGE ,(rtl-expr/entry-edge expression))))) + +(define-integrable (rtl-expr/entry-node expression) + (edge-right-node (rtl-expr/entry-edge expression))) + +(define-structure (rtl-procedure + (conc-name rtl-procedure/) + (constructor make-rtl-procedure + (rgraph label entry-edge n-required n-optional + rest? closure?)) + (print-procedure + (standard-unparser 'RTL-PROCEDURE + (lambda (procedure) + (write (rtl-procedure/label procedure)))))) + (rgraph false read-only true) + (label false read-only true) + (entry-edge false read-only true) + (n-required false read-only true) + (n-optional false read-only true) + (rest? false read-only true) + (closure? false read-only true)) + +(set-type-object-description! + rtl-procedure + (lambda (procedure) + `((RTL-PROCEDURE/RGRAPH ,(rtl-procedure/rgraph procedure)) + (RTL-PROCEDURE/LABEL ,(rtl-procedure/label procedure)) + (RTL-PROCEDURE/ENTRY-EDGE ,(rtl-procedure/entry-edge procedure)) + (RTL-PROCEDURE/N-REQUIRED ,(rtl-procedure/n-required procedure)) + (RTL-PROCEDURE/N-OPTIONAL ,(rtl-procedure/n-optional procedure)) + (RTL-PROCEDURE/REST? ,(rtl-procedure/rest? procedure)) + (RTL-PROCEDURE/CLOSURE? ,(rtl-procedure/closure? procedure))))) + +(define-integrable (rtl-procedure/entry-node procedure) + (edge-right-node (rtl-procedure/entry-edge procedure))) + +(define-structure (rtl-continuation + (conc-name rtl-continuation/) + (constructor make-rtl-continuation + (rgraph label entry-edge)) + (print-procedure + (standard-unparser 'RTL-CONTINUATION + (lambda (continuation) + (write (rtl-continuation/label continuation)))))) + (rgraph false read-only true) + (label false read-only true) + (entry-edge false read-only true)) + +(set-type-object-description! + rtl-continuation + (lambda (continuation) + `((RTL-CONTINUATION/RGRAPH ,(rtl-continuation/rgraph continuation)) + (RTL-CONTINUATION/LABEL ,(rtl-continuation/label continuation)) + (RTL-CONTINUATION/ENTRY-EDGE + ,(rtl-continuation/entry-edge continuation))))) + +(define-integrable (rtl-continuation/entry-node continuation) + (edge-right-node (rtl-continuation/entry-edge continuation))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlreg.scm b/v7/src/compiler/rtlbase/rtlreg.scm index c5f701b7e..5d70f08f3 100644 --- a/v7/src/compiler/rtlbase/rtlreg.scm +++ b/v7/src/compiler/rtlbase/rtlreg.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 1.1 1987/03/19 00:44:37 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 4.1 1987/12/04 20:18:13 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,31 +36,90 @@ MIT in each case. |# (declare (usual-integrations)) -(define machine-register-map - (make-vector number-of-machine-registers)) +(define *machine-register-map*) -(let loop ((n 0)) - (if (< n number-of-machine-registers) - (begin (vector-set! machine-register-map n (%make-register n)) - (loop (1+ n))))) +(define (with-machine-register-map thunk) + (fluid-let ((*machine-register-map* + (let ((map (make-vector number-of-machine-registers))) + (let loop ((n 0)) + (if (< n number-of-machine-registers) + (begin (vector-set! map n (%make-register n)) + (loop (1+ n))))) + map))) + (thunk))) (define-integrable (rtl:make-machine-register n) - (vector-ref machine-register-map n)) + (vector-ref *machine-register-map* n)) -(define *next-pseudo-number*) -(define *temporary->register-map*) +(define-integrable (machine-register? register) + (< register number-of-machine-registers)) + +(define (for-each-machine-register procedure) + (let ((limit number-of-machine-registers)) + (define (loop register) + (if (< register limit) + (begin (procedure register) + (loop (1+ register))))) + (loop 0))) (define (rtl:make-pseudo-register) - (let ((n *next-pseudo-number*)) - (set! *next-pseudo-number* (1+ *next-pseudo-number*)) + (let ((n (rgraph-n-registers *current-rgraph*))) + (set-rgraph-n-registers! *current-rgraph* (1+ n)) (%make-register n))) -(define (temporary->register temporary) - (let ((entry (assq temporary *temporary->register-map*))) - (if entry - (cdr entry) - (let ((register (rtl:make-pseudo-register))) - (set! *temporary->register-map* - (cons (cons temporary register) - *temporary->register-map*)) - register)))) \ No newline at end of file +(define-integrable (pseudo-register? register) + (>= register number-of-machine-registers)) + +(define (for-each-pseudo-register procedure) + (let ((n-registers (rgraph-n-registers *current-rgraph*))) + (define (loop register) + (if (< register n-registers) + (begin (procedure register) + (loop (1+ register))))) + (loop number-of-machine-registers))) + +(let-syntax + ((define-register-references + (macro (slot) + (let ((name (symbol-append 'REGISTER- slot))) + (let ((vector `(,(symbol-append 'RGRAPH- name) *CURRENT-RGRAPH*))) + `(BEGIN (DEFINE-INTEGRABLE (,name REGISTER) + (VECTOR-REF ,vector REGISTER)) + (DEFINE-INTEGRABLE + (,(symbol-append 'SET- name '!) REGISTER VALUE) + (VECTOR-SET! ,vector REGISTER VALUE)))))))) + (define-register-references bblock) + (define-register-references n-refs) + (define-register-references n-deaths) + (define-register-references live-length) + (define-register-references renumber)) + +(define-integrable (reset-register-n-refs! register) + (set-register-n-refs! register 0)) + +(define (increment-register-n-refs! register) + (set-register-n-refs! register (1+ (register-n-refs register)))) + +(define-integrable (reset-register-n-deaths! register) + (set-register-n-deaths! register 0)) + +(define (increment-register-n-deaths! register) + (set-register-n-deaths! register (1+ (register-n-deaths register)))) + +(define-integrable (reset-register-live-length! register) + (set-register-live-length! register 0)) + +(define (increment-register-live-length! register) + (set-register-live-length! register (1+ (register-live-length register)))) + +(define (decrement-register-live-length! register) + (set-register-live-length! register (-1+ (register-live-length register)))) + +(define-integrable (register-crosses-call? register) + (bit-string-ref (rgraph-register-crosses-call? *current-rgraph*) register)) + +(define-integrable (register-crosses-call! register) + (bit-string-set! (rgraph-register-crosses-call? *current-rgraph*) register)) + +(define-integrable (register-contains-address? register) + (memq register (rgraph-address-registers *current-rgraph*))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index 48169623b..fc5f835c7 100644 --- a/v7/src/compiler/rtlbase/rtlty1.scm +++ b/v7/src/compiler/rtlbase/rtlty1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 1.14 1987/10/05 20:22:15 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.1 1987/12/04 20:18:20 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -44,12 +44,12 @@ MIT in each case. |# (define-rtl-expression pre-increment rtl: register number) (define-rtl-expression post-increment rtl: register number) +(define-rtl-expression assignment-cache rtl: name) (define-rtl-expression cons-pointer rtl: type datum) (define-rtl-expression constant % value) (define-rtl-expression variable-cache rtl: name) -(define-rtl-expression assignment-cache rtl: name) -(define-rtl-expression entry:continuation % continuation) -(define-rtl-expression entry:procedure % procedure) +(define-rtl-expression entry:continuation rtl: continuation) +(define-rtl-expression entry:procedure rtl: procedure) (define-rtl-expression offset-address rtl: register number) (define-rtl-expression unassigned rtl:) @@ -59,36 +59,33 @@ MIT in each case. |# (define-rtl-predicate unassigned-test % expression) (define-rtl-statement assign % address expression) -(define-rtl-statement continuation-heap-check % continuation) -(define-rtl-statement procedure-heap-check % procedure) -(define-rtl-statement return rtl:) -(define-rtl-statement setup-lexpr % procedure) +(define-rtl-statement continuation-heap-check rtl: continuation) +(define-rtl-statement procedure-heap-check rtl: procedure) +(define-rtl-statement setup-lexpr rtl: procedure) +(define-rtl-statement pop-return rtl:) (define-rtl-statement interpreter-call:access % environment name) -(define-rtl-statement interpreter-call:cache-assignment % name value) -(define-rtl-statement interpreter-call:cache-reference % name safe?) -(define-rtl-statement interpreter-call:cache-unassigned? % name) (define-rtl-statement interpreter-call:define % environment name value) -(define-rtl-statement interpreter-call:enclose rtl: size) (define-rtl-statement interpreter-call:lookup % environment name safe?) (define-rtl-statement interpreter-call:set! % environment name value) (define-rtl-statement interpreter-call:unassigned? % environment name) (define-rtl-statement interpreter-call:unbound? % environment name) -(define-rtl-statement invocation:apply % pushed prefix continuation) -(define-rtl-statement invocation:cache-reference % pushed prefix continuation +(define-rtl-statement interpreter-call:cache-assignment % name value) +(define-rtl-statement interpreter-call:cache-reference % name safe?) +(define-rtl-statement interpreter-call:cache-unassigned? % name) +(define-rtl-statement interpreter-call:enclose rtl: size) + +(define-rtl-statement invocation:apply rtl: pushed continuation) +(define-rtl-statement invocation:cache-reference rtl: pushed continuation name) +(define-rtl-statement invocation:jump rtl: pushed continuation procedure) +(define-rtl-statement invocation:lexpr rtl: pushed continuation procedure) +(define-rtl-statement invocation:lookup rtl: pushed continuation environment name) -(define-rtl-statement invocation:jump % pushed prefix continuation procedure) -(define-rtl-statement invocation:lexpr % pushed prefix continuation procedure) -(define-rtl-statement invocation:lookup % pushed prefix continuation - environment name) -(define-rtl-statement invocation:primitive % pushed prefix continuation +(define-rtl-statement invocation:primitive rtl: pushed continuation procedure) +(define-rtl-statement invocation:special-primitive rtl: pushed continuation procedure) -(define-rtl-statement invocation:special-primitive % name pushed prefix - continuation) -(define-rtl-statement invocation:uuo-link % pushed prefix continuation name) - -(define-rtl-statement message-sender:value rtl: size) -(define-rtl-statement message-receiver:closure rtl: size) -(define-rtl-statement message-receiver:stack rtl: size) -(define-rtl-statement message-receiver:subproblem % continuation) \ No newline at end of file +(define-rtl-statement invocation:uuo-link rtl: pushed continuation name) + +(define-rtl-statement invocation-prefix:move-frame-up rtl: frame-size locative) +(define-rtl-statement invocation-prefix:dynamic-link rtl: frame-size locative) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlty2.scm b/v7/src/compiler/rtlbase/rtlty2.scm index 84d3bb2d8..5e473b55d 100644 --- a/v7/src/compiler/rtlbase/rtlty2.scm +++ b/v7/src/compiler/rtlbase/rtlty2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 1.2 1987/07/19 21:34:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty2.scm,v 4.1 1987/12/04 20:18:28 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -40,28 +40,9 @@ MIT in each case. |# (define-integrable rtl:address-register second) (define-integrable rtl:address-number third) (define-integrable rtl:invocation-pushed second) -(define-integrable rtl:invocation-prefix third) -(define-integrable rtl:invocation-continuation fourth) +(define-integrable rtl:invocation-continuation third) (define-integrable rtl:test-expression second) -(define-integrable (rtl:make-entry:continuation continuation) - (%make-entry:continuation (continuation-label continuation))) - -(define-integrable (rtl:make-entry:procedure procedure) - (%make-entry:procedure (procedure-label procedure))) - -(define-integrable (rtl:make-continuation-heap-check continuation) - (%make-continuation-heap-check (continuation-label continuation))) - -(define-integrable (rtl:make-procedure-heap-check procedure) - (%make-procedure-heap-check (procedure-label procedure))) - -(define-integrable (rtl:make-setup-lexpr procedure) - (%make-setup-lexpr (procedure-label procedure))) - -(define-integrable (rtl:make-message-receiver:subproblem continuation) - (%make-message-receiver:subproblem (continuation-label continuation))) - (define (rtl:make-constant value) (if (scode/unassigned-object? value) (rtl:make-unassigned) @@ -78,12 +59,12 @@ MIT in each case. |# (define-integrable register:environment 'ENVIRONMENT) -(define-integrable register:frame-pointer - 'FRAME-POINTER) - (define-integrable register:stack-pointer 'STACK-POINTER) +(define-integrable register:dynamic-link + 'DYNAMIC-LINK) + (define-integrable register:value 'VALUE) @@ -116,15 +97,18 @@ MIT in each case. |# ;;; Expressions that are used in the intermediate form. -(define-integrable (rtl:make-fetch locative) - `(FETCH ,locative)) - (define-integrable (rtl:make-address locative) `(ADDRESS ,locative)) +(define-integrable (rtl:make-environment locative) + `(ENVIRONMENT ,locative)) + (define-integrable (rtl:make-cell-cons expression) `(CELL-CONS ,expression)) +(define-integrable (rtl:make-fetch locative) + `(FETCH ,locative)) + (define-integrable (rtl:make-typed-cons:pair type car cdr) `(TYPED-CONS:PAIR ,type ,car ,cdr))