#| -*-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
(declare (usual-integrations))
\f
-(define lap:syntax-instruction)
-(define instruction-append)
-
(define (instruction-sequence->directives insts)
(if (null? insts)
'()
#| -*-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
(declare (usual-integrations))
\f
(define *block-start-label*)
-(define *continuation-queue*)
(define *entry-bblock*)
(define *current-bblock*)
(define *dead-registers*)
*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))))
+\f
(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)))))
\f
(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)
(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)))
#| -*-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
(define-integrable (set-current-branches! consequent alternative)
(set-pblock-consequent-lap-generator! *current-bblock* consequent)
- (set-pblock-alternative-lap-generator! *current-bblock* alternative))
-\f
-;;;; 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
--- /dev/null
+#| -*-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))
+\f
+(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
#| -*-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
(save-into-home-instruction entry))
(receiver map '()))))
\f
+(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
(register->home-transfer (map-entry:any-alias entry)
(map-entry-home entry)))
\f
+(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?))
+\f
;;;; Map Coercion
;;; These operations generate the instructions to coerce one map into
#| -*-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
(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
#| -*-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
(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
(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
(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))
+\f
+;;;; 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
#| -*-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
(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)))
\f
;;;; 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)))
\f
;;;; Miscellaneous
#| -*-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
(vector-ref pcfg 3))
(define-integrable (make-null-cfg) false)
-(define-integrable cfg-null? false?)
+(define-integrable cfg-null? false?)\f
(define-integrable (snode->scfg snode)
(node->scfg snode set-snode-next-edge!))
(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)))
\f
;;;; Hook Datatype
(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)
(define (hook-connect! hook node)
(create-edge! (hook-node hook) (hook-connect hook) node))
+\f
+;;;; 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)))
+\f
+;;;; 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))))
\f
;;;; CFG Construction
(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*)))))
(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))))))))))))
\f
(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))
(scfg*pcfg->cfg! make-scfg*))
)
-
+\f
(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))
(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))
#| -*-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
(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
(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?)
(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)
#| -*-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
(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
(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)
+\f
(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
#| -*-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
(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))))
+\f
+(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 ()
(newline))
(*show-instruction* rtl))
\f
-(package (show-fg)
+(package (show-fg show-fg-node)
(define *procedure-queue*)
(define *procedures*)
(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)))
((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)
--- /dev/null
+(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
#| -*-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
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 '()))
(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)))))))
#| -*-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
(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))
#| -*-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
(write-string "PROCEDURE ")
(write (procedure-label procedure)))
(begin
- (write-string "CONTINUATION ")
+ (write (procedure-label procedure))
+ (write-string " ")
(write type))))))
(define-integrable (rvalue/procedure? rvalue)
(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)))
\f
;;;; Procedure Types
#| -*-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
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))))
\f
;;;; Absolute variables and combinations
#| -*-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
(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)
#| -*-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
(declare (usual-integrations))
\f
-(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
#| -*-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
(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))
+\f
+(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)))
\f
(define (compile-bin-file input-string #!optional output-string)
(compiler-pathnames input-string
(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)))
(scan-defines scode make-open-block))))
\f
(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))))
-\f
(define (compile-scode scode
#!optional
rtl-output-pathname
(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
-|#
)))
\f
-(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))
-\f
(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)))
\f
(define (phase/fg-generation)
(compiler-phase 'FG-GENERATION
(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*))))
-
+\f
(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*))))
-\f
+
(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*))))
-
+\f
(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*))))))
\f
(define (phase/rtl-generation)
(compiler-phase 'RTL-GENERATION
(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*))))
+\f
+(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*))))))))
+\f
+(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)))))
+\f
+(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
#| -*-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
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)
)
\f
-;;;; 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))
-\f
;;;; Type Codes
(let-syntax ((define-type-code
(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))))
+\f
+(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))))
\f
;;;; Special Compiler Support
#| -*-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
(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!
;; 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)))))
\f
;;;; 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))))
-
+\f
(define-integrable (continuation/effect? continuation)
(continuation/type? continuation continuation-type/effect))
\f
;;;; 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
(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))))
\f
-(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)
(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))
\f
;;;; 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)))
+\f
(define (generate/variable block continuation expression)
(continue/rvalue block
continuation
(search block))
\f
(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
(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
\f
;;;; 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
(generate/expression block continuation (car actions))
(join (generate/subproblem/effect block continuation (car actions))
(loop (cdr actions)))))))
-
+\f
(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))))))))))))))))
+\f
+(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)))))
\f
;;;; 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
(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
(scode/make-conditional predicate
predicate
alternative))))))))
-
+\f
(define (generate/error-combination block continuation expression)
(scode/error-combination-components expression
(lambda (message irritants)
continuation
(scode/make-combination compiled-error-procedure
(cons message irritants))))))
-\f
+
(define (generate/in-package block continuation expression)
(warn "IN-PACKAGE not supported; body will be interpreted" expression)
(scode/in-package-components expression
(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))))
\f
;;;; Dispatcher
#| -*-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
(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)
(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)))))
\f
(define (find-closure-bindings block)
(lambda (free-variables bound-variables)
#| -*-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
(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))))
(define (close-assignment-values! assignment)
(close-rvalue! (assignment-rvalue assignment)
(variable-block (assignment-lvalue assignment))))
-
+\f
(define-integrable (close-rvalue! rvalue binding-block)
(close-values! (rvalue-values rvalue) binding-block))
(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
--- /dev/null
+#| -*-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))
+\f
+(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))))
+\f
+(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
#| -*-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
;;; 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.
;;; 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))
\f
-(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))
\f
-(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
#| -*-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
(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))))
\f
(define (fold-combinations combinations)
--- /dev/null
+#| -*-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))
+\f
+(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))))
+\f
+(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
#| -*-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
(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))
#| -*-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
(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)))))
\f
(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)))
\f
(define (optimized-combination-ordering block operator operands callee)
\f
(define (sort-subproblems/out-of-line subproblems callee)
(transmit-values
- (sort-integrated (procedure-original-required callee)
+ (sort-integrated (cdr (procedure-original-required callee))
subproblems
'()
'())
(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)
#| -*-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
\f
(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))
#| -*-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
(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)))))))
\f
#| -*-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
(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)
#| -*-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
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; 68000 Disassembler
+;;;; Disassembler: User Level
(declare (usual-integrations))
\f
-(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 <head> (delay <tail>))
-
-(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))
+\f
+(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
#| -*-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
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; 68000 Disassembler
+;;;; 68000 Disassembler: Top Level
(declare (usual-integrations))
\f
-(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)))))))
-\f
-(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))))
-\f
-(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)))))
+\f
+(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))
\f
;;;; 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)))
+\f
+(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))))
+\f
+(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)))))
+
+)
\f
-(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))))))
-\f
-(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-info<?))
- *symbol-table))
-
-(define (lookup-label block offset)
- (and (not (unassigned? *symbol-table))
- (let ((label (*symbol-table offset)))
- (and label
- (label-info-name label)))))
-
-(define (dcw? block offset)
- (and (not (unassigned? *symbol-table))
- (let ((label (*symbol-table (+ offset 2))))
- (and label
- (label-info-external? label)
- 'W))))
\ No newline at end of file
+(define (undefined)
+ undefined-instruction)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm3.scm,v 1.1 1987/08/07 17:12:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/dassm3.scm,v 4.1 1987/12/30 07:04:49 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; 68000 Disassembler
+;;;; 68000 Disassembler: Internals
(declare (usual-integrations))
\f
-;;; Insides of the disassembler
-
(define opcode-dispatch
(vector (lambda ()
((vector-ref bit-manipulation/MOVEP/immediate-dispatch
(define (make-fetcher size-in-bits)
(let ((size-in-bytes (quotient size-in-bits 8)))
(lambda ()
- (let ((word (bit-string-allocate size-in-bits)))
- (with-interrupt-mask interrupt-mask-none
- (lambda (old)
- (read-bits! (+ (primitive-datum *block) *current-offset) 0 word)))
+ (let ((word (read-bits *current-offset size-in-bits)))
(set! *current-offset (+ *current-offset size-in-bytes))
word))))
(define get-word (make-fetcher 16))
(define get-longword (make-fetcher 32))
-(define-integrable (extract bit-string start end)
+(declare (integrate-operator extract extract+))
+
+(define (extract bit-string start end)
+ (declare (integrate bit-string start end))
(bit-string->unsigned-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
#| -*-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
(declare (usual-integrations))
\f
-(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))))
+\f
+(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)))))
+\f
+(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)))))
+\f
+(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)
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)))
\f
-;;;; 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)
+\f
+;;;; 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"))
+\f
+(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"))
\f
-;;;; 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")
+\f
+(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")
\f
+;;;; 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))
(ACCESS EA-EXTENSION-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE))
(EA-CATEGORIES-EARLY
(ACCESS EA-CATEGORIES-EXPANDER LAP-SYNTAX-PACKAGE COMPILER-PACKAGE))))
-\f
-;;;; 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
#| -*-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
(memq (lap:ea-keyword effective-address) '(A D)))
\f
(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)
#| -*-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
(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
#| -*-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
(declare (usual-integrations))
\f
-;(set-working-directory-pathname! "$zcomp")
-;(load "base/rcs" system-global-environment)
(load "base/pkging.bin" system-global-environment)
(in-package compiler-package
(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
"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
(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
))
))
(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
#| -*-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
(declare (usual-integrations))
\f
-(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
#| -*-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
\f
;;;; 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))))))
+\f
+;;; 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)))
(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))
(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)
(define-rule statement
(ASSIGN (OFFSET (REGISTER (? a)) (? n))
(POST-INCREMENT (REGISTER 15) 1))
- (record-pop!)
(LAP (MOV L
(@A+ 7)
,(indirect-reference! a n))))
(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)))))
(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
#| -*-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
(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
#| -*-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
(declare (usual-integrations))
\f
-(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)))))
-\f
-(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))))
\f
(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 &*)
(define-special-primitive-invocation positive?)
(define-special-primitive-invocation negative?))
\f
-(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))))
-\f
-(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)))
\f
-;;; 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)))))
\f
+;;;; 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
entry:compiler-uuo-link
entry:compiler-uuo-link-multiple))))))))))))
\f
-;;;; 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.
(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
(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)
(B GE B (@PCR ,gc-label)))))
\f
(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))))
(set! compiler:external-labels
(cons label compiler:external-labels))
(LAP (BLOCK-OFFSET ,label)
- (LABEL ,label)))
+ (LABEL ,label)))
\ No newline at end of file
#| -*-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
(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))
+ |#
+ )
\f
(define-rule statement
(INTERPRETER-CALL:DEFINE (? environment) (? name) (? value))
(LAP ,@set-extension
,@clear-map
(JSR ,entry:compiler-unassigned?-trap)
- ,@(make-external-label (generate-label))))))
-\f
-;;;; 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
#| -*-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
(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)
(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)
consequent-lap-generator
alternative-lap-generator)))))
\f
-(define (rinst-dead-register? rinst register)
+(define-integrable (rinst-dead-register? rinst register)
(memq register (rinst-dead-registers rinst)))
(package (bblock-compress!)
(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
#| -*-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
(rtl:make-cons-pointer (rtl:make-constant (ucode-type stack-environment))
address))
\f
-(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)))
\f
;;; Interpreter Calls
#| -*-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
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Linearizer for CFG
+;;;; RTL linearizer
(declare (usual-integrations))
;;; has already been linearized, that it has a label, since this
;;; implies that it has more than one previous neighbor.
\f
-;;;; RTL linearizer
-
(package (bblock-linearize-rtl)
(define-export (bblock-linearize-rtl bblock)
(bblock-linearize-rtl cn)))))))
)
-\f
-;;;; 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
#| -*-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
(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)
(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
`((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)))
\f
(define-structure (rtl-continuation
(conc-name rtl-continuation/)
,(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)))
+\f
+(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
#| -*-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
\f
(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))
#| -*-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
(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
#| -*-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
(declare (usual-integrations))
\f
(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))))
+\f
(define (find-definition-variable block lvalue offset)
(find-block/variable block lvalue offset
(lambda (offset-locative)
(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))
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)))
\f
(package (find-block)
(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)
locative)))
\f
(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
#| -*-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
\f
;;;; 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)))
expressions
finish))
false)))
- offset))
+ (node/offset combination)))
(define (invoke/effect->effect generator expressions)
(generator expressions false))
\f
;;;; 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)
(define-open-coder/predicate 'EQ?
(lambda (operands)
(return-2 open-code/eq-test '(0 1)))))
-
+\f
(let ((open-code/pair-cons
(lambda (type)
(lambda (expressions finish)
(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)))))))
\f
(let ((open-code/general-car-cdr
(lambda (pattern)
(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
#| -*-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
\f
(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
(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
(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
(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
(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)))))))
+\f
+(define (invocation/lookup frame-size continuation prefix environment variable)
(let ((make-invocation
(lambda (environment)
(expression-simplify-for-statement environment
(scfg-append! (rtl:make-assignment register:environment environment)
prefix
(make-invocation register:environment)))))
-\f
+
(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)))
(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)
\f
;;;; 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))
+\f
+(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))))
+\f
+(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)))))
-\f
-;;; 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
)
#| -*-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
(declare (usual-integrations))
\f
-(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
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)
(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)))))
\f
(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)))))
\f
(define (return-operator/pop-frames block operator offset extra)
(if (or (ic-block? block)
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
(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))
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
(transmit-values expression-value
(lambda (prefix expression)
(return-2 prefix (transform expression)))))
-
+\f
result
(lambda (constant offset)
(generate/constant constant)))
(lambda (constant)
(lambda (block offset)
(define-method-table-entry 'BLOCK rvalue-methods
-\f
+
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?))))))))
\f
(define (generate/cached-reference name safe?)
(let ((temp (rtl:make-pseudo-register))
(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)))
(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!
#| -*-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
\f
;;;; 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!
(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)
(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)
\f
;;;; 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))
(lambda (expression)
(rtl:make-assignment register expression))))
\f
-(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))))
\f
;;;; 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)))
\f
(define (generate/unassigned-test rvalue consequent alternative offset)
(let ((block (unassigned-test-block rvalue))
(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)))
#| -*-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
(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*))
\f
(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))
\f
(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)))))
(rtl:make-pop register:environment)
(make-null-cfg)))
\f
-(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)))))
\f
-(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 ()
#| -*-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
(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))))
(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)))
statement
trivial-action)))
\f
+(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!)))
+\f
(define (define-lookup-method type get-environment set-environment! register)
(define-cse-method type
(lambda (statement)
#| -*-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
(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)
#| -*-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
(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)
projects / mit-scheme.git / commitdiff