#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.40 1987/08/04 06:58:01 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.41 1987/08/07 17:10:54 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define *block-start-label*)
-(define *entry-rnode*)
-(define *current-rnode*)
-(define *dead-registers*)
(define *continuation-queue*)
+(define *entry-bblock*)
+(define *current-bblock*)
+(define *dead-registers*)
(define (generate-bits rgraphs receiver)
(with-new-node-marks
(cgen-entry (continuation-rtl-edge continuation))))))
(define (cgen-entry edge)
- (let ((rnode (edge-right-node edge)))
- (fluid-let ((*entry-rnode* rnode))
- (cgen-rnode rnode))))
+ (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))))))))))
\f
-(define (cgen-rnode rnode)
- (let ((offset (cgen-rnode-1 rnode)))
- (define (cgen-right-node edge)
- (let ((next (edge-next-node edge)))
- (if next
- (begin
- (record-rnode-frame-pointer-offset! next offset)
- (if (node-previous>1? next)
- (let ((snode (statement->snode '(NOOP))))
- (set-rnode-lap! snode
- (clear-map-instructions
- (rnode-register-map rnode)))
- (node-mark! snode)
- (edge-insert-snode! edge snode)))
- (if (not (node-marked? next))
- (cgen-rnode next))))))
- (if (rtl-snode? rnode)
- (cgen-right-node (snode-next-edge rnode))
- (begin (cgen-right-node (pnode-consequent-edge rnode))
- (cgen-right-node (pnode-alternative-edge rnode))))))
-
-(define (cgen-rnode-1 rnode)
+(define (cgen-bblock bblock)
;; This procedure is coded out of line to facilitate debugging.
- (node-mark! rnode)
- ;; LOOP is for easy restart while debugging.
- (let loop ()
- (let ((match-result
- (let ((rule
- (if (eq? (car (rnode-rtl rnode)) 'ASSIGN)
- (assq (caadr (rnode-rtl rnode)) *assign-rules*)
- (assq (car (rnode-rtl rnode)) *cgen-rules*))))
- (and rule
- (pattern-lookup (cdr rule) (rnode-rtl rnode))))))
- (if match-result
- (fluid-let ((*current-rnode* rnode)
- (*dead-registers* (rnode-dead-registers rnode))
- (*register-map* (rnode-input-register-map rnode))
- (*prefix-instructions* '())
- (*needed-registers* '())
- (*frame-pointer-offset*
- (rnode-frame-pointer-offset rnode)))
- (let ((instructions (match-result)))
- (set-rnode-lap! rnode
- (LAP ,@*prefix-instructions* ,@instructions)))
- (delete-dead-registers!)
- (set-rnode-register-map! rnode *register-map*)
- *frame-pointer-offset*)
- (begin (error "CGEN-RNODE: No matching rules" (rnode-rtl rnode))
- (loop))))))
-\f
-(define (rnode-input-register-map rnode)
- (if (or (eq? rnode *entry-rnode*)
- (not (node-previous=1? rnode)))
+ (node-mark! bblock)
+ (fluid-let ((*current-bblock* bblock)
+ (*register-map* (bblock-input-register-map bblock))
+ (*frame-pointer-offset* (bblock-frame-pointer-offset bblock)))
+ (set-bblock-instructions! bblock
+ (let loop ((rinst (bblock-instructions bblock)))
+ (if (rinst-next rinst)
+ (let ((instructions (cgen-rinst rinst)))
+ (LAP ,@instructions
+ ,@(loop (rinst-next rinst))))
+ (cgen-rinst rinst))))
+ (set-bblock-register-map! bblock *register-map*)
+ *frame-pointer-offset*))
+
+(define (cgen-rinst rinst)
+ (let ((rtl (rinst-rtl rinst)))
+ ;; LOOP is for easy restart while debugging.
+ (let loop ()
+ (let ((match-result
+ (let ((rule
+ (if (eq? (car rtl) 'ASSIGN)
+ (assq (caadr rtl) *assign-rules*)
+ (assq (car rtl) *cgen-rules*))))
+ (and rule
+ (pattern-lookup (cdr rule) rtl)))))
+ (if match-result
+ (fluid-let ((*dead-registers* (rinst-dead-registers rinst))
+ (*prefix-instructions* '())
+ (*needed-registers* '()))
+ (let ((instructions (match-result)))
+ (delete-dead-registers!)
+ (LAP ,@*prefix-instructions* ,@instructions)))
+ (begin (error "CGEN-BBLOCK: No matching rules" rtl)
+ (loop)))))))
+
+(define (bblock-input-register-map bblock)
+ (if (or (eq? bblock *entry-bblock*)
+ (not (node-previous=1? bblock)))
(empty-register-map)
- (let ((previous (node-previous-first rnode)))
- (let ((map (rnode-register-map previous)))
- (if (rtl-pnode? previous)
+ (let ((previous (node-previous-first bblock)))
+ (let ((map (bblock-register-map previous)))
+ (if (sblock? previous)
+ map
(delete-pseudo-registers
map
(regset->list
- (regset-difference (bblock-live-at-exit (node-bblock previous))
- (bblock-live-at-entry (node-bblock rnode))))
- (lambda (map aliases) map))
- map)))))
-
+ (regset-difference (bblock-live-at-exit previous)
+ (bblock-live-at-entry bblock)))
+ (lambda (map aliases) map)))))))
+\f
(define *cgen-rules* '())
(define *assign-rules* '())
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 1.2 1987/07/08 22:01:20 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 1.3 1987/08/07 17:11:10 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
label))))
(define-integrable (set-current-branches! consequent alternative)
- (set-rtl-pnode-consequent-lap-generator! *current-rnode* consequent)
- (set-rtl-pnode-alternative-lap-generator! *current-rnode* alternative))
+ (set-pblock-consequent-lap-generator! *current-bblock* consequent)
+ (set-pblock-alternative-lap-generator! *current-bblock* alternative))
\f
;;;; Frame Pointer
*frame-pointer-offset*)
(define (record-continuation-frame-pointer-offset! label)
- (let ((continuation (label->continuation label)))
- (guarantee-frame-pointer-offset!)
- (if (continuation-frame-pointer-offset continuation)
- (if (not (= (continuation-frame-pointer-offset continuation)
- *frame-pointer-offset*))
- (error "Continuation frame-pointer offset mismatch" continuation
- *frame-pointer-offset*))
- (set-continuation-frame-pointer-offset! continuation
- *frame-pointer-offset*))
+ (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-rnode-frame-pointer-offset! rnode offset)
- (if (rnode-frame-pointer-offset rnode)
- (if (not (and offset (= (rnode-frame-pointer-offset rnode) offset)))
- (error "RNode frame-pointer offset mismatch" rnode offset))
- (set-rnode-frame-pointer-offset! rnode offset)))
\ No newline at end of file
+(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
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.149 1987/06/13 21:16:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 1.150 1987/08/07 17:02:34 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define cfg-node-tag (make-vector-tag false 'CFG-NODE))
(define cfg-node? (tagged-vector-subclass-predicate cfg-node-tag))
-(define-vector-slots node 1 generation bblock alist previous-edges)
+(define-vector-slots node 1 generation previous-edges)
(define-vector-method cfg-node-tag ':DESCRIBE
(lambda (node)
- (descriptor-list node generation bblock alist previous-edges)))
+ (descriptor-list node generation previous-edges)))
(define snode-tag (make-vector-tag cfg-node-tag 'SNODE))
(define snode? (tagged-vector-subclass-predicate snode-tag))
-(define-vector-slots snode 5 next-edge)
+(define-vector-slots snode 3 next-edge)
(define (make-snode tag . extra)
- (list->vector (cons* tag false false '() '() false extra)))
+ (list->vector (cons* tag false '() false extra)))
(define-vector-method snode-tag ':DESCRIBE
(lambda (snode)
(define pnode-tag (make-vector-tag cfg-node-tag 'PNODE))
(define pnode? (tagged-vector-subclass-predicate pnode-tag))
-(define-vector-slots pnode 5 consequent-edge alternative-edge)
+(define-vector-slots pnode 3 consequent-edge alternative-edge)
(define (make-pnode tag . extra)
- (list->vector (cons* tag false false '() '() false false extra)))
+ (list->vector (cons* tag false '() false false extra)))
(define-vector-method pnode-tag ':DESCRIBE
(lambda (pnode)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 1.1 1987/06/13 21:16:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 1.2 1987/08/07 17:03:02 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
;;;; Editing
-;;; BBlock information is preserved only for deletions. Doing the
-;;; same for insertions is more difficult and not currently needed.
-
(define (snode-delete! snode)
- (let ((bblock (node-bblock snode)))
- (if (and bblock
- (eq? snode (bblock-exit bblock))
- (not (eq? snode (bblock-entry bblock))))
- (set-bblock-exit! bblock (node-previous-first snode))))
(let ((previous-edges (node-previous-edges snode))
(next-edge (snode-next-edge snode)))
(let ((node (edge-right-node next-edge)))
(define-export (node-mark! node)
(set-node-generation! node *generation*))
-)
-
-(define (node-property-get node key)
- (let ((entry (assq key (node-alist node))))
- (and entry (cdr entry))))
-
-(define (node-property-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 (node-property-remove! node key)
- (set-node-alist! node (del-assq! key (node-alist node))))
-
-(define (node-label node)
- (or (node-labelled? node)
- (let ((label (generate-label)))
- (set-node-label! node label)
- label)))
-
-(define-integrable (node-labelled? node)
- (node-property-get node node-label))
-
-(define-integrable (set-node-label! node label)
- (node-property-put! node node-label label))
\ No newline at end of file
+)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 1.1 1987/06/13 21:16:37 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 1.2 1987/08/07 17:03:15 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(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))))))
\f
;;;; CFG Construction
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.50 1987/08/04 06:54:06 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 1.51 1987/08/07 17:03:32 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define-integrable (combination-compiled-for-value? combination)
(eq? 'VALUE (combination-compilation-type combination)))
\f
-(define-snode continuation rtl-edge label frame-pointer-offset block rgraph)
+(define continuation-tag
+ (make-vector-tag false 'CONTINUATION))
+
+(define continuation?
+ (tagged-vector-predicate continuation-tag))
+
+(define-vector-slots continuation 1
+ rtl-edge
+ label
+ frame-pointer-offset
+ block
+ rgraph)
+
(define *continuations*)
-(define-integrable (make-continuation block rgraph)
+(define (make-continuation block rgraph)
(let ((continuation
- (make-snode continuation-tag
- false
- (generate-label 'CONTINUATION)
- false
- block
- rgraph)))
+ (vector continuation-tag
+ false
+ (generate-label 'CONTINUATION)
+ false
+ block
+ rgraph)))
(set! *continuations* (cons continuation *continuations*))
(set-rgraph-continuations!
rgraph
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.60 1987/08/04 06:54:40 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 1.61 1987/08/07 17:04:30 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define (loop slots n)
(if (null? slots)
'()
- (cons (let ((ref-name (symbol-append class '- (car slots))))
- `(BEGIN
- (DEFINE-INTEGRABLE (,ref-name ,class)
- (VECTOR-REF ,class ,n))
- (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!)
- ,class ,(car slots))
- (VECTOR-SET! ,class ,n ,(car slots)))))
- (loop (cdr slots) (1+ n)))))
+ (let ((make-defs
+ (lambda (slot)
+ (let ((ref-name (symbol-append class '- slot)))
+ `(BEGIN
+ (DEFINE-INTEGRABLE (,ref-name ,class)
+ (VECTOR-REF ,class ,n))
+ (DEFINE-INTEGRABLE (,(symbol-append 'SET- ref-name '!)
+ ,class ,slot)
+ (VECTOR-SET! ,class ,n ,slot))))))
+ (rest (loop (cdr slots) (1+ n))))
+ (if (pair? (car slots))
+ (map* rest make-defs (car slots))
+ (cons (make-defs (car slots)) rest)))))
(if (null? slots)
'*THE-NON-PRINTING-OBJECT*
`(BEGIN ,@(loop slots index)))))
(APPEND!
((VECTOR-TAG-METHOD ,',parent ':DESCRIBE) ,type)
(DESCRIPTOR-LIST ,type ,@slots))))))))))))
- (define-type-definition snode 6)
- (define-type-definition pnode 7)
+ (define-type-definition snode 4)
+ (define-type-definition pnode 5)
(define-type-definition rvalue 1)
(define-type-definition vnode 10))
(let ((rtl-common
(lambda (type prefix components wrap-constructor)
`(BEGIN
- (DEFINE-INTEGRABLE (,(symbol-append prefix 'MAKE- type) ,@components)
+ (DEFINE-INTEGRABLE
+ (,(symbol-append prefix 'MAKE- type) ,@components)
,(wrap-constructor `(LIST ',type ,@components)))
(DEFINE-INTEGRABLE (,(symbol-append 'RTL: type '?) EXPRESSION)
(EQ? (CAR EXPRESSION) ',type))
(syntax-table-define compiler-syntax-table 'DEFINE-RTL-STATEMENT
(macro (type prefix . components)
(rtl-common type prefix components
- (lambda (expression) `(STATEMENT->SCFG ,expression)))))
+ (lambda (expression) `(STATEMENT->SRTL ,expression)))))
(syntax-table-define compiler-syntax-table 'DEFINE-RTL-PREDICATE
(macro (type prefix . components)
(rtl-common type prefix components
- (lambda (expression) `(PREDICATE->PCFG ,expression))))))
+ (lambda (expression) `(PREDICATE->PRTL ,expression))))))
\f
(syntax-table-define compiler-syntax-table 'DEFINE-REGISTER-REFERENCES
(macro (slot)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 1.4 1987/08/04 06:54:16 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/rvalue.scm,v 1.5 1987/08/07 17:03:59 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(edge-right-node (quotation-fg-edge quotation)))
(define-integrable (unset-quotation-fg-entry! quotation)
- (set-quotation-fg-edge! quotation false))
-
-(define-vector-slots rgraph 0
- edge
- n-registers
- continuations
- bblocks
- register-bblock
- register-next-use
- register-n-refs
- register-n-deaths
- register-live-length
- register-crosses-call?
- )
-
-(define-integrable rgraph-register-renumber rgraph-register-bblock)
-(define-integrable set-rgraph-register-renumber! set-rgraph-register-bblock!)
-
-(define *rgraphs*)
-(define *current-rgraph*)
-
-(define (rgraph-allocate)
- (make-vector 10 false))
-
-(define (rgraph-entry-edges rgraph)
- (cons (rgraph-edge rgraph)
- (map continuation-rtl-edge (rgraph-continuations rgraph))))
-
-(define (rgraph-initial-edges rgraph)
- (cons (rgraph-edge rgraph)
- (let loop ((continuations (rgraph-continuations rgraph)))
- (if (null? continuations)
- '()
- (let ((edge (continuation-rtl-edge (car continuations))))
- (if (node-previous=0? (edge-right-node edge))
- (cons edge (loop (cdr continuations)))
- (loop (cdr continuations))))))))
\ No newline at end of file
+ (set-quotation-fg-edge! quotation false))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.20 1987/07/17 19:30:31 mhwu Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.21 1987/08/07 17:03:46 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define filenames/dependency-chain/base
(filename/append "base"
- "object" "cfg1" "cfg2" "cfg3" "ctypes" "dtype1" "dtype2"
- "dtype3" "bblock" "dfg" "rtlty1" "rtlty2" "rtlreg" "rtlcfg"
- "emodel" "rtypes" "regset" "infutl" "infgen"))
+ "object" "cfg1" "cfg2" "cfg3" "rgraph" "ctypes" "dtype1"
+ "dtype2" "dtype3" "bblock" "dfg" "rtlty1" "rtlty2" "rtlreg"
+ "rtlcfg" "emodel" "rtypes" "regset" "infutl" "infgen"))
(define filenames/dependency-chain/rcse
(filename/append "front-end" "rcseht" "rcserq" "rcse1" "rcse2"))
(filename/append "alpha" "declar" "dflow1" "dflow2" "dflow3" "dflow4"
"dflow5" "dflow6" "fggen1" "fggen2")
(filename/append "front-end"
- "ralloc" "rcseep" "rcsesa" "rdeath" "rdebug"
- "rgcomb" "rgpcom" "rgpred" "rgproc" "rgrval"
- "rgstmt" "rlife" "rtlgen")
+ "ralloc" "rcseep" "rdeath" "rdebug" "rgcomb"
+ "rgpcom" "rgpred" "rgproc" "rgrval" "rgstmt" "rlife"
+ "rtlgen")
(filename/append "back-end" "lapgn1" "lapgn2" "lapgn3")))
(define filenames/dependency-chain/bits
(file-dependency/integration/join filenames/dependency-group/base
filenames/dependency-chain/base)
+
+(file-dependency/integration/chain
+ (filename/append "machines/bobcat" "dassm1" "infutl"))
+
+(file-dependency/integration/join
+ (filename/append "machines/bobcat" "dassm2" "dassm3")
+ (filename/append "machines/bobcat" "dassm1" "infutl"))
\f
;;;; Lap level integration and expansion dependencies
(append (filename/append "base"
"bblock" "cfg1" "cfg2" "cfg3" "ctypes" "dfg" "dtype1"
"dtype2" "dtype3" "emodel" "infutl" "infgen" "linear"
- "object" "pmerly" "queue" "regset" "rtlcfg" "rtlcon"
- "rtlexp" "rtlreg" "rtlty1" "rtlty2" "rtypes" "sets"
- "toplv1" "toplv2" "toplv3" "utils")
+ "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"
- "rcsesa" "rdeath" "rdebug" "rgcomb" "rgpcom" "rgpred"
- "rgproc" "rgrval" "rgstmt" "rlife" "rtlgen")
+ "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" "insmac" "machin"))
+ (filename/append "machines/bobcat" "dassm1" "dassm2" "dassm3" "insmac"
+ "machin"))
compiler-syntax-table)
(file-dependency/syntax/join
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.41 1987/08/06 03:38:03 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.42 1987/08/07 17:13:18 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(define compiler-system
(make-environment
(define :name "Liar (Bobcat 68020)")
- (define :version 1)
- (define :modification 41)
+ (define :version 3)
+ (define :modification 0)
(define :files)
; (parse-rcs-header
-; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.41 1987/08/06 03:38:03 jinx Exp $"
+; "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.42 1987/08/07 17:13:18 cph Exp $"
; (lambda (filename version date time zone author state)
; (set! :version (car version))
; (set! :modification (cadr version))))
"base/cfg1.bin" ;control flow graph
"base/cfg2.bin"
"base/cfg3.bin"
+ "base/rgraph.bin" ;program graph abstraction
"base/ctypes.bin" ;CFG datatypes
"base/dtype1.bin" ;DFG datatypes
"base/dtype2.bin"
"base/dtype3.bin"
- "base/bblock.bin" ;Basic block datatype
"base/dfg.bin" ;data flow graph
"base/rtlty1.bin" ;RTL: type definitions
"base/rtlty2.bin"
"base/pmpars.bin" ;pattern matcher: parser
"base/infutl.bin" ;utilities for info generation, shared
"back-end/insseq.bin" ;lap instruction sequences
- "machines/bobcat/dassem.bin" ;disassembler
+ "machines/bobcat/dassm1.bin" ;disassembler
+ "base/linear.bin" ;linearization
+ ))
+
+ (cons disassembler-package
+ '("machines/bobcat/dassm2.bin" ;disassembler
+ "machines/bobcat/dassm3.bin"
))
(cons converter-package
"front-end/rgrval.bin" ;RTL generator: RValues
"front-end/rgcomb.bin" ;RTL generator: Combinations
"front-end/rgpcom.bin" ;RTL generator: Primitive open-coding
- "base/linear.bin" ;linearization
))
(cons rtl-cse-package
"front-end/rcse2.bin"
"front-end/rcseep.bin" ;CSE expression predicates
"front-end/rcseht.bin" ;CSE hash table
- "front-end/rcsesa.bin" ;CSE state abstraction
"front-end/rcserq.bin" ;CSE register/quantity abstractions
))
))
- (load-system! compiler-system true)
- (compiler-package/initialize!))
+ (load-system! compiler-system true))
(for-each (lambda (name)
(local-assignment system-global-environment name
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 1.2 1987/05/07 00:10:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 1.3 1987/08/07 17:05:00 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-;;; Hack to make RNODE-RTL, etc, work on both types of node.
-
-(define-snode rtl-snode)
-(define-pnode rtl-pnode)
-(define-vector-slots rnode 7 rtl dead-registers logical-link register-map lap
- frame-pointer-offset)
-(define-vector-slots rtl-pnode 13 consequent-lap-generator
+(define-snode sblock)
+(define-pnode pblock)
+
+(define-vector-slots bblock 5
+ instructions
+ (live-at-entry
+ register-map)
+ live-at-exit
+ (new-live-at-exit
+ frame-pointer-offset)
+ label)
+
+(define (make-sblock instructions)
+ (make-pnode sblock-tag instructions false false false false))
+
+(define-vector-slots pblock 10
+ consequent-lap-generator
alternative-lap-generator)
-(define (statement->snode statement)
- (make-pnode rtl-snode-tag statement '() false false false false))
-
-(define-integrable (statement->scfg statement)
- (snode->scfg (statement->snode statement)))
-
-(define (predicate->pnode predicate)
- (make-pnode rtl-pnode-tag predicate '() false false false false false false))
-
-(define-integrable (predicate->pcfg predicate)
- (pnode->pcfg (predicate->pnode predicate)))
-
-(define-integrable (rnode-dead-register? rnode register)
- (memv register (rnode-dead-registers rnode)))
-
-(let ((rnode-describe
- (lambda (rnode)
- `((RNODE-RTL ,(rnode-rtl rnode))
- (RNODE-DEAD-REGISTERS ,(rnode-dead-registers rnode))
- (RNODE-LOGICAL-LINK ,(rnode-logical-link rnode))
- (RNODE-REGISTER-MAP ,(rnode-register-map rnode))
- (RNODE-LAP ,(rnode-lap rnode))
- (RNODE-FRAME-POINTER-OFFSET ,(rnode-frame-pointer-offset rnode))))))
-
- (define-vector-method rtl-snode-tag ':DESCRIBE
- (lambda (snode)
- (append! ((vector-tag-method snode-tag ':DESCRIBE) snode)
- (rnode-describe snode))))
-
- (define-vector-method rtl-pnode-tag ':DESCRIBE
- (lambda (pnode)
- (append! ((vector-tag-method pnode-tag ':DESCRIBE) pnode)
- (rnode-describe pnode)
- `((RTL-PNODE-CONSEQUENT-LAP-GENERATOR
- ,(rtl-pnode-consequent-lap-generator pnode))
- (RTL-PNODE-ALTERNATIVE-LAP-GENERATOR
- ,(rtl-pnode-alternative-lap-generator pnode)))))))
\ No newline at end of file
+(define (make-pblock instructions)
+ (make-pnode pblock-tag instructions false false false false false false))
+
+(define-vector-slots rinst 0
+ rtl
+ dead-registers
+ next)
+
+(define (make-rtl-instruction rtl)
+ (vector rtl '() false))
+
+(define-integrable (statement->srtl statement)
+ (snode->scfg (make-sblock (make-rtl-instruction statement))))
+
+(define-integrable (predicate->prtl predicate)
+ (pnode->pcfg (make-pblock (make-rtl-instruction predicate))))
+
+(let ((bblock-describe
+ (lambda (bblock)
+ (descriptor-list bblock
+ instructions
+ register-map
+ frame-pointer-offset))))
+ (define-vector-method sblock-tag ':DESCRIBE
+ (lambda (sblock)
+ (append! ((vector-tag-method snode-tag ':DESCRIBE) sblock)
+ (bblock-describe sblock))))
+ (define-vector-method pblock-tag ':DESCRIBE
+ (lambda (pblock)
+ (append! ((vector-tag-method pnode-tag ':DESCRIBE) pblock)
+ (bblock-describe pblock)
+ (descriptor-list pblock
+ consequent-lap-generator
+ alternative-lap-generator)))))
+\f
+(define (rinst-dead-register? rinst register)
+ (memq register (rinst-dead-registers rinst)))
+
+(package (bblock-compress!)
+
+(define-export (bblock-compress! bblock)
+ (if (sblock? bblock)
+ (let ((next (snode-next bblock)))
+ (if next
+ (begin
+ (if (node-previous=1? next)
+ (begin
+ (set-rinst-next! (rinst-last (bblock-instructions bblock))
+ (bblock-instructions next))
+ (set-bblock-instructions! next
+ (bblock-instructions bblock))
+ (snode-delete! bblock)))
+ (bblock-compress! next))))
+ (let ((consequent (pnode-consequent bblock))
+ (alternative (pnode-alternative bblock)))
+ (if consequent
+ (bblock-compress! consequent))
+ (if alternative
+ (bblock-compress! alternative)))))
+
+(define (rinst-last rinst)
+ (if (rinst-next rinst)
+ (rinst-last (rinst-next rinst))
+ rinst))
+
+)
+
+(define (bblock-walk-forward bblock procedure)
+ (let loop ((rinst (bblock-instructions bblock)))
+ (procedure rinst)
+ (if (rinst-next rinst) (loop (rinst-next rinst)))))
+
+(define (bblock-walk-backward bblock procedure)
+ (let loop ((rinst (bblock-instructions bblock)))
+ (if (rinst-next rinst) (loop (rinst-next rinst)))
+ (procedure rinst)))
+
+(define (bblock-label! bblock)
+ (or (bblock-label bblock)
+ (let ((label (generate-label)))
+ (set-bblock-label! bblock label)
+ label)))
+\f
+(define (bblock-perform-deletions! bblock)
+ (define (loop rinst)
+ (let ((next
+ (and (rinst-next rinst)
+ (loop (rinst-next rinst)))))
+ (if (rinst-rtl rinst)
+ (begin (set-rinst-next! rinst next)
+ rinst)
+ next)))
+ (let ((instructions (loop (bblock-instructions bblock))))
+ (if instructions
+ (set-bblock-instructions! bblock instructions)
+ (snode-delete! bblock))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.32 1987/08/04 06:56:57 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 1.33 1987/08/07 17:08:10 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
operator
operands)))))))
-(define (combination/constant combination subproblem?)
- (generate/normal-statement combination subproblem?
- (lambda (subproblem?)
- (let ((value (combination-value combination)))
- (cond ((temporary? value)
- (transmit-values (generate/rvalue (vnode-known-value value))
- (lambda (prefix expression)
- (scfg*scfg->scfg!
- prefix
- (generate/assignment (combination-block combination)
- value
- expression
- subproblem?)))))
- ((value-ignore? value)
- (make-null-cfg))
- (else
- (error "Unknown combination value" value)))))))
+(define combination/constant
+ (normal-statement-generator
+ (lambda (combination subproblem?)
+ (let ((value (combination-value combination)))
+ (cond ((temporary? value)
+ (transmit-values (generate/rvalue (vnode-known-value value))
+ (lambda (prefix expression)
+ (scfg*scfg->scfg!
+ prefix
+ (generate/assignment (combination-block combination)
+ value
+ expression
+ subproblem?)))))
+ ((value-ignore? value)
+ (make-null-cfg))
+ (else
+ (error "Unknown combination value" value)))))))
\f
(define (generate-operands required optional rest operands)
(define (required-loop required operands)
;; For the time being, all close-coded combinations will return
;; their values in the value register.
(generate/normal-statement combination subproblem?
- (lambda (subproblem?)
+ (lambda (combination subproblem?)
(let ((value (combination-value combination)))
(cond ((temporary? value)
(if (not subproblem?)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.17 1987/08/04 06:57:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 1.18 1987/08/07 17:09:04 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
(define (generate-rtl quotation procedures)
- (with-new-node-marks
+ (generate/rgraph
+ (quotation-rgraph quotation)
(lambda ()
- (generate/rgraph
- (quotation-rgraph quotation)
- (lambda ()
- (scfg*scfg->scfg!
- (rtl:make-assignment register:frame-pointer
- (rtl:make-fetch register:stack-pointer))
- (generate/node (let ((entry (quotation-fg-entry quotation)))
- (if (not compiler:preserve-data-structures?)
- (unset-quotation-fg-entry! quotation))
- entry)
- false))))
- (for-each (lambda (procedure)
- (generate/rgraph
- (procedure-rgraph procedure)
- (lambda ()
- (generate/procedure-header
- procedure
- (generate/node
- (let ((entry (procedure-fg-entry procedure)))
- (if (not compiler:preserve-data-structures?)
- (unset-procedure-fg-entry! procedure))
- entry)
- false)))))
- procedures))))
-
+ (scfg*scfg->scfg!
+ (rtl:make-assignment register:frame-pointer
+ (rtl:make-fetch register:stack-pointer))
+ (generate/node (let ((entry (quotation-fg-entry quotation)))
+ (if (not compiler:preserve-data-structures?)
+ (unset-quotation-fg-entry! quotation))
+ entry)
+ false))))
+ (for-each (lambda (procedure)
+ (generate/rgraph
+ (procedure-rgraph procedure)
+ (lambda ()
+ (generate/procedure-header
+ procedure
+ (generate/node
+ (let ((entry (procedure-fg-entry procedure)))
+ (if (not compiler:preserve-data-structures?)
+ (unset-procedure-fg-entry! procedure))
+ entry)
+ false)))))
+ procedures))
+\f
(define (generate/rgraph rgraph generator)
(fluid-let ((*current-rgraph* rgraph)
+ (*next-pseudo-number* number-of-machine-registers)
(*temporary->register-map* '())
- (*next-pseudo-number* number-of-machine-registers))
- (set-rgraph-edge! rgraph (node->edge (cfg-entry-node (generator))))
- (set-rgraph-n-registers! rgraph *next-pseudo-number*)))
+ (*memoizations* '()))
+ (set-rgraph-edge!
+ rgraph
+ (node->edge (cfg-entry-node (with-new-node-marks generator))))
+ (set-rgraph-n-registers! rgraph *next-pseudo-number*))
+ (set-rgraph-bblocks!
+ rgraph
+ (with-new-node-marks
+ (lambda ()
+ (define (loop bblock)
+ (node-mark! bblock)
+ (cons bblock
+ (if (sblock? bblock)
+ (next (snode-next bblock))
+ (append! (next (pnode-consequent bblock))
+ (next (pnode-alternative bblock))))))
+
+ (define (next bblock)
+ (if (and bblock (not (node-marked? bblock)))
+ (loop bblock)
+ '()))
+
+ (mapcan (lambda (edge)
+ (bblock-compress! (edge-right-node edge))
+ (loop (edge-right-node edge)))
+ (rgraph-initial-edges rgraph))))))
\f
+(define *memoizations*)
+
(define (generate/node node subproblem?)
- ;; This won't work when there are loops in the RTL.
- (cond ((not (node-marked? node))
+ ;; This won't work when there are loops in the FG.
+ (cond ((or (null? (node-previous-edges node))
+ (null? (cdr (node-previous-edges node))))
+ (node-mark! node)
+ ((vector-method node generate/node) node subproblem?))
+ ((not (node-marked? node))
(node-mark! node)
- (set-node-rtl-arguments! node subproblem?)
(let ((result ((vector-method node generate/node) node subproblem?)))
- (set-node-rtl-result! node result)
+ (set! *memoizations*
+ (cons (cons* node subproblem? result)
+ *memoizations*))
result))
(else
- (if (not (boolean=? (node-rtl-arguments node) subproblem?))
- (error "Node regenerated with different arguments" node))
- (node-rtl-result node))))
+ (let ((memoization
+ (cdr (or (assq node *memoizations*)
+ (error "Marked node lacking memoization" node)))))
+ (if (not (boolean=? (car memoization) subproblem?))
+ (error "Node regenerated with different arguments" node))
+ (cdr memoization)))))
(define (define-generator tag generator)
(define-vector-method tag generate/node generator))
+(define (define-statement-generator tag generator)
+ (define-generator tag (normal-statement-generator generator)))
+
+(define (normal-statement-generator generator)
+ (lambda (node subproblem?)
+ (generate/normal-statement node subproblem? generator)))
+
+(define (generate/normal-statement node subproblem? generator)
+ (let ((next (snode-next node)))
+ (if next
+ (scfg*scfg->scfg! (generator node true)
+ (generate/node next subproblem?))
+ (generator node subproblem?))))
+
+(define (define-predicate-generator tag generator)
+ (define-generator tag (normal-predicate-generator generator)))
+
+(define (normal-predicate-generator generator)
+ (lambda (node subproblem?)
+ (pcfg*scfg->scfg!
+ (generator node)
+ (let ((consequent (pnode-consequent node)))
+ (and consequent
+ (generate/node consequent subproblem?)))
+ (let ((alternative (pnode-alternative node)))
+ (and alternative
+ (generate/node alternative subproblem?))))))
+\f
(define (generate/subproblem-cfg subproblem)
(if (cfg-null? (subproblem-cfg subproblem))
(make-null-cfg)
(define (generate/subproblem-push subproblem)
(transmit-values (generate/subproblem subproblem)
(lambda (cfg expression)
- (scfg*scfg->scfg! cfg (rtl:make-push expression)))))
-\f
-(define (define-statement-generator tag generator)
- (define-generator tag
- (lambda (node subproblem?)
- (generate/normal-statement node subproblem?
- (lambda (subproblem?)
- (generator node subproblem?))))))
-
-(define (generate/normal-statement node subproblem? generator)
- (if (snode-next node)
- (scfg*scfg->scfg! (generator true)
- (generate/node (snode-next node) subproblem?))
- (generator subproblem?)))
-
-(define (define-predicate-generator tag generator)
- (define-generator tag (normal-predicate-generator generator)))
-
-(define (normal-predicate-generator generator)
- (lambda (node subproblem?)
- (pcfg*scfg->scfg!
- (generator node)
- (and (pnode-consequent node)
- (generate/node (pnode-consequent node) subproblem?))
- (and (pnode-alternative node)
- (generate/node (pnode-alternative node) subproblem?)))))
-
-(define-integrable (node-rtl-result node)
- (node-property-get node tag/node-rtl-result))
-
-(define-integrable (set-node-rtl-result! node cfg)
- (node-property-put! node tag/node-rtl-result cfg))
-
-(define tag/node-rtl-result
- "node rtl result")
-
-(define-integrable (node-rtl-arguments node)
- (node-property-get node tag/node-rtl-arguments))
-
-(define-integrable (set-node-rtl-arguments! node arguments)
- (node-property-put! node tag/node-rtl-arguments arguments))
-
-(define tag/node-rtl-arguments
- "node rtl arguments")
\ No newline at end of file
+ (scfg*scfg->scfg! cfg (rtl:make-push expression)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.11 1987/08/04 06:56:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/ralloc.scm,v 1.12 1987/08/07 17:06:53 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(if renumber
(regset-adjoin! live renumber)))))
(bblock-walk-forward bblock
- (lambda (rnode next)
+ (lambda (rinst)
(for-each-regset-member live
(lambda (renumber)
(regset-union! (vector-ref conflict-matrix
register)))
(if renumber
(regset-delete! live renumber))))
- (rnode-dead-registers rnode))
+ (rinst-dead-registers rinst))
(mark-births! live
- (rnode-rtl rnode)
+ (rinst-rtl rinst)
register->renumber)))))
bblocks)
\f
allocate<?))
next-allocation))))
-)
-
(define (allocate<? x y)
(< (/ (register-n-refs x) (register-live-length x))
(/ (register-n-refs y) (register-live-length y))))
(if (pseudo-register? register)
(regset-adjoin! live
(vector-ref register->renumber
- register))))))))
\ No newline at end of file
+ register))))))))
+
+)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.2 1987/08/04 06:56:48 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcompr.scm,v 1.3 1987/08/07 17:07:52 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; RTL Dead Code Elimination
+;;;; RTL Compression
;;; Based on the GNU C Compiler
(declare (usual-integrations))
\f
-(package (dead-code-elimination)
+(package (code-compression)
-(define-export (dead-code-elimination rgraphs)
+(define-export (code-compression rgraphs)
(for-each walk-rgraph rgraphs))
(define (walk-rgraph rgraph)
(for-each walk-bblock (rgraph-bblocks rgraph))))
(define (walk-bblock bblock)
- (if (not (eq? (bblock-entry bblock) (bblock-exit bblock)))
- (let ((live (regset-copy (bblock-live-at-entry bblock)))
- (births (make-regset (rgraph-n-registers *current-rgraph*))))
- (bblock-walk-forward bblock
- (lambda (rnode next)
- (if next
- (begin (optimize-rtl live rnode next)
- (regset-clear! births)
- (mark-set-registers! live
- births
- (rnode-rtl rnode)
- false)
- (for-each (lambda (register)
- (regset-delete! live register))
- (rnode-dead-registers rnode))
- (regset-union! live births))))))))
-
-)
+ (if (rinst-next (bblock-instructions bblock))
+ (begin
+ (let ((live (regset-copy (bblock-live-at-entry bblock)))
+ (births (make-regset (rgraph-n-registers *current-rgraph*))))
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (if (rinst-next rinst)
+ (let ((rtl (rinst-rtl rinst)))
+ (optimize-rtl live rinst rtl)
+ (regset-clear! births)
+ (mark-set-registers! live births rtl false)
+ (for-each (lambda (register)
+ (regset-delete! live register))
+ (rinst-dead-registers rinst))
+ (regset-union! live births))))))
+ (bblock-perform-deletions! bblock))))
\f
-(define (optimize-rtl live rnode next)
- (let ((rtl (rnode-rtl rnode)))
- (if (rtl:assign? rtl)
- (let ((address (rtl:assign-address rtl)))
- (if (rtl:register? address)
- (let ((register (rtl:register-number address)))
- (if (and (pseudo-register? register)
- (= 2 (register-n-refs register))
- (rnode-dead-register? next register)
- (rtl:any-subexpression? (rnode-rtl next)
- (lambda (expression)
- (and (rtl:register? expression)
- (= (rtl:register-number expression)
- register)))))
- (begin
- (let ((dead (rnode-dead-registers rnode)))
- (for-each increment-register-live-length! dead)
- (set-rnode-dead-registers!
- next
- (eqv-set-union dead
- (delv! register
- (rnode-dead-registers next)))))
- (for-each-regset-member live
- decrement-register-live-length!)
- (rtl:modify-subexpressions (rnode-rtl next)
- (lambda (expression set-expression!)
- (if (and (rtl:register? expression)
- (= (rtl:register-number expression)
- register))
- (set-expression! (rtl:assign-expression rtl)))))
- (snode-delete! rnode)
- (reset-register-n-refs! register)
- (reset-register-n-deaths! register)
- (reset-register-live-length! register)
- (set-register-next-use! register false)
- (set-register-bblock! register false)))))))))
\ No newline at end of file
+(define (optimize-rtl live rinst rtl)
+ (if (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl)))
+ (if (rtl:register? address)
+ (let ((register (rtl:register-number address))
+ (next (rinst-next rinst)))
+ (if (and (pseudo-register? register)
+ (= 2 (register-n-refs register))
+ (rinst-dead-register? next register)
+ (rtl:any-subexpression? (rinst-rtl next)
+ (lambda (expression)
+ (and (rtl:register? expression)
+ (= (rtl:register-number expression)
+ register)))))
+ (begin
+ (let ((dead (rinst-dead-registers rinst)))
+ (for-each increment-register-live-length! dead)
+ (set-rinst-dead-registers!
+ next
+ (eqv-set-union dead
+ (delv! register
+ (rinst-dead-registers next)))))
+ (for-each-regset-member live
+ decrement-register-live-length!)
+ (rtl:modify-subexpressions (rinst-rtl next)
+ (lambda (expression set-expression!)
+ (if (and (rtl:register? expression)
+ (= (rtl:register-number expression)
+ register))
+ (set-expression! (rtl:assign-expression rtl)))))
+ (set-rinst-rtl! rinst false)
+ (reset-register-n-refs! register)
+ (reset-register-n-deaths! register)
+ (reset-register-live-length! register)
+ (set-register-bblock! register false))))))))
+
+)
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.112 1987/08/04 06:56:11 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 1.113 1987/08/07 17:07:06 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(for-each (lambda (edge)
(enqueue! *initial-queue* (edge-right-node edge)))
(rgraph-initial-edges rgraph))
- (state:initialize rgraph continue-walk)))
+ (fluid-let ((*register-tables*
+ (register-tables/make (rgraph-n-registers rgraph)))
+ (*hash-table*))
+ (continue-walk))))
(define (continue-walk)
(cond ((not (null? *branch-queue*))
(let ((entry (car *branch-queue*)))
(set! *branch-queue* (cdr *branch-queue*))
- (state:set! *current-rgraph* (car entry))
- (walk-rnode (cdr entry))))
+ (set! *register-tables* (caar entry))
+ (set! *hash-table* (cdar entry))
+ (walk-bblock (cdr entry))))
((not (queue-empty? *initial-queue*))
- (state:reset! *current-rgraph*)
- (walk-rnode (dequeue! *initial-queue*)))))
-\f
-(define (walk-rnode rnode)
- (node-mark! rnode)
- ((vector-method rnode walk-rnode) rnode))
-
-(define-vector-method rtl-snode-tag walk-rnode
- (lambda (rnode)
- (cse-statement (rnode-rtl rnode))
- (let ((next (snode-next rnode)))
- (if (walk-next? next)
- (walk-next next)
- (continue-walk)))))
-
-(define-vector-method rtl-pnode-tag walk-rnode
- (lambda (rnode)
- (cse-statement (rnode-rtl rnode))
- (let ((consequent (pnode-consequent rnode))
- (alternative (pnode-alternative rnode)))
- (if (walk-next? consequent)
- (if (walk-next? alternative)
- (if (node-previous>1? consequent)
- (begin (enqueue! *initial-queue* consequent)
- (walk-next alternative))
- (begin (if (node-previous>1? alternative)
- (enqueue! *initial-queue* alternative)
- (set! *branch-queue*
- (cons (cons (state:get *current-rgraph*)
- alternative)
- *branch-queue*)))
- (walk-rnode consequent)))
- (walk-next consequent))
- (if (walk-next? alternative)
- (walk-next alternative)
- (continue-walk))))))
-
-(define (walk-next? rnode)
- (and rnode (not (node-marked? rnode))))
-
-(define (walk-next rnode)
- (if (node-previous>1? rnode) (state:reset! *current-rgraph*))
- (walk-rnode rnode))
-\f
-(define (cse-statement statement)
- ((if (eq? (rtl:expression-type statement) 'ASSIGN)
- cse/assign
- (cdr (or (assq (rtl:expression-type statement) cse-methods)
- (error "Missing CSE method" (car statement)))))
- statement))
+ (state:reset!)
+ (walk-bblock (dequeue! *initial-queue*)))))
-(define cse-methods '())
+(define (state:reset!)
+ (register-tables/reset! *register-tables*)
+ (set! *hash-table* (make-hash-table)))
+
+(define (state:get)
+ (cons (register-tables/copy *register-tables*)
+ (hash-table-copy *hash-table*)))
+\f
+(define (walk-bblock bblock)
+ (define (loop rinst)
+ (let ((rtl (rinst-rtl rinst)))
+ ((if (eq? (rtl:expression-type rtl) 'ASSIGN)
+ cse/assign
+ (cdr (or (assq (rtl:expression-type rtl) cse-methods)
+ (error "Missing CSE method" (car rtl)))))
+ rtl))
+ (if (rinst-next rinst)
+ (loop (rinst-next rinst))))
+ (loop (bblock-instructions bblock))
+ (node-mark! bblock)
+ (if (sblock? bblock)
+ (let ((next (snode-next bblock)))
+ (if (walk-next? next)
+ (walk-next next)
+ (continue-walk)))
+ (let ((consequent (pnode-consequent bblock))
+ (alternative (pnode-alternative bblock)))
+ (if (walk-next? consequent)
+ (if (walk-next? alternative)
+ (if (node-previous>1? consequent)
+ (begin (enqueue! *initial-queue* consequent)
+ (walk-next alternative))
+ (begin (if (node-previous>1? alternative)
+ (enqueue! *initial-queue* alternative)
+ (set! *branch-queue*
+ (cons (cons (state:get) alternative)
+ *branch-queue*)))
+ (walk-bblock consequent)))
+ (walk-next consequent))
+ (if (walk-next? alternative)
+ (walk-next alternative)
+ (continue-walk))))))
+
+(define (walk-next? bblock)
+ (and bblock (not (node-marked? bblock))))
+
+(define (walk-next bblock)
+ (if (node-previous>1? bblock) (state:reset!))
+ (walk-bblock bblock))
(define (define-cse-method type method)
(let ((entry (assq type cse-methods)))
(set-cdr! entry method)
(set! cse-methods (cons (cons type method) cse-methods))))
type)
+
+(define cse-methods
+ '())
\f
(define (cse/assign statement)
(expression-replace! rtl:assign-expression rtl:set-assign-expression!
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.3 1987/08/04 06:56:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcserq.scm,v 1.4 1987/08/07 17:07:33 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(let ((quantity (new-quantity register)))
(set-register-quantity! register quantity)
quantity)))
+\f
+(define (register-tables/make n-registers)
+ (vector (make-vector n-registers)
+ (make-vector n-registers)
+ (make-vector n-registers)
+ (make-vector n-registers)
+ (make-vector n-registers)
+ (make-vector n-registers)))
+
+(define (register-tables/reset! register-tables)
+ (vector-fill! (vector-ref register-tables 0) false)
+ (vector-fill! (vector-ref register-tables 1) false)
+ (vector-fill! (vector-ref register-tables 2) false)
+ (let ((expressions (vector-ref register-tables 3)))
+ (vector-fill! expressions false)
+ (for-each-machine-register
+ (lambda (register)
+ (vector-set! expressions
+ register
+ (rtl:make-machine-register register)))))
+ (vector-fill! (vector-ref register-tables 4) 0)
+ (vector-fill! (vector-ref register-tables 5) -1))
+
+(define (register-tables/copy register-tables)
+ (vector (vector-map (vector-ref register-tables 0)
+ (lambda (quantity)
+ (and quantity
+ (quantity-copy quantity))))
+ (vector-copy (vector-ref register-tables 1))
+ (vector-copy (vector-ref register-tables 2))
+ (vector-copy (vector-ref register-tables 3))
+ (vector-copy (vector-ref register-tables 4))
+ (vector-copy (vector-ref register-tables 5))))
+\f
+(define *register-tables*)
+
+(define-integrable (register-quantity register)
+ (vector-ref (vector-ref *register-tables* 0) register))
+
+(define-integrable (set-register-quantity! register quantity)
+ (vector-set! (vector-ref *register-tables* 0) register quantity))
+
+(define-integrable (register-next-equivalent register)
+ (vector-ref (vector-ref *register-tables* 1) register))
+
+(define-integrable (set-register-next-equivalent! register next-equivalent)
+ (vector-set! (vector-ref *register-tables* 1) register next-equivalent))
+
+(define-integrable (register-previous-equivalent register)
+ (vector-ref (vector-ref *register-tables* 2) register))
+
+(define-integrable
+ (set-register-previous-equivalent! register previous-equivalent)
+ (vector-set! (vector-ref *register-tables* 2) register previous-equivalent))
+
+(define-integrable (register-expression register)
+ (vector-ref (vector-ref *register-tables* 3) register))
+
+(define-integrable (set-register-expression! register expression)
+ (vector-set! (vector-ref *register-tables* 3) register expression))
+
+(define-integrable (register-tick register)
+ (vector-ref (vector-ref *register-tables* 4) register))
+
+(define-integrable (set-register-tick! register tick)
+ (vector-set! (vector-ref *register-tables* 4) register tick))
+
+(define-integrable (register-in-table register)
+ (vector-ref (vector-ref *register-tables* 5) register))
-(define-integrable rgraph-register-quantity rgraph-register-bblock)
-(define-integrable rgraph-register-next-equivalent rgraph-register-next-use)
-(define-integrable rgraph-register-previous-equivalent rgraph-register-n-refs)
-(define-integrable rgraph-register-expression rgraph-register-n-deaths)
-(define-integrable rgraph-register-tick rgraph-register-live-length)
-(define-integrable rgraph-register-in-table rgraph-register-crosses-call?)
-
-(define-integrable set-rgraph-register-quantity! set-rgraph-register-bblock!)
-(define-integrable set-rgraph-register-next-equivalent!
- set-rgraph-register-next-use!)
-(define-integrable set-rgraph-register-previous-equivalent!
- set-rgraph-register-n-refs!)
-(define-integrable set-rgraph-register-expression!
- set-rgraph-register-n-deaths!)
-(define-integrable set-rgraph-register-tick! set-rgraph-register-live-length!)
-(define-integrable set-rgraph-register-in-table!
- set-rgraph-register-crosses-call?!)
-
-(define-register-references quantity)
-(define-register-references next-equivalent)
-(define-register-references previous-equivalent)
-(define-register-references expression)
-(define-register-references tick)
-(define-register-references in-table)
\ No newline at end of file
+(define-integrable (set-register-in-table! register in-table)
+ (vector-set! (vector-ref *register-tables* 5) register in-table))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rdebug.scm,v 1.1 1987/04/17 10:53:25 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rdebug.scm,v 1.2 1987/08/07 17:08:01 cph Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-(define (dump-register-info)
- (for-each-pseudo-register
- (lambda (register)
- (if (positive? (register-n-refs register))
- (begin (newline)
- (write register)
- (write-string ": renumber ")
- (write (register-renumber register))
- (write-string "; nrefs ")
- (write (register-n-refs register))
- (write-string "; length ")
- (write (register-live-length register))
- (write-string "; ndeaths ")
- (write (register-n-deaths register))
- (let ((bblock (register-bblock register)))
- (cond ((eq? bblock 'NON-LOCAL)
- (if (register-crosses-call? register)
- (write-string "; crosses calls")
- (write-string "; multiple blocks")))
- (bblock
- (write-string "; block ")
- (write (unhash bblock)))
- (else
- (write-string "; no block!")))))))))
-
-(define (dump-block-info bblocks)
- (let ((null-set (make-regset *n-registers*))
- (machine-regs (make-regset *n-registers*)))
- (for-each-machine-register
+(define (dump-register-info rgraph)
+ (fluid-let ((*current-rgraph* rgraph))
+ (for-each-pseudo-register
(lambda (register)
- (regset-adjoin! machine-regs register)))
- (for-each (lambda (bblock)
- (newline)
- (newline)
- (write bblock)
- (let ((exit (bblock-exit bblock)))
- (let loop ((rnode (bblock-entry bblock)))
- (pp (rnode-rtl rnode))
- (if (not (eq? rnode exit))
- (loop (snode-next rnode)))))
- (let ((live-at-exit (bblock-live-at-exit bblock)))
- (regset-difference! live-at-exit machine-regs)
- (if (not (regset=? null-set live-at-exit))
- (begin (newline)
- (write-string "Registers live at end:")
- (for-each-regset-member live-at-exit
- (lambda (register)
- (write-string " ")
- (write register)))))))
- (reverse bblocks))))
\ No newline at end of file
+ (if (positive? (register-n-refs register))
+ (begin (newline)
+ (write register)
+ (write-string ": renumber ")
+ (write (register-renumber register))
+ (write-string "; nrefs ")
+ (write (register-n-refs register))
+ (write-string "; length ")
+ (write (register-live-length register))
+ (write-string "; ndeaths ")
+ (write (register-n-deaths register))
+ (let ((bblock (register-bblock register)))
+ (cond ((eq? bblock 'NON-LOCAL)
+ (if (register-crosses-call? register)
+ (write-string "; crosses calls")
+ (write-string "; multiple blocks")))
+ (bblock
+ (write-string "; block ")
+ (write (unhash bblock)))
+ (else
+ (write-string "; no block!"))))))))))
+
+(define (dump-block-info rgraph)
+ (fluid-let ((*current-rgraph* rgraph))
+ (let ((machine-regs (make-regset (rgraph-n-registers rgraph))))
+ (for-each-machine-register
+ (lambda (register)
+ (regset-adjoin! machine-regs register)))
+ (for-each (lambda (bblock)
+ (newline)
+ (newline)
+ (write bblock)
+ (bblock-walk-forward bblock
+ (lambda (rinst)
+ (pp (rinst-rtl rinst))))
+ (let ((live-at-exit (bblock-live-at-exit bblock)))
+ (regset-difference! live-at-exit machine-regs)
+ (if (not (regset-null? live-at-exit))
+ (begin (newline)
+ (write-string "Registers live at end:")
+ (for-each-regset-member live-at-exit
+ (lambda (register)
+ (write-string " ")
+ (write register)))))))
+ (rgraph-bblocks rgraph)))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.57 1987/08/04 06:57:18 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rlife.scm,v 1.58 1987/08/07 17:08:45 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
(declare (usual-integrations))
\f
-;;;; Lifetime Analysis
-
-(package (lifetime-analysis)
+(package (lifetime-analysis mark-set-registers!)
(define-export (lifetime-analysis rgraphs)
(for-each walk-rgraph rgraphs))
(let ((n-registers (rgraph-n-registers rgraph))
(bblocks (rgraph-bblocks rgraph)))
(set-rgraph-register-bblock! rgraph (make-vector n-registers false))
- (set-rgraph-register-next-use! rgraph (make-vector n-registers false))
(set-rgraph-register-n-refs! rgraph (make-vector n-registers 0))
(set-rgraph-register-n-deaths! rgraph (make-vector n-registers 0))
(set-rgraph-register-live-length! rgraph (make-vector n-registers 0))
- (set-rgraph-register-crosses-call?! rgraph (make-bit-string n-registers false))
+ (set-rgraph-register-crosses-call?! rgraph
+ (make-bit-string n-registers false))
(for-each (lambda (bblock)
- (bblock-initialize-regsets! bblock n-registers))
+ (set-bblock-live-at-entry! bblock (make-regset n-registers))
+ (set-bblock-live-at-exit! bblock (make-regset n-registers))
+ (set-bblock-new-live-at-exit! bblock
+ (make-regset n-registers)))
bblocks)
(fluid-let ((*current-rgraph* rgraph))
- (walk-bblock bblocks))))
+ (walk-bblocks bblocks))
+ (for-each (lambda (bblock)
+ (set-bblock-new-live-at-exit! bblock false))
+ (rgraph-bblocks rgraph))))
-(define (walk-bblock bblocks)
+(define (walk-bblocks bblocks)
(let ((changed? false))
(define (loop first-pass?)
(for-each (lambda (bblock)
(regset-copy! (bblock-live-at-entry bblock)
(bblock-live-at-exit bblock))
(propagate-block bblock)
- (for-each-previous-node (bblock-entry bblock)
- (lambda (rnode)
+ (for-each-previous-node bblock
+ (lambda (bblock*)
(regset-union!
- (bblock-new-live-at-exit (node-bblock rnode))
+ (bblock-new-live-at-exit bblock*)
(bblock-live-at-entry bblock)))))))
bblocks)
(if changed?
(propagate-block&delete! bblock))
bblocks)))
(loop true)))
-
-)
\f
(define (propagate-block bblock)
(propagation-loop bblock
- (lambda (old dead live rtl rnode)
- (update-live-registers! old dead live rtl false))))
+ (lambda (dead live rinst)
+ (update-live-registers! (bblock-live-at-entry bblock)
+ dead
+ live
+ (rinst-rtl rinst)
+ false false))))
(define (propagate-block&delete! bblock)
(for-each-regset-member (bblock-live-at-entry bblock)
(lambda (register)
(set-register-bblock! register 'NON-LOCAL)))
(propagation-loop bblock
- (lambda (old dead live rtl rnode)
- (if (rtl:invocation? rtl)
- (for-each-regset-member old register-crosses-call!))
- (if (instruction-dead? rtl old)
- (snode-delete! rnode)
- (begin (update-live-registers! old dead live rtl rnode)
- (for-each-regset-member old
- increment-register-live-length!))))))
+ (lambda (dead live rinst)
+ (let ((rtl (rinst-rtl rinst))
+ (old (bblock-live-at-entry bblock)))
+ (if (rtl:invocation? rtl)
+ (for-each-regset-member old register-crosses-call!))
+ (if (instruction-dead? rtl old)
+ (set-rinst-rtl! rinst false)
+ (begin (update-live-registers! old dead live rtl bblock rinst)
+ (for-each-regset-member old
+ increment-register-live-length!))))))
+ (bblock-perform-deletions! bblock))
(define (propagation-loop bblock procedure)
- (let ((old (bblock-live-at-entry bblock))
- (dead (regset-allocate (rgraph-n-registers *current-rgraph*)))
+ (let ((dead (regset-allocate (rgraph-n-registers *current-rgraph*)))
(live (regset-allocate (rgraph-n-registers *current-rgraph*))))
(bblock-walk-backward bblock
- (lambda (rnode previous)
+ (lambda (rinst)
(regset-clear! dead)
(regset-clear! live)
- (procedure old dead live (rnode-rtl rnode) rnode)))))
+ (procedure dead live rinst)))))
-(define (update-live-registers! old dead live rtl rnode)
- (mark-set-registers! old dead rtl rnode)
- (mark-used-registers! old live rtl rnode)
+(define (update-live-registers! old dead live rtl bblock rinst)
+ (mark-set-registers! old dead rtl bblock)
+ (mark-used-registers! old live rtl bblock rinst)
(regset-difference! old dead)
(regset-union! old live))
-
-(define (instruction-dead? rtl needed)
- (and (rtl:assign? rtl)
- (let ((address (rtl:assign-address rtl)))
- (and (rtl:register? address)
- (let ((register (rtl:register-number address)))
- (and (pseudo-register? register)
- (not (regset-member? needed register))))))))
\f
-(define (mark-set-registers! needed dead rtl rnode)
+(define (mark-set-registers! needed dead rtl bblock)
;; **** This code safely ignores PRE-INCREMENT and POST-INCREMENT
;; modes, since they are only used on the stack pointer.
(if (rtl:assign? rtl)
(if (interesting-register? address)
(let ((register (rtl:register-number address)))
(regset-adjoin! dead register)
- (if rnode
- (let ((rnode* (register-next-use register)))
- (record-register-reference register rnode)
- (if (and (regset-member? needed register)
- rnode*
- (eq? (node-bblock rnode) (node-bblock rnode*)))
- (set-rnode-logical-link! rnode* rnode)))))))))
-
-(define (mark-used-registers! needed live rtl rnode)
+ (if bblock (record-register-reference register bblock)))))))
+
+(define (mark-used-registers! needed live rtl bblock rinst)
(define (loop expression)
(if (interesting-register? expression)
(let ((register (rtl:register-number expression)))
(regset-adjoin! live register)
- (if rnode
- (begin (record-register-reference register rnode)
- (set-register-next-use! register rnode)
+ (if bblock
+ (begin (record-register-reference register bblock)
(if (and (not (regset-member? needed register))
- (not (rnode-dead-register? rnode register)))
- (begin (set-rnode-dead-registers!
- rnode
+ (not (rinst-dead-register? rinst register)))
+ (begin (set-rinst-dead-registers!
+ rinst
(cons register
- (rnode-dead-registers rnode)))
+ (rinst-dead-registers rinst)))
(increment-register-n-deaths! register))))))
(rtl:for-each-subexpression expression loop)))
(if (and (rtl:assign? rtl)
(loop (rtl:assign-expression rtl)))
(rtl:for-each-subexpression rtl loop)))
-(define (record-register-reference register rnode)
- (let ((bblock (node-bblock rnode))
- (bblock* (register-bblock register)))
+(define (record-register-reference register bblock)
+ (let ((bblock* (register-bblock register)))
(cond ((not bblock*)
(set-register-bblock! register bblock))
((not (eq? bblock bblock*))
(set-register-bblock! register 'NON-LOCAL)))
(increment-register-n-refs! register)))
+(define (instruction-dead? rtl needed)
+ (and (rtl:assign? rtl)
+ (let ((address (rtl:assign-address rtl)))
+ (and (rtl:register? address)
+ (let ((register (rtl:register-number address)))
+ (and (pseudo-register? register)
+ (not (regset-member? needed register))))))))
+
(define (interesting-register? expression)
(and (rtl:register? expression)
- (pseudo-register? (rtl:register-number expression))))
\ No newline at end of file
+ (pseudo-register? (rtl:register-number expression))))
+
+)
\ No newline at end of file
projects / mit-scheme.git / commitdiff