From d112f3da3409627afc0463a2ca61c787a3608606 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 7 Aug 1987 17:13:18 +0000 Subject: [PATCH] Redesign RTL data structures. New structures have CFG nodes which represent basic blocks. Each basic block contains one or more RTL instructions. Resulting data structures use considerably less storage than old representation. --- v7/src/compiler/back/lapgn1.scm | 141 +++++++------- v7/src/compiler/back/lapgn3.scm | 32 ++-- v7/src/compiler/base/cfg1.scm | 14 +- v7/src/compiler/base/cfg2.scm | 37 +--- v7/src/compiler/base/cfg3.scm | 14 +- v7/src/compiler/base/ctypes.scm | 30 ++- v7/src/compiler/base/macros.scm | 34 ++-- v7/src/compiler/base/rvalue.scm | 40 +--- v7/src/compiler/machines/bobcat/decls.scm | 34 ++-- .../compiler/machines/bobcat/make.scm-68040 | 23 ++- v7/src/compiler/rtlbase/rtlcfg.scm | 159 +++++++++++----- v7/src/compiler/rtlgen/rgcomb.scm | 38 ++-- v7/src/compiler/rtlgen/rtlgen.scm | 179 ++++++++++-------- v7/src/compiler/rtlopt/ralloc.scm | 14 +- v7/src/compiler/rtlopt/rcompr.scm | 115 ++++++----- v7/src/compiler/rtlopt/rcse1.scm | 117 ++++++------ v7/src/compiler/rtlopt/rcserq.scm | 97 +++++++--- v7/src/compiler/rtlopt/rdebug.scm | 99 +++++----- v7/src/compiler/rtlopt/rlife.scm | 122 ++++++------ 19 files changed, 728 insertions(+), 611 deletions(-) diff --git a/v7/src/compiler/back/lapgn1.scm b/v7/src/compiler/back/lapgn1.scm index 766ca26a6..773f3c416 100644 --- a/v7/src/compiler/back/lapgn1.scm +++ b/v7/src/compiler/back/lapgn1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn1.scm,v 1.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 @@ -37,10 +37,10 @@ MIT in each case. |# (declare (usual-integrations)) (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 @@ -66,75 +66,82 @@ MIT in each case. |# (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)))))))))) -(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)))))) - -(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))))))) + (define *cgen-rules* '()) (define *assign-rules* '()) diff --git a/v7/src/compiler/back/lapgn3.scm b/v7/src/compiler/back/lapgn3.scm index 9597557d7..dfe52b741 100644 --- a/v7/src/compiler/back/lapgn3.scm +++ b/v7/src/compiler/back/lapgn3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 1.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 @@ -81,8 +81,8 @@ MIT in each case. |# 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)) ;;;; Frame Pointer @@ -124,19 +124,17 @@ MIT in each case. |# *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 diff --git a/v7/src/compiler/base/cfg1.scm b/v7/src/compiler/base/cfg1.scm index 0e4c983b9..6df9701fa 100644 --- a/v7/src/compiler/base/cfg1.scm +++ b/v7/src/compiler/base/cfg1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg1.scm,v 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 @@ -40,18 +40,18 @@ MIT in each case. |# (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) @@ -60,10 +60,10 @@ MIT in each case. |# (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) diff --git a/v7/src/compiler/base/cfg2.scm b/v7/src/compiler/base/cfg2.scm index 0b34b479b..e8840172d 100644 --- a/v7/src/compiler/base/cfg2.scm +++ b/v7/src/compiler/base/cfg2.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg2.scm,v 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 @@ -38,15 +38,7 @@ MIT in each case. |# ;;;; 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))) @@ -177,29 +169,4 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/base/cfg3.scm b/v7/src/compiler/base/cfg3.scm index 617c35f02..b69a58903 100644 --- a/v7/src/compiler/base/cfg3.scm +++ b/v7/src/compiler/base/cfg3.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/cfg3.scm,v 1.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 @@ -128,6 +128,18 @@ MIT in each case. |# (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)))))) ;;;; CFG Construction diff --git a/v7/src/compiler/base/ctypes.scm b/v7/src/compiler/base/ctypes.scm index 7e77a5019..d2ea36b65 100644 --- a/v7/src/compiler/base/ctypes.scm +++ b/v7/src/compiler/base/ctypes.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/ctypes.scm,v 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 @@ -97,17 +97,29 @@ MIT in each case. |# (define-integrable (combination-compiled-for-value? combination) (eq? 'VALUE (combination-compilation-type combination))) -(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 diff --git a/v7/src/compiler/base/macros.scm b/v7/src/compiler/base/macros.scm index c9e10489c..92e2eecc3 100644 --- a/v7/src/compiler/base/macros.scm +++ b/v7/src/compiler/base/macros.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/macros.scm,v 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 @@ -149,14 +149,19 @@ MIT in each case. |# (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))))) @@ -179,8 +184,8 @@ MIT in each case. |# (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)) @@ -194,7 +199,8 @@ MIT in each case. |# (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)) @@ -220,12 +226,12 @@ MIT in each case. |# (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)))))) (syntax-table-define compiler-syntax-table 'DEFINE-REGISTER-REFERENCES (macro (slot) diff --git a/v7/src/compiler/base/rvalue.scm b/v7/src/compiler/base/rvalue.scm index c6f7bbc51..db33ef18c 100644 --- a/v7/src/compiler/base/rvalue.scm +++ b/v7/src/compiler/base/rvalue.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -147,40 +147,4 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/bobcat/decls.scm b/v7/src/compiler/machines/bobcat/decls.scm index 14c7324a9..ebc33f821 100644 --- a/v7/src/compiler/machines/bobcat/decls.scm +++ b/v7/src/compiler/machines/bobcat/decls.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/decls.scm,v 1.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 @@ -75,9 +75,9 @@ MIT in each case. |# (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")) @@ -87,9 +87,9 @@ MIT in each case. |# (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 @@ -105,6 +105,13 @@ MIT in each case. |# (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")) ;;;; Lap level integration and expansion dependencies @@ -172,19 +179,20 @@ MIT in each case. |# (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 diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index e4192f59e..f82de3a3f 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 1.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 @@ -45,12 +45,12 @@ MIT in each case. |# (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)))) @@ -78,11 +78,11 @@ MIT in each case. |# "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" @@ -97,7 +97,13 @@ MIT in each case. |# "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 @@ -123,7 +129,6 @@ MIT in each case. |# "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 @@ -131,7 +136,6 @@ MIT in each case. |# "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 )) @@ -178,8 +182,7 @@ MIT in each case. |# )) - (load-system! compiler-system true) - (compiler-package/initialize!)) + (load-system! compiler-system true)) (for-each (lambda (name) (local-assignment system-global-environment name diff --git a/v7/src/compiler/rtlbase/rtlcfg.scm b/v7/src/compiler/rtlbase/rtlcfg.scm index e486136a0..39268215f 100644 --- a/v7/src/compiler/rtlbase/rtlcfg.scm +++ b/v7/src/compiler/rtlbase/rtlcfg.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlbase/rtlcfg.scm,v 1.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 @@ -36,49 +36,118 @@ MIT in each case. |# (declare (usual-integrations)) -;;; 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))))) + +(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))) + +(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 diff --git a/v7/src/compiler/rtlgen/rgcomb.scm b/v7/src/compiler/rtlgen/rgcomb.scm index fc2364cc1..9d9a2a2c7 100644 --- a/v7/src/compiler/rtlgen/rgcomb.scm +++ b/v7/src/compiler/rtlgen/rgcomb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rgcomb.scm,v 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 @@ -68,23 +68,23 @@ MIT in each case. |# 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))))))) (define (generate-operands required optional rest operands) (define (required-loop required operands) @@ -121,7 +121,7 @@ MIT in each case. |# ;; 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?) diff --git a/v7/src/compiler/rtlgen/rtlgen.scm b/v7/src/compiler/rtlgen/rtlgen.scm index f1dd8c252..42eec2151 100644 --- a/v7/src/compiler/rtlgen/rtlgen.scm +++ b/v7/src/compiler/rtlgen/rtlgen.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlgen/rtlgen.scm,v 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 @@ -37,56 +37,116 @@ MIT in each case. |# (declare (usual-integrations)) (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)) + (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)))))) +(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?)))))) + (define (generate/subproblem-cfg subproblem) (if (cfg-null? (subproblem-cfg subproblem)) (make-null-cfg) @@ -107,47 +167,4 @@ MIT in each case. |# (define (generate/subproblem-push subproblem) (transmit-values (generate/subproblem subproblem) (lambda (cfg expression) - (scfg*scfg->scfg! cfg (rtl:make-push expression))))) - -(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 diff --git a/v7/src/compiler/rtlopt/ralloc.scm b/v7/src/compiler/rtlopt/ralloc.scm index 6d68a0f72..129266643 100644 --- a/v7/src/compiler/rtlopt/ralloc.scm +++ b/v7/src/compiler/rtlopt/ralloc.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -81,7 +81,7 @@ MIT in each case. |# (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 @@ -93,9 +93,9 @@ MIT in each case. |# 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) @@ -126,8 +126,6 @@ MIT in each case. |# allocaterenumber - register)))))))) \ No newline at end of file + register)))))))) + +) \ No newline at end of file diff --git a/v7/src/compiler/rtlopt/rcompr.scm b/v7/src/compiler/rtlopt/rcompr.scm index 714e2ee1d..fcf956091 100644 --- a/v7/src/compiler/rtlopt/rcompr.scm +++ b/v7/src/compiler/rtlopt/rcompr.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -32,14 +32,14 @@ Technology nor of any adaptation thereof in any advertising, 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)) -(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) @@ -47,58 +47,57 @@ MIT in each case. |# (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)))) -(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 diff --git a/v7/src/compiler/rtlopt/rcse1.scm b/v7/src/compiler/rtlopt/rcse1.scm index 9eaed458d..89efbb150 100644 --- a/v7/src/compiler/rtlopt/rcse1.scm +++ b/v7/src/compiler/rtlopt/rcse1.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/rtlopt/rcse1.scm,v 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 @@ -53,67 +53,71 @@ MIT in each case. |# (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*))))) - -(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)) - -(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*))) + +(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))) @@ -121,6 +125,9 @@ MIT in each case. |# (set-cdr! entry method) (set! cse-methods (cons (cons type method) cse-methods)))) type) + +(define cse-methods + '()) (define (cse/assign statement) (expression-replace! rtl:assign-expression rtl:set-assign-expression! diff --git a/v7/src/compiler/rtlopt/rcserq.scm b/v7/src/compiler/rtlopt/rcserq.scm index 755c97776..a6e464cde 100644 --- a/v7/src/compiler/rtlopt/rcserq.scm +++ b/v7/src/compiler/rtlopt/rcserq.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -64,28 +64,75 @@ MIT in each case. |# (let ((quantity (new-quantity register))) (set-register-quantity! register quantity) quantity))) + +(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)))) + +(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 diff --git a/v7/src/compiler/rtlopt/rdebug.scm b/v7/src/compiler/rtlopt/rdebug.scm index f84e63e19..cdc7faaa3 100644 --- a/v7/src/compiler/rtlopt/rdebug.scm +++ b/v7/src/compiler/rtlopt/rdebug.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -36,53 +36,52 @@ MIT in each case. |# (declare (usual-integrations)) -(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 diff --git a/v7/src/compiler/rtlopt/rlife.scm b/v7/src/compiler/rtlopt/rlife.scm index 5dc9700dd..936183ba2 100644 --- a/v7/src/compiler/rtlopt/rlife.scm +++ b/v7/src/compiler/rtlopt/rlife.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -37,9 +37,7 @@ MIT in each case. |# (declare (usual-integrations)) -;;;; Lifetime Analysis - -(package (lifetime-analysis) +(package (lifetime-analysis mark-set-registers!) (define-export (lifetime-analysis rgraphs) (for-each walk-rgraph rgraphs)) @@ -48,18 +46,24 @@ MIT in each case. |# (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) @@ -72,10 +76,10 @@ MIT in each case. |# (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? @@ -87,53 +91,49 @@ MIT in each case. |# (propagate-block&delete! bblock)) bblocks))) (loop true))) - -) (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)))))))) -(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) @@ -141,28 +141,21 @@ MIT in each case. |# (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) @@ -173,15 +166,24 @@ MIT in each case. |# (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 -- 2.25.1