} cond ;
: fold-branch ( ? -- insn )
- 0 1 ?
- basic-block get [ nth 1vector ] change-successors drop
+ drop
+ ! 0 1 ?
+ ! basic-block get [ nth 1vector ] change-successors drop
\ ##branch new-insn ;
: fold-compare-imm-branch ( insn -- insn/f )
SYMBOL: input-expr-counter
-! assoc mapping vregs to value numbers
+! assoc mapping vregs to *optimistic* value numbers
+! initialized per iteration of global value numbering
! this is the identity on canonical representatives
SYMBOL: vregs>vns
! assoc mapping value numbers to instructions
SYMBOL: vns>insns
-! assoc mapping vregs to *global* value numbers
-SYMBOL: vregs>gvns
+! assoc mapping vregs to value numbers
+! once this stops changing, we know the value numbers are sound
+SYMBOL: valid-vns
+! boolean to track whether valid-vns changes
SYMBOL: changed?
: vn>insn ( vn -- insn ) vns>insns get at ;
-! : vreg>vn ( vreg -- vn ) vregs>vns get [ ] cache ;
-
-: vreg>vn ( vreg -- vn ) vregs>gvns get at ;
-
-! : set-vn ( vn vreg -- ) vregs>vns get set-at ;
+: vreg>vn ( vreg -- vn ) valid-vns get at ;
-: local-vn ( vn vreg -- lvn )
+: optimistic-vn ( default-vn vreg -- vn )
vregs>vns get ?at
[ nip ]
[ dupd vregs>vns get set-at ] if ;
-: set-vn ( vn vreg -- )
- [ local-vn ] keep
- vregs>gvns get maybe-set-at [ changed? on ] when ;
+: set-vn ( default-vn vreg -- )
+ [ optimistic-vn ] keep
+ valid-vns get maybe-set-at [ changed? on ] when ;
: vreg>insn ( vreg -- insn ) vreg>vn vn>insn ;
-: init-gvn ( -- )
- H{ } clone vregs>gvns set ;
+: clear-optimistic-value-graph ( -- )
+ vregs>vns get clear-assoc
+ exprs>vns get clear-assoc
+ vns>insns get clear-assoc ;
: init-value-graph ( -- )
0 input-expr-counter set
+ H{ } clone valid-vns set
H{ } clone vregs>vns set
H{ } clone exprs>vns set
H{ } clone vns>insns set ;
M: ##phi rewrite
[ dst>> ] [ inputs>> values [ vreg>vn ] map ] bi
dup sift
- dup all-equal? [
+ dup all-equal? [
nip
[ drop f ]
[ first <copy> ] if-empty
[ process-instruction ] map ;
: value-numbering-step ( insns -- insns' )
- init-value-graph
- ! [ process-instruction ] map flatten ;
+ [ process-instruction ] map flatten ;
- ! idea: let rewrite do the constant/copy propagation (as
- ! that eventually leads to better VNs), but don't actually
- ! use them here, since changing the CFG mid-optimistic-GVN
- ! won't be sound
- dup [ process-instruction drop ] each ;
+! XXX there's going to be trouble with certain rewrites that
+! modify the cfg / instructions destructively; namely those in
+! comparisons.factor, alien.factor, and slots.factor
: value-numbering-iteration ( cfg -- )
- [ value-numbering-step ] simple-optimization ;
+ clear-optimistic-value-graph
+ [ value-numbering-step drop ] simple-analysis ;
-: value-numbering ( cfg -- cfg )
- dup
- init-gvn
+: identify-redundancies ( cfg -- )
+ init-value-graph
'[
changed? off
_ value-numbering-iteration
changed? get
- ] loop
+ ] loop ;
- dup [ init-value-graph [ process-instruction ] map flatten ] simple-optimization
+: eliminate-redundancies ( cfg -- )
+ clear-optimistic-value-graph
+ [ value-numbering-step ] simple-optimization ;
+
+: value-numbering ( cfg -- cfg )
+ dup identify-redundancies
+ dup eliminate-redundancies
cfg-changed predecessors-changed ;
M: integer-expr expr>str value>> number>string ;
-M: reference-expr expr>str value>> number>string "&" prepend ;
+M: reference-expr expr>str value>> unparse ;
M: object expr>str [ unparse ] map " " join ;
drop "%d -> <%d>\\l" sprintf
] if ;
-: lvns ( -- str )
+: optimistic ( -- str )
vregs>vns get >alist natural-sort [
first2 local-value-mapping
] map "" concat-as ;
[ push-at ] curry assoc-each
] keep ;
-: gvns ( -- str )
- vregs>gvns get invert-assoc >alist natural-sort [
+: valid ( -- str )
+ valid-vns get invert-assoc >alist natural-sort [
first2
natural-sort [ number>string ] map ", " join
"<%d> : {%s}\\l" sprintf
: basic-block# ( -- n )
basic-block get number>> ;
-: add-gvns ( graph -- graph' )
+: add-valid-vns ( graph -- graph' )
<anon>
- "gvns" add-node[ gvns =label "plaintext" =shape ];
- "gvns" 0 add-edge[ "invis" =style ];
+ "valid" add-node[ valid =label "plaintext" =shape ];
+ "valid" 0 add-edge[ "invis" =style ];
add ;
-: add-lvns ( graph -- graph' )
- "lvn" <cluster>
+: add-optimistic-vns ( graph -- graph' )
+ "opt" <cluster>
"invis" =style
- "lvns" add-node[ lvns =label "plaintext" =shape ];
+ "opt" add-node[ optimistic =label "plaintext" =shape ];
basic-block# add-node[ "bold" =style ];
add ;
: draw-annotated-cfg ( -- )
iteration-dir [
- cfg get cfgviz add-gvns add-lvns
+ cfg get cfgviz add-valid-vns add-optimistic-vns
basic-block# number>string "bb" prepend png
] with-directory ;