From 763dbee9aac4ca24028a71392dfa06afaf9b8954 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 30 Dec 1987 07:13:28 +0000 Subject: [PATCH] Final check-in for version 4.1 of compiler. --- v7/src/compiler/back/insseq.scm | 5 +- v7/src/compiler/back/lapgn1.scm | 74 +-- v7/src/compiler/back/lapgn3.scm | 59 +- v7/src/compiler/back/linear.scm | 92 +++ v7/src/compiler/back/regmap.scm | 20 +- v7/src/compiler/base/blocks.scm | 23 +- v7/src/compiler/base/cfg1.scm | 32 +- v7/src/compiler/base/cfg2.scm | 52 +- v7/src/compiler/base/cfg3.scm | 225 ++++--- v7/src/compiler/base/contin.scm | 20 +- v7/src/compiler/base/ctypes.scm | 59 +- v7/src/compiler/base/debug.scm | 86 ++- v7/src/compiler/base/infnew.scm | 18 + v7/src/compiler/base/lvalue.scm | 32 +- v7/src/compiler/base/macros.scm | 6 +- v7/src/compiler/base/proced.scm | 19 +- v7/src/compiler/base/scode.scm | 21 +- v7/src/compiler/base/subprb.scm | 6 +- v7/src/compiler/base/switch.scm | 12 +- v7/src/compiler/base/toplev.scm | 554 +++++++++++++----- v7/src/compiler/base/utils.scm | 136 ++--- v7/src/compiler/fggen/fggen.scm | 359 ++++++++---- v7/src/compiler/fgopt/blktyp.scm | 36 +- v7/src/compiler/fgopt/closan.scm | 50 +- v7/src/compiler/fgopt/conect.scm | 99 ++++ v7/src/compiler/fgopt/contan.scm | 159 +++-- v7/src/compiler/fgopt/folcon.scm | 12 +- v7/src/compiler/fgopt/offset.scm | 139 +++++ v7/src/compiler/fgopt/operan.scm | 8 +- v7/src/compiler/fgopt/order.scm | 30 +- v7/src/compiler/fgopt/outer.scm | 4 +- v7/src/compiler/fgopt/simapp.scm | 20 +- v7/src/compiler/fgopt/simple.scm | 4 +- v7/src/compiler/machines/bobcat/dassm1.scm | 121 +++- v7/src/compiler/machines/bobcat/dassm2.scm | 447 +++++++------- v7/src/compiler/machines/bobcat/dassm3.scm | 19 +- v7/src/compiler/machines/bobcat/decls.scm | 451 ++++++++++---- v7/src/compiler/machines/bobcat/lapgen.scm | 28 +- v7/src/compiler/machines/bobcat/machin.scm | 7 +- .../compiler/machines/bobcat/make.scm-68040 | 166 +++--- v7/src/compiler/machines/bobcat/rgspcm.scm | 59 +- v7/src/compiler/machines/bobcat/rules1.scm | 101 ++-- v7/src/compiler/machines/bobcat/rules2.scm | 4 +- v7/src/compiler/machines/bobcat/rules3.scm | 386 ++++++------ v7/src/compiler/machines/bobcat/rules4.scm | 89 +-- v7/src/compiler/rtlbase/rtlcfg.scm | 31 +- v7/src/compiler/rtlbase/rtlcon.scm | 33 +- v7/src/compiler/rtlbase/rtline.scm | 21 +- v7/src/compiler/rtlbase/rtlobj.scm | 47 +- v7/src/compiler/rtlbase/rtlreg.scm | 19 +- v7/src/compiler/rtlbase/rtlty1.scm | 5 +- v7/src/compiler/rtlgen/fndblk.scm | 91 ++- v7/src/compiler/rtlgen/opncod.scm | 18 +- v7/src/compiler/rtlgen/rgcomb.scm | 253 ++++---- v7/src/compiler/rtlgen/rgretn.scm | 82 ++- v7/src/compiler/rtlgen/rgrval.scm | 108 ++-- v7/src/compiler/rtlgen/rgstmt.scm | 141 +++-- v7/src/compiler/rtlgen/rtlgen.scm | 140 +++-- v7/src/compiler/rtlopt/rcse1.scm | 48 +- v7/src/compiler/rtlopt/rcse2.scm | 11 +- v7/src/compiler/rtlopt/rcseht.scm | 4 +- 61 files changed, 3308 insertions(+), 2093 deletions(-) create mode 100644 v7/src/compiler/back/linear.scm create mode 100644 v7/src/compiler/base/infnew.scm create mode 100644 v7/src/compiler/fgopt/conect.scm create mode 100644 v7/src/compiler/fgopt/offset.scm diff --git a/v7/src/compiler/back/insseq.scm b/v7/src/compiler/back/insseq.scm index 3057e6b71..883857ffe 100644 --- a/v7/src/compiler/back/insseq.scm +++ b/v7/src/compiler/back/insseq.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 1.3 1987/08/13 02:00:21 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/insseq.scm,v 4.1 1987/12/30 06:51:12 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,9 +36,6 @@ MIT in each case. |# (declare (usual-integrations)) -(define lap:syntax-instruction) -(define instruction-append) - (define (instruction-sequence->directives insts) (if (null? insts) '() diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 51249f7d3..0e251ef55 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.42 1987/10/05 20:39:46 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 4.1 1987/12/30 06:53:23 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -37,7 +37,6 @@ MIT in each case. |# (declare (usual-integrations)) (define *block-start-label*) -(define *continuation-queue*) (define *entry-bblock*) (define *current-bblock*) (define *dead-registers*) @@ -60,44 +59,54 @@ MIT in each case. |# *interned-uuo-links*)))))) (define (cgen-rgraph rgraph) - (fluid-let ((*current-rgraph* rgraph) - (*continuation-queue* (make-queue))) - (cgen-entry (rgraph-edge rgraph)) - (queue-map! *continuation-queue* - (lambda (continuation) - (cgen-entry (continuation-rtl-edge continuation)))))) - + (fluid-let ((*current-rgraph* rgraph)) + (for-each (lambda (edge) + (if (not (node-marked? (edge-right-node edge))) + (cgen-entry edge))) + (rgraph-entry-edges rgraph)))) + (define (cgen-entry edge) (let ((bblock (edge-right-node edge))) (fluid-let ((*entry-bblock* bblock)) (let loop ((bblock bblock)) - (let ((offset (cgen-bblock bblock))) - (let ((cgen-right - (lambda (edge) - (let ((next (edge-next-node edge))) - (if next - (begin - (record-bblock-frame-pointer-offset! next offset) - (if (node-previous>1? next) - (let ((sblock - (make-sblock - (clear-map-instructions - (bblock-register-map bblock))))) - (node-mark! sblock) - (edge-insert-snode! edge sblock))) - (if (not (node-marked? next)) - (loop next)))))))) - (if (sblock? bblock) - (cgen-right (snode-next-edge bblock)) - (begin (cgen-right (pnode-consequent-edge bblock)) - (cgen-right (pnode-alternative-edge bblock)))))))))) + (cgen-bblock bblock) + (let ((cgen-right + (lambda (edge) + (let ((next (edge-next-node edge))) + (if next + (begin + (if (node-previous>1? next) + (clear-map-between bblock edge next)) + (if (not (node-marked? next)) + (loop next)))))))) + (if (sblock? bblock) + (cgen-right (snode-next-edge bblock)) + (begin (cgen-right (pnode-consequent-edge bblock)) + (cgen-right (pnode-alternative-edge bblock))))))))) + +(define (clear-map-between bblock edge bblock*) + (let ((map + (let ((map (bblock-register-map bblock)) + (live-at-entry (bblock-live-at-entry bblock*))) + (let ((deletions + (list-transform-negative (register-map-live-homes map) + (lambda (pseudo-register) + (regset-member? live-at-entry pseudo-register))))) + (if (not (null? deletions)) + (delete-pseudo-registers map + deletions + (lambda (map aliases) map)) + map))))) + (if (not (register-map-clear? map)) + (let ((sblock (make-sblock (clear-map-instructions map)))) + (node-mark! sblock) + (edge-insert-snode! edge sblock))))) (define (cgen-bblock bblock) ;; This procedure is coded out of line to facilitate debugging. (node-mark! bblock) (fluid-let ((*current-bblock* bblock) - (*register-map* (bblock-input-register-map bblock)) - (*frame-pointer-offset* (bblock-frame-pointer-offset bblock))) + (*register-map* (bblock-input-register-map bblock))) (set-bblock-instructions! bblock (let loop ((rinst (bblock-instructions bblock))) (if (rinst-next rinst) @@ -105,8 +114,7 @@ MIT in each case. |# (LAP ,@instructions ,@(loop (rinst-next rinst)))) (cgen-rinst rinst)))) - (set-bblock-register-map! bblock *register-map*) - *frame-pointer-offset*)) + (set-bblock-register-map! bblock *register-map*))) (define (cgen-rinst rinst) (let ((rtl (rinst-rtl rinst))) diff --git a/v7/src/compiler/back/lapgn3.scm b/v7/src/compiler/back/lapgn3.scm index 8cb47d353..3b1472834 100644 --- a/v7/src/compiler/back/lapgn3.scm +++ b/v7/src/compiler/back/lapgn3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 1.5 1987/11/21 18:45:34 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 4.1 1987/12/30 06:53:31 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -81,59 +81,4 @@ MIT in each case. |# (define-integrable (set-current-branches! consequent alternative) (set-pblock-consequent-lap-generator! *current-bblock* consequent) - (set-pblock-alternative-lap-generator! *current-bblock* alternative)) - -;;;; Frame Pointer - -(define *frame-pointer-offset*) - -(define (disable-frame-pointer-offset! instructions) - (set! *frame-pointer-offset* false) - instructions) - -(define (enable-frame-pointer-offset! offset) - (if (not offset) (error "Null frame-pointer offset")) - (set! *frame-pointer-offset* offset)) - -(define (record-push! instructions) - (if *frame-pointer-offset* - (set! *frame-pointer-offset* (1+ *frame-pointer-offset*))) - instructions) - -(define (record-pop!) - (if *frame-pointer-offset* - (set! *frame-pointer-offset* (-1+ *frame-pointer-offset*)))) - -(define (decrement-frame-pointer-offset! n instructions) - (if *frame-pointer-offset* - (set! *frame-pointer-offset* - (and (<= n *frame-pointer-offset*) (- *frame-pointer-offset* n)))) - instructions) - -(define (guarantee-frame-pointer-offset!) - (if (not *frame-pointer-offset*) (error "Frame pointer not initialized"))) - -(define (increment-frame-pointer-offset! n instructions) - (guarantee-frame-pointer-offset!) - (set! *frame-pointer-offset* (+ *frame-pointer-offset* n)) - instructions) - -(define (frame-pointer-offset) - (guarantee-frame-pointer-offset!) - *frame-pointer-offset*) - -(define (record-continuation-frame-pointer-offset! label) - (guarantee-frame-pointer-offset!) - (let ((continuation (label->continuation label)) - (offset *frame-pointer-offset*)) - (cond ((not (continuation-frame-pointer-offset continuation)) - (set-continuation-frame-pointer-offset! continuation offset)) - ((not (= (continuation-frame-pointer-offset continuation) offset)) - (error "Continuation frame-pointer offset mismatch" continuation))) - (enqueue! *continuation-queue* continuation))) - -(define (record-bblock-frame-pointer-offset! bblock offset) - (cond ((not (bblock-frame-pointer-offset bblock)) - (set-bblock-frame-pointer-offset! bblock offset)) - ((not (and offset (= (bblock-frame-pointer-offset bblock) offset))) - (error "Basic block frame-pointer offset mismatch" bblock offset)))) \ No newline at end of file + (set-pblock-alternative-lap-generator! *current-bblock* alternative)) \ No newline at end of file diff --git a/v7/src/compiler/back/linear.scm b/v7/src/compiler/back/linear.scm new file mode 100644 index 000000000..b0b285cfc --- /dev/null +++ b/v7/src/compiler/back/linear.scm @@ -0,0 +1,92 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/linear.scm,v 4.1 1987/12/30 06:57: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. |# + +;;;; LAP linearizer + +(declare (usual-integrations)) + +(package (bblock-linearize-bits) + +(define-export (bblock-linearize-bits bblock) + (node-mark! bblock) + (if (and (not (bblock-label bblock)) + (node-previous>1? bblock)) + (bblock-label! bblock)) + (let ((kernel + (lambda () + (LAP ,@(bblock-instructions bblock) + ,@(if (sblock? bblock) + (linearize-sblock-next (snode-next bblock)) + (linearize-pblock bblock + (pnode-consequent bblock) + (pnode-alternative bblock))))))) + (if (bblock-label bblock) + (LAP ,(lap:make-label-statement (bblock-label bblock)) ,@(kernel)) + (kernel)))) + +(define (linearize-sblock-next bblock) + (cond ((not bblock) (LAP)) + ((node-marked? bblock) + (LAP ,(lap:make-unconditional-branch (bblock-label! bblock)))) + (else (bblock-linearize-bits bblock)))) + +(define (linearize-pblock pblock cn an) + (if (node-marked? cn) + (if (node-marked? an) + (LAP ,@((pblock-consequent-lap-generator pblock) (bblock-label! cn)) + ,(lap:make-unconditional-branch (bblock-label! an))) + (LAP ,@((pblock-consequent-lap-generator pblock) (bblock-label! cn)) + ,@(bblock-linearize-bits an))) + (if (node-marked? an) + (LAP ,@((pblock-alternative-lap-generator pblock) (bblock-label! an)) + ,@(bblock-linearize-bits cn)) + (let ((label (bblock-label! cn)) + (alternative (bblock-linearize-bits an))) + (LAP ,@((pblock-consequent-lap-generator pblock) label) + ,@alternative + ,@(if (node-marked? cn) + (LAP) + (bblock-linearize-bits cn))))))) + +) + +(define (map-lap procedure objects) + (let loop ((objects objects)) + (if (null? objects) + (LAP) + (LAP ,@(procedure (car objects)) + ,@(loop (cdr objects)))))) + +(define linearize-bits + (make-linearizer map-lap bblock-linearize-bits)) \ No newline at end of file diff --git a/v7/src/compiler/back/regmap.scm b/v7/src/compiler/back/regmap.scm index d57f57b4f..d2848075f 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 1.90 1987/07/08 22:01:47 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/regmap.scm,v 4.1 1987/12/30 06:53:36 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -386,6 +386,11 @@ REGISTER-RENUMBERs are equal. (save-into-home-instruction entry)) (receiver map '())))) +(define (pseudo-register-saved-into-home? map register) + (let ((entry (map-entries:find-home map register))) + (or (not entry) + (map-entry-saved-into-home? entry)))) + (define (delete-machine-register map register) (let ((entry (map-entries:find-alias map register))) (if entry @@ -436,6 +441,19 @@ REGISTER-RENUMBERs are equal. (register->home-transfer (map-entry:any-alias entry) (map-entry-home entry))) +(define (register-map-live-homes map) + (let loop ((entries (map-entries map))) + (if (null? entries) + '() + (let ((home (map-entry-home (car entries))) + (rest (loop (cdr entries)))) + (if home + (cons home rest) + rest))))) + +(define (register-map-clear? map) + (for-all? (map-entries map) map-entry-saved-into-home?)) + ;;;; Map Coercion ;;; These operations generate the instructions to coerce one map into diff --git a/v7/src/compiler/base/blocks.scm b/v7/src/compiler/base/blocks.scm index 01a4019f1..a912ebf56 100644 --- a/v7/src/compiler/base/blocks.scm +++ b/v7/src/compiler/base/blocks.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.1 1987/12/04 20:00:46 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/blocks.scm,v 4.2 1987/12/30 06:57:42 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -236,12 +236,23 @@ from the continuation, and then "glued" into place afterwards. (for-each loop (block-children block)))) (define-integrable (internal-block/parent-known? block) - (not (null? (block-stack-link block)))) + (block-stack-link block)) + +(define (stack-block/static-link? block) + (and (block-parent block) + (or (not (stack-block? (block-parent block))) + (not (internal-block/parent-known? block))))) (define-integrable (stack-block/continuation-lvalue block) (procedure-continuation-lvalue (block-procedure block))) -(define (stack-block/static-link? block) - (and (not (null? (block-free-variables block))) - (or (not (stack-block? (block-parent block))) - (not (internal-block/parent-known? block))))) \ No newline at end of file +(define (block/dynamic-link? block) + (and (stack-block? block) + (stack-block/dynamic-link? block))) + +(define (stack-block/dynamic-link? block) + (and (stack-parent? block) + (internal-block/dynamic-link? block))) + +(define-integrable (internal-block/dynamic-link? block) + (not (variable-popping-limit (stack-block/continuation-lvalue block)))) \ No newline at end of file diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index 2e10f5cbc..5eb0ff5f1 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.1 1987/12/04 20:03:16 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 4.2 1987/12/30 06:57:50 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -40,19 +40,19 @@ MIT in each case. |# (define cfg-node-tag (make-vector-tag false 'CFG-NODE false)) (define cfg-node? (tagged-vector/subclass-predicate cfg-node-tag)) -(define-vector-slots node 1 generation previous-edges) +(define-vector-slots node 1 generation alist previous-edges) (set-vector-tag-description! cfg-node-tag (lambda (node) - (descriptor-list node generation previous-edges))) + (descriptor-list node generation alist previous-edges))) (define snode-tag (make-vector-tag cfg-node-tag 'SNODE false)) (define snode? (tagged-vector/subclass-predicate snode-tag)) -(define-vector-slots snode 3 next-edge) +(define-vector-slots snode 4 next-edge) (define (make-snode tag . extra) - (list->vector (cons* tag false '() false extra))) + (list->vector (cons* tag false '() '() false extra))) (set-vector-tag-description! snode-tag @@ -62,10 +62,10 @@ MIT in each case. |# (define pnode-tag (make-vector-tag cfg-node-tag 'PNODE false)) (define pnode? (tagged-vector/subclass-predicate pnode-tag)) -(define-vector-slots pnode 3 consequent-edge alternative-edge) +(define-vector-slots pnode 4 consequent-edge alternative-edge) (define (make-pnode tag . extra) - (list->vector (cons* tag false '() false false extra))) + (list->vector (cons* tag false '() '() false false extra))) (set-vector-tag-description! pnode-tag @@ -144,4 +144,20 @@ MIT in each case. |# (edge-disconnect-right! edge)) (define (edges-disconnect-right! edges) - (for-each edge-disconnect-right! edges)) \ No newline at end of file + (for-each edge-disconnect-right! edges)) + +;;;; Node Properties + +(define (cfg-node-get node key) + (let ((entry (assq key (node-alist node)))) + (and entry + (cdr entry)))) + +(define (cfg-node-put! node key item) + (let ((entry (assq key (node-alist node)))) + (if entry + (set-cdr! entry item) + (set-node-alist! node (cons (cons key item) (node-alist node)))))) + +(define (cfg-node-remove! node key) + (set-node-alist! node (del-assq! key (node-alist node)))) \ No newline at end of file diff --git a/v7/src/compiler/base/cfg2.scm b/v7/src/compiler/base/cfg2.scm index 3fc0aa108..464fda5ca 100644 --- a/v7/src/compiler/base/cfg2.scm +++ b/v7/src/compiler/base/cfg2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 4.1 1987/12/04 20:03:33 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 4.2 1987/12/30 06:58:00 cph Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -41,10 +41,12 @@ MIT in each case. |# (define (snode-delete! snode) (let ((previous-edges (node-previous-edges snode)) (next-edge (snode-next-edge snode))) - (let ((node (edge-right-node next-edge))) - (edges-disconnect-right! previous-edges) - (edge-disconnect! next-edge) - (edges-connect-right! previous-edges node)))) + (if next-edge + (let ((node (edge-right-node next-edge))) + (edges-disconnect-right! previous-edges) + (edge-disconnect! next-edge) + (edges-connect-right! previous-edges node)) + (edges-disconnect-right! previous-edges)))) (define (edge-insert-snode! edge snode) (let ((next (edge-right-node edge))) @@ -115,33 +117,45 @@ MIT in each case. |# ;;;; Noops -(define *noop-nodes*) +(package (cfg-node-tag/noop! cfg-node-tag/noop?) -(define (cleanup-noop-nodes thunk) - (fluid-let ((*noop-nodes* '())) - (let ((value (thunk))) - (for-each snode-delete! *noop-nodes*) - value))) +(define-export (cfg-node-tag/noop! tag) + (vector-tag-put! tag noop-tag-property true)) + +(define-export (cfg-node-tag/noop? tag) + (vector-tag-get tag noop-tag-property)) + +(define noop-tag-property + "noop-tag-property") + +) + +(define-integrable (cfg-node/noop? node) + (cfg-node-tag/noop? (tagged-vector/tag node))) (define noop-node-tag (make-vector-tag snode-tag 'NOOP false)) +(cfg-node-tag/noop! noop-node-tag) + (define-integrable (make-noop-node) (let ((node (make-snode noop-node-tag))) (set! *noop-nodes* (cons node *noop-nodes*)) node)) +(define *noop-nodes*) + +(define (cleanup-noop-nodes thunk) + (fluid-let ((*noop-nodes* '())) + (let ((value (thunk))) + (for-each snode-delete! *noop-nodes*) + value))) + (define (make-false-pcfg) - (let ((node (make-noop-node))) - (make-pcfg node - '() - (list (make-hook node set-snode-next-edge!))))) + (snode->pcfg-false (make-noop-node))) (define (make-true-pcfg) - (let ((node (make-noop-node))) - (make-pcfg node - (list (make-hook node set-snode-next-edge!)) - '()))) + (snode->pcfg-true (make-noop-node))) ;;;; Miscellaneous diff --git a/v7/src/compiler/base/cfg3.scm b/v7/src/compiler/base/cfg3.scm index 879ba1ad6..d0e68a1ff 100644 --- a/v7/src/compiler/base/cfg3.scm +++ b/v7/src/compiler/base/cfg3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 1.4 1987/08/31 21:50:31 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 4.1 1987/12/30 06:58:08 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -68,7 +68,7 @@ MIT in each case. |# (vector-ref pcfg 3)) (define-integrable (make-null-cfg) false) -(define-integrable cfg-null? false?) +(define-integrable cfg-null? false?) (define-integrable (snode->scfg snode) (node->scfg snode set-snode-next-edge!)) @@ -85,6 +85,21 @@ MIT in each case. |# (make-pcfg node (list (make-hook node set-node-consequent!)) (list (make-hook node set-node-alternative!)))) + +(define (snode->pcfg-false snode) + (make-pcfg snode + (make-null-hooks) + (list (make-hook snode set-snode-next-edge!)))) + +(define (snode->pcfg-true snode) + (make-pcfg snode + (list (make-hook snode set-snode-next-edge!)) + (make-null-hooks))) + +(define (pcfg-invert pcfg) + (make-pcfg (cfg-entry-node pcfg) + (pcfg-alternative-hooks pcfg) + (pcfg-consequent-hooks pcfg))) ;;;; Hook Datatype @@ -99,6 +114,12 @@ MIT in each case. |# (define hook-member? (member-procedure hook=?)) +(define-integrable (make-null-hooks) + '()) + +(define-integrable hooks-null? + null?) + (define (hooks-union x y) (let loop ((x x)) (cond ((null? x) y) @@ -112,34 +133,59 @@ MIT in each case. |# (define (hook-connect! hook node) (create-edge! (hook-node hook) (hook-connect hook) node)) + +;;;; Simplicity Tests + +(define (scfg-simple? scfg) + (cfg-branch-simple? (cfg-entry-node scfg) (scfg-next-hooks scfg))) + +(define (pcfg-simple? pcfg) + (let ((entry-node (cfg-entry-node pcfg))) + (and (cfg-branch-simple? entry-node (pcfg-consequent-hooks pcfg)) + (cfg-branch-simple? entry-node (pcfg-alternative-hooks pcfg))))) + +(define (cfg-branch-simple? entry-node hooks) + (and (not (null? hooks)) + (null? (cdr hooks)) + (eq? entry-node (hook-node (car hooks))))) + +(define (scfg-null? scfg) + (or (cfg-null? scfg) + (cfg-branch-null? (cfg-entry-node scfg) + (scfg-next-hooks scfg)))) + +(define (pcfg-true? pcfg) + (and (hooks-null? (pcfg-alternative-hooks pcfg)) + (cfg-branch-null? (cfg-entry-node pcfg) + (pcfg-consequent-hooks pcfg)))) + +(define (pcfg-false? pcfg) + (and (hooks-null? (pcfg-consequent-hooks pcfg)) + (cfg-branch-null? (cfg-entry-node pcfg) + (pcfg-alternative-hooks pcfg)))) + +(define (cfg-branch-null? entry-node hooks) + (and (cfg-branch-simple? entry-node hooks) + (cfg-node/noop? entry-node))) + +;;;; Node-result Constructors (define (scfg*node->node! scfg next-node) - (if (cfg-null? scfg) + (if (scfg-null? scfg) next-node - (begin (if next-node - (hooks-connect! (scfg-next-hooks scfg) next-node)) - (cfg-entry-node scfg)))) + (begin + (hooks-connect! (scfg-next-hooks scfg) next-node) + (cfg-entry-node scfg)))) (define (pcfg*node->node! pcfg consequent-node alternative-node) (if (cfg-null? pcfg) (error "PCFG*NODE->NODE!: Can't have null predicate")) - (if consequent-node - (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node)) - (if alternative-node - (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node)) - (cfg-entry-node pcfg)) - -(define (scfg-simple? scfg) - (cfg-simple? scfg scfg-next-hooks)) - -(define (pcfg-simple? pcfg) - (and (cfg-simple? pcfg pcfg-consequent-hooks) - (cfg-simple? pcfg pcfg-alternative-hooks))) - -(define-integrable (cfg-simple? cfg cfg-hooks) - (and (not (null? (cfg-hooks cfg))) - (null? (cdr (cfg-hooks cfg))) - (eq? (cfg-entry-node cfg) (hook-node (car (cfg-hooks cfg)))))) + (cond ((pcfg-true? pcfg) consequent-node) + ((pcfg-false? pcfg) alternative-node) + (else + (hooks-connect! (pcfg-consequent-hooks pcfg) consequent-node) + (hooks-connect! (pcfg-alternative-hooks pcfg) alternative-node) + (cfg-entry-node pcfg)))) ;;;; CFG Construction @@ -153,8 +199,8 @@ MIT in each case. |# (hooks-connect! (pcfg-alternative-hooks pcfg) (cfg-entry-node cfg))) (define (scfg*scfg->scfg! scfg scfg*) - (cond ((not scfg) scfg*) - ((not scfg*) scfg) + (cond ((scfg-null? scfg) scfg*) + ((scfg-null? scfg*) scfg) (else (scfg-next-connect! scfg scfg*) (make-scfg (cfg-entry-node scfg) (scfg-next-hooks scfg*))))) @@ -164,41 +210,53 @@ MIT in each case. |# (define scfg*->scfg! (let () + (define (find-non-null scfgs) + (if (and (not (null? scfgs)) + (scfg-null? (car scfgs))) + (find-non-null (cdr scfgs)) + scfgs)) + (define (loop first second rest) (scfg-next-connect! first second) (if (null? rest) second (loop second (car rest) (find-non-null (cdr rest))))) - (define (find-non-null scfgs) - (if (or (null? scfgs) - (car scfgs)) - scfgs - (find-non-null (cdr scfgs)))) - (named-lambda (scfg*->scfg! scfgs) (let ((first (find-non-null scfgs))) - (and (not (null? first)) - (let ((second (find-non-null (cdr first)))) - (if (null? second) - (car first) - (make-scfg (cfg-entry-node (car first)) - (scfg-next-hooks - (loop (car first) - (car second) - (find-non-null (cdr second)))))))))))) + (if (null? first) + (make-null-cfg) + (let ((second (find-non-null (cdr first)))) + (if (null? second) + (car first) + (make-scfg (cfg-entry-node (car first)) + (scfg-next-hooks + (loop (car first) + (car second) + (find-non-null (cdr second)))))))))))) (package (scfg*pcfg->pcfg! scfg*pcfg->scfg!) (define ((scfg*pcfg->cfg! constructor) scfg pcfg) - (if (not pcfg) + (if (cfg-null? pcfg) (error "SCFG*PCFG->CFG!: Can't have null predicate")) - (constructor (if (not scfg) - (cfg-entry-node pcfg) - (begin (scfg-next-connect! scfg pcfg) - (cfg-entry-node scfg))) - (pcfg-consequent-hooks pcfg) - (pcfg-alternative-hooks pcfg))) + (cond ((scfg-null? scfg) + (constructor (cfg-entry-node pcfg) + (pcfg-consequent-hooks pcfg) + (pcfg-alternative-hooks pcfg))) + ((pcfg-true? pcfg) + (constructor (cfg-entry-node scfg) + (scfg-next-hooks scfg) + (make-null-hooks))) + ((pcfg-false? pcfg) + (constructor (cfg-entry-node scfg) + (make-null-hooks) + (scfg-next-hooks scfg))) + (else + (scfg-next-connect! scfg pcfg) + (constructor (cfg-entry-node scfg) + (pcfg-consequent-hooks pcfg) + (pcfg-alternative-hooks pcfg))))) (define-export scfg*pcfg->pcfg! (scfg*pcfg->cfg! make-pcfg)) @@ -207,22 +265,32 @@ MIT in each case. |# (scfg*pcfg->cfg! make-scfg*)) ) - + (package (pcfg*scfg->pcfg! pcfg*scfg->scfg!) (define ((pcfg*scfg->cfg! constructor) pcfg consequent alternative) - (if (not pcfg) + (if (cfg-null? pcfg) (error "PCFG*SCFG->CFG!: Can't have null predicate")) - (constructor (cfg-entry-node pcfg) - (connect! (pcfg-consequent-hooks pcfg) consequent) - (connect! (pcfg-alternative-hooks pcfg) alternative))) + (cond ((pcfg-true? pcfg) + (constructor (cfg-entry-node consequent) + (scfg-next-hooks consequent) + (make-null-hooks))) + ((pcfg-false? pcfg) + (constructor (cfg-entry-node consequent) + (make-null-hooks) + (scfg-next-hooks consequent))) + (else + (constructor (cfg-entry-node pcfg) + (connect! (pcfg-consequent-hooks pcfg) consequent) + (connect! (pcfg-alternative-hooks pcfg) alternative))))) (define (connect! hooks scfg) - (cond ((not scfg) hooks) - ((null? hooks) '()) - (else - (hooks-connect! hooks (cfg-entry-node scfg)) - (scfg-next-hooks scfg)))) + (if (or (hooks-null? hooks) + (scfg-null? scfg)) + hooks + (begin + (hooks-connect! hooks (cfg-entry-node scfg)) + (scfg-next-hooks scfg)))) (define-export pcfg*scfg->pcfg! (pcfg*scfg->cfg! make-pcfg)) @@ -235,29 +303,44 @@ MIT in each case. |# (package (pcfg*pcfg->pcfg! pcfg*pcfg->scfg!) (define ((pcfg*pcfg->cfg! constructor) pcfg consequent alternative) - (if (not pcfg) + (if (cfg-null? pcfg) (error "PCFG*PCFG->CFG!: Can't have null predicate")) - (connect! (pcfg-consequent-hooks pcfg) consequent consequent-select - (lambda (cchooks cahooks) - (connect! (pcfg-alternative-hooks pcfg) alternative alternative-select - (lambda (achooks aahooks) - (constructor (cfg-entry-node pcfg) - (hooks-union cchooks achooks) - (hooks-union cahooks aahooks))))))) + (cond ((pcfg-true? pcfg) + (constructor (cfg-entry-node consequent) + (pcfg-consequent-hooks consequent) + (pcfg-alternative-hooks consequent))) + ((pcfg-true? pcfg) + (constructor (cfg-entry-node alternative) + (pcfg-consequent-hooks alternative) + (pcfg-alternative-hooks alternative))) + (else + (connect! (pcfg-consequent-hooks pcfg) + consequent + consequent-select + (lambda (cchooks cahooks) + (connect! (pcfg-alternative-hooks pcfg) + alternative + alternative-select + (lambda (achooks aahooks) + (constructor (cfg-entry-node pcfg) + (hooks-union cchooks achooks) + (hooks-union cahooks aahooks))))))))) (define (connect! hooks pcfg select receiver) - (cond ((not pcfg) (select receiver hooks)) - ((null? hooks) (receiver '() '())) + (cond ((hooks-null? hooks) (receiver (make-null-hooks) (make-null-hooks))) + ((cfg-null? pcfg) (select receiver hooks)) + ((pcfg-true? pcfg) (consequent-select receiver hooks)) + ((pcfg-false? pcfg) (alternative-select receiver hooks)) (else (hooks-connect! hooks (cfg-entry-node pcfg)) (receiver (pcfg-consequent-hooks pcfg) (pcfg-alternative-hooks pcfg))))) -(define (consequent-select receiver hooks) - (receiver hooks '())) +(define-integrable (consequent-select receiver hooks) + (receiver hooks (make-null-hooks))) -(define (alternative-select receiver hooks) - (receiver '() hooks)) +(define-integrable (alternative-select receiver hooks) + (receiver (make-null-hooks) hooks)) (define-export pcfg*pcfg->pcfg! (pcfg*pcfg->cfg! make-pcfg)) diff --git a/v7/src/compiler/base/contin.scm b/v7/src/compiler/base/contin.scm index bb0e6116a..97c582649 100644 --- a/v7/src/compiler/base/contin.scm +++ b/v7/src/compiler/base/contin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.1 1987/12/04 20:00:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/contin.scm,v 4.2 1987/12/30 06:58:17 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -44,7 +44,7 @@ MIT in each case. |# (let ((required (list (make-value-variable block)))) (set-block-bound-variables! block required) (make-procedure type block 'CONTINUATION required '() false '() '() - (make-fg-noop))))) + (snode->scfg (make-fg-noop)))))) (define-enumeration continuation-type (effect @@ -74,11 +74,6 @@ MIT in each case. |# (define-integrable set-continuation/returns! set-procedure-applications!) (define-integrable continuation/always-known-operator? procedure-always-known-operator?) -(define-integrable continuation/dynamic-link? procedure-closing-limit) -(define-integrable set-continuation/dynamic-link?! - set-procedure-closing-limit!) -(define-integrable continuation/lvalues procedure-closure-block) -(define-integrable set-continuation/lvalues! set-procedure-closure-block!) (define-integrable continuation/offset procedure-closure-offset) (define-integrable set-continuation/offset! set-procedure-closure-offset!) (define-integrable continuation/passed-out? procedure-passed-out?) @@ -108,9 +103,14 @@ MIT in each case. |# (continuation/closing-block operator))) (define (continuation/frame-size continuation) - (cond ((continuation/always-known-operator? continuation) 0) - ((continuation/dynamic-link? continuation) 2) - (else 1))) + (let ((closing-block (continuation/closing-block continuation))) + (+ (if (ic-block? closing-block) 1 0) + (if (continuation/always-known-operator? continuation) + 0 + (if (and (stack-block? closing-block) + (stack-block/dynamic-link? closing-block)) + 2 + 1))))) (define (uni-continuation? rvalue) (and (rvalue/procedure? rvalue) diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index d9268acea..5ddf1987a 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.1 1987/12/04 20:03:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 4.2 1987/12/30 06:58:24 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -156,10 +156,14 @@ MIT in each case. |# (define (make-assignment block lvalue rvalue) (lvalue-connect! lvalue rvalue) + (variable-assigned! lvalue) (let ((assignment (make-snode assignment-tag block lvalue rvalue))) (set! *assignments* (cons assignment *assignments*)) (snode->scfg assignment))) +(define-integrable (node/assignment? node) + (eq? (tagged-vector/tag node) assignment-tag)) + (define-snode definition block lvalue @@ -169,30 +173,73 @@ MIT in each case. |# (lvalue-connect! lvalue rvalue) (snode->scfg (make-snode definition-tag block lvalue rvalue))) +(define-integrable (node/definition? node) + (eq? (tagged-vector/tag node) definition-tag)) + (define-pnode true-test rvalue) (define (make-true-test rvalue) (pnode->pcfg (make-pnode true-test-tag rvalue))) +(define-integrable (node/true-test? node) + (eq? (tagged-vector/tag node) true-test-tag)) + (define-snode fg-noop) (define (make-fg-noop) - (snode->scfg (make-snode fg-noop-tag))) + (make-snode fg-noop-tag)) + +(define-integrable (node/fg-noop? node) + (eq? (tagged-vector/tag node) fg-noop-tag)) +(cfg-node-tag/noop! fg-noop-tag) + (define-snode virtual-return + block operator operand) -(define (make-virtual-return operator operand) - (snode->scfg (make-snode virtual-return-tag operator operand))) +(define (make-virtual-return block operator operand) + (snode->scfg (make-snode virtual-return-tag block operator operand))) + +(define-integrable (node/virtual-return? node) + (eq? (tagged-vector/tag node) virtual-return-tag)) (define (make-push block rvalue) - (make-virtual-return (virtual-continuation/make block continuation-type/push) + (make-virtual-return block + (virtual-continuation/make block continuation-type/push) rvalue)) (define-snode pop continuation) (define (make-pop continuation) - (snode->scfg (make-snode pop-tag continuation))) \ No newline at end of file + (snode->scfg (make-snode pop-tag continuation))) + +(define-integrable (node/pop? node) + (eq? (tagged-vector/tag node) pop-tag)) + +(define-integrable (node/subgraph-color node) + (cfg-node-get node node/subgraph-color-tag)) + +(define-integrable (set-node/subgraph-color! node color) + (cfg-node-put! node node/subgraph-color-tag color)) + +(define node/subgraph-color-tag + "subgraph-color-tag") + +(define-integrable (node/offset node) + (cfg-node-get node node/offset-tag)) + +(define-integrable (set-node/offset! node offset) + (cfg-node-put! node node/offset-tag offset)) + +(define node/offset-tag + "node/offset-tag") + +(define-structure (subgraph-color + (conc-name subgraph-color/) + (constructor make-subgraph-color ())) + (nodes '()) + (rgraph false)) \ No newline at end of file diff --git a/v7/src/compiler/base/debug.scm b/v7/src/compiler/base/debug.scm index 66d5e392d..6bc802fd5 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.1 1987/12/04 20:00:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/debug.scm,v 4.2 1987/12/30 06:58:32 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -41,6 +41,59 @@ MIT in each case. |# (write-line object) (for-each pp ((tagged-vector/description object) object)))) +(define (debug/find-procedure name) + (let loop ((procedures *procedures*)) + (and (not (null? procedures)) + (if (and (not (procedure-continuation? (car procedures))) + (or (eq? name (procedure-name (car procedures))) + (eq? name (procedure-label (car procedures))))) + (car procedures) + (loop (cdr procedures)))))) + +(define (debug/find-continuation number) + (let ((label + (string->symbol (string-append "CONTINUATION-" + (number->string number 10))))) + (let loop ((procedures *procedures*)) + (and (not (null? procedures)) + (if (and (procedure-continuation? (car procedures)) + (eq? label (procedure-label (car procedures)))) + (car procedures) + (loop (cdr procedures))))))) + +(define (debug/find-entry-node node) + (let ((node (->tagged-vector node))) + (if (eq? (expression-entry-node *root-expression*) node) + (write-line *root-expression*)) + (for-each (lambda (procedure) + (if (eq? (procedure-entry-node procedure) node) + (write-line procedure))) + *procedures*))) + +(define (debug/where object) + (cond ((compiled-code-block? object) + (write-line (compiled-code-block/debugging-info object))) + ((compiled-code-address? object) + (write-line + (compiled-code-block/debugging-info + (compiled-code-address->block object))) + (write-string "\nOffset: ") + (write-string + (number->string (compiled-code-address->offset object) + '(HEUR (RADIX X S))))) ((compiled-procedure? object) + (debug/where (compiled-procedure-entry object))) + (else + (error "debug/where -- what?" object)))) + +(define (compiler:write-rtl-file pathname) + (let ((pathname (->pathname pathname))) + (write-instructions + (lambda () + (with-output-to-file (pathname-new-type pathname "rtl") + (lambda () + (for-each show-rtl-instruction + (fasload (pathname-new-type pathname "brtl"))))))))) + (define (dump-rtl filename) (write-instructions (lambda () @@ -81,7 +134,7 @@ MIT in each case. |# (newline)) (*show-instruction* rtl)) -(package (show-fg) +(package (show-fg show-fg-node) (define *procedure-queue*) (define *procedures*) @@ -104,6 +157,16 @@ MIT in each case. |# (write-string "\n\n---------- Blocks ----------") (fg/print-blocks (expression-block *root-expression*)))) +(define-export (show-fg-node node) + (fluid-let ((*procedure-queue* false)) + (with-new-node-marks + (lambda () + (fg/print-entry-node + (let ((node (->tagged-vector node))) + (if (procedure? node) + (procedure-entry-node node) + node))))))) + (define (fg/print-entry-node node) (if node (fg/print-node node))) @@ -146,16 +209,19 @@ MIT in each case. |# ((TRUE-TEST) (fg/print-rvalue (true-test-rvalue node)) (fg/print-node (pnode-consequent node)) - (fg/print-node (pnode-alternative node))))))) + (fg/print-node (pnode-alternative node))) + ((FG-NOOP) + (fg/print-node (snode-next node))))))) (define (fg/print-rvalue rvalue) - (let ((rvalue (rvalue-known-value rvalue))) - (if (and rvalue - (rvalue/procedure? rvalue) - (not (memq rvalue *procedures*))) - (begin - (set! *procedures* (cons rvalue *procedures*)) - (enqueue! *procedure-queue* rvalue))))) + (if *procedure-queue* + (let ((rvalue (rvalue-known-value rvalue))) + (if (and rvalue + (rvalue/procedure? rvalue) + (not (memq rvalue *procedures*))) + (begin + (set! *procedures* (cons rvalue *procedures*)) + (enqueue! *procedure-queue* rvalue)))))) (define (fg/print-subproblem subproblem) (fg/print-object subproblem) diff --git a/v7/src/compiler/base/infnew.scm b/v7/src/compiler/base/infnew.scm new file mode 100644 index 000000000..5cdb5bb12 --- /dev/null +++ b/v7/src/compiler/base/infnew.scm @@ -0,0 +1,18 @@ +(declare (usual-integrations)) + +(define (generation-phase2 label-bindings external-labels) + (make-compiler-info + '() + '() + (list->vector + (sort (map (lambda (association) + (make-label-info + (symbol->string (car association)) + (cdr association) + (let loop ((external-labels external-labels)) + (cond ((null? external-labels) false) + ((eq? (car association) (car external-labels)) true) + (else (loop (cdr external-labels))))))) + label-bindings) + (lambda (x y) + (< (label-info-offset x) (label-info-offset y))))))) \ No newline at end of file diff --git a/v7/src/compiler/base/lvalue.scm b/v7/src/compiler/base/lvalue.scm index c155daf54..fb98060d0 100644 --- a/v7/src/compiler/base/lvalue.scm +++ b/v7/src/compiler/base/lvalue.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.1 1987/12/04 20:03:56 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/lvalue.scm,v 4.2 1987/12/30 06:58:51 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -76,6 +76,9 @@ MIT in each case. |# declarations ;list of declarations for this variable ) +(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 '())) @@ -228,16 +231,17 @@ MIT in each case. |# (not (null? (lvalue-initial-values lvalue)))) (define (variable-in-known-location? block variable) - (let ((definition-block (variable-block variable))) - (or (not (ic-block? definition-block)) - ;; If the block has no procedure, then we know nothing about - ;; the locations of its bindings. - (and (rvalue/procedure? (block-procedure block)) - ;; If IC reference in same block as definition, then - ;; incremental definitions cannot screw us. - (eq? block definition-block) - ;; Make sure that IC variables are bound! A variable - ;; that is not bound by the code being compiled still has - ;; a "definition" block, which is the outermost IC block - ;; of the expression in which the variable is referenced. - (memq variable (block-bound-variables block)))))) + (or (variable/value-variable? variable) + (let ((definition-block (variable-block variable))) + (or (not (ic-block? definition-block)) + ;; If the block has no procedure, then we know nothing about + ;; the locations of its bindings. + (and (rvalue/procedure? (block-procedure block)) + ;; If IC reference in same block as definition, then + ;; incremental definitions cannot screw us. + (eq? block definition-block) + ;; Make sure that IC variables are bound! A variable + ;; that is not bound by the code being compiled still has + ;; a "definition" block, which is the outermost IC block + ;; of the expression in which the variable is referenced. + (memq variable (block-bound-variables block))))))) diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index 337d10f40..18efab17d 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.1 1987/12/04 20:04:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 4.2 1987/12/30 06:58:58 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -195,8 +195,8 @@ MIT in each case. |# (APPEND! ((VECTOR-TAG-DESCRIPTION ,',parent) ,type) (DESCRIPTOR-LIST ,type ,@slots)))))))))))) - (define-type-definition snode 4 false) - (define-type-definition pnode 5 false) + (define-type-definition snode 5 false) + (define-type-definition pnode 6 false) (define-type-definition rvalue 2 rvalue-types) (define-type-definition lvalue 10 false)) diff --git a/v7/src/compiler/base/proced.scm b/v7/src/compiler/base/proced.scm index 1ab8da3bc..fe22ebb46 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.1 1987/12/04 20:04:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/proced.scm,v 4.2 1987/12/30 06:59:17 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -84,7 +84,8 @@ MIT in each case. |# (write-string "PROCEDURE ") (write (procedure-label procedure))) (begin - (write-string "CONTINUATION ") + (write (procedure-label procedure)) + (write-string " ") (write type)))))) (define-integrable (rvalue/procedure? rvalue) @@ -141,15 +142,15 @@ MIT in each case. |# (null? (cdr (procedure-applications procedure)))) (define (procedure-inline-code? procedure) - (and (procedure-always-known-operator? procedure) + (and (procedure/open? procedure) + (procedure-always-known-operator? procedure) (procedure-application-unique? procedure))) -(define (open-procedure-needs-static-link? procedure) - (let ((block (procedure-block procedure))) - (let ((parent (block-parent block))) - (and parent - (or (not (stack-block? parent)) - (not (internal-block/parent-known? block))))))) +(define-integrable (open-procedure-needs-static-link? procedure) + (stack-block/static-link? (procedure-block procedure))) + +(define-integrable (open-procedure-needs-dynamic-link? procedure) + (stack-block/dynamic-link? (procedure-block procedure))) ;;;; Procedure Types diff --git a/v7/src/compiler/base/scode.scm b/v7/src/compiler/base/scode.scm index 73d5ad5b0..f7ee30b2d 100644 --- a/v7/src/compiler/base/scode.scm +++ b/v7/src/compiler/base/scode.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.1 1987/12/04 20:04:59 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/scode.scm,v 4.2 1987/12/30 06:59:28 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -76,14 +76,17 @@ MIT in each case. |# make-variable variable? variable-components variable-name )) -(define-integrable (scode/make-constant const) - const) - -(define scode/constant? - (access scode-constant? system-global-environment)) - -(define-integrable (scode/constant-value const) - const) +(define-integrable (scode/make-constant value) value) +(define-integrable (scode/constant-value constant) constant) +(define scode/constant? (access scode-constant? system-global-environment)) + +(define (scode/make-let names values . body) + (scan-defines (scode/make-sequence body) + (lambda (auxiliary declarations body) + (scode/make-combination + (scode/make-lambda lambda-tag:let names '() false + auxiliary declarations body) + values)))) ;;;; Absolute variables and combinations diff --git a/v7/src/compiler/base/subprb.scm b/v7/src/compiler/base/subprb.scm index d0e4ccb2a..4f53b71c7 100644 --- a/v7/src/compiler/base/subprb.scm +++ b/v7/src/compiler/base/subprb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.1 1987/12/04 20:05:10 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/subprb.scm,v 4.2 1987/12/30 06:59:38 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -74,10 +74,6 @@ known that the continuation need not be used. (define-integrable (subproblem-canonical? subproblem) (procedure? (subproblem-continuation subproblem))) -(define-integrable (subproblem-block subproblem) - ;; This is defined only for non-canonical subproblems. - (virtual-continuation/block (subproblem-continuation subproblem))) - (define (subproblem-type subproblem) (let ((continuation (subproblem-continuation subproblem))) (if (procedure? continuation) diff --git a/v7/src/compiler/base/switch.scm b/v7/src/compiler/base/switch.scm index 3cfb3e55a..ee74ea77b 100644 --- a/v7/src/compiler/base/switch.scm +++ b/v7/src/compiler/base/switch.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.1 1987/12/04 20:05:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/switch.scm,v 4.2 1987/12/30 06:59:45 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,11 +36,13 @@ MIT in each case. |# (declare (usual-integrations)) -(define compiler:enable-integration-declarations? false) -(define compiler:enable-expansion-declarations? false) -(define compiler:preserve-data-structures? true) +(define compiler:enable-integration-declarations? true) +(define compiler:enable-expansion-declarations? true) +(define compiler:show-subphases? false) +(define compiler:preserve-data-structures? false) (define compiler:code-compression? true) (define compiler:cache-free-variables? true) (define compiler:implicit-self-static? false) (define compiler:cse? true) -(define compiler:open-code-primitives? true) \ No newline at end of file +(define compiler:open-code-primitives? true) +(define compiler:generate-rtl-files? false) \ No newline at end of file diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 2503f8387..fca360838 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.1 1987/12/04 20:05:18 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.2 1987/12/30 06:56:34 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -45,15 +45,90 @@ MIT in each case. |# (define *rtl-procedures*) (define *rtl-continuations*) (define *rtl-graphs*) +(define label->object) ;;; These variable names mistakenly use the format "compiler:..." ;;; instead of the correct format, which is "*...*". Fix it sometime. -(define compiler:continuation-fp-offsets) (define compiler:external-labels) (define compiler:label-bindings) +(define compiler:block-label) +(define compiler:entry-label) +(define compiler:bits) +(define compiler:code-vector) +(define compiler:entry-points) +(define compiler:expression) (define compiler:phase-wrapper false) -(define compiler:compile-time 0) +(define compiler:process-time 0) +(define compiler:real-time 0) + +(define (compiler:reset!) + (set! *input-scode*) + (set! *current-label-number*) + (set! *constants*) + (set! *blocks*) + (set! *expressions*) + (set! *procedures*) + (set! *lvalues*) + (set! *applications*) + (set! *parallels*) + (set! *assignments*) + (set! *ic-procedure-headers*) + (set! *root-expression*) + (set! *root-block*) + (set! *rtl-expression*) + (set! *rtl-procedures*) + (set! *rtl-continuations*) + (set! *rtl-graphs*) + (set! label->object) + (set! *machine-register-map*) + (set! compiler:external-labels) + (set! compiler:label-bindings) + (set! compiler:block-label) + (set! compiler:entry-label) + (set! compiler:bits) + (set! compiler:code-vector) + (set! compiler:entry-points) + (set! compiler:expression)) + +(define (in-compiler thunk) + (fluid-let ((compiler:process-time 0) + (compiler:real-time 0) + #|(*input-scode*) + (*current-label-number*) + (*constants*) + (*blocks*) + (*expressions*) + (*procedures*) + (*lvalues*) + (*applications*) + (*parallels*) + (*assignments*) + (*ic-procedure-headers*) + (*root-expression*) + (*root-block*) + (*rtl-expression*) + (*rtl-procedures*) + (*rtl-continuations*) + (*rtl-graphs*) + (label->object) + (*machine-register-map*) + (compiler:external-labels) + (compiler:label-bindings) + (compiler:block-label) + (compiler:entry-label) + (compiler:bits) + (compiler:code-vector) + (compiler:entry-points) + (compiler:expression)|#) + (compiler:reset!) + (let ((value (thunk))) + (if (not compiler:preserve-data-structures?) + (compiler:reset!)) + (compiler-time-report "Total compilation time" + compiler:process-time + compiler:real-time) + value))) (define (compile-bin-file input-string #!optional output-string) (compiler-pathnames input-string @@ -61,9 +136,36 @@ MIT in each case. |# (make-pathname false false false "bin" 'NEWEST) (lambda (input-pathname output-pathname) (compile-scode (compiler-fasload input-pathname) - (pathname-new-type output-pathname "brtl") + (and compiler:generate-rtl-files? + (pathname-new-type output-pathname "brtl")) (pathname-new-type output-pathname "binf"))))) +(define (compiler-pathnames input-string output-string default transform) + (let ((kernel + (lambda (input-string) + (let ((input-pathname + (pathname->input-truename + (merge-pathnames (->pathname input-string) default)))) + (if (not input-pathname) + (error "File does not exist" input-string)) + (let ((output-pathname + (let ((output-pathname + (pathname-new-type input-pathname "com"))) + (if output-string + (merge-pathnames (->pathname output-string) + output-pathname) + output-pathname)))) + (newline) + (write-string "Compile File: ") + (write (pathname->string input-pathname)) + (write-string " => ") + (write (pathname->string output-pathname)) + (fasdump (transform input-pathname output-pathname) + output-pathname)))))) + (if (pair? input-string) + (for-each kernel input-string) + (kernel input-string)))) + (define (compiler-fasload pathname) (let ((scode (let ((scode (fasload pathname))) @@ -83,27 +185,9 @@ MIT in each case. |# (scan-defines scode make-open-block)))) (define (compile-procedure procedure) - (scode-eval (compile-scode (procedure-lambda procedure)) + (scode-eval (compile-scode (procedure-lambda procedure) false false) (procedure-environment procedure))) -(define (compiler-pathnames input-string output-string default transform) - (let ((input-pathname - (pathname->input-truename - (merge-pathnames (->pathname input-string) default)))) - (if (not input-pathname) - (error "File does not exist" input-string)) - (let ((output-pathname - (let ((output-pathname (pathname-new-type input-pathname "com"))) - (if output-string - (merge-pathnames (->pathname output-string) output-pathname) - output-pathname)))) - (newline) - (write-string "Compile File: ") - (write (pathname->string input-pathname)) - (write-string " => ") - (write (pathname->string output-pathname)) - (fasdump (transform input-pathname output-pathname) output-pathname)))) - (define (compile-scode scode #!optional rtl-output-pathname @@ -118,127 +202,68 @@ MIT in each case. |# (lambda () (set! *input-scode* scode) (phase/fg-generation) - (phase/simulate-application) - (phase/outer-analysis) - (phase/fold-constants) - (phase/open-coding-analysis) - (phase/operator-analysis) - (phase/identify-closure-limits) - (phase/setup-block-types) - (phase/continuation-analysis) - (phase/simplicity-analysis) - (phase/subproblem-ordering) - (phase/design-environment-frames) + (phase/fg-optimization) (phase/rtl-generation) - (let ((n-registers - (map (lambda (rgraph) - (- (rgraph-n-registers rgraph) - number-of-machine-registers)) - *rtl-graphs*))) - (newline) - (write-string "Registers used: ") - (write (apply max n-registers)) - (write-string " max, ") - (write (apply min n-registers)) - (write-string " min, ") - (write (/ (apply + n-registers) (length n-registers))) - (write-string " mean")) #| (if info-output-pathname - (compiler:info-generation-1 info-output-pathname)) - (compiler:rtl-generation-cleanup) - (if compiler:cse? - (compiler:cse)) - (compiler:lifetime-analysis) - (if compiler:code-compression? - (compiler:code-compression)) + (phase/info-generation-1 info-output-pathname)) +|# + (phase/rtl-optimization) (if rtl-output-pathname - (compiler:rtl-file-output rtl-output-pathname)) - (compiler:register-allocation) - (compiler:rtl-optimization-cleanup) - (compiler:bit-generation) - (compiler:bit-linearization) - (compiler:assemble) + (phase/rtl-file-output rtl-output-pathname)) + (phase/bit-generation) + (phase/bit-linearization) + (phase/assemble) (if info-output-pathname - (compiler:info-generation-2 info-output-pathname)) - (compiler:link) + (phase/info-generation-2 info-output-pathname)) + (phase/link) compiler:expression -|# ))) -(define (in-compiler thunk) - (fluid-let ((compiler:compile-time 0) - #|(*input-scode*) - (*current-label-number*) - (*constants*) - (*blocks*) - (*expressions*) - (*procedures*) - (*lvalues*) - (*applications*) - (*parallels*) - (*assignments*) - (*ic-procedure-headers*) - (*root-expression*) - (*root-block*) - (*rtl-expression*) - (*rtl-procedures*) - (*rtl-continuations*) - (*rtl-graphs*) - (compiler:continuation-fp-offsets) - (compiler:external-labels) - (compiler:label-bindings)|#) - (compiler:reset!) - (let ((value (thunk))) -; (compiler:reset!) - (newline) - (write-string "Total compilation time: ") - (write compiler:compile-time) - value))) - -(define (compiler:reset!) - (set! *input-scode*) - (set! *current-label-number*) - (set! *constants*) - (set! *blocks*) - (set! *expressions*) - (set! *procedures*) - (set! *lvalues*) - (set! *applications*) - (set! *parallels*) - (set! *assignments*) - (set! *ic-procedure-headers*) - (set! *root-expression*) - (set! *root-block*) - (set! *rtl-expression*) - (set! *rtl-procedures*) - (set! *rtl-continuations*) - (set! *rtl-graphs*) - (set! compiler:continuation-fp-offsets) - (set! compiler:external-labels) - (set! compiler:label-bindings)) - (define (compiler-phase name thunk) + (compiler-phase/visible name + (lambda () + (compiler-phase/invisible thunk)))) + +(define (compiler-superphase name thunk) + (if compiler:show-subphases? + (thunk) + (compiler-phase/visible name thunk))) + +(define (compiler-subphase name thunk) + (if compiler:show-subphases? + (compiler-phase name thunk) + (compiler-phase/invisible thunk))) + +(define (compiler-phase/visible name thunk) (write-line name) - (let ((delta - (let ((start-time (runtime))) - (if compiler:phase-wrapper - (compiler:phase-wrapper thunk) - (thunk)) - (- (runtime) start-time)))) - (set! compiler:compile-time (+ delta compiler:compile-time)) - (newline) - (write-string "Time taken: ") - (write delta))) -#| + (let ((process-start (process-time-clock)) + (real-start (real-time-clock))) + (thunk) + (let ((process-delta (- (process-time-clock) process-start)) + (real-delta (- (real-time-clock) real-start))) + (set! compiler:process-time (+ process-delta compiler:process-time)) + (set! compiler:real-time (+ real-delta compiler:real-time)) + (compiler-time-report "Time taken" process-delta real-delta)))) + +(define (compiler-phase/invisible thunk) + (if compiler:phase-wrapper + (compiler:phase-wrapper thunk) + (thunk))) + +(define (compiler-time-report prefix process-time real-time) + (newline) + (write-string prefix) + (write-string ": ") + (write (/ process-time 1000)) + (write-string " (process time); ") + (write (/ real-time 1000)) + (write-string " (real time)")) + (define-macro (last-reference name) - (let ((temp (generate-uninterned-symbol))) - `(IF COMPILER:PRESERVE-DATA-STRUCTURES? - ,name - (LET ((,temp name)) - (set! ,name) - ,temp)))) -|# + `(IF COMPILER:PRESERVE-DATA-STRUCTURES? + ,name + (SET! ,name))) (define (phase/fg-generation) (compiler-phase 'FG-GENERATION @@ -253,86 +278,131 @@ MIT in each case. |# (set! *parallels* '()) (set! *assignments* '()) (set! *root-expression* - ((access construct-graph fg-generator-package) *input-scode*)) + ((access construct-graph fg-generator-package) + (if compiler:preserve-data-structures? + *input-scode* + (set! *input-scode*)))) (set! *root-block* (expression-block *root-expression*)) (if (or (null? *expressions*) (not (null? (cdr *expressions*)))) (error "Multiple expressions")) (set! *expressions*)))) +(define (phase/fg-optimization) + (compiler-superphase 'FG-OPTIMIZATION + (lambda () + (phase/simulate-application) + (phase/outer-analysis) + (phase/fold-constants) + (phase/open-coding-analysis) + (phase/operator-analysis) + (phase/identify-closure-limits) + (phase/setup-block-types) (phase/continuation-analysis) + (phase/simplicity-analysis) + (phase/subproblem-ordering) + (phase/connectivity-analysis) + (phase/design-environment-frames) + (phase/compute-node-offsets) + (phase/fg-optimization-cleanup)))) + (define (phase/simulate-application) - (compiler-phase 'SIMULATE-APPLICATION + (compiler-subphase 'SIMULATE-APPLICATION (lambda () - ((access simulate-application fg-analyzer-package) + ((access simulate-application fg-optimizer-package) *lvalues* *applications*)))) - + (define (phase/outer-analysis) - (compiler-phase 'OUTER-ANALYSIS + (compiler-subphase 'OUTER-ANALYSIS (lambda () - ((access outer-analysis fg-analyzer-package) + ((access outer-analysis fg-optimizer-package) *root-expression* *procedures* *applications*)))) (define (phase/fold-constants) - (compiler-phase 'FOLD-CONSTANTS + (compiler-subphase 'FOLD-CONSTANTS (lambda () - ((access fold-constants fg-analyzer-package) + ((access fold-constants fg-optimizer-package) *lvalues* *applications*)))) - + (define (phase/open-coding-analysis) - (compiler-phase 'OPEN-CODING-ANALYSIS + (compiler-subphase 'OPEN-CODING-ANALYSIS (lambda () ((access open-coding-analysis rtl-generator-package) *applications*)))) (define (phase/operator-analysis) - (compiler-phase 'OPERATOR-ANALYSIS + (compiler-subphase 'OPERATOR-ANALYSIS (lambda () - ((access operator-analysis fg-analyzer-package) + ((access operator-analysis fg-optimizer-package) *procedures* *applications*)))) (define (phase/identify-closure-limits) - (compiler-phase 'IDENTIFY-CLOSURE-LIMITS + (compiler-subphase 'IDENTIFY-CLOSURE-LIMITS (lambda () - ((access identify-closure-limits! fg-analyzer-package) + ((access identify-closure-limits! fg-optimizer-package) *procedures* *applications* *assignments*)))) (define (phase/setup-block-types) - (compiler-phase 'SETUP-BLOCK-TYPES + (compiler-subphase 'SETUP-BLOCK-TYPES (lambda () - ((access setup-block-types! fg-analyzer-package) + ((access setup-block-types! fg-optimizer-package) *root-block*)))) (define (phase/continuation-analysis) - (compiler-phase 'CONTINUATION-ANALYSIS + (compiler-subphase 'CONTINUATION-ANALYSIS (lambda () - ((access continuation-analysis fg-analyzer-package) - *blocks* - *procedures*)))) + ((access continuation-analysis fg-optimizer-package) + *blocks*)))) (define (phase/simplicity-analysis) - (compiler-phase 'SIMPLICITY-ANALYSIS + (compiler-subphase 'SIMPLICITY-ANALYSIS (lambda () - ((access simplicity-analysis fg-analyzer-package) + ((access simplicity-analysis fg-optimizer-package) *parallels*)))) - + (define (phase/subproblem-ordering) - (compiler-phase 'SUBPROBLEM-ORDERING + (compiler-subphase 'SUBPROBLEM-ORDERING (lambda () - ((access subproblem-ordering fg-analyzer-package) + ((access subproblem-ordering fg-optimizer-package) *parallels*)))) +(define (phase/connectivity-analysis) + (compiler-subphase 'CONNECTIVITY-ANALYSIS + (lambda () + ((access connectivity-analysis fg-optimizer-package) + *root-expression* + *procedures*)))) + (define (phase/design-environment-frames) - (compiler-phase 'DESIGN-ENVIRONMENT-FRAMES + (compiler-subphase 'DESIGN-ENVIRONMENT-FRAMES (lambda () - ((access design-environment-frames! fg-analyzer-package) + ((access design-environment-frames! fg-optimizer-package) *blocks*)))) + +(define (phase/compute-node-offsets) + (compiler-subphase 'COMPUTE-NODE-OFFSETS + (lambda () + ((access compute-node-offsets fg-optimizer-package) + *root-expression*)))) + +(define (phase/fg-optimization-cleanup) + (compiler-subphase 'FG-OPTIMIZATION-CLEANUP + (lambda () + (if (not compiler:preserve-data-structures?) + (begin (set! *constants*) + (set! *blocks*) + (set! *procedures*) + (set! *lvalues*) + (set! *applications*) + (set! *parallels*) + (set! *assignments*) + (set! *root-block*)))))) (define (phase/rtl-generation) (compiler-phase 'RTL-GENERATION @@ -340,4 +410,166 @@ MIT in each case. |# (set! *rtl-procedures* '()) (set! *rtl-continuations* '()) (set! *rtl-graphs* '()) - ((access generate/top-level rtl-generator-package) *root-expression*)))) \ No newline at end of file + (set! *ic-procedure-headers* '()) + (initialize-machine-register-map!) + ((access generate/top-level rtl-generator-package) + (if compiler:preserve-data-structures? + *root-expression* + (set! *root-expression*))) + (set! label->object + (make/label->object *rtl-expression* + *rtl-procedures* + *rtl-continuations*)) + (let ((n-registers + (map (lambda (rgraph) + (- (rgraph-n-registers rgraph) + number-of-machine-registers)) + *rtl-graphs*))) + (newline) + (write-string "Registers used: ") + (write (apply max n-registers)) + (write-string " max, ") + (write (apply min n-registers)) + (write-string " min, ") + (write (/ (apply + n-registers) (length n-registers))) + (write-string " mean"))))) + +(define (phase/rtl-optimization) + (compiler-superphase 'RTL-OPTIMIZATION + (lambda () + (if compiler:cse? + (phase/common-subexpression-elimination)) + (phase/lifetime-analysis) + (if compiler:code-compression? + (phase/code-compression)) + (phase/register-allocation) + (phase/rtl-optimization-cleanup)))) + +(define (phase/common-subexpression-elimination) + (compiler-subphase 'COMMON-SUBEXPRESSION-ELIMINATION + (lambda () + ((access common-subexpression-elimination rtl-cse-package) + *rtl-graphs*)))) + +(define (phase/lifetime-analysis) + (compiler-subphase 'LIFETIME-ANALYSIS + (lambda () + ((access lifetime-analysis rtl-optimizer-package) *rtl-graphs*)))) + +(define (phase/code-compression) + (compiler-subphase 'CODE-COMPRESSION + (lambda () + ((access code-compression rtl-optimizer-package) *rtl-graphs*)))) + +(define (phase/rtl-file-output pathname) + (compiler-phase 'RTL-FILE-OUTPUT + (lambda () + (fasdump ((access linearize-rtl rtl-generator-package) *rtl-graphs*) + pathname)))) + +(define (phase/register-allocation) + (compiler-subphase 'REGISTER-ALLOCATION + (lambda () + ((access register-allocation rtl-optimizer-package) *rtl-graphs*)))) + +(define (phase/rtl-optimization-cleanup) + (if (not compiler:preserve-data-structures?) + (for-each (lambda (rgraph) + ;; **** this slot is reused. **** + ;;(set-rgraph-register-bblock! rgraph false) + (set-rgraph-register-crosses-call?! rgraph false) + (set-rgraph-register-n-deaths! rgraph false) + (set-rgraph-register-live-length! rgraph false) + (set-rgraph-register-n-refs! rgraph false)) + *rtl-graphs*))) + +(define (phase/bit-generation) + (compiler-phase 'BIT-GENERATION + (lambda () + (set! compiler:external-labels '()) + ((access generate-bits lap-syntax-package) + *rtl-graphs* + (lambda (block-label prefix) + (set! compiler:block-label block-label) + (node-insert-snode! (rtl-expr/entry-node *rtl-expression*) + (make-sblock prefix)))) + (set! compiler:entry-label (rtl-expr/label *rtl-expression*)) + (if (not compiler:preserve-data-structures?) + (begin (set! label->object) + (set! *rtl-expression*) + (set! *rtl-procedures*) + (set! *rtl-continuations*)))))) + +(define (phase/bit-linearization) + (compiler-phase 'BIT-LINEARIZATION + (lambda () + (set! compiler:bits + (LAP ,@(lap:make-entry-point compiler:entry-label + compiler:block-label) + ,@((access linearize-bits lap-syntax-package) + (if compiler:preserve-data-structures? + *rtl-graphs* + (set! *rtl-graphs*)))))))) + +(define (phase/assemble) + (compiler-phase 'ASSEMBLE + (lambda () + (if compiler:preserve-data-structures? + ((access assemble bit-package) + compiler:block-label + compiler:bits + phase/assemble-finish) + ((access assemble bit-package) + (set! compiler:block-label) + (set! compiler:bits) + phase/assemble-finish))))) + +(define (phase/assemble-finish code-vector labels bindings linkage-info) + (set! compiler:code-vector code-vector) + (set! compiler:entry-points labels) + (set! compiler:label-bindings bindings)) + +(define (phase/info-generation-2 pathname) + (compiler-phase 'DEBUGGING-INFO-GENERATION-2 + (lambda () + (fasdump ((access generation-phase2 debugging-information-package) + compiler:label-bindings + (if compiler:preserve-data-structures? + compiler:external-labels + (set! compiler:external-labels))) + pathname) + (set-compiled-code-block/debugging-info! compiler:code-vector + (pathname->string pathname))))) + +(define (phase/link) + (compiler-phase 'LINK + (lambda () + ;; This has sections locked against GC since the code may not be + ;; purified. + (let ((bindings + (map (lambda (label) + (cons + label + (with-interrupt-mask interrupt-mask-none + (lambda (old) + ((ucode-primitive &make-object) + type-code:compiled-expression + (make-non-pointer-object + (+ (cdr (or (assq label compiler:label-bindings) + (error "Missing entry point" label))) + (primitive-datum compiler:code-vector)))))))) + compiler:entry-points))) + (let ((label->expression + (lambda (label) + (cdr (or (assq label bindings) + (error "Label not defined as entry point" label)))))) + (set! compiler:expression (label->expression compiler:entry-label)) + (for-each (lambda (entry) + (set-lambda-body! (car entry) + (label->expression (cdr entry)))) + *ic-procedure-headers*))) + (set! compiler:code-vector) + (set! compiler:entry-points) + (set! compiler:label-bindings) + (set! compiler:entry-label) + (set! *ic-procedure-headers*)))) \ No newline at end of file diff --git a/v7/src/compiler/base/utils.scm b/v7/src/compiler/base/utils.scm index b6ae61c61..190190f6f 100644 --- a/v7/src/compiler/base/utils.scm +++ b/v7/src/compiler/base/utils.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.1 1987/12/04 20:05:24 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/utils.scm,v 4.2 1987/12/30 06:56:48 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -108,9 +108,16 @@ MIT in each case. |# irritants)) (define (show-time thunk) - (let ((start (runtime))) + (let ((process-start (process-time-clock)) + (real-start (real-time-clock))) (let ((value (thunk))) - (write-line (- (runtime) start)) + (let ((process-end (process-time-clock)) + (real-end (real-time-clock))) + (newline) + (write-string "process time: ") + (write (- process-end process-start)) + (write-string "; real time: ") + (write (- real-end real-start))) value))) (define (list-filter-indices items indices) @@ -184,61 +191,6 @@ MIT in each case. |# ) -;;;; Symbol Hash Tables - -(define (symbol-hash-table/make n-buckets) - (make-vector n-buckets '())) - -(define (symbol-hash-table/modify! table symbol if-found if-not-found) - (let ((hash (string-hash-mod (symbol->string symbol) (vector-length table)))) - (let ((bucket (vector-ref table hash))) - (let ((entry (assq symbol bucket))) - (if entry - (set-cdr! entry (if-found (cdr entry))) - (vector-set! table hash - (cons (cons symbol (if-not-found)) - bucket))))))) - -(define (symbol-hash-table/lookup* table symbol if-found if-not-found) - (let ((value - (assq symbol - (vector-ref table - (string-hash-mod (symbol->string symbol) - (vector-length table)))))) - (if value - (if-found (cdr value)) - (if-not-found)))) - -(define (symbol-hash-table/insert! table symbol item) - (symbol-hash-table/modify! table symbol - (lambda (old-value) item) - (lambda () item))) - -(define (symbol-hash-table/lookup table symbol) - (symbol-hash-table/lookup* table symbol - identity-procedure - (lambda () (error "Missing item" symbol)))) - -(define (symbol-hash-table/bindings table) - (apply append (vector->list table))) - -(define (symbol-hash-table/positive-bindings table predicate) - (mapcan (lambda (bucket) - (list-transform-positive bucket - (lambda (entry) - (predicate (cdr entry))))) - (vector->list table))) - -(define (symbol-hash-table/negative-bindings table predicate) - (mapcan (lambda (bucket) - (list-transform-negative bucket - (lambda (entry) - (predicate (cdr entry))))) - (vector->list table))) - -(define-integrable string-hash-mod - (ucode-primitive string-hash-mod)) - ;;;; Type Codes (let-syntax ((define-type-code @@ -280,40 +232,52 @@ MIT in each case. |# (define (primitive-arity-correct? primitive argument-count) (if (eq? primitive compiled-error-procedure) - (> argument-count 1) + (positive? argument-count) (let ((arity (primitive-procedure-arity primitive))) (or (= arity -1) (= arity argument-count))))) (define (primitive-procedure-safe? object) (and (primitive-type? (ucode-type primitive) object) - (not (memq object - (let-syntax ((primitives - (macro names - `'(,@(map make-primitive-procedure names))))) - (primitives call-with-current-continuation - non-reentrant-call-with-current-continuation - scode-eval - apply - garbage-collect - primitive-fasdump - set-current-history! - with-history-disabled - force - primitive-purify - ;;complete-garbage-collect - dump-band - primitive-impurify - with-threaded-continuation - within-control-point - with-interrupts-reduced - primitive-eval-step - primitive-apply-step - primitive-return-step - execute-at-new-state-point - translate-to-state-point - with-interrupt-mask - error-procedure)))))) + (not (memq object unsafe-primitive-procedures)))) + +(define unsafe-primitive-procedures + (let-syntax ((primitives + (macro names + `'(,@(map (lambda (spec) + (if (pair? spec) + (apply make-primitive-procedure spec) + (make-primitive-procedure spec))) + names))))) + (primitives scode-eval + apply + force + error-procedure + within-control-point + call-with-current-continuation + non-reentrant-call-with-current-continuation + with-threaded-continuation + with-interrupt-mask + with-interrupts-reduced + execute-at-new-state-point + translate-to-state-point + set-current-history! + with-history-disabled + garbage-collect + primitive-purify + primitive-impurify + primitive-fasdump + dump-band + load-band + (primitive-eval-step 3) + (primitive-apply-step 3) + (primitive-return-step 2) + (dump-world 1) + (complete-garbage-collect 1) + (with-saved-fluid-bindings 1) + (global-interrupt 3) + (get-work 1) + (master-gc-loop 1)))) ;;;; Special Compiler Support diff --git a/v7/src/compiler/fggen/fggen.scm b/v7/src/compiler/fggen/fggen.scm index 261faafef..7959af0e1 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.1 1987/12/04 19:27:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/fggen.scm,v 4.2 1987/12/30 06:42:50 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -55,6 +55,7 @@ MIT in each case. |# (lambda (variables declarations scode) (set-block-bound-variables! block variables) (generate/body block continuation declarations scode)))))) + ;; Delete as many noop nodes as possible. (for-each (lambda (procedure) (if (procedure-continuation? procedure) (set-procedure-entry-node! @@ -74,49 +75,60 @@ MIT in each case. |# ;; expression is generated because it can refer to the set of free ;; variables in the expression. (let ((node (generate/expression block continuation expression))) - (process-declarations! block declarations) + (process-top-level-declarations! block declarations) node)) - -(define (continue/rvalue block continuation rvalue) - ((continuation/case continuation - (lambda () - (make-return block (make-reference block continuation true) rvalue)) - (lambda () - (make-null-cfg)) - (lambda () - (make-true-test rvalue)) - (lambda () - (if (not (virtual-continuation? continuation)) - (error "Continuation should be virtual" continuation)) - (make-subproblem (make-null-cfg) continuation rvalue))))) ;;;; Continuations (define (continuation/case continuation unknown effect predicate value) - (cond ((variable? continuation) unknown) + (cond ((variable? continuation) + (let ((type (continuation-variable/type continuation))) + (cond ((not type) unknown) + ((eq? type continuation-type/effect) effect) + ((eq? type continuation-type/predicate) unknown) + ((eq? type continuation-type/value) unknown) + (else (error "Illegal continuation type" type))))) + ((virtual-continuation? continuation) + (if (virtual-continuation/reified? continuation) + (continuation/case (virtual-continuation/reification continuation) + unknown + effect + predicate + value) + (let ((type (virtual-continuation/type continuation))) + (cond ((eq? type continuation-type/effect) effect) + ((eq? type continuation-type/predicate) predicate) + ((eq? type continuation-type/value) value) + (else + (error "Illegal virtual continuation type" type)))))) ((procedure? continuation) (let ((type (continuation/type continuation))) (cond ((eq? type continuation-type/effect) effect) ((eq? type continuation-type/predicate) predicate) ((eq? type continuation-type/value) value) (else (error "Illegal continuation type" type))))) - ((virtual-continuation? continuation) - (let ((type (virtual-continuation/type continuation))) - (cond ((eq? type continuation-type/effect) effect) - ((eq? type continuation-type/predicate) predicate) - ((eq? type continuation-type/value) value) - (else (error "Illegal virtual continuation type" type))))) (else (error "Illegal continuation" continuation)))) -(define (continuation/type? continuation type) - (cond ((variable? continuation) false) +(define (continuation/known-type continuation) + (cond ((variable? continuation) + (continuation-variable/type continuation)) + ((virtual-continuation? continuation) + (virtual-continuation/type continuation)) ((procedure? continuation) - (eq? (continuation/type continuation) type)) + (continuation/type continuation)) + (else + (error "Illegal continuation" continuation)))) + +(define (continuation/type? continuation type) + (cond ((variable? continuation) + (eq? (continuation-variable/type continuation) type)) ((virtual-continuation? continuation) (eq? (virtual-continuation/type continuation) type)) + ((procedure? continuation) + (eq? (continuation/type continuation) type)) (else (error "Illegal continuation" continuation)))) - + (define-integrable (continuation/effect? continuation) (continuation/type? continuation continuation-type/effect)) @@ -139,22 +151,15 @@ MIT in each case. |# ;;;; Subproblems -(define (subproblem-canonicalize subproblem) - (if (subproblem-canonical? subproblem) - subproblem - (let ((continuation - (continuation/reify! (subproblem-continuation subproblem)))) - (make-subproblem/canonical - (scfg*scfg->scfg! (subproblem-prefix subproblem) - (make-return (subproblem-block subproblem) - continuation - (subproblem-rvalue subproblem))) - continuation)))) - -(define (continuation/reify! continuation) +(define (with-reified-continuation block + continuation + scfg*value->value! + generator) (if (virtual-continuation? continuation) - (virtual-continuation/reify! continuation) - continuation)) + (let ((continuation (virtual-continuation/reify! continuation))) + (scfg*value->value! (make-push block continuation) + (generator continuation))) + (generator continuation))) (define (make-subproblem/canonical prefix continuation) (make-subproblem prefix @@ -165,29 +170,7 @@ MIT in each case. |# (make-subproblem (scfg*scfg->scfg! scfg (subproblem-prefix subproblem)) (subproblem-continuation subproblem) (subproblem-rvalue subproblem))) - -(define (pcfg*subproblem->subproblem! predicate consequent alternative) - ;; This depends on the fact that, after canonicalizing two - ;; subproblems which were generated with the same continuation, the - ;; block, continuation, and rvalue of each subproblem are identical. - (let ((consequent (subproblem-canonicalize consequent)) - (alternative (subproblem-canonicalize alternative))) - (make-subproblem (pcfg*scfg->scfg! predicate - (subproblem-prefix consequent) - (subproblem-prefix alternative)) - (subproblem-continuation consequent) - (subproblem-rvalue consequent)))) -(define (generator/subproblem type scfg*value->value!) - (lambda (block continuation expression) - (let ((continuation (virtual-continuation/make block continuation type))) - (let ((value (generate/expression block continuation expression))) - (if (virtual-continuation/reified? continuation) - (scfg*value->value! - (make-push block (virtual-continuation/reification continuation)) - value) - value))))) - (define *virtual-continuations*) (define (virtual-continuation/make block parent type) @@ -195,23 +178,85 @@ MIT in each case. |# (set! *virtual-continuations* (cons continuation *virtual-continuations*)) continuation)) +(define (wrapper/subproblem type) + (lambda (block continuation generator) + (generator (virtual-continuation/make block continuation type)))) + +(define wrapper/subproblem/effect + (wrapper/subproblem continuation-type/effect)) + +(define wrapper/subproblem/predicate + (wrapper/subproblem continuation-type/predicate)) + +(define wrapper/subproblem/value + (wrapper/subproblem continuation-type/value)) + +(define (generator/subproblem wrapper) + (lambda (block continuation expression) + (wrapper block continuation + (lambda (continuation) + (generate/expression block continuation expression))))) + (define generate/subproblem/effect - (generator/subproblem continuation-type/effect scfg*scfg->scfg!)) + (generator/subproblem wrapper/subproblem/effect)) (define generate/subproblem/predicate - (generator/subproblem continuation-type/predicate scfg*pcfg->pcfg!)) + (generator/subproblem wrapper/subproblem/predicate)) (define generate/subproblem/value - (generator/subproblem continuation-type/value scfg*subproblem->subproblem!)) + (generator/subproblem wrapper/subproblem/value)) ;;;; Values (define (generate/constant block continuation expression) - (continue/rvalue block continuation (make-constant expression))) + (continue/rvalue-constant block continuation (make-constant expression))) (define (generate/the-environment block continuation expression) - (continue/rvalue block continuation block)) + (continue/rvalue-constant block continuation block)) + +(define (continue/rvalue-constant block continuation rvalue) + ((continuation/case continuation + continue/unknown + continue/effect + continue/predicate-constant + continue/value) + block + continuation + rvalue)) +(define (continue/predicate-constant block continuation rvalue) + (if (and (rvalue/constant? rvalue) + (false? (constant-value rvalue))) + (snode->pcfg-false (make-fg-noop)) + (snode->pcfg-true (make-fg-noop)))) + +(define (continue/rvalue block continuation rvalue) + ((continuation/case continuation + continue/unknown + continue/effect + continue/predicate + continue/value) + block + continuation + rvalue)) + +(define (continue/unknown block continuation rvalue) + (make-return block (make-reference block continuation true) rvalue)) + +(define (continue/effect block continuation rvalue) + (if (variable? continuation) + (continue/unknown block continuation (make-constant false)) + (make-null-cfg))) + +(define-integrable (continue/predicate block continuation rvalue) + (make-true-test rvalue)) + +(define (continue/value block continuation rvalue) + (if (virtual-continuation? continuation) + (make-subproblem (make-null-cfg) continuation rvalue) + (make-subproblem/canonical (make-return block continuation rvalue) + continuation))) + (define (generate/variable block continuation expression) (continue/rvalue block continuation @@ -263,7 +308,10 @@ MIT in each case. |# (search block)) (define (generate/lambda block continuation expression) - (continue/rvalue + (generate/lambda* block continuation expression false)) + +(define (generate/lambda* block continuation expression continuation-type) + (continue/rvalue-constant block continuation (scode/lambda-components expression @@ -276,6 +324,7 @@ MIT in each case. |# (optional (make-variables block optional)) (rest (and rest (make-variable block rest))) (names (make-variables block names))) + (set-continuation-variable/type! continuation continuation-type) (set-block-bound-variables! block `(,continuation ,@required @@ -350,34 +399,6 @@ MIT in each case. |# ;;;; Combinators -(define (generate/combination block continuation expression) - (let ((continuation (continuation/reify! continuation))) - (let ((generator - (lambda (expression) - (generate/subproblem/value block #|(make-block block 'JOIN)|# - continuation - expression)))) - (scode/combination-components expression - (lambda (operator operands) - (let ((combination - (make-combination block - (continuation-reference block continuation) - (generator operator) - (map generator operands)))) - ((continuation/case continuation - (lambda () - combination) - (lambda () - (make-scfg (cfg-entry-node combination) - (continuation/next-hooks continuation))) - (lambda () - (scfg*pcfg->pcfg! - (make-scfg (cfg-entry-node combination) - (continuation/next-hooks continuation)) - (make-true-test (continuation/rvalue continuation)))) - (lambda () - (make-subproblem/canonical combination continuation)))))))))) - (define (generate/sequence block continuation expression) (let ((join (continuation/case continuation @@ -390,30 +411,124 @@ MIT in each case. |# (generate/expression block continuation (car actions)) (join (generate/subproblem/effect block continuation (car actions)) (loop (cdr actions))))))) - + (define (generate/conditional block continuation expression) (scode/conditional-components expression (lambda (predicate consequent alternative) - ((continuation/case continuation - pcfg*scfg->scfg! - pcfg*scfg->scfg! - pcfg*pcfg->pcfg! - pcfg*subproblem->subproblem!) - (generate/subproblem/predicate block continuation predicate) - (generate/expression block continuation consequent) - (generate/expression block continuation alternative))))) + (let ((predicate + (generate/subproblem/predicate block continuation predicate))) + (let ((simple + (lambda (hooks branch) + ((continuation/case continuation + scfg*scfg->scfg! + scfg*scfg->scfg! + scfg*pcfg->pcfg! + scfg*subproblem->subproblem!) + (make-scfg (cfg-entry-node predicate) hooks) + (generate/expression block continuation branch))))) + (cond ((hooks-null? (pcfg-consequent-hooks predicate)) + (simple (pcfg-alternative-hooks predicate) alternative)) + ((hooks-null? (pcfg-alternative-hooks predicate)) + (simple (pcfg-consequent-hooks predicate) consequent)) + (else + (let ((finish + (lambda (continuation combiner) + (combiner + predicate + (generate/expression block + continuation + consequent) + (generate/expression block + continuation + alternative))))) + ((continuation/case continuation + (lambda () (finish continuation pcfg*scfg->scfg!)) + (lambda () (finish continuation pcfg*scfg->scfg!)) + (lambda () (finish continuation pcfg*pcfg->pcfg!)) + (lambda () + (with-reified-continuation block + continuation + scfg*subproblem->subproblem! + (lambda (continuation) + (finish continuation + (lambda (predicate consequent alternative) + (make-subproblem/canonical + (pcfg*scfg->scfg! + predicate + (subproblem-prefix consequent) + (subproblem-prefix alternative)) + continuation)))))))))))))))) + +(define (generate/combination block continuation expression) + (scode/combination-components expression + (lambda (operator operands) + (let ((make-combination + (lambda (continuation) + (make-combination + block + (continuation-reference block continuation) + (generate/operator block continuation operator) + (map (lambda (expression) + (generate/subproblem/value block + continuation + expression)) + operands))))) + ((continuation/case continuation + (lambda () (make-combination continuation)) + (lambda () + (if (variable? continuation) + (make-combination continuation) + (with-reified-continuation block + continuation + scfg*scfg->scfg! + (lambda (continuation) + (make-scfg + (cfg-entry-node (make-combination continuation)) + (continuation/next-hooks continuation)))))) + (lambda () + (if (eq? not operator) + (pcfg-invert + (generate/expression block continuation (car operands))) (with-reified-continuation block + continuation + scfg*pcfg->pcfg! + (lambda (continuation) + (scfg*pcfg->pcfg! + (make-scfg + (cfg-entry-node (make-combination continuation)) + (continuation/next-hooks continuation)) + (make-true-test (continuation/rvalue continuation))))))) + (lambda () + (with-reified-continuation block + continuation + scfg*subproblem->subproblem! + (lambda (continuation) + (make-subproblem/canonical (make-combination continuation) + continuation)))))))))) + +(define (generate/operator block continuation operator) + (wrapper/subproblem/value block continuation + (lambda (continuation*) + (if (scode/lambda? operator) + (generate/lambda* block + continuation* + operator + (continuation/known-type continuation)) + (generate/expression block + continuation* + operator))))) ;;;; Assignments (define (generate/assignment* maker find-name block continuation name value) (let ((subproblem (generate/subproblem/value block continuation value))) - (scfg*scfg->scfg! + (scfg-append! (if (subproblem-canonical? subproblem) (make-scfg (cfg-entry-node (subproblem-prefix subproblem)) (continuation/next-hooks (subproblem-continuation subproblem))) (subproblem-prefix subproblem)) - (maker block (find-name block name) (subproblem-rvalue subproblem))))) + (maker block (find-name block name) (subproblem-rvalue subproblem)) + (continue/effect block continuation false)))) (define (generate/assignment block continuation expression) (scode/assignment-components expression @@ -484,6 +599,22 @@ MIT in each case. |# (scode/delay-expression expression)))) (define (generate/disjunction block continuation expression) + ((continuation/case continuation + generate/disjunction/value + generate/disjunction/control + generate/disjunction/control + generate/disjunction/value) + block continuation expression)) + +(define (generate/disjunction/control block continuation expression) + (scode/disjunction-components expression + (lambda (predicate alternative) + (generate/conditional + block + continuation + (scode/make-conditional predicate (make-constant true) alternative))))) + +(define (generate/disjunction/value block continuation expression) (scode/disjunction-components expression (lambda (predicate alternative) (generate/combination @@ -496,7 +627,7 @@ MIT in each case. |# (scode/make-conditional predicate predicate alternative)))))))) - + (define (generate/error-combination block continuation expression) (scode/error-combination-components expression (lambda (message irritants) @@ -505,7 +636,7 @@ MIT in each case. |# continuation (scode/make-combination compiled-error-procedure (cons message irritants)))))) - + (define (generate/in-package block continuation expression) (warn "IN-PACKAGE not supported; body will be interpreted" expression) (scode/in-package-components expression @@ -524,14 +655,6 @@ MIT in each case. |# (scode/make-combination (ucode-primitive car) (list (list (scode/quotation-expression expression)))))) - -(define (scode/make-let names values . body) - (scan-defines (scode/make-sequence body) - (lambda (auxiliary declarations body) - (scode/make-combination - (scode/make-lambda lambda-tag:let names '() false - auxiliary declarations body) - values)))) ;;;; Dispatcher diff --git a/v7/src/compiler/fgopt/blktyp.scm b/v7/src/compiler/fgopt/blktyp.scm index b42b52a20..70da01da4 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.1 1987/12/04 19:23:42 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/blktyp.scm,v 4.2 1987/12/30 06:43:54 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -40,8 +40,6 @@ MIT in each case. |# (define-export (setup-block-types! root-block) (define (loop block) - ;; **** Why is this here? Leave comment. - (set-block-applications! block '()) (enumeration-case block-type (block-type block) ((PROCEDURE) (if (block-passed-out? block) @@ -65,21 +63,23 @@ MIT in each case. |# (loop root-block)) (define (maybe-close-procedure! block) - (let ((procedure (block-procedure block))) - (if (close-procedure? procedure) - (let ((parent (block-parent block))) - (set-procedure-closure-block! procedure parent) - (set-block-parent! - block - ((find-closure-bindings parent) - (list-transform-negative (block-free-variables block) - (lambda (lvalue) - (eq? (lvalue-known-value lvalue) procedure))) - '())) - (set-block-children! parent (delq! block (block-children parent))) - (set-block-disowned-children! - parent - (cons block (block-disowned-children parent))))))) + (if (close-procedure? (block-procedure block)) (close-procedure! block))) + +(define (close-procedure! block) + (let ((procedure (block-procedure block)) + (parent (block-parent block))) + (set-procedure-closure-block! procedure parent) + (set-block-parent! + block + ((find-closure-bindings parent) + (list-transform-negative (block-free-variables block) + (lambda (lvalue) + (eq? (lvalue-known-value lvalue) procedure))) + '())) + (set-block-children! parent (delq! block (block-children parent))) + (set-block-disowned-children! + parent + (cons block (block-disowned-children parent))))) (define (find-closure-bindings block) (lambda (free-variables bound-variables) diff --git a/v7/src/compiler/fgopt/closan.scm b/v7/src/compiler/fgopt/closan.scm index 06652be22..7efa0a294 100644 --- a/v7/src/compiler/fgopt/closan.scm +++ b/v7/src/compiler/fgopt/closan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.1 1987/12/04 19:27:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/closan.scm,v 4.2 1987/12/30 06:44:12 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -66,17 +66,28 @@ simple techniques it generates more information than is needed. (define-export (identify-closure-limits! procedures applications assignments) (for-each initialize-closure-limit! procedures) + (for-each close-passed-out! procedures) (for-each close-application-arguments! applications) (for-each close-assignment-values! assignments)) (define (initialize-closure-limit! procedure) (if (not (procedure-continuation? procedure)) - (set-procedure-closing-limit! - procedure - (and (not (procedure-passed-out? procedure)) - (procedure-closing-block procedure))))) + (set-procedure-closing-limit! procedure + (procedure-closing-block procedure)))) + +(define (close-passed-out! procedure) + (if (and (not (procedure-continuation? procedure)) + (procedure-passed-out? procedure)) + (close-procedure! procedure false))) (define (close-application-arguments! application) + ;; Note that case where all procedures are closed in same block can + ;; be solved by introduction of another kind of closure, which has a + ;; fixed environment but carries around a pointer to the code. + (if (application/combination? application) + (let ((operator (application-operator application))) + (if (not (rvalue-known-value operator)) + (close-rvalue! operator false)))) (close-values! (application-operand-values application) (let ((procedure (rvalue-known-value (application-operator application)))) @@ -88,7 +99,7 @@ simple techniques it generates more information than is needed. (define (close-assignment-values! assignment) (close-rvalue! (assignment-rvalue assignment) (variable-block (assignment-lvalue assignment)))) - + (define-integrable (close-rvalue! rvalue binding-block) (close-values! (rvalue-values rvalue) binding-block)) @@ -108,11 +119,26 @@ simple techniques it generates more information than is needed. (if (not (eq? new-closing-limit closing-limit)) (begin (set-procedure-closing-limit! procedure new-closing-limit) - (for-each-block-descendent! (procedure-block procedure) - (lambda (block) - (for-each (lambda (application) - (close-rvalue! (application-operator application) - new-closing-limit)) - (block-applications block))))))))) + ;; The following line forces the procedure's type to CLOSURE. + (set-procedure-closure-block! procedure true) + (close-callees! (procedure-block procedure) new-closing-limit)))))) + +(define (close-callees! block new-closing-limit) + (for-each-callee! block + (lambda (value) + (if (not (block-ancestor-or-self? (procedure-block value) block)) + (close-procedure! value new-closing-limit))))) + +(define (for-each-callee! block procedure) + (for-each-block-descendent! block + (lambda (block*) + (for-each (lambda (application) + (for-each (lambda (value) + (if (and (rvalue/procedure? value) + (not (procedure-continuation? value))) + (procedure value))) + (rvalue-values + (application-operator application)))) + (block-applications block*))))) ) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/conect.scm b/v7/src/compiler/fgopt/conect.scm new file mode 100644 index 000000000..084cc8184 --- /dev/null +++ b/v7/src/compiler/fgopt/conect.scm @@ -0,0 +1,99 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/conect.scm,v 4.1 1987/12/30 06:47:26 cph Exp $ + +Copyright (c) 1987 Massachusetts Institute of Technology + +This material was developed by the Scheme project at the Massachusetts +Institute of Technology, Department of Electrical Engineering and +Computer Science. Permission to copy this software, to redistribute +it, and to use it for any purpose is granted, subject to the following +restrictions and understandings. + +1. Any copy made of this software must include this copyright notice +in full. + +2. Users of this software agree to make their best efforts (a) to +return to the MIT Scheme project any improvements or extensions that +they make, so that these may be included in future releases; and (b) +to inform MIT of noteworthy uses of this software. + +3. All materials developed as a consequence of the use of this +software shall duly acknowledge such use, in accordance with the usual +standards of acknowledging credit in academic research. + +4. MIT has made no warrantee or representation that the operation of +this software will be error-free, and MIT is under no obligation to +provide any services, by way of maintenance, update, or otherwise. + +5. In conjunction with products arising from the use of this material, +there shall be no use of the name of the Massachusetts Institute of +Technology nor of any adaptation thereof in any advertising, +promotional, or sales literature without prior written consent from +MIT in each case. |# + +;;;; FG Connectivity Analysis + +(declare (usual-integrations)) + +(package (connectivity-analysis) + +(define-export (connectivity-analysis expression procedures) + (walk-node (expression-entry-node expression) (make-subgraph-color)) + (for-each (lambda (procedure) + (if (not (procedure-direct-linked? procedure)) + (walk-node (procedure-entry-node procedure) + (make-subgraph-color)))) + procedures)) + +(define (procedure-direct-linked? procedure) + (if (procedure-continuation? procedure) + (continuation/always-known-operator? procedure) + (procedure-inline-code? procedure))) + +(define (walk-node node color) + (let ((color* (node/subgraph-color node))) + (cond ((not color*) + (color-node! node color) + (walk-next node color)) + ((not (eq? color color*)) + (recolor-nodes! (subgraph-color/nodes color*) color))))) + +(define (color-node! node color) + (set-node/subgraph-color! node color) + (set-subgraph-color/nodes! color (cons node (subgraph-color/nodes color)))) + +(define (recolor-nodes! nodes color) + (for-each (lambda (node) + (set-node/subgraph-color! node color)) + nodes) + (set-subgraph-color/nodes! color + (append! nodes (subgraph-color/nodes color)))) + +(define (walk-next node color) + (cfg-node-case (tagged-vector/tag node) + ((APPLICATION) + (case (application-type node) + ((COMBINATION) + (if (combination/inline? node) + (walk-continuation (combination/continuation node) color) + (let ((operator (rvalue-known-value (application-operator node)))) + (if (and operator + (rvalue/procedure? operator) + (procedure-inline-code? operator)) + (walk-node (procedure-entry-node operator) color))))) + ((RETURN) + (walk-continuation (return/operator node) color)))) + ((VIRTUAL-RETURN POP ASSIGNMENT DEFINITION FG-NOOP) + (walk-node (snode-next node) color)) + ((TRUE-TEST) + (walk-node (pnode-consequent node) color) + (walk-node (pnode-alternative node) color)))) + +(define (walk-continuation continuation color) + (let ((rvalue (rvalue-known-value continuation))) + (if (and rvalue + (continuation/always-known-operator? rvalue)) + (walk-node (continuation/entry-node rvalue) color)))) + +) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/contan.scm b/v7/src/compiler/fgopt/contan.scm index 5f26f8373..5ee21447f 100644 --- a/v7/src/compiler/fgopt/contan.scm +++ b/v7/src/compiler/fgopt/contan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.1 1987/12/04 19:27:35 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/contan.scm,v 4.2 1987/12/30 06:44:19 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -48,7 +48,7 @@ MIT in each case. |# ;;; For dynamic links, we compute the popping limit of a procedure's ;;; continuation variable, which is the farthest ancestor of the -;;; procedure's block that is be popped when invoking the +;;; procedure's block that is to be popped when invoking the ;;; continuation. If we cannot compute the limit statically (value is ;;; #F), we must use a dynamic link. @@ -56,113 +56,86 @@ MIT in each case. |# ;;; variable is not referenced in blocks other than the procedure's ;;; block. This may change if call/cc is handled specially. -(define-export (continuation-analysis blocks procedures) - (for-each (lambda (procedure) - (if (procedure-continuation? procedure) - (begin - (set-continuation/lvalues! procedure '()) - (set-continuation/dynamic-link?! procedure false)))) - procedures) +(define-export (continuation-analysis blocks) (for-each (lambda (block) (if (stack-block? block) - (analyze-continuation block))) + (set-variable-popping-limit! + (stack-block/continuation-lvalue block) + true))) blocks) (for-each (lambda (block) (if (stack-block? block) (let ((lvalue (stack-block/continuation-lvalue block))) - (if (not (variable-popping-limit lvalue)) - (force-dynamic-link! lvalue))))) - blocks) - (for-each (lambda (block) - (if (stack-block? block) - (lvalue-mark-clear! (stack-block/continuation-lvalue block) - dynamic-link-marker))) + (if (eq? (variable-popping-limit lvalue) true) + (set-variable-popping-limit! + lvalue + (analyze-continuation block lvalue)))))) blocks)) -(define (force-dynamic-link! lvalue) - (if (not (lvalue-mark-set? lvalue dynamic-link-marker)) - (begin - (lvalue-mark-set! lvalue dynamic-link-marker) - (for-each (lambda (continuation) - (if (not (continuation/dynamic-link? continuation)) - (begin - (set-continuation/dynamic-link?! continuation true) - (for-each (lambda (lvalue) - (if (variable-popping-limit lvalue) - (force-dynamic-link! lvalue))) - (continuation/lvalues continuation))))) - (lvalue-values lvalue))))) - -(define dynamic-link-marker - "dynamic-link") - -(define (analyze-continuation block) - (let ((lvalue (stack-block/continuation-lvalue block))) - (for-each (lambda (continuation) - (set-continuation/lvalues! - continuation - (cons lvalue (continuation/lvalues continuation)))) - (lvalue-values lvalue)) - (set-variable-popping-limit! - lvalue - (if (stack-parent? block) - (let ((external (stack-block/external-ancestor block))) - (let ((joins (continuation-join-blocks block lvalue external))) - (set-block-stack-link! block (adjacent-blocks block lvalue joins)) - (and (not (null? joins)) - (null? (cdr joins)) - (or (car joins) external)))) - block)))) +(define (analyze-continuation block lvalue) + (if (stack-parent? block) + (let ((external (stack-block/external-ancestor block)) + (blocks (map continuation/block (lvalue-values lvalue)))) + (let ((closing-blocks (map->eq-set block-parent blocks))) + (let ((join-blocks + (continuation-join-blocks block + lvalue + external + closing-blocks))) + (set-block-stack-link! + block + (if (null? (lvalue-initial-values lvalue)) + ;; In this case, the procedure is always invoked + ;; as a reduction. + (block-parent block) + (and (null? (cdr blocks)) + (always-subproblem? block join-blocks) + (not (null? closing-blocks)) + (null? (cdr closing-blocks)) + ;; The procedure is always invoked as a + ;; subproblem, all of the continuations are + ;; closed in the same block, and all are the + ;; same size. We can consistently find the + ;; parent block from the continuation. + (car blocks)))) + (let ((popping-limits + (map->eq-set + (lambda (join) + (cond ((not join) external) + ((eq? join block) block) + (else + (block-farthest-uncommon-ancestor block join)))) + join-blocks))) + (and (not (null? popping-limits)) + (null? (cdr popping-limits)) + (car popping-limits)))))) + block)) -(define (adjacent-blocks block lvalue joins) - (let ((parent (block-parent block))) - (transmit-values - (discriminate-items joins - (lambda (join) - (or (eq? join block) - (eq? join parent)))) - (lambda (internal external) - (cond ((null? internal) - ;; The procedure is never invoked as a subproblem. - ;; Therefore its ancestor frame and all intermediate - ;; frames are always immediately adjacent on the stack. - (list parent)) - ((and (null? external) - (null? (cdr internal)) - ;; Eliminate pathological case of procedure which - ;; is always invoked as a subproblem of itself. - ;; This can be written but the code can never be - ;; invoked. - (not (block-ancestor-or-self? (car internal) block))) - ;; The procedure is always invoked as a subproblem, and - ;; all of the continuations are closed in the same - ;; block. Therefore we can reach the ancestor frame by - ;; reference to that block. - (map continuation/block (lvalue-values lvalue))) - (else - ;; The relative position of the ancestor frame is not - ;; statically determinable. - '())))))) - -(define (continuation-join-blocks block lvalue external) +(define (always-subproblem? block join-blocks) + (and (not (null? join-blocks)) + (null? (cdr join-blocks)) + (or (eq? (car join-blocks) block) + (eq? (car join-blocks) (block-parent block))))) + +(define (continuation-join-blocks block lvalue external closing-blocks) (let ((ancestry (memq external (block-ancestry block '())))) - (let ((blocks + (let ((join-blocks (map->eq-set (lambda (block*) (let ((ancestry* (memq external (block-ancestry block* '())))) (and ancestry* (let loop ((ancestry (cdr ancestry)) - (ancestry* (cdr ancestry*))) - (cond ((null? ancestry) block) - ((and (not (null? ancestry*)) - (eq? (car ancestry) (car ancestry*))) - (loop (cdr ancestry) (cdr ancestry*))) - (else (car ancestry))))))) - (map->eq-set continuation/closing-block - (lvalue-values lvalue))))) + (ancestry* (cdr ancestry*)) + (join (car ancestry))) + (if (and (not (null? ancestry)) + (not (null? ancestry*)) + (eq? (car ancestry) (car ancestry*))) + (loop (cdr ancestry) (cdr ancestry*) (car ancestry)) + join))))) + closing-blocks))) (if (lvalue-passed-in? lvalue) - (eq-set-adjoin false blocks) - blocks)))) + (eq-set-adjoin false join-blocks) + join-blocks)))) ) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/folcon.scm b/v7/src/compiler/fgopt/folcon.scm index bff3111c3..813c924b7 100644 --- a/v7/src/compiler/fgopt/folcon.scm +++ b/v7/src/compiler/fgopt/folcon.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 4.1 1987/12/04 19:06:29 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/folcon.scm,v 4.2 1987/12/30 06:44:31 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -75,20 +75,12 @@ MIT in each case. |# (define (delete-if-known! lvalue) (if (and (not (lvalue-known-value lvalue)) - (null? (lvalue-backward-links lvalue))) + (for-all? (lvalue-backward-links lvalue) lvalue-known-value)) (let ((value (car (lvalue-values lvalue)))) (for-each (lambda (lvalue*) - (set-lvalue-backward-links! - lvalue* - (delq! lvalue (lvalue-backward-links lvalue*))) - ;; This is needed because, previously, LVALUE* - ;; inherited this value from LVALUE. - (lvalue-connect!:rvalue lvalue* value) (if (lvalue-mark-set? lvalue* 'KNOWABLE) (enqueue-node! lvalue*))) (lvalue-forward-links lvalue)) - (set-lvalue-forward-links! lvalue '()) - (set-lvalue-initial-values! lvalue (list value)) (set-lvalue-known-value! lvalue value)))) (define (fold-combinations combinations) diff --git a/v7/src/compiler/fgopt/offset.scm b/v7/src/compiler/fgopt/offset.scm new file mode 100644 index 000000000..104a4fcd0 --- /dev/null +++ b/v7/src/compiler/fgopt/offset.scm @@ -0,0 +1,139 @@ +#| -*-Scheme-*- + +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/offset.scm,v 4.1 1987/12/30 06:47:51 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. |# + +;;;; Compute FG Node Offsets + +(declare (usual-integrations)) + +(package (compute-node-offsets) + +(define *procedure-queue*) +(define *procedures*) + +(define-export (compute-node-offsets root-expression) + (fluid-let ((*procedure-queue* (make-queue)) + (*procedures* '())) + (walk-node (expression-entry-node root-expression) 0) + (queue-map! *procedure-queue* + (lambda (procedure) + (if (procedure-continuation? procedure) + (walk-node (continuation/entry-node procedure) + (if (eq? (continuation/type procedure) + continuation-type/push) + (1+ (continuation/offset procedure)) + (continuation/offset procedure))) + (walk-node (procedure-entry-node procedure) 0)))))) + +(define (walk-node node offset) + (let ((offset* (node/offset node))) + (cond ((not offset*) + (set-node/offset! node offset) + (walk-node* node offset)) + ((not (= offset offset*)) + (error "COMPUTE-NODE-OFFSETS: mismatched offsets" node))))) + +(define (walk-rvalue rvalue) + (let ((rvalue (rvalue-known-value rvalue))) + (if (and rvalue + (rvalue/procedure? rvalue) + (not (procedure-continuation? rvalue)) + (not (memq rvalue *procedures*))) + (enqueue-procedure! rvalue)))) + +(define (enqueue-procedure! procedure) + (set! *procedures* (cons procedure *procedures*)) + (enqueue! *procedure-queue* procedure)) + +(define (walk-return operator operand offset) + (walk-rvalue operator) + (let ((continuation (rvalue-known-value operator))) + (if (not (and continuation + (eq? continuation-type/effect + (continuation/type continuation)))) + (walk-rvalue operand)))) + +(define (walk-node* node offset) + (cfg-node-case (tagged-vector/tag node) + ((VIRTUAL-RETURN) + (let ((operator (virtual-return-operator node)) + (operand (virtual-return-operand node))) + (if (virtual-continuation/reified? operator) + (walk-return operator operand offset) + (walk-node + (snode-next node) + (enumeration-case continuation-type + (virtual-continuation/type operator) + ((EFFECT) + offset) + ((REGISTER VALUE) + (walk-rvalue operand) + offset) + ((PUSH) + (if (rvalue/continuation? operand) + (begin + (set-continuation/offset! operand offset) + (enqueue-procedure! operand) + (+ offset + (block-frame-size (continuation/block operand)))) + (begin + (walk-rvalue operand) + (1+ offset)))) + (else + (error "Unknown continuation type" return))))))) + ((APPLICATION) + (case (application-type node) + ((COMBINATION) + (walk-rvalue (combination/operator node))) + ((RETURN) + (walk-return (return/operator node) (return/operand node) offset)))) + ((POP) + (let ((continuation (pop-continuation node))) + (if (procedure? continuation) + (walk-rvalue continuation))) + (walk-node (snode-next node) (-1+ offset))) + ((ASSIGNMENT) + (if (not (lvalue-integrated? (assignment-lvalue node))) + (walk-rvalue (assignment-rvalue node))) + (walk-node (snode-next node) offset)) + ((DEFINITION) + (walk-rvalue (definition-rvalue node)) + (walk-node (snode-next node) offset)) + ((FG-NOOP) + (walk-node (snode-next node) offset)) + ((TRUE-TEST) + (walk-node (pnode-consequent node) offset) + (walk-node (pnode-alternative node) offset)))) + +;;; end COMPUTE-NODE-OFFSETS +) \ No newline at end of file diff --git a/v7/src/compiler/fgopt/operan.scm b/v7/src/compiler/fgopt/operan.scm index f43e60b7c..7f4583482 100644 --- a/v7/src/compiler/fgopt/operan.scm +++ b/v7/src/compiler/fgopt/operan.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.1 1987/12/04 19:28:06 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/operan.scm,v 4.2 1987/12/30 06:44:37 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -73,8 +73,10 @@ MIT in each case. |# (there-exists? (continuation/combinations continuation) (lambda (combination) (and (not (combination/inline? combination)) - (there-exists? (rvalue-values (combination/operator combination)) - (lambda (rvalue) (not (rvalue/procedure? rvalue)))))))) + (let ((operator (combination/operator combination))) + (or (rvalue-passed-in? operator) + (there-exists? (rvalue-values operator) + (lambda (rvalue) (not (rvalue/procedure? rvalue)))))))))) (define (analyze/continuation continuation) (and (not (continuation/passed-out? continuation)) diff --git a/v7/src/compiler/fgopt/order.scm b/v7/src/compiler/fgopt/order.scm index bed72ef36..09194cf2b 100644 --- a/v7/src/compiler/fgopt/order.scm +++ b/v7/src/compiler/fgopt/order.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.1 1987/12/04 19:28:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/order.scm,v 4.2 1987/12/30 06:44:43 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -82,7 +82,8 @@ MIT in each case. |# (if (eq? continuation-type/effect (virtual-continuation/type continuation)) (make-null-cfg) - (make-virtual-return continuation + (make-virtual-return (virtual-continuation/block continuation) + continuation (subproblem-rvalue subproblem))) rest))))) @@ -147,15 +148,17 @@ MIT in each case. |# (define (order-subproblems/out-of-line block operator operands callee) (set-subproblem-type! operator (operator-type (subproblem-rvalue operator))) - (if (and callee - (rvalue/procedure? callee) - (procedure/open? callee)) - (generate/static-link - block - callee - (if (procedure-interface-optimizible? callee) - (optimized-combination-ordering block operator operands callee) - (standard-combination-ordering operator operands))) + (if (and callee (rvalue/procedure? callee)) + (let ((rest + (if (procedure-interface-optimizible? callee) + (optimized-combination-ordering block + operator + operands + callee) + (standard-combination-ordering operator operands)))) + (if (procedure/open? callee) + (generate/static-link block callee rest) + rest)) (standard-combination-ordering operator operands))) (define (optimized-combination-ordering block operator operands callee) @@ -196,7 +199,7 @@ MIT in each case. |# (define (sort-subproblems/out-of-line subproblems callee) (transmit-values - (sort-integrated (procedure-original-required callee) + (sort-integrated (cdr (procedure-original-required callee)) subproblems '() '()) @@ -247,7 +250,8 @@ MIT in each case. |# (define (operator-type operator) (let ((callee (rvalue-known-value operator))) (cond ((not callee) - (if (reference? operator) + (if (and (reference? operator) + (not (reference-to-known-location? operator))) continuation-type/effect continuation-type/apply)) ((rvalue/constant? callee) diff --git a/v7/src/compiler/fgopt/outer.scm b/v7/src/compiler/fgopt/outer.scm index 79a0e0604..8cf29746d 100644 --- a/v7/src/compiler/fgopt/outer.scm +++ b/v7/src/compiler/fgopt/outer.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 4.2 1987/12/04 19:18:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/outer.scm,v 4.3 1987/12/30 06:44:51 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -144,7 +144,7 @@ MIT in each case. |# (define (lvalue-externally-visible! lvalue) (if (not (and (lvalue/variable? lvalue) - (memq 'CONSTANT (variable-declarations? lvalue)))) + (memq 'CONSTANT (variable-declarations lvalue)))) (lvalue-passed-in! lvalue)) (lvalue-passed-out! lvalue)) diff --git a/v7/src/compiler/fgopt/simapp.scm b/v7/src/compiler/fgopt/simapp.scm index c582e8589..ad16763b2 100644 --- a/v7/src/compiler/fgopt/simapp.scm +++ b/v7/src/compiler/fgopt/simapp.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.1 1987/12/04 19:06:39 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simapp.scm,v 4.2 1987/12/30 06:45:00 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -111,14 +111,16 @@ MIT in each case. |# (loop (cdr parameters) (cdr operands))))))) ((rvalue/constant? operator) (let ((value (constant-value operator))) - (if (primitive-procedure? value) - (if (not (primitive-arity-correct? value - (-1+ number-supplied))) - (warn - "Primitive called with wrong number of arguments" - value - number-supplied)) - (warn "Inapplicable operator" value)))) + (cond ((primitive-procedure? value) + (if (not + (primitive-arity-correct? value + (-1+ number-supplied))) + (warn + "Primitive called with wrong number of arguments" + value + number-supplied))) + ((not (scode/unassigned-object? value)) + (warn "Inapplicable operator" value))))) (else (warn "Inapplicable operator" operator))))))) diff --git a/v7/src/compiler/fgopt/simple.scm b/v7/src/compiler/fgopt/simple.scm index 2c688c208..a06cb8c11 100644 --- a/v7/src/compiler/fgopt/simple.scm +++ b/v7/src/compiler/fgopt/simple.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simple.scm,v 4.1 1987/12/04 19:28:21 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fgopt/simple.scm,v 4.2 1987/12/30 06:45:09 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -93,7 +93,7 @@ MIT in each case. |# (continuation-simple? (return/operator return) continuation)) (define (virtual-return-simple? return continuation) - (continuation-simple? (virtual-return-operator return) continuation)) + (node-simple? (snode-next return) continuation)) (define (continuation-simple? rvalue continuation) (or (eq? rvalue continuation) diff --git a/v7/src/compiler/machines/bobcat/dassm1.scm b/v7/src/compiler/machines/bobcat/dassm1.scm index 1af33086e..6b317e869 100644 --- a/v7/src/compiler/machines/bobcat/dassm1.scm +++ b/v7/src/compiler/machines/bobcat/dassm1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 1.1 1987/08/07 17:12:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm1.scm,v 4.1 1987/12/30 07:04:31 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -32,31 +32,100 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; 68000 Disassembler +;;;; Disassembler: User Level (declare (usual-integrations)) -(define disassembler:symbolize-output? true) - -(define disassembly-stream) -(define setup-table!) ;; Temporary -(define compiler:write-lap-file) -(define compiler:write-constants-file) - -;;; Little bit of abstraction for instructions shipped outside - -(define-integrable (make-instruction offset label? code) - (cons* offset label? code)) - -(define-integrable instruction-offset car) -(define-integrable instruction-label? cadr) -(define-integrable instruction-code cddr) - -;; INSTRUCTION-STREAM-CONS is (cons (delay )) - -(define-integrable instruction-stream? pair?) -(define-integrable instruction-stream-null? null?) -(define-integrable instruction-stream-head car) - -(define-integrable (instruction-stream-tail stream) - (force (cdr stream))) \ No newline at end of file +;;; Flags that control disassembler behavior +(define disassembler/symbolize-output? true) +(define disassembler/compiled-code-heuristics? true) +(define disassembler/write-offsets? true) + +;;; Operations exported from the disassembler package +(define disassembler/instructions) +(define disassembler/instructions/null?) +(define disassembler/instructions/read) +(define disassembler/lookup-symbol) + +(define (compiler:write-lap-file filename #!optional symbol-table?) + (let ((pathname (->pathname filename))) + (with-output-to-file (pathname-new-type pathname "lap") + (lambda () + (disassembler/write-compiled-code-block + (compiled-code-block/read-file (pathname-new-type pathname "com")) + (let ((pathname (pathname-new-type pathname "binf"))) + (and (if (unassigned? symbol-table?) + (file-exists? pathname) + symbol-table?) + (compiler-info/symbol-table + (compiler-info/read-file pathname))))))))) + +(define (disassembler/write-compiled-code-block block symbol-table) + (write-string "Code:\n\n") + (disassembler/write-instruction-stream + symbol-table + (disassembler/instructions/compiled-code-block block symbol-table)) + (write-string "\nConstants:\n\n") + (disassembler/write-constants-block block symbol-table)) + +(define (disassembler/instructions/compiled-code-block block symbol-table) + (disassembler/instructions block + (compiled-code-block/code-start block) + (compiled-code-block/code-end block) + symbol-table)) + +(define (disassembler/instructions/address start-address end-address) + (disassembler/instructions false start-address end-address false)) + +(define (disassembler/write-instruction-stream symbol-table instruction-stream) + (fluid-let ((*unparser-radix* 16)) + (disassembler/for-each-instruction instruction-stream + (lambda (offset instruction) + (disassembler/write-instruction + symbol-table + offset + (lambda () + (let ((string + (with-output-to-string + (lambda () + (display instruction))))) + (string-downcase! string) + (write-string string)))))))) + +(define (disassembler/for-each-instruction instruction-stream procedure) + (let loop ((instruction-stream instruction-stream)) + (if (not (disassembler/instructions/null? instruction-stream)) + (disassembler/instructions/read instruction-stream + (lambda (offset instruction instruction-stream) + (procedure offset instruction) + (loop (instruction-stream))))))) + +(define (disassembler/write-constants-block block symbol-table) + (fluid-let ((*unparser-radix* 16)) + (let ((end (compiled-code-block/constants-end block))) + (let loop ((index (compiled-code-block/constants-start block))) + (if (< index end) + (begin + (disassembler/write-instruction + symbol-table + (compiled-code-block/index->offset index) + (lambda () (write (system-vector-ref block index)))) + (loop (1+ index)))))))) + +(define (disassembler/write-instruction symbol-table offset write-instruction) + (if symbol-table + (let ((label (disassembler/lookup-symbol symbol-table offset))) + (if label + (begin (write-char #\Tab) + (write-string (string-downcase label)) + (write-char #\:) + (newline))))) + (if disassembler/write-offsets? + (begin (write-string + ((access unparse-number-heuristically number-unparser-package) + offset 16 false false)) + (write-char #\Tab))) + (if symbol-table + (write-string " ")) + (write-instruction) + (newline)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/dassm2.scm b/v7/src/compiler/machines/bobcat/dassm2.scm index 85734cc99..5ddf4b2e1 100644 --- a/v7/src/compiler/machines/bobcat/dassm2.scm +++ b/v7/src/compiler/machines/bobcat/dassm2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 1.2 1987/10/05 20:24:22 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm2.scm,v 4.1 1987/12/30 07:04:38 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -32,252 +32,251 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. |# -;;;; 68000 Disassembler +;;;; 68000 Disassembler: Top Level (declare (usual-integrations)) -(define ((with-info-to-file type receiver) filename) - (let ((filename (->pathname filename))) - (let ((block (file->block (pathname-new-type filename "com")))) - (fluid-let ((*symbol-table)) - (setup-table! (pathname-new-type filename "binf")) - (call-with-output-file (pathname-new-type filename type) - (lambda (port) (receiver block port))))))) - -(define (block-code->port! block port) - (define (instruction-output-string label? instruction) - (let ((string (with-output-to-string - (lambda () - (if label? (format "~%~s:" label?)) - (format "~% ") - (display instruction))))) - (string-downcase! string) - string)) - - (let ((last-valid-offset (block-code-ending-offset block))) - (let loop ((offset (block-code-starting-offset block))) - (disassemble-one-instruction block offset - (lambda (new-offset label? instruction) - (write-string (instruction-output-string label? instruction) port) - (and (<= new-offset last-valid-offset) - (loop new-offset))))))) - -(define (block-constants->port! block port) - (define (constant-output-string label? constant) - (with-output-to-string - (lambda () - (if label? - (format "~%~s:" (string-downcase label?))) - (format "~% ~o" constant)))) - - (let ((last-valid-index (block-constants-ending-index block))) - (let loop ((index (block-constants-starting-index block))) - (and (<= index last-valid-index) - (let ((offset (block-index->offset index))) - (write-string - (constant-output-string (lookup-label block offset) - (system-vector-ref block index)) - port) - (loop (1+ index))))))) - -(set! compiler:write-lap-file - (with-info-to-file "lap" - (lambda (block port) - (newline port) - (write-string "Executable Code:" port) - (newline port) - (block-code->port! block port) - (newline port) - (newline port) - (write-string "Constants:" port) - (newline port) - (block-constants->port! block port)))) - -(set! compiler:write-constants-file - (with-info-to-file "con" block-constants->port!)) - -(set! disassembly-stream - (named-lambda (disassembly-stream start) - (disassemble-anything start - (lambda (base block offset) - (let ((last-valid-offset (block-code-ending-offset block))) - (let loop ((offset offset)) - (disassemble-one-instruction block offset - (lambda (new-offset label? instruction) - (if (> new-offset last-valid-offset) - '() - ;; INSTRUCTION-STREAM-CONS - (cons (make-instruction offset label? instruction) - (delay (loop new-offset)))))))))))) - -(define (disassemble-anything thing continuation) - (cond ((compiled-code-address? thing) - (let ((block (compiled-code-address->block thing))) - (continuation (primitive-datum block) - block - (compiled-code-address->offset thing)))) - ((integer? thing) - (continuation 0 0 thing)) - (else - (error "Unknown entry to disassemble" thing)))) - -(define (make-address base offset label?) - (or label? offset)) +(set! compiled-code-block/bytes-per-object 4) + +(set! disassembler/instructions + (lambda (block start-offset end-offset symbol-table) + (let loop ((offset start-offset) (state (disassembler/initial-state))) + (if (and end-offset + (< offset end-offset)) + (disassemble-one-instruction block offset symbol-table state + (lambda (offset* instruction state) + (make-instruction offset + instruction + (lambda () (loop offset* state))))) + '())))) + +(set! disassembler/instructions/null? + null?) + +(set! disassembler/instructions/read + (lambda (instruction-stream receiver) + (receiver (instruction-offset instruction-stream) + (instruction-instruction instruction-stream) + (instruction-next instruction-stream)))) + +(define-structure (instruction (type vector)) + (offset false read-only true) + (instruction false read-only true) + (next false read-only true)) (define *block) -(define *initial-offset) (define *current-offset) -(define *valid?) +(define *symbol-table) (define *ir) +(define *valid?) -(define (disassemble-one-instruction block offset receiver) - (define (make-losing-instruction size) - (if (eq? size 'W) - `(DC W ,(bit-string->unsigned-integer *ir)) - `(DC L ,(bit-string->unsigned-integer (bit-string-append (get-word) - *ir))))) - +(define (disassemble-one-instruction block offset symbol-table state receiver) (fluid-let ((*block block) - (*initial-offset offset) (*current-offset offset) - (*valid? true) - (*ir)) + (*symbol-table symbol-table) + (*ir) + (*valid? true)) (set! *ir (get-word)) - (receiver *current-offset - (lookup-label block offset) - (let ((size (dcw? block offset))) - (if size - (make-losing-instruction size) - (let ((instruction - (((vector-ref opcode-dispatch (extract *ir 12 16)))))) - (if *valid? - instruction - (make-losing-instruction 'W)))))))) - -(define (undefined-instruction) - ;; This losing assignment removes a 'cwcc'. Too bad. - (set! *valid? false) - '()) - -(define (undefined) - undefined-instruction) + (let ((instruction + (if (external-label-marker? symbol-table offset state) + (make-dc 'W *ir) + (let ((instruction + (((vector-ref opcode-dispatch (extract *ir 12 16)))))) + (if *valid? + instruction + (make-dc 'W *ir)))))) + (receiver *current-offset + instruction + (disassembler/next-state instruction state))))) + +(define (disassembler/initial-state) + 'INSTRUCTION-NEXT) + +(define (disassembler/next-state instruction state) + (if (and disassembler/compiled-code-heuristics? + (or (memq (car instruction) '(BRA JMP RTS)) + (and (eq? (car instruction) 'JSR) + (let ((entry + (interpreter-register? (cadr instruction)))) + (and entry + (eq? (car entry) 'ENTRY) + (not (eq? (cadr entry) 'SETUP-LEXPR))))))) + 'EXTERNAL-LABEL + 'INSTRUCTION)) + +(set! disassembler/lookup-symbol + (lambda (symbol-table offset) + (and symbol-table + (let ((label (symbol-table offset))) + (and label + (label-info-name label)))))) + +(define (external-label-marker? symbol-table offset state) + (if symbol-table + (let ((label (symbol-table (+ offset 2)))) + (and label + (label-info-external? label))) + (and *block + (not (eq? state 'INSTRUCTION)) + (let loop ((offset (+ offset 2))) + (let ((contents (read-bits (- offset 2) 16))) + (if (bit-string-clear! contents 0) + (let ((offset + (- offset (bit-string->unsigned-integer contents)))) + (and (positive? offset) + (loop offset))) + (= offset (bit-string->unsigned-integer contents)))))))) + +(define (make-dc wl bit-string) + `(DC ,wl ,(bit-string->unsigned-integer bit-string))) + +(define (read-bits offset size-in-bits) + (let ((word (bit-string-allocate size-in-bits))) + (with-interrupt-mask interrupt-mask-none + (lambda (old) + (read-bits! (if *block + (+ (primitive-datum *block) offset) + offset) + 0 + word))) + word)) ;;;; Compiler specific information +(define make-data-register) +(define make-address-register) +(define make-address-offset) +(define interpreter-register?) +(let () + +(define (register-maker assignments) + (lambda (mode register) + (list mode + (if disassembler/symbolize-output? + (cdr (assq register assignments)) + register)))) + +(set! make-data-register + (lambda (mode register) + (list mode + (if disassembler/symbolize-output? + (cdr (assq register data-register-assignments)) + register)))) + +(set! make-address-register + (lambda (mode register) + (if disassembler/symbolize-output? + (or (and (eq? mode '@A) + (= register interpreter-register-pointer) + (let ((entry (assq 0 interpreter-register-assignments))) + (and entry + (cdr entry)))) + (list mode (cdr (assq register address-register-assignments)))) + (list mode register)))) + (define data-register-assignments - ;; D0 serves multiple functions, not handled now - '((7 . REFERENCE-MASK))) + '((0 . 0) ;serves multiple functions, not handled now + (1 . 1) + (2 . 2) + (3 . 3) + (4 . 4) + (5 . 5) + (6 . 6) + (7 . REFERENCE-MASK))) (define address-register-assignments - '((4 . FRAME-POINTER) + '((0 . 0) + (1 . 1) + (2 . 2) + (3 . 3) + (4 . DYNAMIC-LINK) (5 . FREE-POINTER) (6 . REGS-POINTER) (7 . STACK-POINTER))) + +(set! make-address-offset + (lambda (register offset) + (if disassembler/symbolize-output? + (or (and (= register interpreter-register-pointer) + (let ((entry (assq offset interpreter-register-assignments))) + (and entry + (cdr entry)))) + `(@AO ,(cdr (assq register address-register-assignments)) + ,offset)) + `(@AO ,register ,offset)))) + +(set! interpreter-register? + (lambda (effective-address) + (case (car effective-address) + ((@AO) + (and (= (cadr effective-address) interpreter-register-pointer) + (let ((entry + (assq (caddr effective-address) + interpreter-register-assignments))) + (and entry + (cdr entry))))) + ((REGISTER TEMPORARY ENTRY) effective-address) + (else false)))) + +(define interpreter-register-pointer + 6) (define interpreter-register-assignments - (let-syntax () - (define-macro (make-table) - (define (make-entries index names) - (if (null? names) - '() - (cons `(,index . (ENTRY ,(car names))) - (make-entries (+ index 6) (cdr names))))) - `'(;; Interpreter registers - (0 . (REG MEMORY-TOP)) - (4 . (REG STACK-GUARD)) - (8 . (REG VALUE)) - (12 . (REG ENVIRONMENT)) - (16 . (REG TEMPORARY)) - (20 . (REG INTERPRETER-CALL-RESULT:ENCLOSE)) - ;; Interpreter entry points - ,@(make-entries - #x00F0 - '(apply error wrong-number-of-arguments interrupt-procedure - interrupt-continuation lookup-apply lookup access - unassigned? unbound? set! define primitive-apply - enclose setup-lexpr return-to-interpreter safe-lookup - cache-variable reference-trap assignment-trap)) - ,@(make-entries - #x0228 - '(uuo-link uuo-link-trap cache-reference-apply - safe-reference-trap unassigned?-trap - cache-variable-multiple uuo-link-multiple - &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? negative? - cache-assignment cache-assignment-multiple operator-trap)))) - (make-table))) + (let () + (define (make-entries index names) + (if (null? names) + '() + (cons `(,index . (ENTRY ,(car names))) + (make-entries (+ index 6) (cdr names))))) + `(;; Interpreter registers + (0 . (REGISTER MEMORY-TOP)) + (4 . (REGISTER STACK-GUARD)) + (8 . (REGISTER VALUE)) + (12 . (REGISTER ENVIRONMENT)) + (16 . (REGISTER TEMPORARY)) + (20 . (REGISTER INTERPRETER-CALL-RESULT:ENCLOSE)) + ;; Compiler temporaries + ,@(let loop ((index 40) (i 0)) + (if (= i 50) + '() + (cons `(,index . (TEMPORARY ,i)) + (loop (+ index 4) (1+ i))))) + ;; Interpreter entry points + ,@(make-entries + #x00F0 + '(apply error wrong-number-of-arguments + interrupt-procedure interrupt-continuation + lookup-apply lookup access unassigned? unbound? set! + define primitive-apply enclose setup-lexpr + return-to-interpreter safe-lookup cache-variable + reference-trap assignment-trap)) + ,@(make-entries + #x0228 + '(uuo-link uuo-link-trap cache-reference-apply + safe-reference-trap unassigned?-trap + cache-variable-multiple uuo-link-multiple + &+ &- &* &/ &= &< &> 1+ -1+ zero? positive? + negative? cache-assignment cache-assignment-multiple + operator-trap))))) + +) -(define-integrable (lookup-special-register reg table) - (assq reg table)) - -(define-integrable (special-register reg-pair) - (cdr reg-pair)) - -(define ((register-maker table) mode register) - (let ((special (and disassembler:symbolize-output? - (lookup-special-register register table)))) - (list mode - (if special - (special-register special) - register)))) +(define (make-pc-relative thunk) + (let ((reference-offset *current-offset)) + (let ((pco (thunk))) + (offset->pc-relative pco reference-offset)))) -(define make-data-register - (register-maker data-register-assignments)) - -(define make-address-register - (register-maker address-register-assignments)) - -(define (make-address-offset register offset) - (if (not disassembler:symbolize-output?) - `(@AO ,register ,offset) - (let ((special - (lookup-special-register register address-register-assignments))) - (if special - (if (eq? (special-register special) 'REGS-POINTER) - (let ((interpreter-register - (lookup-special-register offset - interpreter-register-assignments))) - (if interpreter-register - (special-register interpreter-register) - `(@AO REGS-POINTER ,offset))) - `(@AO ,(special-register special) ,offset)) - `(@AO ,register ,offset))))) +(define (offset->pc-relative pco reference-offset) + (if disassembler/symbolize-output? + `(@PCR ,(let ((absolute (+ pco reference-offset))) + (or (disassembler/lookup-symbol *symbol-table absolute) + absolute))) + `(@PCO ,pco))) -(define (make-pc-relative thunk) - ;; Done this way to force order of evaluation - (let* ((reference-offset *current-offset) - (pco (thunk))) - (offset->pc-relative pco reference-offset))) - -(define-integrable (offset->pc-relative pco reference-offset) - (let ((absolute (+ pco reference-offset))) - (if disassembler:symbolize-output? - (let ((answ (lookup-label *block absolute))) - (if answ - `(@PCR ,answ) - `(@PCO ,(- pco (- reference-offset *initial-offset))))) - `(@PCO ,(- pco (- reference-offset *initial-offset)))))) - -(define *symbol-table) +(define (undefined-instruction) + ;; This losing assignment removes a 'cwcc'. Too bad. + (set! *valid? false) + '()) -;; Temporary Kludge - -(set! setup-table! - (named-lambda (setup-table! filename) - (set! *symbol-table - (make-binary-searcher (compiler-info-labels (fasload filename)) - offset/label-info=? - offset/label-infounsigned-integer (bit-substring bit-string start end))) -(define-integrable (extract+ bit-string start end) +(define (extract+ bit-string start end) + (declare (integrate bit-string start end)) (bit-string->signed-integer (bit-substring bit-string start end))) ;;; Symbolic representation of bit strings diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 2f3a67cac..1eccadf91 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 1.24 1987/09/03 05:17:16 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 4.1 1987/12/30 07:03:02 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,10 +36,135 @@ MIT in each case. |# (declare (usual-integrations)) -(define (file-dependency/integration/chain filenames) - (if (not (null? (cdr filenames))) - (begin (file-dependency/integration/make (car filenames) (cdr filenames)) - (file-dependency/integration/chain (cdr filenames))))) +(define-structure (source-node + (conc-name source-node/) + (constructor make/source-node (filename))) + (filename false read-only true) + (forward-links '()) + (backward-links '()) + (forward-closure '()) + (backward-closure '()) + (dependencies '()) + (rank false)) + +(define source-filenames + (mapcan (lambda (subdirectory) + (map (lambda (pathname) + (string-append subdirectory "/" (pathname-name pathname))) + (directory-read (string-append subdirectory "/*.scm")))) + '("back" "base" "fggen" "fgopt" "rtlbase" "rtlgen" "rtlopt" + "machines/bobcat"))) + +(define source-hash + (make/hash-table 101 + string-hash-mod + (lambda (filename source-node) + (string=? filename (source-node/filename source-node))) + make/source-node)) + +(define source-nodes + (map (lambda (filename) + (hash-table/intern! source-hash + filename + identity-procedure + identity-procedure)) + source-filenames)) + +(define (filename->source-node filename) + (hash-table/lookup source-hash + filename + identity-procedure + (lambda () (error "Unknown source file" filename)))) + +(define (source-node/link! node dependency) + (if (not (memq dependency (source-node/backward-links node))) + (begin + (set-source-node/backward-links! + node + (cons dependency (source-node/backward-links node))) + (set-source-node/forward-links! + dependency + (cons node (source-node/forward-links dependency))) + (source-node/close! node dependency)))) + +(define (source-node/close! node dependency) + (if (not (memq dependency (source-node/backward-closure node))) + (begin + (set-source-node/backward-closure! + node + (cons dependency (source-node/backward-closure node))) + (set-source-node/forward-closure! + dependency + (cons node (source-node/forward-closure dependency))) + (for-each (lambda (dependency) + (source-node/close! node dependency)) + (source-node/backward-closure dependency)) + (for-each (lambda (node) + (source-node/close! node dependency)) + (source-node/forward-closure node))))) + +(define (source-files-by-rank) + (source-nodes/rank! source-nodes) + (map source-node/filename (source-nodes/sort-by-rank source-nodes))) + +(define (source-files-with-circular-dependencies) + (map source-node/filename + (list-transform-positive source-nodes + (lambda (node) + (memq node (source-node/backward-closure node)))))) + +(define source-nodes/rank!) +(let () + +(set! source-nodes/rank! + (lambda (nodes) + (compute-dependencies! nodes) + (compute-ranks! nodes))) + +(define (compute-dependencies! nodes) + (for-each (lambda (node) + (set-source-node/dependencies! + node + (list-transform-negative (source-node/backward-closure node) + (lambda (node*) + (memq node (source-node/backward-closure node*)))))) + nodes)) + +(define (compute-ranks! nodes) + (let loop ((nodes nodes) (unranked-nodes '())) + (if (null? nodes) + (if (not (null? unranked-nodes)) + (loop unranked-nodes '())) + (loop (cdr nodes) + (let ((node (car nodes))) + (let ((rank (source-node/rank* node))) + (if rank + (begin + (set-source-node/rank! node rank) + unranked-nodes) + (cons node unranked-nodes)))))))) + +(define (source-node/rank* node) + (let loop ((nodes (source-node/dependencies node)) (rank -1)) + (if (null? nodes) + (1+ rank) + (let ((rank* (source-node/rank (car nodes)))) + (and rank* + (loop (cdr nodes) (max rank rank*))))))) + +) + +(define (source-nodes/sort-by-rank nodes) + (sort nodes (lambda (x y) (< (source-node/rank x) (source-node/rank y))))) + +(define (file-dependency/syntax/join filenames dependency) + (for-each (lambda (filename) + (sf/set-file-syntax-table! filename dependency)) + filenames)) + +(define (define-integration-dependencies directory name directory* . names) + (file-dependency/integration/make (string-append directory "/" name) + (apply filename/append directory* names))) (define (file-dependency/integration/join filenames dependencies) (for-each (lambda (filename) @@ -47,112 +172,225 @@ MIT in each case. |# filenames)) (define (file-dependency/integration/make filename dependencies) - (if enable-integration-declarations - (sf/add-file-declarations! filename - `((INTEGRATE-EXTERNAL ,@dependencies))))) + (let ((node (filename->source-node filename))) + (for-each (lambda (dependency) + (let ((node* (filename->source-node dependency))) + (if (not (eq? node node*)) + (source-node/link! node node*)))) + dependencies))) + +(define (finish-integration-dependencies!) + (if compiler:enable-integration-declarations? + (for-each (lambda (node) + (let ((links (source-node/backward-links node))) + (if (not (null? links)) + (sf/add-file-declarations! + (source-node/filename node) + `((INTEGRATE-EXTERNAL + ,@(map (lambda (node*) + (filename->absolute-pathname + (source-node/filename node*))) + links))))))) + source-nodes))) (define (file-dependency/expansion/join filenames expansions) - (for-each (lambda (filename) - (file-dependency/expansion/make filename expansions)) - filenames)) - -(define (file-dependency/expansion/make filename expansions) - (if enable-expansion-declarations - (sf/add-file-declarations! filename `((EXPAND-OPERATOR ,@expansions))))) + (if compiler:enable-expansion-declarations? + (for-each (lambda (filename) + (sf/add-file-declarations! + filename + `((EXPAND-OPERATOR ,@expansions)))) + filenames))) (define (filename/append directory . names) - (map (lambda (name) - (pathname->absolute-pathname - (string->pathname (string-append directory "/" name)))) - names)) + (map (lambda (name) (string-append directory "/" name)) names)) -(define (file-dependency/syntax/join filenames dependency) - (for-each (lambda (filename) - (sf/set-file-syntax-table! filename dependency)) - filenames)) +(define (filename->absolute-pathname filename) + (pathname->absolute-pathname (->pathname filename))) -;;;; Integration and expansion dependencies +;;;; Syntax dependencies + +(file-dependency/syntax/join + (append (filename/append "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "ctypes" + "debug" "enumer" "infgen" "infutl" "lvalue" "object" + "pmerly" "proced" "queue" "rvalue" "scode" "sets" + "subprb" "switch" "toplev" "utils") + (filename/append "back" + "asmmac" "bittop" "bitutl" "insseq" "lapgn1" "lapgn2" + "lapgn3" "linear" "regmap" "symtab" "syntax") + (filename/append "machines/bobcat" + "insmac" "machin" "rgspcm") + (filename/append "fggen" + "declar" "fggen") + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "desenv" "folcon" + "offset" "operan" "order" "outer" "simapp" "simple") + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" "rtline" + "rtlobj" "rtlreg" "rtlty1" "rtlty2") + (filename/append "rtlgen" + "fndblk" "opncod" "rgcomb" "rgproc" "rgretn" "rgrval" + "rgstmt" "rtlgen") + (filename/append "rtlopt" + "ralloc" "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" + "rcsesr" "rdeath" "rdebug" "rlife")) + compiler-syntax-table) + +(file-dependency/syntax/join + (filename/append "machines/bobcat" + "lapgen" "rules1" "rules2" "rules3" "rules4") + lap-generator-syntax-table) -(define filenames/dependency-chain/base +(file-dependency/syntax/join + (filename/append "machines/bobcat" + "insutl" "instr1" "instr2" "instr3" "instr4") + assembler-syntax-table) + +;;;; Integration Dependencies + +(define-integration-dependencies "base" "object" "base" "enumer") +(define-integration-dependencies "base" "enumer" "base" "object") +(define-integration-dependencies "base" "utils" "base" "scode") +(define-integration-dependencies "base" "cfg1" "base" "object") +(define-integration-dependencies "base" "cfg2" "base" "cfg1" "cfg3" "object") +(define-integration-dependencies "base" "cfg3" "base" "cfg1" "cfg2") +(define-integration-dependencies "base" "ctypes" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "lvalue" "object" "subprb") +(define-integration-dependencies "base" "rvalue" "base" + "blocks" "cfg1" "cfg2" "cfg3" "enumer" "lvalue" "object" "utils") +(define-integration-dependencies "base" "lvalue" "base" + "blocks" "object" "proced" "rvalue" "utils") +(define-integration-dependencies "base" "blocks" "base" + "enumer" "lvalue" "object" "proced" "rvalue" "scode") +(define-integration-dependencies "base" "proced" "base" + "blocks" "cfg1" "cfg2" "cfg3" "contin" "enumer" "lvalue" "object" "rvalue" + "utils") +(define-integration-dependencies "base" "contin" "base" + "blocks" "cfg3" "ctypes") +(define-integration-dependencies "base" "subprb" "base" + "cfg3" "contin" "enumer" "object" "proced") +(define-integration-dependencies "base" "infnew" "base" "infutl") + +(define front-end-base (filename/append "base" - "object" "cfg1" "cfg2" "cfg3" "rgraph" "ctypes" "dtype1" - "dtype2" "dtype3" "dfg" "rtlty1" "rtlty2" "rtlreg" "rtlcfg" - "emodel" "rtypes" "regset" "infutl" "infgen")) - -(define filenames/dependency-chain/rcse - (filename/append "front-end" "rcseht" "rcserq" "rcse1" "rcse2")) - -(define filenames/dependency-group/base - (append (filename/append "base" "linear" "rtlcon" "rtlexp") - (filename/append "alpha" "declar" "dflow1" "dflow2" "dflow3" "dflow4" - "dflow5" "dflow6" "fggen1" "fggen2") - (filename/append "front-end" - "ralloc" "rcseep" "rdeath" "rdebug" "rgcomb" - "rgpcom" "rgpred" "rgproc" "rgrval" "rgstmt" "rlife" - "rtlgen") - (filename/append "back-end" "lapgn1" "lapgn2" "lapgn3") - (filename/append "machines/bobcat" "rgspcm"))) - -(define filenames/dependency-chain/bits - (filename/append "back-end" "symtab" "bitutl" "bittop")) - -(file-dependency/integration/chain - (reverse - (append filenames/dependency-chain/base - filenames/dependency-chain/rcse))) - -(file-dependency/integration/chain - (reverse filenames/dependency-chain/bits)) - -(file-dependency/integration/join filenames/dependency-group/base - filenames/dependency-chain/base) - -(file-dependency/integration/chain - (append (filename/append "machines/bobcat" "dassm1") - (filename/append "base" "infutl"))) + "blocks" "cfg1" "cfg2" "cfg3" "contin" "ctypes" "enumer" + "lvalue" "object" "proced" "queue" "rvalue" "scode" + "subprb" "utils")) -(file-dependency/integration/join - (filename/append "machines/bobcat" "dassm2" "dassm3") - (append (filename/append "machines/bobcat" "dassm1") - (filename/append "base" "infutl"))) +(define-integration-dependencies "machines/bobcat" "machin" "rtlbase" + "rtlreg" "rtlty1" "rtlty2") + +(define bobcat-base + (filename/append "machines/bobcat" "machin")) + +(define-integration-dependencies "rtlbase" "regset" "base") +(define-integration-dependencies "rtlbase" "rgraph" "base" "cfg1" "cfg2") +(define-integration-dependencies "rtlbase" "rgraph" "machines/bobcat" "machin") +(define-integration-dependencies "rtlbase" "rtlcfg" "base" + "cfg1" "cfg2" "cfg3") +(define-integration-dependencies "rtlbase" "rtlcon" "base" "cfg3" "utils") +(define-integration-dependencies "rtlbase" "rtlcon" "machines/bobcat" "machin") +(define-integration-dependencies "rtlbase" "rtlexp" "base" "utils") +(define-integration-dependencies "rtlbase" "rtlexp" "rtlbase" "rtlreg") +(define-integration-dependencies "rtlbase" "rtline" "base" "cfg1" "cfg2") +(define-integration-dependencies "rtlbase" "rtline" "rtlbase" + "rtlcfg" "rtlty2") +(define-integration-dependencies "rtlbase" "rtlobj" "base" + "cfg1" "object" "utils") +(define-integration-dependencies "rtlbase" "rtlreg" "machines/bobcat" "machin") +(define-integration-dependencies "rtlbase" "rtlreg" "rtlbase" + "rgraph" "rtlty1") +(define-integration-dependencies "rtlbase" "rtlty1" "rtlbase" "rtlcfg") +(define-integration-dependencies "rtlbase" "rtlty2" "base" "scode") +(define-integration-dependencies "rtlbase" "rtlty2" "machines/bobcat" "machin") +(define-integration-dependencies "rtlbase" "rtlty2" "rtlbase" "rtlty1") + +(define rtl-base + (filename/append "rtlbase" + "regset" "rgraph" "rtlcfg" "rtlcon" "rtlexp" "rtlobj" + "rtlreg" "rtlty1" "rtlty2")) -;;;; Lap level integration and expansion dependencies +(file-dependency/integration/join + (append + (filename/append "fggen" + "declar" "fggen") + (filename/append "fgopt" + "blktyp" "closan" "conect" "contan" "desenv" "folcon" + "offset" "operan" "order" "outer" "simapp" "simple")) + (append front-end-base bobcat-base)) -(define filenames/dependency-group/lap - (filename/append "machines/bobcat" "instr1" "instr2" "instr3" "instr4")) +(file-dependency/integration/join + (filename/append "rtlgen" + "fndblk" "opncod" "rgcomb" "rgproc" "rgretn" "rgrval" + "rgstmt" "rtlgen") + (append front-end-base bobcat-base rtl-base)) + +(define cse-base + (filename/append "rtlopt" + "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" "rcsesr")) -(define filenames/dependency-group/lap-syn1 - (append (filename/append "back-end" "lapgn1" "lapgn2" "lapgn3" "regmap") - (filename/append "base" "linear"))) +(file-dependency/integration/join + (append cse-base + (filename/append "rtlopt" "ralloc" "rdeath" "rdebug" "rlife")) + (append bobcat-base rtl-base)) -(define filenames/dependency-group/lap-syn2 - (filename/append "machines/bobcat" "lapgen")) +(file-dependency/integration/join cse-base cse-base) -(define filenames/dependency-group/lap-syn3 - (filename/append "machines/bobcat" "rules1" "rules2" "rules3" "rules4")) +(define-integration-dependencies "rtlopt" "rcseht" "base" "object") +(define-integration-dependencies "rtlopt" "rcserq" "base" "object") +(define-integration-dependencies "rtlopt" "rlife" "base" "cfg2") + +(define instruction-base + (append (filename/append "back" "insseq") + (filename/append "machines/bobcat" "assmd" "machin"))) -(define filenames/dependency-group/lap-syn4 - (append filenames/dependency-group/lap-syn2 - filenames/dependency-group/lap-syn3)) +(define lapgen-base + (append (filename/append "back" "lapgn2" "lapgn3" "regmap") + (filename/append "machines/bobcat" "lapgen"))) -(file-dependency/integration/join filenames/dependency-group/lap-syn3 - filenames/dependency-group/lap-syn2) +(define assembler-base + (append (filename/append "back" "bitutl" "symtab") + (filename/append "machines/bobcat" "insutl"))) -(file-dependency/integration/join filenames/dependency-group/lap-syn4 - (append - (filename/append "machines/bobcat" "machin") - (filename/append "base" "utils"))) +(define lapgen-body + (append + (filename/append "back" "lapgn1" "syntax") + (filename/append "machines/bobcat" "rules1" "rules2" "rules3" "rules4"))) -(file-dependency/integration/join (append filenames/dependency-group/lap-syn1 - filenames/dependency-group/lap-syn4) - (filename/append "back-end" "insseq")) +(define assembler-body + (append + (filename/append "back" "bittop") + (filename/append "machines/bobcat" "instr1" "instr2" "instr3" "instr4"))) -(file-dependency/integration/join (append filenames/dependency-group/lap - filenames/dependency-group/lap-syn4) - (filename/append "machines/bobcat" "insutl")) +(file-dependency/integration/join + (append instruction-base + lapgen-base + lapgen-body + assembler-base + assembler-body + (filename/append "back" "linear" "syerly")) + instruction-base) + +(file-dependency/integration/join (append lapgen-base lapgen-body) lapgen-base) + +(file-dependency/integration/join (append assembler-base assembler-body) + assembler-base) + +(define-integration-dependencies "back" "lapgn1" "base" "cfg1" "cfg2" "utils") +(define-integration-dependencies "back" "lapgn1" "rtlbase" + "regset" "rgraph" "rtlcfg") +(define-integration-dependencies "back" "lapgn2" "rtlbase" "rtlreg") +(define-integration-dependencies "back" "lapgn3" "rtlbase" "rtlcfg") +(define-integration-dependencies "back" "linear" "base" "cfg1" "cfg2") +(define-integration-dependencies "back" "linear" "rtlbase" "rtlcfg") +(define-integration-dependencies "back" "regmap" "base" "utils") +(define-integration-dependencies "back" "symtab" "base" "utils") +;;;; Expansion Dependencies + (file-dependency/expansion/join - filenames/dependency-group/lap-syn4 + (filename/append "machines/bobcat" + "lapgen" "rules1" "rules2" "rules3" "rules4") '((LAP:SYNTAX-INSTRUCTION (ACCESS LAP:SYNTAX-INSTRUCTION-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE)) @@ -175,36 +413,5 @@ MIT in each case. |# (ACCESS EA-EXTENSION-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE)) (EA-CATEGORIES-EARLY (ACCESS EA-CATEGORIES-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE)))) - -;;;; Syntax dependencies - -(file-dependency/syntax/join - (append (filename/append "base" - "cfg1" "cfg2" "cfg3" "ctypes" "dfg" "dtype1" "dtype2" - "dtype3" "emodel" "infutl" "infgen" "linear" "object" - "pmerly" "queue" "regset" "rgraph" "rtlcfg" "rtlcon" - "rtlexp" "rtlreg" "rtlty1" "rtlty2" "rtypes" "sets" - "toplv1" "toplv2" "toplv3" "utils") - (filename/append "alpha" "declar" "dflow1" "dflow2" "dflow3" "dflow4" - "dflow5" "dflow6" "fggen1" "fggen2") - (filename/append "front-end" - "ralloc" "rcse1" "rcse2" "rcseep" "rcseht" "rcserq" - "rdeath" "rdebug" "rgcomb" "rgpcom" "rgpred" "rgproc" - "rgrval" "rgstmt" "rlife" "rtlgen") - (filename/append "back-end" - "asmmac" "bittop" "bitutl" "insseq" "lapgn1" "lapgn2" - "lapgn3" "regmap" "symtab" "syntax") - (filename/append "machines/bobcat" "dassm1" "dassm2" "dassm3" "insmac" - "machin")) - compiler-syntax-table) - -(file-dependency/syntax/join - (append (filename/append "machines/spectrum" "lapgen") - filenames/dependency-group/lap-syn4) - lap-generator-syntax-table) -(file-dependency/syntax/join - (append (filename/append "machines/bobcat" "insutl" "instr1" "instr2" - "instr3" "instr4") - (filename/append "machines/spectrum" "instrs")) - assembler-syntax-table) \ No newline at end of file +(finish-integration-dependencies!) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/lapgen.scm b/v7/src/compiler/machines/bobcat/lapgen.scm index 0dc50db41..b16a6732e 100644 --- a/v7/src/compiler/machines/bobcat/lapgen.scm +++ b/v7/src/compiler/machines/bobcat/lapgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 1.191 1987/11/25 01:39:12 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/lapgen.scm,v 4.1 1987/12/30 07:05:00 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -191,20 +191,18 @@ MIT in each case. |# (memq (lap:ea-keyword effective-address) '(A D))) (define (indirect-reference! register offset) - (if (= register regnum:frame-pointer) - (offset-reference regnum:stack-pointer (+ offset (frame-pointer-offset))) - (offset-reference - (if (machine-register? register) - register - (or (register-alias register false) - ;; This means that someone has written an address out - ;; to memory, something that should happen only when the - ;; register block spills something. - (begin (warn "Needed to load indirect register!" register) - ;; Should specify preference for ADDRESS but will - ;; accept DATA if no ADDRESS registers available. - (load-alias-register! register 'ADDRESS)))) - offset))) + (offset-reference + (if (machine-register? register) + register + (or (register-alias register false) + ;; This means that someone has written an address out + ;; to memory, something that should happen only when the + ;; register block spills something. + (begin (warn "Needed to load indirect register!" register) + ;; Should specify preference for ADDRESS but will + ;; accept DATA if no ADDRESS registers available. + (load-alias-register! register 'ADDRESS)))) + offset)) (define (coerce->any register) (if (machine-register? register) diff --git a/v7/src/compiler/machines/bobcat/machin.scm b/v7/src/compiler/machines/bobcat/machin.scm index e289c2961..9742b3f8e 100644 --- a/v7/src/compiler/machines/bobcat/machin.scm +++ b/v7/src/compiler/machines/bobcat/machin.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.1 1987/12/04 20:35:52 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/machin.scm,v 4.2 1987/12/30 07:05:19 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -214,7 +214,4 @@ MIT in each case. |# (define lap:make-label-statement) (define lap:make-unconditional-branch) -(define lap:make-entry-point) - -(define special-primitive-handlers - '()) \ No newline at end of file +(define lap:make-entry-point) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index eb85635f4..5fb505d6b 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 1.46 1987/12/04 06:17:32 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.1 1987/12/30 07:05:27 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,8 +36,6 @@ MIT in each case. |# (declare (usual-integrations)) -;(set-working-directory-pathname! "$zcomp") -;(load "base/rcs" system-global-environment) (load "base/pkging.bin" system-global-environment) (in-package compiler-package @@ -45,60 +43,69 @@ MIT in each case. |# (define compiler-system (make-environment (define :name "Liar (Bobcat 68020)") - (define :version 3) - (define :modification 4) + (define :version 4) + (define :modification 1) (define :files) -; (parse-rcs-header -; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.46 1987/12/04 06:17:32 jinx Exp $" -; (lambda (filename version date time zone author state) -; (set! :version (car version)) -; (set! :modification (cadr version)))) - (define :files-lists (list (cons system-global-environment '("base/pbs.bin" ;bit-string read/write syntax + "/scheme/rel5/etc/direct.bin" ;directory reader + "butils.bin" ;system building utilities )) (cons compiler-package - '("base/macros.bin" ;compiler syntax - "base/decls.bin" ;declarations + '("base/switch.bin" ;compiler option switches + "base/macros.bin" ;compiler syntax + "base/hashtb.com" ;hash tables + )) + + (cons decls-package + '("base/decls.com" ;declarations + )) - "base/object.com" ;tagged object support + (cons compiler-package + '("base/object.com" ;tagged object support + "base/enumer.com" ;enumerations "base/queue.com" ;queue abstraction "base/sets.com" ;set abstraction "base/mvalue.com" ;multiple-value support + "base/scode.com" ;SCode abstraction + "base/pmlook.com" ;pattern matcher: lookup + "base/pmpars.com" ;pattern matcher: parser "machines/bobcat/machin.com" ;machine dependent stuff - "base/toplv1.com" ;top level - "base/toplv2.com" - "base/toplv3.com" + "base/toplev.com" ;top level + "base/debug.com" ;debugging support "base/utils.com" ;odds and ends + "base/cfg1.com" ;control flow graph "base/cfg2.com" "base/cfg3.com" - "base/rgraph.com" ;program graph abstraction "base/ctypes.com" ;CFG datatypes - "base/dtype1.com" ;DFG datatypes - "base/dtype2.com" - "base/dtype3.com" - "base/dfg.com" ;data flow graph - "base/rtlty1.com" ;RTL: type definitions - "base/rtlty2.com" - "base/rtlexp.com" ;RTL: expression operations - "base/rtlcon.com" ;RTL: complex constructors - "base/rtlreg.com" ;RTL: registers - "base/rtlcfg.com" ;RTL: CFG types - "base/emodel.com" ;environment model - "base/rtypes.com" ;RTL Registers - "base/regset.com" ;RTL Register Sets - "base/pmlook.com" ;pattern matcher: lookup - "base/pmpars.com" ;pattern matcher: parser + + "base/rvalue.com" ;Right hand values + "base/lvalue.com" ;Left hand values + "base/blocks.com" ;rvalue: blocks + "base/proced.com" ;rvalue: procedures + "base/contin.com" ;rvalue: continuations + + "base/subprb.com" ;subproblem datatype + + "rtlbase/rgraph.com" ;program graph abstraction + "rtlbase/rtlty1.com" ;RTL: type definitions + "rtlbase/rtlty2.com" ;RTL: type definitions + "rtlbase/rtlexp.com" ;RTL: expression operations + "rtlbase/rtlcon.com" ;RTL: complex constructors + "rtlbase/rtlreg.com" ;RTL: registers + "rtlbase/rtlcfg.com" ;RTL: CFG types + "rtlbase/rtlobj.com" ;RTL: CFG objects + "rtlbase/regset.com" ;RTL: register sets + "base/infutl.com" ;utilities for info generation, shared - "back-end/insseq.com" ;lap instruction sequences + "back/insseq.com" ;LAP instruction sequences "machines/bobcat/dassm1.com" ;disassembler - "base/linear.com" ;linearization )) (cons disassembler-package @@ -106,64 +113,73 @@ MIT in each case. |# "machines/bobcat/dassm3.com" )) - (cons converter-package - '("alpha/fggen1.com" ;SCode->flow-graph converter - "alpha/fggen2.com" + (cons fg-generator-package + '("alpha/fggen.com" ;SCode->flow-graph converter "alpha/declar.com" ;Declaration handling )) - (cons dataflow-package - '("alpha/dflow1.com" ;Dataflow analyzer - "alpha/dflow2.com" - "alpha/dflow3.com" - "alpha/dflow4.com" - "alpha/dflow5.com" - "alpha/dflow6.com" + (cons fg-optimizer-package + '("alpha/simapp.com" ;simulate applications + "alpha/outer.com" ;outer analysis + "alpha/folcon.com" ;fold constants + "alpha/operan.com" ;operator analysis + "alpha/closan.com" ;closure analysis + "alpha/blktyp.com" ;environment type assignment + "alpha/contan.com" ;continuation analysis + "alpha/simple.com" ;simplicity analysis + "alpha/order.com" ;subproblem ordering + "alpha/conect.com" ;connectivity analysis + "alpha/desenv.com" ;environment design + "alpha/offset.com" ;compute node offsets )) (cons rtl-generator-package - '("front-end/rtlgen.com" ;RTL generator - "front-end/rgproc.com" ;RTL generator: Procedure Headers - "front-end/rgstmt.com" ;RTL generator: Statements - "front-end/rgpred.com" ;RTL generator: Predicates - "front-end/rgrval.com" ;RTL generator: RValues - "front-end/rgcomb.com" ;RTL generator: Combinations - "front-end/rgpcom.com" ;RTL generator: Primitive open-coding - "machines/bobcat/rgspcm.com" ;RTL generator: primitives treated specially. + '("rtlgen/rtlgen.com" ;RTL generator + "rtlgen/rgproc.com" ;procedure headers + "rtlgen/rgstmt.com" ;statements + "rtlgen/rgrval.com" ;rvalues + "rtlgen/rgcomb.com" ;combinations + "rtlgen/rgretn.com" ;returns + "rtlgen/fndblk.com" ;find blocks and variables + "rtlgen/opncod.com" ;open-coded primitives + "machines/bobcat/rgspcm.com" ;special close-coded primitives + "rtlbase/rtline.com" ;linearizer )) (cons rtl-cse-package - '("front-end/rcse1.com" ;RTL common subexpression eliminator - "front-end/rcse2.com" - "front-end/rcseep.com" ;CSE expression predicates - "front-end/rcseht.com" ;CSE hash table - "front-end/rcserq.com" ;CSE register/quantity abstractions + '("rtlopt/rcse1.com" ;RTL common subexpression eliminator + "rtlopt/rcse2.com" + "rtlopt/rcseep.com" ;CSE expression predicates + "rtlopt/rcseht.com" ;CSE hash table + "rtlopt/rcserq.com" ;CSE register/quantity abstractions + "rtlopt/rcsesr.com" ;CSE stack references )) - (cons rtl-analyzer-package - '("front-end/rlife.com" ;RTL register lifetime analyzer - "front-end/rdeath.com" ;RTL dead code eliminations - "front-end/rdebug.com" ;RTL optimizer debugging output - "front-end/ralloc.com" ;RTL register allocator + (cons rtl-optimizer-package + '("rtlopt/rlife.com" ;RTL register lifetime analyzer + "rtlopt/rdeath.com" ;RTL code compression + "rtlopt/rdebug.com" ;RTL optimizer debugging output + "rtlopt/ralloc.com" ;RTL register allocation )) (cons debugging-information-package - '("base/infgen.com" ;debugging information generation + '("base/infnew.com" ;debugging information generation )) (cons lap-syntax-package - '("back-end/lapgn1.com" ;LAP generator. - "back-end/lapgn2.com" - "back-end/lapgn3.com" - "back-end/regmap.com" ;Hardware register allocator. + '("back/lapgn1.com" ;LAP generator. + "back/lapgn2.com" + "back/lapgn3.com" + "back/regmap.com" ;Hardware register allocator. + "back/linear.com" ;LAP linearizer. "machines/bobcat/lapgen.com" ;code generation rules. "machines/bobcat/rules1.com" "machines/bobcat/rules2.com" "machines/bobcat/rules3.com" "machines/bobcat/rules4.com" - "back-end/syntax.com" ;Generic syntax phase + "back/syntax.com" ;Generic syntax phase "machines/bobcat/coerce.com" ;Coercions: integer -> bit string - "back-end/asmmac.com" ;Macros for hairy syntax + "back/asmmac.com" ;Macros for hairy syntax "machines/bobcat/insmac.com" ;Macros for hairy syntax "machines/bobcat/insutl.com" ;Utilities for instructions "machines/bobcat/instr1.com" ;68000 Effective addressing @@ -174,9 +190,9 @@ MIT in each case. |# (cons bit-package '("machines/bobcat/assmd.com" ;Machine dependent - "back-end/symtab.com" ;Symbol tables - "back-end/bitutl.com" ;Assembly blocks - "back-end/bittop.com" ;Assembler top level + "back/symtab.com" ;Symbol tables + "back/bitutl.com" ;Assembly blocks + "back/bittop.com" ;Assembler top level )) )) @@ -188,5 +204,5 @@ MIT in each case. |# (for-each (lambda (name) (local-assignment system-global-environment name (lexical-reference compiler-package name))) - '(COMPILE-BIN-FILE COMPILE-PROCEDURE COMPILER:RESET!)) -(toggle-gc-notification!) \ No newline at end of file + '(COMPILE-BIN-FILE COMPILE-PROCEDURE COMPILER:RESET! + COMPILER:WRITE-LAP-FILE)) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rgspcm.scm b/v7/src/compiler/machines/bobcat/rgspcm.scm index ce737833c..eecaf7380 100644 --- a/v7/src/compiler/machines/bobcat/rgspcm.scm +++ b/v7/src/compiler/machines/bobcat/rgspcm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rgspcm.scm,v 1.1 1987/09/03 05:13:59 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rgspcm.scm,v 4.1 1987/12/30 07:05:38 cph Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,26 +36,37 @@ MIT in each case. |# (declare (usual-integrations)) -(define (define-standard-special-handler &prim &prim-name) - (define-special-primitive-handler &prim - (lambda (combination prefix continuation) - (lambda (number-pushed) - (rtl:make-invocation:special-primitive - &prim-name - (1+ number-pushed) - (prefix combination number-pushed) - continuation))))) - -(let-syntax ((primitive (macro (name) (make-primitive-procedure name)))) - (define-standard-special-handler (primitive &+) '&+) - (define-standard-special-handler (primitive &-) '&-) - (define-standard-special-handler (primitive &*) '&*) - (define-standard-special-handler (primitive &/) '&/) - (define-standard-special-handler (primitive &=) '&=) - (define-standard-special-handler (primitive &<) '&<) - (define-standard-special-handler (primitive &>) '&>) - (define-standard-special-handler 1+ '1+) - (define-standard-special-handler -1+ '-1+) - (define-standard-special-handler zero? 'zero?) - (define-standard-special-handler positive? 'positive?) - (define-standard-special-handler negative? 'negative?)) +(define (define-special-primitive-handler name handler) + (let ((primitive (make-primitive-procedure name true))) + (let ((entry (assq primitive special-primitive-handlers))) + (if entry + (set-cdr! entry handler) + (set! special-primitive-handlers + (cons (cons primitive handler) + special-primitive-handlers))))) + name) + +(define (special-primitive-handler primitive) + (let ((entry (assq primitive special-primitive-handlers))) + (and entry + (cdr entry)))) + +(define special-primitive-handlers + '()) + +(define (define-special-primitive/standard primitive) + (define-special-primitive-handler primitive + rtl:make-invocation:special-primitive)) + +(define-special-primitive/standard '&+) +(define-special-primitive/standard '&-) +(define-special-primitive/standard '&*) +(define-special-primitive/standard '&/) +(define-special-primitive/standard '&=) +(define-special-primitive/standard '&<) +(define-special-primitive/standard '&>) +(define-special-primitive/standard '1+) +(define-special-primitive/standard '-1+) +(define-special-primitive/standard 'zero?) +(define-special-primitive/standard 'positive?) +(define-special-primitive/standard 'negative?) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules1.scm b/v7/src/compiler/machines/bobcat/rules1.scm index 4551ebdcc..e6766126f 100644 --- a/v7/src/compiler/machines/bobcat/rules1.scm +++ b/v7/src/compiler/machines/bobcat/rules1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 1.8 1987/11/18 22:32:07 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules1.scm,v 4.1 1987/12/30 07:05:45 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,20 +38,57 @@ MIT in each case. |# ;;;; Transfers to Registers -;;; All assignments to pseudo registers are required to delete the -;;; dead registers BEFORE performing the assignment. This is because -;;; the register being assigned may be PSEUDO-REGISTER=? to one of the -;;; dead registers, and thus would be flushed if the deletions -;;; happened after the assignment. +(define-rule statement + (ASSIGN (REGISTER 15) (REGISTER (? source))) + (LAP (MOV L ,(coerce->any source) (A 7)))) (define-rule statement - (ASSIGN (REGISTER 12) (REGISTER 15)) - (enable-frame-pointer-offset! 0) - (LAP)) + (ASSIGN (REGISTER 15) (OFFSET-ADDRESS (REGISTER (? source)) (? offset))) + (QUALIFIER (pseudo-register? source)) + (LAP (LEA ,(indirect-reference! source offset) (A 7)))) (define-rule statement (ASSIGN (REGISTER 15) (OFFSET-ADDRESS (REGISTER 15) (? n))) - (decrement-frame-pointer-offset! n (increment-anl 7 n))) + (increment-anl 7 n)) + +(define-rule statement + (ASSIGN (REGISTER 12) (REGISTER 15)) + (LAP (MOV L (A 7) (A 4)))) + +(define-rule statement + (ASSIGN (REGISTER 12) (OFFSET-ADDRESS (REGISTER 15) (? offset))) + (LAP (LEA (@AO 7 ,(* 4 offset)) (A 4)))) + +;;; The following rule always occurs immediately after an instruction +;;; of the form +;;; +;;; (ASSIGN (REGISTER (? source)) (POST-INCREMENT (REGISTER 15) 1)) +;;; +;;; in which case it could be implemented very efficiently using the +;;; sequence +;;; +;;; (LAP (CLR (@A 7)) (MOV L (@A+ 7) (A 4))) +;;; +;;; but unfortunately we have no mechanism to take advantage of this. + +(define-rule statement + (ASSIGN (REGISTER 12) (OBJECT->ADDRESS (REGISTER (? source)))) + (QUALIFIER (pseudo-register? source)) + (if (and (dead-register? source) + (register-has-alias? source 'DATA)) + (let ((source (register-reference (register-alias source 'DATA)))) + (LAP (AND L ,mask-reference ,source) + (MOV L ,source (A 4)))) + (let ((temp (reference-temporary-register! 'DATA))) + (LAP (MOV L ,(coerce->any source) ,temp) + (AND L ,mask-reference ,temp) + (MOV L ,temp (A 4)))))) + +;;; All assignments to pseudo registers are required to delete the +;;; dead registers BEFORE performing the assignment. This is because +;;; the register being assigned may be PSEUDO-REGISTER=? to one of the +;;; dead registers, and thus would be flushed if the deletions +;;; happened after the assignment. (define-rule statement (ASSIGN (REGISTER (? target)) (OFFSET-ADDRESS (REGISTER 15) (? n))) @@ -60,11 +97,6 @@ MIT in each case. |# (LEA (@AO 7 ,(* 4 n)) ,(reference-assignment-alias! target 'ADDRESS)))) -(define-rule statement - (ASSIGN (REGISTER 15) (REGISTER (? source))) - (disable-frame-pointer-offset! - (LAP (MOV L ,(coerce->any source) (A 7))))) - (define-rule statement (ASSIGN (REGISTER (? target)) (CONSTANT (? source))) (QUALIFIER (pseudo-register? target)) @@ -119,7 +151,6 @@ MIT in each case. |# (define-rule statement (ASSIGN (REGISTER (? target)) (POST-INCREMENT (REGISTER 15) 1)) (QUALIFIER (pseudo-register? target)) - (record-pop!) (delete-dead-registers!) (LAP (MOV L (@A+ 7) @@ -162,7 +193,6 @@ MIT in each case. |# (define-rule statement (ASSIGN (OFFSET (REGISTER (? a)) (? n)) (POST-INCREMENT (REGISTER 15) 1)) - (record-pop!) (LAP (MOV L (@A+ 7) ,(indirect-reference! a n)))) @@ -204,7 +234,7 @@ MIT in each case. |# (ASSIGN (POST-INCREMENT (REGISTER 13) 1) (ENTRY:PROCEDURE (? label))) (let ((temporary (register-reference (allocate-temporary-register! 'ADDRESS)))) - (LAP (LEA (@PCR ,(procedure-external-label (label->procedure label))) + (LAP (LEA (@PCR ,(rtl-procedure/external-label (label->object label))) ,temporary) (MOV L ,temporary (@A+ 5)) (MOV B (& ,(ucode-type compiled-expression)) (@AO 5 -4))))) @@ -213,46 +243,27 @@ MIT in each case. |# (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONSTANT (? object))) - (record-push! - (LAP ,(load-constant object (INST-EA (@-A 7)))))) + (LAP ,(load-constant object (INST-EA (@-A 7))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (UNASSIGNED)) - (record-push! - (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@-A 7)))))) + (LAP ,(load-non-pointer (ucode-type unassigned) 0 (INST-EA (@-A 7))))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (REGISTER (? r))) - (record-push! - (if (= r regnum:frame-pointer) - (LAP (PEA ,(offset-reference regnum:stack-pointer - (frame-pointer-offset))) - (MOV B (& ,(ucode-type stack-environment)) (@A 7))) - (LAP (MOV L ,(coerce->any r) (@-A 7)))))) + (LAP (MOV L ,(coerce->any r) (@-A 7)))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (CONS-POINTER (CONSTANT (? type)) (REGISTER (? r)))) - (record-push! - (LAP (MOV L ,(coerce->any r) (@-A 7)) - (MOV B (& ,type) (@A 7))))) + (LAP (MOV L ,(coerce->any r) (@-A 7)) + (MOV B (& ,type) (@A 7)))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (OFFSET (REGISTER (? r)) (? n))) - (record-push! - (LAP (MOV L ,(indirect-reference! r n) (@-A 7))))) - -(define-rule statement - (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) - (OFFSET-ADDRESS (REGISTER 12) (? n))) - (record-push! - (LAP (PEA ,(offset-reference regnum:stack-pointer - (+ n (frame-pointer-offset)))) - (MOV B (& ,(ucode-type stack-environment)) (@A 7))))) + (LAP (MOV L ,(indirect-reference! r n) (@-A 7)))) (define-rule statement (ASSIGN (PRE-INCREMENT (REGISTER 15) -1) (ENTRY:CONTINUATION (? label))) - (record-continuation-frame-pointer-offset! label) - (record-push! - (LAP (PEA (@PCR ,label)) - (MOV B (& ,(ucode-type compiler-return-address)) (@A 7))))) + (LAP (PEA (@PCR ,label)) + (MOV B (& ,(ucode-type compiler-return-address)) (@A 7)))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules2.scm b/v7/src/compiler/machines/bobcat/rules2.scm index 9dec03bb9..725b1e29c 100644 --- a/v7/src/compiler/machines/bobcat/rules2.scm +++ b/v7/src/compiler/machines/bobcat/rules2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 1.3 1987/07/27 23:19:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules2.scm,v 4.1 1987/12/30 07:05:55 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -172,12 +172,10 @@ MIT in each case. |# (define-rule predicate (EQ-TEST (POST-INCREMENT (REGISTER 15) 1) (REGISTER (? register))) - (record-pop!) (eq-test/register*memory register (INST-EA (@A+ 7)))) (define-rule predicate (EQ-TEST (REGISTER (? register)) (POST-INCREMENT (REGISTER 15) 1)) - (record-pop!) (eq-test/register*memory register (INST-EA (@A+ 7)))) (define-rule predicate diff --git a/v7/src/compiler/machines/bobcat/rules3.scm b/v7/src/compiler/machines/bobcat/rules3.scm index 494970c33..4a2d4bb08 100644 --- a/v7/src/compiler/machines/bobcat/rules3.scm +++ b/v7/src/compiler/machines/bobcat/rules3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 1.18 1987/12/04 11:56:07 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules3.scm,v 4.1 1987/12/30 07:06:03 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,128 +36,97 @@ MIT in each case. |# (declare (usual-integrations)) -(define-rule statement - (RETURN) - (disable-frame-pointer-offset! - (LAP ,@(clear-map!) - (CLR B (@A 7)) - (RTS)))) - ;;;; Invocations (define-rule statement - (INVOCATION:APPLY (? frame-size) (? prefix) (? continuation)) - (disable-frame-pointer-offset! - (LAP ,@(generate-invocation-prefix prefix '()) - ,(load-dnw frame-size 0) - (JMP ,entry:compiler-apply)))) + (POP-RETURN) + (LAP ,@(clear-map!) + (CLR B (@A 7)) + (RTS))) (define-rule statement - (INVOCATION:JUMP (? n) - (APPLY-CLOSURE (? frame-size) (? receiver-offset)) - (? continuation) (? label)) - (disable-frame-pointer-offset! - (LAP ,@(clear-map!) - ,@(apply-closure-sequence frame-size receiver-offset label)))) + (INVOCATION:APPLY (? frame-size) (? continuation)) + (LAP ,@(clear-map!) + ,(load-dnw frame-size 0) + (JMP ,entry:compiler-apply))) (define-rule statement - (INVOCATION:JUMP (? n) - (APPLY-STACK (? frame-size) (? receiver-offset) - (? n-levels)) - (? continuation) (? label)) - (disable-frame-pointer-offset! - (LAP ,@(clear-map!) - ,@(apply-stack-sequence frame-size receiver-offset n-levels label)))) + (INVOCATION:JUMP (? frame-size) (? continuation) (? label)) + (LAP ,@(clear-map!) + (BRA (@PCR ,label)))) (define-rule statement - (INVOCATION:JUMP (? frame-size) (? prefix) (? continuation) (? label)) - (QUALIFIER (not (memq (car prefix) '(APPLY-CLOSURE APPLY-STACK)))) - (disable-frame-pointer-offset! - (LAP ,@(generate-invocation-prefix prefix '()) - (BRA (@PCR ,label))))) + (INVOCATION:LEXPR (? number-pushed) (? continuation) (? label)) + (LAP ,@(clear-map!) + ,(load-dnw number-pushed 0) + (BRA (@PCR ,label)))) (define-rule statement - (INVOCATION:LEXPR (? number-pushed) (? prefix) (? continuation) - (? label)) - (disable-frame-pointer-offset! - (LAP ,@(generate-invocation-prefix prefix '()) - ,(load-dnw number-pushed 0) - (BRA (@PCR ,label))))) - -(define-rule statement - (INVOCATION:CACHE-REFERENCE (? frame-size) (? prefix) (? continuation) - (? extension)) - (disable-frame-pointer-offset! - (let ((set-extension (expression->machine-register! extension a3))) - (delete-dead-registers!) - (LAP ,@set-extension - ,@(generate-invocation-prefix prefix (list a3)) - ,(load-dnw frame-size 0) - (LEA (@PCR ,*block-start-label*) (A 1)) - (JMP ,entry:compiler-cache-reference-apply))))) + (INVOCATION:CACHE-REFERENCE (? frame-size) (? continuation) (? extension)) + (let ((set-extension (expression->machine-register! extension a3))) + (delete-dead-registers!) + (LAP ,@set-extension + ,@(clear-map!) + ,(load-dnw frame-size 0) + (LEA (@PCR ,*block-start-label*) (A 1)) + (JMP ,entry:compiler-cache-reference-apply)))) (define-rule statement - (INVOCATION:LOOKUP (? frame-size) (? prefix) (? continuation) - (? environment) (? name)) - (disable-frame-pointer-offset! - (let ((set-environment (expression->machine-register! environment d4))) - (delete-dead-registers!) - (LAP ,@set-environment - ,@(generate-invocation-prefix prefix (list d4)) - ,(load-constant name (INST-EA (D 5))) - ,(load-dnw frame-size 0) - (JMP ,entry:compiler-lookup-apply))))) + (INVOCATION:LOOKUP (? frame-size) (? continuation) (? environment) (? name)) + (let ((set-environment (expression->machine-register! environment d4))) + (delete-dead-registers!) + (LAP ,@set-environment + ,@(clear-map!) + ,(load-constant name (INST-EA (D 5))) + ,(load-dnw frame-size 0) + (JMP ,entry:compiler-lookup-apply)))) (define-rule statement - (INVOCATION:UUO-LINK (? frame-size) (? prefix) (? continuation) (? name)) - (disable-frame-pointer-offset! - (LAP ,@(generate-invocation-prefix prefix '()) - ,(load-dnw frame-size 0) - (MOV L (@PCR ,(free-uuo-link-label name)) (D 1)) - (MOV L (D 1) (@-A 7)) - (AND L (D 7) (D 1)) - (MOV L (D 1) (A 1)) - (MOV L (@A 1) (D 1)) - (AND L (D 7) (D 1)) - (MOV L (D 1) (A 0)) - (JMP (@A 0))))) + (INVOCATION:UUO-LINK (? frame-size) (? continuation) (? name)) + (LAP ,@(clear-map!) + ,(load-dnw frame-size 0) + (MOV L (@PCR ,(free-uuo-link-label name)) (D 1)) + (MOV L (D 1) (@-A 7)) + (AND L (D 7) (D 1)) + (MOV L (D 1) (A 1)) + (MOV L (@A 1) (D 1)) + (AND L (D 7) (D 1)) + (MOV L (D 1) (A 0)) + (JMP (@A 0)))) (define-rule statement - (INVOCATION:PRIMITIVE (? frame-size) (? prefix) (? continuation) - (? primitive)) - (disable-frame-pointer-offset! - (LAP ,@(generate-invocation-prefix prefix '()) - ,@(if (eq? primitive compiled-error-procedure) - (LAP ,(load-dnw frame-size 0) - (JMP ,entry:compiler-error)) - (let ((arity (primitive-procedure-arity primitive))) - (cond ((not (negative? arity)) - (LAP (MOV L (@PCR ,(constant->label primitive)) (D 6)) - (JMP ,entry:compiler-primitive-apply))) - ((= arity -1) - (LAP (MOV L (& ,frame-size) ,reg:lexpr-primitive-arity) - (MOV L (@PCR ,(constant->label primitive)) (D 6)) - (JMP ,entry:compiler-primitive-apply))) - (else - ;; Unknown primitive arity. Go through apply. - (LAP ,(load-dnw frame-size 0) - (MOV L (@PCR ,(constant->label primitive)) (@-A 7)) - (JMP ,entry:compiler-apply))))))))) + (INVOCATION:PRIMITIVE (? frame-size) (? continuation) (? primitive)) + (LAP ,@(clear-map!) + ,@(if (eq? primitive compiled-error-procedure) + (LAP ,(load-dnw frame-size 0) + (JMP ,entry:compiler-error)) + (let ((arity (primitive-procedure-arity primitive))) + (cond ((not (negative? arity)) + (LAP (MOV L (@PCR ,(constant->label primitive)) (D 6)) + (JMP ,entry:compiler-primitive-apply))) + ((= arity -1) + (LAP (MOV L (& ,frame-size) ,reg:lexpr-primitive-arity) + (MOV L (@PCR ,(constant->label primitive)) (D 6)) + (JMP ,entry:compiler-primitive-apply))) + (else + ;; Unknown primitive arity. Go through apply. + (LAP ,(load-dnw frame-size 0) + (MOV L (@PCR ,(constant->label primitive)) (@-A 7)) + (JMP ,entry:compiler-apply)))))))) (let-syntax ((define-special-primitive-invocation (macro (name) `(define-rule statement - (INVOCATION:SPECIAL-PRIMITIVE ,name (? frame-size) - (? prefix) (? continuation)) - (disable-frame-pointer-offset! - ,(list 'LAP - (list 'UNQUOTE-SPLICING - '(generate-invocation-prefix prefix '())) - (list 'JMP - (list 'UNQUOTE - (symbol-append 'ENTRY:COMPILER- name))))))))) - + (INVOCATION:SPECIAL-PRIMITIVE + (? frame-size) + (? continuation) + ,(make-primitive-procedure name true)) + ,(list 'LAP + (list 'UNQUOTE-SPLICING '(clear-map!)) + (list 'JMP + (list 'UNQUOTE + (symbol-append 'ENTRY:COMPILER- name)))))))) (define-special-primitive-invocation &+) (define-special-primitive-invocation &-) (define-special-primitive-invocation &*) @@ -171,90 +140,103 @@ MIT in each case. |# (define-special-primitive-invocation positive?) (define-special-primitive-invocation negative?)) -(define (generate-invocation-prefix prefix needed-registers) - (let ((clear-map (clear-map!))) - (need-registers! needed-registers) - (LAP ,@clear-map - ,@(case (car prefix) - ((NULL) '()) - ((MOVE-FRAME-UP) - (apply generate-invocation-prefix:move-frame-up (cdr prefix))) - ((APPLY-CLOSURE) - (apply generate-invocation-prefix:apply-closure (cdr prefix))) - ((APPLY-STACK) - (apply generate-invocation-prefix:apply-stack (cdr prefix))) - (else - (error "bad prefix type" prefix)))))) +;;;; Invocation Prefixes -(define (generate-invocation-prefix:apply-closure frame-size receiver-offset) - (let ((label (generate-label))) - (LAP ,@(apply-closure-sequence frame-size receiver-offset label) - (LABEL ,label)))) +(define-rule statement + (INVOCATION-PREFIX:MOVE-FRAME-UP 0 (REGISTER 15)) + (LAP)) -(define (generate-invocation-prefix:apply-stack frame-size receiver-offset - n-levels) - (let ((label (generate-label))) - (LAP ,@(apply-stack-sequence frame-size receiver-offset n-levels label) - (LABEL ,label)))) - -(define (generate-invocation-prefix:move-frame-up frame-size how-far) - (cond ((zero? how-far) - (LAP)) - ((zero? frame-size) - (increment-anl 7 how-far)) - ((= frame-size 1) - (LAP (MOV L (@A+ 7) ,(offset-reference a7 (-1+ how-far))) - ,@(increment-anl 7 (-1+ how-far)))) - ((= frame-size 2) - (if (= how-far 1) - (LAP (MOV L (@AO 7 4) (@AO 7 8)) - (MOV L (@A+ 7) (@A 7))) - (let ((i (lambda () - (INST (MOV L (@A+ 7) - ,(offset-reference a7 (-1+ how-far))))))) - (LAP ,(i) - ,(i) - ,@(increment-anl 7 (- how-far 2)))))) - (else - (let ((temp-0 (allocate-temporary-register! 'ADDRESS)) - (temp-1 (allocate-temporary-register! 'ADDRESS))) - (LAP (LEA ,(offset-reference a7 frame-size) - ,(register-reference temp-0)) - (LEA ,(offset-reference a7 (+ frame-size how-far)) - ,(register-reference temp-1)) - ,@(generate-n-times - frame-size 5 - (lambda () - (INST (MOV L - (@-A ,(- temp-0 8)) - (@-A ,(- temp-1 8))))) - (lambda (generator) - (generator (allocate-temporary-register! 'DATA)))) - (MOV L ,(register-reference temp-1) (A 7))))))) +(define-rule statement + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) + (OFFSET-ADDRESS (REGISTER 15) (? offset))) + (let ((how-far (- offset frame-size))) + (cond ((zero? how-far) + (LAP)) + ((zero? frame-size) + (increment-anl 7 how-far)) + ((= frame-size 1) + (LAP (MOV L (@A+ 7) ,(offset-reference a7 (-1+ how-far))) + ,@(increment-anl 7 (-1+ how-far)))) + ((= frame-size 2) + (if (= how-far 1) + (LAP (MOV L (@AO 7 4) (@AO 7 8)) + (MOV L (@A+ 7) (@A 7))) + (let ((i (lambda () + (INST (MOV L (@A+ 7) + ,(offset-reference a7 (-1+ how-far))))))) + (LAP ,(i) + ,(i) + ,@(increment-anl 7 (- how-far 2)))))) + (else + (generate/move-frame-up frame-size (offset-reference a7 offset)))))) + +(define-rule statement + (INVOCATION-PREFIX:MOVE-FRAME-UP (? frame-size) + (OFFSET-ADDRESS (REGISTER (? base)) + (? offset))) + (QUALIFIER (pseudo-register? base)) + (generate/move-frame-up frame-size (indirect-reference! base offset))) -;;; This is invoked by the top level of the LAP GENERATOR. +(define-rule statement + (INVOCATION-PREFIX:DYNAMIC-LINK 0 (REGISTER 15) (REGISTER 12)) + (LAP)) -(define generate/quotation-header - (let () - (define (declare-constants constants code) - (define (inner constants) - (if (null? constants) - code - (let ((entry (car constants))) - (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry)) - ,@(inner (cdr constants)))))) - (inner constants)) +(define-rule statement + (INVOCATION-PREFIX:DYNAMIC-LINK (? frame-size) + (OFFSET-ADDRESS (REGISTER (? base)) + (? offset)) + (REGISTER 12)) + (let ((label (generate-label)) + (temp (allocate-temporary-register! 'ADDRESS))) + (let ((temp-ref (register-reference temp))) + (LAP (LEA ,(indirect-reference! base offset) ,temp-ref) + (CMP L ,temp-ref (A 4)) + (B HS B (@PCR ,label)) + (MOV L (A 4) ,temp-ref) + (LABEL ,label) + ,@(generate/move-frame-up* frame-size temp))))) - (define (declare-references references entry:single entry:multiple) - (if (null? references) - (LAP) - (LAP (LEA (@PCR ,(cdar references)) (A 1)) - ,@(if (null? (cdr references)) - (LAP (JSR ,entry:single)) - (LAP ,(load-dnw (length references) 1) - (JSR ,entry:multiple))) - ,@(make-external-label (generate-label))))) +(define (generate/move-frame-up frame-size destination) + (let ((temp (allocate-temporary-register! 'ADDRESS))) + (LAP (LEA ,destination ,(register-reference temp)) + ,@(generate/move-frame-up* frame-size temp)))) + +(define (generate/move-frame-up* frame-size destination) + (let ((temp (allocate-temporary-register! 'ADDRESS))) + (LAP (LEA ,(offset-reference a7 frame-size) ,(register-reference temp)) + ,@(generate-n-times + frame-size 5 + (lambda () + (INST (MOV L + (@-A ,(- temp 8)) + (@-A ,(- destination 8))))) + (lambda (generator) + (generator (allocate-temporary-register! 'DATA)))) + (MOV L ,(register-reference destination) (A 7))))) +;;;; Entry Headers + +(define generate/quotation-header + ;; This is invoked by the top level of the LAP generator. + (let ((declare-constants + (lambda (constants code) + (define (inner constants) + (if (null? constants) + code + (let ((entry (car constants))) + (LAP (SCHEME-OBJECT ,(cdr entry) ,(car entry)) + ,@(inner (cdr constants)))))) + (inner constants))) + (declare-references + (lambda (references entry:single entry:multiple) + (if (null? references) + (LAP) + (LAP (LEA (@PCR ,(cdar references)) (A 1)) + ,@(if (null? (cdr references)) + (LAP (JSR ,entry:single)) + (LAP ,(load-dnw (length references) 1) + (JSR ,entry:multiple))) + ,@(make-external-label (generate-label))))))) (lambda (block-label constants references assignments uuo-links) (declare-constants uuo-links (declare-constants references @@ -286,8 +268,6 @@ MIT in each case. |# entry:compiler-uuo-link entry:compiler-uuo-link-multiple)))))))))))) -;;;; Procedure/Continuation Entries - ;;; The following calls MUST appear as the first thing at the entry ;;; point of a procedure. They assume that the register map is clear ;;; and that no register contains anything of value. @@ -299,11 +279,10 @@ MIT in each case. |# (define-rule statement (PROCEDURE-HEAP-CHECK (? label)) - (disable-frame-pointer-offset! - (let ((gc-label (generate-label))) - (LAP ,@(procedure-header (label->procedure label) gc-label) - (CMP L ,reg:compiled-memtop (A 5)) - (B GE B (@PCR ,gc-label)))))) + (let ((gc-label (generate-label))) + (LAP ,@(procedure-header (label->object label) gc-label) + (CMP L ,reg:compiled-memtop (A 5)) + (B GE B (@PCR ,gc-label))))) ;;; Note: do not change the MOVE.W in the setup-lexpr call to a MOVEQ. ;;; The setup-lexpr code assumes a fixed calling sequence to compute @@ -313,21 +292,18 @@ MIT in each case. |# (define-rule statement (SETUP-LEXPR (? label)) - (disable-frame-pointer-offset! - (let ((procedure (label->procedure label))) - (LAP ,@(procedure-header procedure false) - (MOV W - (& ,(+ (procedure-required procedure) - (procedure-optional procedure) - (if (procedure/closure? procedure) 1 0))) - (D 1)) - (MOVEQ (& ,(if (procedure-rest procedure) 1 0)) (D 2)) - (JSR ,entry:compiler-setup-lexpr))))) + (let ((procedure (label->object label))) + (LAP ,@(procedure-header procedure false) + (MOV W + (& ,(+ (rtl-procedure/n-required procedure) + (rtl-procedure/n-optional procedure) + (if (rtl-procedure/closure? procedure) 1 0))) + (D 1)) + (MOVEQ (& ,(if (rtl-procedure/rest? procedure) 1 0)) (D 2)) + (JSR ,entry:compiler-setup-lexpr)))) (define-rule statement (CONTINUATION-HEAP-CHECK (? internal-label)) - (enable-frame-pointer-offset! - (continuation-frame-pointer-offset (label->continuation internal-label))) (let ((gc-label (generate-label))) (LAP (LABEL ,gc-label) (JSR ,entry:compiler-interrupt-continuation) @@ -336,19 +312,19 @@ MIT in each case. |# (B GE B (@PCR ,gc-label))))) (define (procedure-header procedure gc-label) - (let ((internal-label (procedure-label procedure)) - (external-label (procedure-external-label procedure))) - (LAP ,@(case (procedure-name procedure) ;really `procedure/type'. + (let ((internal-label (rtl-procedure/label procedure)) + (external-label (rtl-procedure/external-label procedure))) + (LAP ,@(case (rtl-procedure/type procedure) ((IC) (LAP (ENTRY-POINT ,external-label) (EQUATE ,external-label ,internal-label))) ((CLOSURE) - (let ((required (1+ (procedure-required procedure))) - (optional (procedure-optional procedure))) + (let ((required (1+ (rtl-procedure/n-required procedure))) + (optional (rtl-procedure/n-optional procedure))) (LAP (ENTRY-POINT ,external-label) ,@(make-external-label external-label) ,(test-dnw required 0) - ,@(cond ((procedure-rest procedure) + ,@(cond ((rtl-procedure/rest? procedure) (LAP (B GE B (@PCR ,internal-label)))) ((zero? optional) (LAP (B EQ B (@PCR ,internal-label)))) @@ -370,4 +346,4 @@ MIT in each case. |# (set! compiler:external-labels (cons label compiler:external-labels)) (LAP (BLOCK-OFFSET ,label) - (LABEL ,label))) + (LABEL ,label))) \ No newline at end of file diff --git a/v7/src/compiler/machines/bobcat/rules4.scm b/v7/src/compiler/machines/bobcat/rules4.scm index 8756b74b3..4e4c58ea9 100644 --- a/v7/src/compiler/machines/bobcat/rules4.scm +++ b/v7/src/compiler/machines/bobcat/rules4.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 1.4 1987/08/07 22:52:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/rules4.scm,v 4.1 1987/12/30 07:06:20 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -66,27 +66,25 @@ MIT in each case. |# (define-rule statement (INTERPRETER-CALL:ENCLOSE (? number-pushed)) - (decrement-frame-pointer-offset! - number-pushed - (LAP (MOV L (A 5) ,reg:enclose-result) - (MOV B (& ,(ucode-type vector)) ,reg:enclose-result) - ,(load-non-pointer (ucode-type manifest-vector) number-pushed - (INST-EA (@A+ 5))) - - ,@(generate-n-times - number-pushed 5 - (lambda () (INST (MOV L (@A+ 7) (@A+ 5)))) - (lambda (generator) - (generator (allocate-temporary-register! 'DATA))))) - #| Alternate sequence which minimizes code size. ; - DO NOT USE THIS! The `clear-registers!' call does not distinguish between - registers containing objects and registers containing unboxed things, and - as a result can write unboxed stuff to memory. - (LAP ,@(clear-registers! a0 a1 d0) - (MOV W (& ,number-pushed) (D 0)) - (JSR ,entry:compiler-enclose)) - |# - )) + (LAP (MOV L (A 5) ,reg:enclose-result) + (MOV B (& ,(ucode-type vector)) ,reg:enclose-result) + ,(load-non-pointer (ucode-type manifest-vector) number-pushed + (INST-EA (@A+ 5))) + + ,@(generate-n-times + number-pushed 5 + (lambda () (INST (MOV L (@A+ 7) (@A+ 5)))) + (lambda (generator) + (generator (allocate-temporary-register! 'DATA))))) + #| Alternate sequence which minimizes code size. ; + DO NOT USE THIS! The `clear-registers!' call does not distinguish between + registers containing objects and registers containing unboxed things, and + as a result can write unboxed stuff to memory. + (LAP ,@(clear-registers! a0 a1 d0) + (MOV W (& ,number-pushed) (D 0)) + (JSR ,entry:compiler-enclose)) + |# + ) (define-rule statement (INTERPRETER-CALL:DEFINE (? environment) (? name) (? value)) @@ -181,49 +179,4 @@ MIT in each case. |# (LAP ,@set-extension ,@clear-map (JSR ,entry:compiler-unassigned?-trap) - ,@(make-external-label (generate-label)))))) - -;;;; Poppers - -(define-rule statement - (MESSAGE-RECEIVER:CLOSURE (? frame-size)) - (record-push! - (LAP (MOV L (& ,(* frame-size 4)) (@-A 7))))) - -(define-rule statement - (MESSAGE-RECEIVER:STACK (? frame-size)) - (record-push! - (LAP (MOV L - (& ,(+ #x00100000 (* frame-size 4))) - (@-A 7))))) - -(define-rule statement - (MESSAGE-RECEIVER:SUBPROBLEM (? label)) - (record-continuation-frame-pointer-offset! label) - (increment-frame-pointer-offset! - 2 - (LAP (PEA (@PCR ,label)) - (MOV B (& ,type-code:return-address) (@A 7)) - (MOV L (& #x00200000) (@-A 7))))) - -(define (apply-closure-sequence frame-size receiver-offset label) - (LAP ,(load-dnw frame-size 1) - (LEA (@AO 7 ,(* (+ receiver-offset (frame-pointer-offset)) 4)) - (A 0)) - (LEA (@PCR ,label) (A 1)) - (JMP ,popper:apply-closure))) - -(define (apply-stack-sequence frame-size receiver-offset n-levels label) - (LAP (MOVEQ (& ,n-levels) (D 0)) - ,(load-dnw frame-size 1) - (LEA (@AO 7 ,(* (+ receiver-offset (frame-pointer-offset)) 4)) - (A 0)) - (LEA (@PCR ,label) (A 1)) - (JMP ,popper:apply-stack))) - -(define-rule statement - (MESSAGE-SENDER:VALUE (? receiver-offset)) - (disable-frame-pointer-offset! - (LAP ,@(clear-map!) - ,@(increment-anl 7 (+ receiver-offset (frame-pointer-offset))) - (JMP ,popper:value)))) \ No newline at end of file + ,@(make-external-label (generate-label)))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlcfg.scm b/v7/src/compiler/rtlbase/rtlcfg.scm index 58e0027e9..05cf31f52 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 4.1 1987/12/04 20:17:27 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 4.2 1987/12/30 07:07:18 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -39,17 +39,17 @@ MIT in each case. |# (define-snode sblock) (define-pnode pblock) -(define-vector-slots bblock 5 +(define-vector-slots bblock 6 instructions - (live-at-entry register-map) + live-at-entry live-at-exit - (new-live-at-exit frame-pointer-offset) + (new-live-at-exit register-map) label) (define (make-sblock instructions) (make-pnode sblock-tag instructions false false false false)) -(define-vector-slots pblock 10 +(define-vector-slots pblock 11 consequent-lap-generator alternative-lap-generator) @@ -74,8 +74,10 @@ MIT in each case. |# (lambda (bblock) (descriptor-list bblock instructions + live-at-entry + live-at-exit register-map - frame-pointer-offset)))) + label)))) (set-vector-tag-description! sblock-tag (lambda (sblock) @@ -90,7 +92,7 @@ MIT in each case. |# consequent-lap-generator alternative-lap-generator))))) -(define (rinst-dead-register? rinst register) +(define-integrable (rinst-dead-register? rinst register) (memq register (rinst-dead-registers rinst))) (package (bblock-compress!) @@ -159,4 +161,17 @@ MIT in each case. |# (snode-delete! bblock) (set-rgraph-bblocks! *current-rgraph* (delq! bblock - (rgraph-bblocks *current-rgraph*))))))) \ No newline at end of file + (rgraph-bblocks *current-rgraph*))))))) + +(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))))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlcon.scm b/v7/src/compiler/rtlbase/rtlcon.scm index 8f30fb765..874ef5aa2 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 4.1 1987/12/04 20:17:34 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcon.scm,v 4.2 1987/12/30 07:07:25 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -81,28 +81,25 @@ MIT in each case. |# (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-push-link) + (rtl:make-push + (rtl:make-cons-pointer (rtl:make-constant (ucode-type stack-environment)) + (rtl:make-fetch register:dynamic-link)))) (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))))) + (rtl:make-assignment register:dynamic-link + (rtl:make-object->address (stack-pop-address)))) + +(define (rtl:make-stack-pointer->link) + (rtl:make-assignment register:dynamic-link + (rtl:make-fetch register:stack-pointer))) + +(define (rtl:make-link->stack-pointer) + (rtl:make-assignment register:stack-pointer + (rtl:make-fetch register:dynamic-link))) ;;; Interpreter Calls diff --git a/v7/src/compiler/rtlbase/rtline.scm b/v7/src/compiler/rtlbase/rtline.scm index 1df57e123..bb76c8f50 100644 --- a/v7/src/compiler/rtlbase/rtline.scm +++ b/v7/src/compiler/rtlbase/rtline.scm @@ -1,6 +1,6 @@ #| -*-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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtline.scm,v 4.2 1987/12/30 07:07:37 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -32,7 +32,7 @@ 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 +;;;; RTL linearizer (declare (usual-integrations)) @@ -43,8 +43,6 @@ MIT in each case. |# ;;; 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) @@ -96,21 +94,6 @@ MIT in each case. |# (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 index fe2fdbc8f..49910469a 100644 --- a/v7/src/compiler/rtlbase/rtlobj.scm +++ b/v7/src/compiler/rtlbase/rtlobj.scm @@ -1,6 +1,6 @@ #| -*-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 $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlobj.scm,v 4.2 1987/12/30 07:07:44 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -60,8 +60,8 @@ MIT in each case. |# (define-structure (rtl-procedure (conc-name rtl-procedure/) (constructor make-rtl-procedure - (rgraph label entry-edge n-required n-optional - rest? closure?)) + (rgraph label entry-edge name n-required + n-optional rest? closure? type)) (print-procedure (standard-unparser 'RTL-PROCEDURE (lambda (procedure) @@ -69,10 +69,13 @@ MIT in each case. |# (rgraph false read-only true) (label false read-only true) (entry-edge false read-only true) + (name 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)) + (closure? false read-only true) + (type false read-only true) + (%external-label false)) (set-type-object-description! rtl-procedure @@ -80,13 +83,23 @@ MIT in each case. |# `((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/NAME ,(rtl-procedure/name 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))))) + (RTL-PROCEDURE/CLOSURE? ,(rtl-procedure/closure? procedure)) + (RTL-PROCEDURE/TYPE ,(rtl-procedure/type procedure)) + (RTL-PROCEDURE/%EXTERNAL-LABEL + ,(rtl-procedure/%external-label procedure))))) (define-integrable (rtl-procedure/entry-node procedure) (edge-right-node (rtl-procedure/entry-edge procedure))) + +(define (rtl-procedure/external-label procedure) + (or (rtl-procedure/%external-label procedure) + (let ((label (generate-label (rtl-procedure/name procedure)))) + (set-rtl-procedure/%external-label! procedure label) + label))) (define-structure (rtl-continuation (conc-name rtl-continuation/) @@ -109,4 +122,26 @@ MIT in each case. |# ,(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 + (edge-right-node (rtl-continuation/entry-edge continuation))) + +(define (make/label->object expression procedures continuations) + (let ((hash-table + (symbol-hash-table/make + (1+ (+ (length procedures) (length continuations)))))) + (symbol-hash-table/insert! hash-table + (rtl-expr/label expression) + expression) (for-each (lambda (procedure) + (symbol-hash-table/insert! hash-table + (rtl-procedure/label procedure) + procedure)) + procedures) + (for-each (lambda (continuation) + (symbol-hash-table/insert! hash-table + (rtl-continuation/label continuation) + continuation)) + continuations) + (make/label->object* hash-table))) + +(define (make/label->object* hash-table) + (lambda (label) + (symbol-hash-table/lookup hash-table label))) \ No newline at end of file diff --git a/v7/src/compiler/rtlbase/rtlreg.scm b/v7/src/compiler/rtlbase/rtlreg.scm index 5d70f08f3..ee22fbb1f 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 4.1 1987/12/04 20:18:13 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlreg.scm,v 4.2 1987/12/30 07:07:50 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,15 +38,14 @@ MIT in each case. |# (define *machine-register-map*) -(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 (initialize-machine-register-map!) + (set! *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))) (define-integrable (rtl:make-machine-register n) (vector-ref *machine-register-map* n)) diff --git a/v7/src/compiler/rtlbase/rtlty1.scm b/v7/src/compiler/rtlbase/rtlty1.scm index fc5f835c7..0a7067cf7 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 4.1 1987/12/04 20:18:20 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlty1.scm,v 4.2 1987/12/30 07:07:57 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -88,4 +88,5 @@ MIT in each case. |# (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 +(define-rtl-statement invocation-prefix:dynamic-link rtl: frame-size locative + register) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/fndblk.scm b/v7/src/compiler/rtlgen/fndblk.scm index 06ca71688..f1faa5662 100644 --- a/v7/src/compiler/rtlgen/fndblk.scm +++ b/v7/src/compiler/rtlgen/fndblk.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.1 1987/12/04 20:30:26 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/fndblk.scm,v 4.2 1987/12/30 07:09:45 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -37,32 +37,53 @@ MIT in each case. |# (declare (usual-integrations)) (define (find-variable start-block variable offset if-compiler if-ic if-cached) - (find-block/variable start-block variable offset - (lambda (offset-locative) - (lambda (block locative) - (if-compiler - (let ((locative - (offset-locative locative (variable-offset block variable)))) + (if (variable/value-variable? variable) + (if-compiler + (let ((continuation (block-procedure start-block))) + (if (continuation/always-known-operator? continuation) + (continuation/register continuation) + register:value))) + (find-variable-internal start-block variable offset + (lambda (locative) + (if-compiler (if (variable-in-cell? variable) (rtl:make-fetch locative) - locative))))) - (lambda (block locative) - (cond ((variable-in-known-location? start-block variable) - (if-compiler - (rtl:locative-offset locative (variable-offset block variable)))) - ((ic-block/use-lookup? block) - (if-ic locative (variable-name variable))) - (else - (if-cached (variable-name variable))))))) + locative))) + (lambda (block locative) + (cond ((variable-in-known-location? start-block variable) + (if-compiler + (rtl:locative-offset locative + (variable-offset block variable)))) + ((ic-block/use-lookup? block) + (if-ic locative (variable-name variable))) + (else + (if-cached (variable-name variable)))))))) (define (find-closure-variable block variable offset) - (find-block/variable block variable offset - (lambda (offset-locative) - (lambda (block locative) - (offset-locative locative (variable-offset block variable)))) + (find-variable-internal block variable offset + identity-procedure (lambda (block locative) (error "Closure variable in IC frame" variable)))) +(define (find-variable-internal block variable offset if-compiler if-ic) + (let ((rvalue (lvalue-known-value variable))) + (if (and rvalue + (rvalue/procedure? rvalue) + (procedure/closure? rvalue) + (block-ancestor-or-self? block (procedure-block rvalue))) + (if-compiler + (stack-locative-offset + (block-ancestor-or-self->locative block + (procedure-block rvalue) + offset) + (procedure-closure-offset rvalue))) + (find-block/variable block variable offset + (lambda (offset-locative) + (lambda (block locative) + (if-compiler + (offset-locative locative (variable-offset block variable))))) + if-ic)))) + (define (find-definition-variable block lvalue offset) (find-block/variable block lvalue offset (lambda (offset-locative) @@ -75,9 +96,11 @@ MIT in each case. |# (find-block block offset (lambda (block) - (or (memq variable (block-bound-variables block)) - (and (not (block-parent block)) - (memq variable (block-free-variables block))))) + (if block + (or (memq variable (block-bound-variables block)) + (and (not (block-parent block)) + (memq variable (block-free-variables block)))) + (error "Unable to find variable" variable))) (lambda (block locative) ((enumeration-case block-type (block-type block) ((STACK) (if-known stack-locative-offset)) @@ -113,6 +136,12 @@ MIT in each case. |# block* offset) (+ extra (block-frame-size block*))))) + +(define (block-closure-locative block offset) + ;; BLOCK must be the invocation block of a closure. + (stack-locative-offset (rtl:make-fetch register:stack-pointer) + (+ (procedure-closure-offset (block-procedure block)) + offset))) (package (find-block) @@ -150,6 +179,7 @@ MIT in each case. |# (else (error "Illegal procedure parent" parent))) (error "Block has no parent" block)))) ((CLOSURE) closure-block/parent-locative) + ((CONTINUATION) continuation-block/parent-locative) (else (error "Illegal parent block type" block)))) (define (find-block/same-block? block) @@ -163,13 +193,18 @@ MIT in each case. |# locative))) (define (internal-block/parent-locative block locative) - (let ((links (block-stack-link block))) - (if (null? links) - (stack-block/static-link-locative block locative) + (let ((link (block-stack-link block))) + (if link (find-block/specific - (car links) + link (block-parent block) - (stack-locative-offset locative (block-frame-size block)))))) + (stack-locative-offset locative (block-frame-size block))) + (stack-block/static-link-locative block locative)))) + +(define (continuation-block/parent-locative block locative) + (stack-locative-offset locative + (+ (block-frame-size block) + (continuation/offset (block-procedure block))))) (define (stack-block/static-link-locative block locative) (rtl:make-fetch diff --git a/v7/src/compiler/rtlgen/opncod.scm b/v7/src/compiler/rtlgen/opncod.scm index 55b95ae83..b5ea85b39 100644 --- a/v7/src/compiler/rtlgen/opncod.scm +++ b/v7/src/compiler/rtlgen/opncod.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.1 1987/12/04 20:30:30 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/opncod.scm,v 4.2 1987/12/30 07:09:53 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -75,7 +75,7 @@ MIT in each case. |# ;;;; Code Generator -(define-export (combination/inline combination offset) +(define-export (combination/inline combination) (generate/return* (combination/block combination) (combination/continuation combination) (let ((inliner (combination/inliner combination))) @@ -98,7 +98,7 @@ MIT in each case. |# expressions finish)) false))) - offset)) + (node/offset combination))) (define (invoke/effect->effect generator expressions) (generator expressions false)) @@ -188,6 +188,12 @@ MIT in each case. |# ;;;; Open Coders +(define-open-coder/predicate 'NULL? + (lambda (operands) + (return-2 (lambda (expressions finish) + (finish (pcfg-invert (rtl:make-true-test (car expressions))))) + '(0)))) + (let ((open-code/type-test (lambda (type) (lambda (expressions finish) @@ -216,7 +222,7 @@ MIT in each case. |# (define-open-coder/predicate 'EQ? (lambda (operands) (return-2 open-code/eq-test '(0 1))))) - + (let ((open-code/pair-cons (lambda (type) (lambda (expressions finish) @@ -270,7 +276,7 @@ MIT in each case. |# (lambda (operands) (filter/nonnegative-integer (cadr operands) (lambda (index) - (return-2 (open-code/memory-ref index) '(0))))))) + (return-2 (open-code/memory-ref (1+ index)) '(0))))))) (let ((open-code/general-car-cdr (lambda (pattern) @@ -321,7 +327,7 @@ MIT in each case. |# (lambda (operands) (filter/nonnegative-integer (cadr operands) (lambda (index) - (return-2 (open-code/memory-assignment index) '(0 2))))))) + (return-2 (open-code/memory-assignment (1+ index)) '(0 2))))))) ;;; end COMBINATION/INLINE ) \ No newline at end of file diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index a01bb62e4..6277f1157 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.1 1987/12/04 20:30:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 4.2 1987/12/30 07:10:01 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,35 +38,29 @@ MIT in each case. |# (package (generate/combination) -(define (generate/combination combination offset) +(define (generate/combination combination) (if (combination/inline? combination) - (combination/inline combination offset) - (combination/normal combination offset))) + (combination/inline combination) + (combination/normal combination))) -(define (combination/normal combination offset) +(define (combination/normal combination) (let ((block (combination/block combination)) (operator (combination/operator combination)) (frame-size (combination/frame-size combination)) - (continuation (combination/continuation combination))) + (continuation (combination/continuation combination)) + (offset (node/offset combination))) (let ((callee (rvalue-known-value operator))) (let ((finish (lambda (invocation callee-external?) - (if (return-operator/subproblem? continuation) - (invocation operator - offset - frame-size - (continuation/label continuation) - invocation-prefix/null) - (invocation operator - offset - frame-size - false - (generate/invocation-prefix - block - offset - callee - continuation - callee-external?)))))) + (invocation operator + offset + frame-size + (and (return-operator/subproblem? continuation) + (continuation/label continuation)) + (generate/invocation-prefix block + callee + continuation + callee-external?))))) (cond ((not callee) (finish (if (reference? operator) invocation/reference @@ -93,7 +87,7 @@ MIT in each case. |# (define (invocation/jump operator offset frame-size continuation prefix) (let ((callee (rvalue-known-value operator))) (scfg*scfg->scfg! - (prefix frame-size) + (prefix offset frame-size) (if (procedure-inline-code? callee) (generate/procedure-entry/inline callee) (begin @@ -106,10 +100,10 @@ MIT in each case. |# (procedure-label callee))))))) (define (invocation/apply operator offset frame-size continuation prefix) - (invocation/apply* frame-size continuation prefix)) + (invocation/apply* offset frame-size continuation prefix)) -(define (invocation/apply* frame-size continuation prefix) - (scfg*scfg->scfg! (prefix frame-size) +(define (invocation/apply* offset frame-size continuation prefix) + (scfg*scfg->scfg! (prefix offset frame-size) (rtl:make-invocation:apply frame-size continuation))) (define invocation/ic @@ -120,14 +114,9 @@ MIT in each case. |# (define (invocation/primitive operator offset frame-size continuation prefix) (scfg*scfg->scfg! - (prefix frame-size) - (let ((primitive - (let ((primitive (constant-value (rvalue-known-value operator)))) - (if (eq? primitive compiled-error-procedure) - primitive - (primitive-procedure-name primitive))))) - ((if (memq primitive special-primitive-handlers) - rtl:make-invocation:special-primitive + (prefix offset frame-size) + (let ((primitive (constant-value (rvalue-known-value operator)))) + ((or (special-primitive-handler primitive) rtl:make-invocation:primitive) (1+ frame-size) continuation @@ -137,35 +126,37 @@ MIT in each case. |# (define-export (invocation/reference operator offset frame-size continuation prefix) - (let ((block (reference-block operator)) - (variable (reference-lvalue operator))) - (find-variable block variable offset - (lambda (locative) - (scfg*scfg->scfg! - (rtl:make-push (rtl:make-fetch locative)) - (invocation/apply* (1+ frame-size) continuation prefix))) - (lambda (environment name) - (invocation/lookup frame-size - continuation - (prefix frame-size) - environment - (intern-scode-variable! block name))) - (lambda (name) - (if (memq 'UUO-LINK (variable-declarations variable)) - (invocation/uuo-link frame-size - continuation - (prefix frame-size) - name) - (invocation/cache-reference frame-size - continuation - prefix - name)))))) - -(define (invocation/lookup frame-size - continuation - prefix - environment - variable) + (if (reference-to-known-location? operator) + (invocation/apply* offset frame-size continuation prefix) + (let ((block (reference-block operator)) + (variable (reference-lvalue operator))) + (find-variable block variable offset + (lambda (locative) + (scfg*scfg->scfg! + (rtl:make-push (rtl:make-fetch locative)) + (invocation/apply* (1+ offset) + (1+ frame-size) + continuation + prefix))) + (lambda (environment name) + (invocation/lookup frame-size + continuation + (prefix offset frame-size) + environment + (intern-scode-variable! block name))) + (lambda (name) + (if (memq 'UUO-LINK (variable-declarations variable)) + (invocation/uuo-link frame-size + continuation + (prefix offset frame-size) + name) + (invocation/cache-reference offset + frame-size + continuation + prefix + name))))))) + +(define (invocation/lookup frame-size continuation prefix environment variable) (let ((make-invocation (lambda (environment) (expression-simplify-for-statement environment @@ -179,14 +170,14 @@ MIT in each case. |# (scfg-append! (rtl:make-assignment register:environment environment) prefix (make-invocation register:environment))))) - + (define (invocation/uuo-link frame-size continuation prefix name) (scfg*scfg->scfg! prefix (rtl:make-invocation:uuo-link (1+ frame-size) continuation name))) -(define (invocation/cache-reference frame-size continuation prefix name) +(define (invocation/cache-reference offset frame-size continuation prefix name) (let* ((temp (rtl:make-pseudo-register)) (cell (rtl:make-fetch temp)) (contents (rtl:make-fetch cell))) @@ -197,10 +188,13 @@ MIT in each case. |# (n3 (scfg*scfg->scfg! (rtl:make-push contents) - (invocation/apply* (1+ frame-size) continuation prefix))) + (invocation/apply* (1+ offset) + (1+ frame-size) + continuation + prefix))) (n4 (scfg*scfg->scfg! - (prefix frame-size) + (prefix offset frame-size) (expression-simplify-for-statement cell (lambda (cell) (rtl:make-invocation:cache-reference (1+ frame-size) @@ -218,71 +212,96 @@ MIT in each case. |# ;;;; Prefixes -(package (generate/invocation-prefix invocation-prefix/null) +(package (generate/invocation-prefix) (define-export (generate/invocation-prefix block - offset callee continuation callee-external?) - (let ((caller (block-procedure block))) - (cond ((or (not (rvalue/procedure? caller)) - (procedure/ic? caller)) - invocation-prefix/null) - ((procedure/external? caller) - (if callee-external? - (invocation-prefix/move-frame-up block offset block) - invocation-prefix/null)) - (callee-external? - (invocation-prefix/erase-to block - offset - continuation - (stack-block/external-ancestor block))) - (else - (let ((block* (procedure-block callee))) - (cond ((block-child? block block*) - invocation-prefix/null) - ((block-sibling? block block*) - (invocation-prefix/move-frame-up block offset block)) - (else - (invocation-prefix/erase-to - block - offset - continuation - (block-farthest-uncommon-ancestor block block*))))))))) + (prefix-append + (generate/link-prefix block callee continuation callee-external?) + (let ((caller (block-procedure block))) + (cond ((or (return-operator/subproblem? continuation) + (not (rvalue/procedure? caller)) + (procedure/ic? caller)) + prefix/null) + ((procedure/external? caller) + (if callee-external? + (invocation-prefix/move-frame-up block block) + prefix/null)) + (callee-external? + (invocation-prefix/erase-to block + continuation + (stack-block/external-ancestor block))) + (else + (let ((block* (procedure-block callee))) + (if (block-child? block block*) + prefix/null + (invocation-prefix/erase-to block + continuation + (block-farthest-uncommon-ancestor + block + (block-parent block*)))))))))) + +(define (prefix-append prefix prefix*) + (lambda (offset frame-size) + (scfg*scfg->scfg! (prefix offset frame-size) (prefix* offset frame-size)))) -(define (invocation-prefix/erase-to block offset continuation callee-limit) +(define (prefix/null offset frame-size) + (make-null-cfg)) + +(define (generate/link-prefix block callee continuation callee-external?) + (cond ((not (and (not callee-external?) + (internal-block/dynamic-link? (procedure-block callee)))) + prefix/null) + ((return-operator/subproblem? continuation) + link-prefix/subproblem) + ((block/dynamic-link? block) + prefix/null) + (else + (link-prefix/reduction + block + (reduction-continuation/popping-limit continuation))))) + +(define (link-prefix/subproblem offset frame-size) + (rtl:make-assignment + register:dynamic-link + (rtl:make-address + (stack-locative-offset (rtl:make-fetch register:stack-pointer) + frame-size)))) + +(define (link-prefix/reduction block block*) + (lambda (offset frame-size) + (rtl:make-assignment register:dynamic-link + (popping-limit/locative block offset block* 0)))) + +(define (invocation-prefix/erase-to block continuation callee-limit) (let ((popping-limit (reduction-continuation/popping-limit continuation))) (if popping-limit (invocation-prefix/move-frame-up block - offset (if (block-ancestor? callee-limit popping-limit) callee-limit popping-limit)) - (invocation-prefix/dynamic-link - (popping-limit/locative block offset callee-limit 0))))) - -;;; The invocation prefix is always one of the following: - -(define-export (invocation-prefix/null frame-size) - (make-null-cfg)) - -(define (invocation-prefix/move-frame-up block offset block*) - (invocation-prefix/move-frame-up* - (popping-limit/locative block offset block* 0))) + (invocation-prefix/dynamic-link block callee-limit)))) -(define (invocation-prefix/move-frame-up* locative) - (lambda (frame-size) - (expression-simplify-for-statement locative - (lambda (locative) - (rtl:make-invocation-prefix:move-frame-up frame-size locative))))) +(define (invocation-prefix/move-frame-up block block*) + (lambda (offset frame-size) + (expression-simplify-for-statement + (popping-limit/locative block offset block* 0) + (lambda (locative) + (rtl:make-invocation-prefix:move-frame-up frame-size locative))))) -(define (invocation-prefix/dynamic-link locative) - (lambda (frame-size) - (expression-simplify-for-statement locative - (lambda (locative) - (rtl:make-invocation-prefix:dynamic-link frame-size locative))))) +(define (invocation-prefix/dynamic-link block block*) + (lambda (offset frame-size) + (expression-simplify-for-statement + (popping-limit/locative block offset block* 0) + (lambda (locative) + (expression-simplify-for-statement (interpreter-dynamic-link) + (lambda (dynamic-link) + (rtl:make-invocation-prefix:dynamic-link frame-size + locative + dynamic-link))))))) ;;; end GENERATE/INVOCATION-PREFIX ) diff --git a/v7/src/compiler/rtlgen/rgretn.scm b/v7/src/compiler/rtlgen/rgretn.scm index be67b165e..cfe0d83b5 100644 --- a/v7/src/compiler/rtlgen/rgretn.scm +++ b/v7/src/compiler/rtlgen/rgretn.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.1 1987/12/04 20:31:36 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgretn.scm,v 4.2 1987/12/30 07:10:22 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -36,11 +36,14 @@ MIT in each case. |# (declare (usual-integrations)) -(define (generate/return return offset) +(define (generate/return return) (generate/return* (return/block return) (return/operator return) (trivial-return-operand (return/operand return)) - offset)) + (node/offset return))) + +(define (generate/trivial-return block operator operand offset) + (generate/return* block operator (trivial-return-operand operand) offset)) (define (trivial-return-operand operand) (make-return-operand @@ -74,9 +77,7 @@ MIT in each case. |# continuation) (scfg-append! (if (and continuation (continuation/effect? continuation)) - (scfg*scfg->scfg! - (effect-prefix operand offset) - (rtl:make-assignment register:value (rtl:make-constant false))) + (effect-prefix operand offset) ((return-operand/value-generator operand) offset (lambda (expression) @@ -95,67 +96,64 @@ MIT in each case. |# (scfg-append! (effect-prefix operand offset) (common-prefix block operator offset continuation) - (generate/node/memoize (continuation/entry-node continuation) - (continuation/offset continuation))))) + (generate/node (continuation/entry-node continuation))))) (define-method-table-entries '(REGISTER VALUE) simple-methods (lambda (block operator operand offset continuation) (scfg-append! (if (lvalue-integrated? (continuation/parameter continuation)) (effect-prefix operand offset) - (value-prefix operand offset continuation)) + ((return-operand/value-generator operand) + offset + (lambda (expression) + (rtl:make-assignment (continuation/register continuation) + expression)))) (common-prefix block operator offset continuation) - (generate/node/memoize (continuation/entry-node continuation) - (continuation/offset continuation))))) + (generate/node (continuation/entry-node continuation))))) (define-method-table-entry 'PUSH simple-methods (lambda (block operator operand offset continuation) (scfg*scfg->scfg! (let ((prefix (common-prefix block operator offset continuation))) (if (cfg-null? prefix) - ((return-operand/value-generator operand) - offset - (lambda (expression) - (rtl:make-push expression))) - (scfg-append! - (value-prefix operand offset continuation) - prefix - (rtl:make-push - (rtl:make-fetch (continuation/register continuation)))))) - (generate/node/memoize (continuation/entry-node continuation) - (1+ (continuation/offset continuation)))))) + ((return-operand/value-generator operand) offset rtl:make-push) + (use-temporary-register operand offset prefix rtl:make-push))) + (generate/node (continuation/entry-node continuation))))) (define-method-table-entry 'PREDICATE simple-methods (lambda (block operator operand offset continuation) (let ((node (continuation/entry-node continuation)) - (offset* (continuation/offset continuation)) (value (return-operand/known-value operand)) (prefix (common-prefix block operator offset continuation))) (if value (scfg-append! (effect-prefix operand offset) prefix - (generate/node/memoize (if (and (rvalue/constant? value) - (false? (constant-value value))) - (pnode-alternative node) - (pnode-consequent node)) - offset*)) + (generate/node (if (and (rvalue/constant? value) + (false? (constant-value value))) + (pnode-alternative node) + (pnode-consequent node)))) (let ((finish (lambda (pcfg) (pcfg*scfg->scfg! pcfg - (generate/node/memoize (pnode-consequent node) offset*) - (generate/node/memoize (pnode-alternative node) - offset*))))) + (generate/node (pnode-consequent node)) + (generate/node (pnode-alternative node)))))) (if (cfg-null? prefix) ((return-operand/predicate-generator operand) offset finish) - (scfg-append! - (value-prefix operand offset continuation) - prefix - (finish - (rtl:make-true-test - (rtl:make-fetch - (continuation/register continuation))))))))))) + (use-temporary-register operand offset prefix + (lambda (expression) + (finish (rtl:make-true-test expression)))))))))) + +(define (use-temporary-register operand offset prefix finish) + (let ((register (rtl:make-pseudo-register))) + (scfg-append! + ((return-operand/value-generator operand) + offset + (lambda (expression) + (rtl:make-assignment register expression))) + prefix + (finish (rtl:make-fetch register))))) (define (return-operator/pop-frames block operator offset extra) (if (or (ic-block? block) @@ -169,7 +167,7 @@ MIT in each case. |# popping-limit extra)) (scfg*scfg->scfg! - (rtl:make-pop-link) + (rtl:make-link->stack-pointer) (if (zero? extra) (make-null-cfg) (rtl:make-assignment register:stack-pointer @@ -178,12 +176,6 @@ MIT in each case. |# (rtl:make-fetch register:stack-pointer) extra))))))))) -(define (value-prefix operand offset continuation) - ((return-operand/value-generator operand) - offset - (lambda (expression) - (rtl:make-assignment (continuation/register continuation) expression)))) - (define-integrable (effect-prefix operand offset) ((return-operand/effect-generator operand) offset)) diff --git a/v7/src/compiler/rtlgen/rgrval.scm b/v7/src/compiler/rtlgen/rgrval.scm index c35d8701d..34129d7e8 100644 --- a/v7/src/compiler/rtlgen/rgrval.scm +++ b/v7/src/compiler/rtlgen/rgrval.scm @@ -1,9 +1,9 @@ d3 1 a4 1 -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.1 1987/12/04 20:31:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.2 1987/12/30 07:10:29 cph Exp $ #| -*-Scheme-*- Copyright (c) 1987 Massachusetts Institute of Technology -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.1 1987/12/04 20:31:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgrval.scm,v 4.2 1987/12/30 07:10:29 cph Exp $ Copyright (c) 1988, 1990 Massachusetts Institute of Technology @@ -63,7 +63,7 @@ promotional, or sales literature without prior written consent from (transmit-values expression-value (lambda (prefix expression) (return-2 prefix (transform expression))))) - + result (lambda (constant offset) (generate/constant constant))) @@ -74,49 +74,27 @@ promotional, or sales literature without prior written consent from (lambda (constant) (lambda (block offset) (define-method-table-entry 'BLOCK rvalue-methods - + block ;; ignored (lambda (reference offset) (let ((block (reference-block reference)) (define-method-table-entry 'REFERENCE rvalue-methods (lambda (reference) - (let ((standard-case - (lambda () - (if (value-variable? lvalue) - (expression-value/simple - (rtl:make-fetch - (let ((continuation (block-procedure block))) - (if (continuation/always-known-operator? continuation) - (continuation/register continuation) - register:value)))) - (find-variable block lvalue offset - (lambda (locative) - (expression-value/simple (rtl:make-fetch locative))) - (lambda (environment name) - (expression-value/temporary - (rtl:make-interpreter-call:lookup - environment - (intern-scode-variable! block name) - safe?) - (rtl:interpreter-call-result:lookup))) - (lambda (name) - (generate/cached-reference name safe?))))))) - (let ((value (lvalue-known-value lvalue))) - (cond ((not value) - (standard-case)) - ((not (rvalue/procedure? value)) - (generate/rvalue* value offset)) - ((and (procedure/closure? value) - (block-ancestor-or-self? block (procedure-block value))) - (expression-value/simple - (rtl:make-fetch - (stack-locative-offset - (block-ancestor-or-self->locative block - (procedure-block value) - offset) - (procedure-closure-offset value))))) - (else - (standard-case)))))))) + (let ((value (lvalue-known-value lvalue))) + (if (and value (not (rvalue/procedure? value))) + (generate/rvalue* value offset) + (find-variable block lvalue offset + (lambda (locative) + (expression-value/simple (rtl:make-fetch locative))) + (lambda (environment name) + (expression-value/temporary + (rtl:make-interpreter-call:lookup + environment + (intern-scode-variable! block name) + safe?) + (rtl:interpreter-call-result:lookup))) + (lambda (name) + (generate/cached-reference name safe?)))))))) (define (generate/cached-reference name safe?) (let ((temp (rtl:make-pseudo-register)) @@ -170,7 +148,7 @@ promotional, or sales literature without prior written consent from (if (not (procedure-virtual-closure? procedure)) (error "Reference to open procedure" procedure)) ;; inside another IC procedure? -(define (make-closure-environment procedure offset) +(define-export (make-closure-environment procedure offset) (let ((block (procedure-closing-block procedure))) (define (make-non-trivial-closure-cons procedure block**) (expression-value/simple (rtl:make-constant false))) @@ -183,29 +161,33 @@ promotional, or sales literature without prior written consent from (closure-ic-locative closure-block block offset))) (rtl:make-constant false)))) ((closure-block? block) - (let ((closure-block (procedure-closure-block procedure))) - (define (loop variables) - (cond ((null? variables) '()) - ((lvalue-integrated? (car variables)) - (loop (cdr variables))) - (else - (cons (rtl:make-push - (rtl:make-fetch - (find-closure-variable closure-block - (car variables) - offset))) - (loop (cdr variables)))))) + (let ((closure-block (procedure-closure-block procedure)) + (entries (block-closure-offsets block))) + (define (loop entries offset) + (let loop + '() + (cons (rtl:make-push + (rtl:make-fetch + (let ((variable (caar entries))) + (if (eq? (lvalue-known-value variable) + (block-procedure closure-block)) + (block-closure-locative closure-block offset) + (find-closure-variable closure-block + variable + offset))))) + (loop (cdr entries) (-1+ offset))))) (let ((pushes - (let ((parent (block-parent block)) - (pushes (loop (block-bound-variables block)))) - (if (and parent (ic-block/use-lookup? parent)) - (cons (rtl:make-push - (closure-ic-locative closure-block - parent - offset)) - pushes) - pushes)))) + (let ((offset (+ offset (length entries)))) + (let ((parent (block-parent block)) + (pushes (loop entries (-1+ offset)))) + (if (and parent (ic-block/use-lookup? parent)) + (cons (rtl:make-push + (closure-ic-locative closure-block + parent + offset)) + pushes) + pushes))))) (expression-value/temporary (scfg*->scfg! (reverse! diff --git a/v7/src/compiler/rtlgen/rgstmt.scm b/v7/src/compiler/rtlgen/rgstmt.scm index cc54b7e13..d05388222 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.1 1987/12/04 20:31:53 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgstmt.scm,v 4.2 1987/12/30 07:10:38 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -38,10 +38,11 @@ MIT in each case. |# ;;;; Assignments -(define (generate/assignment assignment offset) +(define (generate/assignment assignment) (let ((block (assignment-block assignment)) (lvalue (assignment-lvalue assignment)) - (rvalue (assignment-rvalue assignment))) + (rvalue (assignment-rvalue assignment)) + (offset (node/offset assignment))) (if (lvalue-integrated? lvalue) (make-null-cfg) (generate/rvalue rvalue offset scfg*scfg->scfg! @@ -67,6 +68,7 @@ MIT in each case. |# (n3 (rtl:make-unassigned-test contents)) (n4 (rtl:make-assignment cell value)) (n5 (rtl:make-interpreter-call:cache-assignment cell value)) + ;; Copy prevents premature control merge which confuses CSE (n6 (rtl:make-assignment cell value))) (scfg-next-connect! n1 n2) (pcfg-consequent-connect! n2 n3) @@ -78,10 +80,11 @@ MIT in each case. |# (hooks-union (scfg-next-hooks n5) (scfg-next-hooks n6))))))))) -(define (generate/definition definition offset) +(define (generate/definition definition) (let ((block (definition-block definition)) (lvalue (definition-lvalue definition)) - (rvalue (definition-rvalue definition))) + (rvalue (definition-rvalue definition)) + (offset (node/offset definition))) (generate/rvalue rvalue offset scfg*scfg->scfg! (lambda (expression) (transmit-values (find-definition-variable block lvalue offset) @@ -92,34 +95,38 @@ MIT in each case. |# ;;;; Virtual Returns -(define (generate/virtual-return return offset) +(define (generate/virtual-return return) (let ((operator (virtual-return-operator return)) - (operand (virtual-return-operand return))) - (enumeration-case continuation-type (virtual-continuation/type operator) - ((EFFECT) - (return-2 (make-null-cfg) offset)) - ((REGISTER VALUE) - (return-2 (operand->register operand - offset - (virtual-continuation/register operator)) - offset)) - ((PUSH) - (let ((block (virtual-continuation/block operator))) - (cond ((rvalue/block? operand) - (return-2 - (rtl:make-push - (rtl:make-environment - (block-ancestor-or-self->locative block - operand - offset))) - (1+ offset))) - ((rvalue/continuation? operand) - ;; This is a pun set up by the FG generator. - (generate/continuation-cons block operand offset)) - (else - (return-2 (operand->push operand offset) (1+ offset)))))) - (else - (error "Unknown continuation type" return))))) + (operand (virtual-return-operand return)) + (offset (node/offset return))) + (if (virtual-continuation/reified? operator) + (generate/trivial-return (virtual-return-block return) + (virtual-continuation/reification operator) + operand + offset) + (enumeration-case continuation-type + (virtual-continuation/type operator) + ((EFFECT) + (make-null-cfg)) + ((REGISTER VALUE) + (operand->register operand + offset + (virtual-continuation/register operator))) + ((PUSH) + (let ((block (virtual-continuation/block operator))) + (cond ((rvalue/block? operand) + (rtl:make-push + (rtl:make-environment + (block-ancestor-or-self->locative block + operand + offset)))) + ((rvalue/continuation? operand) + ;; This is a pun set up by the FG generator. + (generate/continuation-cons block operand)) + (else + (operand->push operand offset))))) + (else + (error "Unknown continuation type" return)))))) (define (operand->push operand offset) (generate/rvalue operand offset scfg*scfg->scfg! rtl:make-push)) @@ -129,62 +136,50 @@ MIT in each case. |# (lambda (expression) (rtl:make-assignment register expression)))) -(package (generate/continuation-cons) - -(define-export (generate/continuation-cons block continuation offset) - (set-continuation/offset! continuation offset) - (let ((values - (let ((values - (if (continuation/dynamic-link? continuation) - (return-2 (rtl:make-push-link) (1+ offset)) - (return-2 (make-null-cfg) offset)))) - (if (continuation/always-known-operator? continuation) - values - (begin - (enqueue-continuation! continuation) - (push-prefix values - (rtl:make-push-return - (continuation/label continuation)))))))) - (if (ic-block? (continuation/closing-block continuation)) - (push-prefix values - (rtl:make-push (rtl:make-fetch register:environment))) - values))) - -(define (push-prefix values prefix) - (transmit-values values - (lambda (scfg offset) - (return-2 (scfg*scfg->scfg! prefix scfg) (1+ offset))))) - -) - -(define (generate/pop pop offset) +(define (generate/continuation-cons block continuation) + (let ((closing-block (continuation/closing-block continuation))) + (scfg*scfg->scfg! + (if (ic-block? closing-block) + (rtl:make-push (rtl:make-fetch register:environment)) + (make-null-cfg)) + (if (continuation/always-known-operator? continuation) + (make-null-cfg) + (begin + (enqueue-continuation! continuation) + (scfg*scfg->scfg! + (if (and (stack-block? closing-block) + (stack-block/dynamic-link? closing-block)) + (rtl:make-push-link) + (make-null-cfg)) + (rtl:make-push-return (continuation/label continuation)))))))) + +(define (generate/pop pop) (rtl:make-pop (continuation*/register (pop-continuation pop)))) ;;;; Predicates -(define (generate/true-test true-test offset) +(define (generate/true-test true-test) (generate/predicate (true-test-rvalue true-test) (pnode-consequent true-test) (pnode-alternative true-test) - offset)) + (node/offset true-test))) (define (generate/predicate rvalue consequent alternative offset) (if (rvalue/unassigned-test? rvalue) (generate/unassigned-test rvalue consequent alternative offset) (let ((value (rvalue-known-value rvalue))) (if value - (generate/known-predicate value consequent alternative offset) + (generate/known-predicate value consequent alternative) (pcfg*scfg->scfg! (generate/rvalue rvalue offset scfg*pcfg->pcfg! rtl:make-true-test) - (generate/node consequent offset) - (generate/node alternative offset)))))) + (generate/node consequent) + (generate/node alternative)))))) -(define (generate/known-predicate value consequent alternative offset) +(define (generate/known-predicate value consequent alternative) (generate/node (if (and (constant? value) (false? (constant-value value))) alternative - consequent) - offset)) + consequent))) (define (generate/unassigned-test rvalue consequent alternative offset) (let ((block (unassigned-test-block rvalue)) @@ -201,13 +196,13 @@ MIT in each case. |# (rtl:make-true-test (rtl:interpreter-call-result:unassigned?)))) generate/cached-unassigned?) - (generate/node consequent offset) - (generate/node alternative offset))) + (generate/node consequent) + (generate/node alternative))) ((and (rvalue/constant? value) (scode/unassigned-object? (constant-value value))) - (generate/node consequent offset)) + (generate/node consequent)) (else - (generate/node alternative offset)))))) + (generate/node alternative)))))) (define (generate/cached-unassigned? name) (let ((temp (rtl:make-pseudo-register))) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index 1bd43a077..e35ae7d7e 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.1 1987/12/04 20:32:02 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 4.2 1987/12/30 07:10:47 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -39,24 +39,20 @@ MIT in each case. |# (define *generation-queue*) (define *queued-procedures*) (define *queued-continuations*) -(define *memoizations*) (define (generate/top-level expression) - (with-machine-register-map - (lambda () - (fluid-let ((*generation-queue* (make-queue)) - (*queued-procedures* '()) - (*queued-continuations* '()) - (*memoizations* '())) - (set! *rtl-expression* (generate/expression expression)) - (queue-map! *generation-queue* (lambda (thunk) (thunk))) - (set! *rtl-graphs* - (list-transform-positive (reverse! *rtl-graphs*) - (lambda (rgraph) - (not (null? (rgraph-entry-edges rgraph)))))) - (for-each rgraph/compress! *rtl-graphs*) - (set! *rtl-procedures* (reverse! *rtl-procedures*)) - (set! *rtl-continuations* (reverse! *rtl-continuations*)))))) + (fluid-let ((*generation-queue* (make-queue)) + (*queued-procedures* '()) + (*queued-continuations* '())) + (set! *rtl-expression* (generate/expression expression)) + (queue-map! *generation-queue* (lambda (thunk) (thunk))) + (set! *rtl-graphs* + (list-transform-positive (reverse! *rtl-graphs*) + (lambda (rgraph) + (not (null? (rgraph-entry-edges rgraph)))))) + (for-each rgraph/compress! *rtl-graphs*) + (set! *rtl-procedures* (reverse! *rtl-procedures*)) + (set! *rtl-continuations* (reverse! *rtl-continuations*)))) (define (enqueue-procedure! procedure) (if (not (memq procedure *queued-procedures*)) @@ -81,58 +77,62 @@ MIT in each case. |# (define (generate/expression expression) (transmit-values - (generate/rgraph - (lambda () - (generate/node (expression-entry-node expression) 0))) + (generate/rgraph (expression-entry-node expression) generate/node) (lambda (rgraph entry-edge) (make-rtl-expr rgraph (expression-label expression) entry-edge)))) (define (generate/procedure procedure) (transmit-values (generate/rgraph - (lambda () + (procedure-entry-node procedure) + (lambda (node) (generate/procedure-header procedure - (generate/node (procedure-entry-node procedure) 0) + (generate/node node) false))) (lambda (rgraph entry-edge) (make-rtl-procedure rgraph (procedure-label procedure) entry-edge - (length (procedure-original-required procedure)) + (procedure-name procedure) + (length (cdr (procedure-original-required procedure))) (length (procedure-original-optional procedure)) (and (procedure-original-rest procedure) true) - (and (procedure/closure? procedure) true))))) + (and (procedure/closure? procedure) true) + (procedure/type procedure))))) (define (generate/procedure-entry/inline procedure) (generate/procedure-header procedure - (generate/node (procedure-entry-node procedure) 0) + (generate/node (procedure-entry-node procedure)) true)) (define (generate/continuation continuation) - (let ((label (continuation/label continuation)) - (node (continuation/entry-node continuation)) - (offset (continuation/offset continuation))) + (let ((label (continuation/label continuation))) (transmit-values (generate/rgraph - (lambda () + (continuation/entry-node continuation) + (lambda (node) (scfg-append! (rtl:make-continuation-heap-check label) (generate/continuation-entry/ic-block continuation) + (if (block/dynamic-link? + (continuation/closing-block continuation)) + (rtl:make-pop-link) + (make-null-cfg)) (enumeration-case continuation-type (continuation/type continuation) ((PUSH) (scfg*scfg->scfg! (rtl:make-push (rtl:make-fetch register:value)) - (generate/node node (1+ offset)))) + (generate/node node))) ((REGISTER) (scfg*scfg->scfg! (rtl:make-assignment (continuation/register continuation) (rtl:make-fetch register:value)) - (generate/node node offset))) + (generate/node node))) (else - (generate/node node offset)))))) + (generate/node node)))))) (lambda (rgraph entry-edge) (make-rtl-continuation rgraph label entry-edge))))) @@ -141,56 +141,68 @@ MIT in each case. |# (rtl:make-pop register:environment) (make-null-cfg))) -(define (generate/node/memoize node offset) - (let ((entry (assq node *memoizations*))) - (cond ((not entry) - (let ((entry (cons node false))) - (set! *memoizations* (cons entry *memoizations*)) - (let ((result (generate/node node offset))) - (set-cdr! entry (cons offset result)) - result))) - ((not (cdr entry)) - (error "GENERATE/NODE/MEMOIZE: loop" node)) - ((not (= offset (cadr entry))) - (error "GENERATE/NODE/MEMOIZE: mismatched offsets" node)) - (else (cddr entry))))) - -(define (generate/node node offset) +(define (generate/node node) + (let ((memoization (cfg-node-get node memoization-tag))) + (cond ((not memoization) + (cfg-node-put! node memoization-tag loop-memoization-marker) + (let ((result (generate/node/no-memoize node))) + (cfg-node-put! node memoization-tag result) + result)) + ((eq? memoization loop-memoization-marker) + (error "GENERATE/NODE: loop" node)) + (else memoization)))) + +(define memoization-tag + "rtlgen-memoization-tag") + +(define loop-memoization-marker + "rtlgen-loop-memoization-marker") + +(define (generate/node/no-memoize node) (cfg-node-case (tagged-vector/tag node) ((APPLICATION) (if (snode-next node) (error "Application node has next" node)) (case (application-type node) - ((COMBINATION) (generate/combination node offset)) - ((RETURN) (generate/return node offset)) + ((COMBINATION) (generate/combination node)) + ((RETURN) (generate/return node)) (else (error "Unknown application type" node)))) ((VIRTUAL-RETURN) - (transmit-values (generate/virtual-return node offset) - (lambda (scfg offset) - (scfg*scfg->scfg! scfg - (generate/node (snode-next node) offset))))) + (scfg*scfg->scfg! (generate/virtual-return node) + (generate/node (snode-next node)))) ((POP) - (scfg*scfg->scfg! (generate/pop node offset) - (generate/node (snode-next node) offset))) + (scfg*scfg->scfg! (generate/pop node) + (generate/node (snode-next node)))) ((ASSIGNMENT) - (scfg*scfg->scfg! (generate/assignment node offset) - (generate/node (snode-next node) offset))) + (scfg*scfg->scfg! (generate/assignment node) + (generate/node (snode-next node)))) ((DEFINITION) - (scfg*scfg->scfg! (generate/definition node offset) - (generate/node (snode-next node) offset))) + (scfg*scfg->scfg! (generate/definition node) + (generate/node (snode-next node)))) ((TRUE-TEST) - (generate/true-test node offset)))) + (generate/true-test node)) + ((FG-NOOP) + (generate/node (snode-next node))))) -(define (generate/rgraph generator) - (let ((rgraph (make-rgraph number-of-machine-registers))) - (set! *rtl-graphs* (cons rgraph *rtl-graphs*)) +(define (generate/rgraph node generator) + (let ((rgraph (node->rgraph node))) (let ((entry-node (cfg-entry-node (fluid-let ((*current-rgraph* rgraph)) - (with-new-node-marks generator))))) + (with-new-node-marks (lambda () (generator node))))))) (add-rgraph-entry-node! rgraph entry-node) (return-2 rgraph (node->edge entry-node))))) +(define (node->rgraph node) + (let ((color + (or (node/subgraph-color node) + (error "node lacking subgraph color" node)))) + (or (subgraph-color/rgraph color) + (let ((rgraph (make-rgraph number-of-machine-registers))) + (set-subgraph-color/rgraph! color rgraph) + (set! *rtl-graphs* (cons rgraph *rtl-graphs*)) + rgraph)))) + (define (rgraph/compress! rgraph) (with-new-node-marks (lambda () diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index 87a1be6ea..6378ba243 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.1 1987/12/08 13:55:03 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 4.2 1987/12/30 07:13:08 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -148,7 +148,16 @@ MIT in each case. |# (lambda (volatile? insert-source!) (let ((address (rtl:assign-address statement))) (cond ((rtl:register? address) - (register-expression-invalidate! address) + (if (interpreter-stack-pointer? address) + (let ((expression (rtl:assign-expression statement))) + (if (and (rtl:offset? expression) + (interpreter-stack-pointer? + (rtl:offset-register expression))) + (stack-pointer-adjust! (rtl:offset-number expression)) + (begin + (stack-invalidate!) + (stack-pointer-invalidate!)))) + (register-expression-invalidate! address)) (if (and (not volatile?) (not (rtl:machine-register-expression? (rtl:assign-expression statement)))) @@ -243,14 +252,6 @@ MIT in each case. |# (define-cse-method 'INVOCATION:SPECIAL-PRIMITIVE method/noop) (define-cse-method 'INVOCATION:UUO-LINK method/noop) -(define (method/trash-stack statement) - (stack-invalidate!) - (stack-pointer-invalidate!)) - -(define-cse-method 'SETUP-LEXPR method/trash-stack) -(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP method/trash-stack) -(define-cse-method 'INVOCATION-PREFIX:DYNAMIC-LINK method/trash-stack) - (define-cse-method 'INTERPRETER-CALL:ENCLOSE (lambda (statement) (let ((n (rtl:interpreter-call:enclose-size statement))) @@ -272,6 +273,33 @@ MIT in each case. |# statement trivial-action))) +(define-cse-method 'SETUP-LEXPR + (lambda (statement) + (stack-invalidate!) + (stack-pointer-invalidate!))) + +(define-cse-method 'INVOCATION-PREFIX:MOVE-FRAME-UP + (lambda (statement) + (expression-replace! rtl:invocation-prefix:move-frame-up-locative + rtl:set-invocation-prefix:move-frame-up-locative! + statement + trivial-action) + (stack-invalidate!) + (stack-pointer-invalidate!))) + +(define-cse-method 'INVOCATION-PREFIX:DYNAMIC-LINK + (lambda (statement) + (expression-replace! rtl:invocation-prefix:dynamic-link-locative + rtl:set-invocation-prefix:dynamic-link-locative! + statement + trivial-action) + (expression-replace! rtl:invocation-prefix:dynamic-link-register + rtl:set-invocation-prefix:dynamic-link-register! + statement + trivial-action) + (stack-invalidate!) + (stack-pointer-invalidate!))) + (define (define-lookup-method type get-environment set-environment! register) (define-cse-method type (lambda (statement) diff --git a/v7/src/compiler/rtlopt/rcse2.scm b/v7/src/compiler/rtlopt/rcse2.scm index 9ad3b58ad..590d070b4 100644 --- a/v7/src/compiler/rtlopt/rcse2.scm +++ b/v7/src/compiler/rtlopt/rcse2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.1 1987/12/08 13:55:35 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse2.scm,v 4.2 1987/12/30 07:13:20 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -94,8 +94,13 @@ MIT in each case. |# (define (non-object-invalidate!) (hash-table-delete-class! (lambda (element) - (memq (rtl:expression-type (element-expression element)) - '(OBJECT->ADDRESS OBJECT->DATUM OBJECT->TYPE))))) + (let ((expression (element-expression element))) + (if (rtl:register? expression) + (register-contains-address? (rtl:register-number expression)) + (memq (rtl:expression-type expression) + '(OBJECT->ADDRESS OBJECT->DATUM + OBJECT->TYPE + OFFSET-ADDRESS))))))) (define (element-address-varies? element) (and (element-in-memory? element) diff --git a/v7/src/compiler/rtlopt/rcseht.scm b/v7/src/compiler/rtlopt/rcseht.scm index 3263a5c4e..6dec14e3b 100644 --- a/v7/src/compiler/rtlopt/rcseht.scm +++ b/v7/src/compiler/rtlopt/rcseht.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.1 1987/12/08 13:55:52 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcseht.scm,v 4.2 1987/12/30 07:13:28 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -145,7 +145,7 @@ MIT in each case. |# (define (hash-table-delete-class! predicate) (let table-loop ((i 0)) - (if (< i n-buckets) + (if (< i (hash-table-size)) (let bucket-loop ((element (hash-table-ref i))) (if element (begin (if (predicate element) -- 2.25.1