compiler.cfg: Minor optimization. Instructions can now only ever produce a single value; this eliminates 1array constructions and some iterations

basis/compiler/cfg/checker/checker.factor

@@ -59,7 +59,7 @@ ERROR: undefined-values uses defs ;
     ! Check that every used register has a definition
     instructions>>
     [ [ uses-vregs ] map concat ]
-    [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
+    [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
     2dup subset? [ 2drop ] [ undefined-values ] if ;
 
 : check-cfg ( cfg -- )

basis/compiler/cfg/def-use/def-use.factor

@@ -4,14 +4,14 @@ USING: accessors arrays kernel assocs sequences namespaces fry
 sets compiler.cfg.rpo compiler.cfg.instructions ;
 IN: compiler.cfg.def-use
 
-GENERIC: defs-vregs ( insn -- seq )
+GENERIC: defs-vreg ( insn -- vreg/f )
 GENERIC: temp-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-M: ##flushable defs-vregs dst>> 1array ;
-M: ##fixnum-overflow defs-vregs dst>> 1array ;
-M: _fixnum-overflow defs-vregs dst>> 1array ;
-M: insn defs-vregs drop f ;
+M: ##flushable defs-vreg dst>> ;
+M: ##fixnum-overflow defs-vreg dst>> ;
+M: _fixnum-overflow defs-vreg dst>> ;
+M: insn defs-vreg drop f ;
 
 M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
 M: ##unary/temp temp-vregs temp>> 1array ;
@@ -50,55 +50,48 @@ M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: _dispatch uses-vregs src>> 1array ;
 M: insn uses-vregs drop f ;
 
-! Computing def-use chains. We don't assume a program is in SSA form,
-! since SSA construction itself needs def-use information. defs-1
-! is only useful if the program is SSA.
-SYMBOLS: defs defs-1 insns uses ;
+! Computing def-use chains.
 
-: def-of ( vreg -- node ) defs-1 get at ;
-: defs-of ( vreg -- nodes ) defs get at ;
+SYMBOLS: defs insns uses ;
+
+: def-of ( vreg -- node ) defs get at ;
 : uses-of ( vreg -- nodes ) uses get at ;
 : insn-of ( vreg -- insn ) insns get at ;
 
-<PRIVATE
+: set-def-of ( obj insn assoc -- )
+    swap defs-vreg dup [ swap set-at ] [ 3drop ] if ;
 
-: finish-defs ( -- )
-    defs [ [ keys ] assoc-map ] change ;
-
-: finish-uses ( -- )
-    uses [ [ keys ] assoc-map ] change ;
-
-: (compute-def-use) ( cfg quot -- assoc )
+: compute-defs ( cfg -- )
     H{ } clone [
         '[
             dup instructions>> [
-                @ [
-                    _ conjoin-at
-                ] with each
+                _ set-def-of
             ] with each
         ] each-basic-block
     ] keep
-    [ keys ] assoc-map ; inline
-
-PRIVATE>
-
-: compute-defs ( cfg -- )
-    [ defs-vregs ] (compute-def-use)
-    [ defs set ] [ [ first ] assoc-map defs-1 set ] bi ;
-
-: compute-uses ( cfg -- )
-    [ uses-vregs ] (compute-def-use) uses set ;
+    defs set ;
 
 : compute-insns ( cfg -- )
     H{ } clone [
         '[
             instructions>> [
-                dup defs-vregs [
-                    _ set-at
-                ] with each
+                dup _ set-def-of
             ] each
         ] each-basic-block
     ] keep insns set ;
 
+: compute-uses ( cfg -- )
+    H{ } clone [
+        '[
+            dup instructions>> [
+                uses-vregs [
+                    _ conjoin-at
+                ] with each
+            ] with each
+        ] each-basic-block
+    ] keep
+    [ keys ] assoc-map
+    uses set ;
+
 : compute-def-use ( cfg -- )
     [ compute-defs ] [ compute-uses ] [ compute-insns ] tri ;

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -86,7 +86,9 @@ GENERIC: assign-registers-in-insn ( insn -- )
     [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
 
 : all-vregs ( insn -- vregs )
-    [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
+    [ [ temp-vregs ] [ uses-vregs ] bi append ]
+    [ defs-vreg ] bi
+    [ suffix ] when* ;
 
 SYMBOL: check-assignment?
 

basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -98,7 +98,7 @@ M: insn compute-live-intervals* drop ;
 M: vreg-insn compute-live-intervals*
     dup insn#>>
     live-intervals get
-    [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
+    [ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ]
     [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
     [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
     3tri ;

basis/compiler/cfg/liveness/liveness.factor

@@ -13,7 +13,7 @@ BACKWARD-ANALYSIS: live
 GENERIC: insn-liveness ( live-set insn -- )
 
 : kill-defs ( live-set insn -- live-set )
-    defs-vregs [ over delete-at ] each ;
+    defs-vreg [ over delete-at ] when* ;
 
 : gen-uses ( live-set insn -- live-set )
     dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ;

basis/compiler/cfg/ssa/construction/construction.factor

@@ -26,6 +26,27 @@ IN: compiler.cfg.ssa.construction
 
 <PRIVATE
 
+! Maps vregs to sets of basic blocks
+SYMBOL: defs
+
+! Set of vregs defined in more than one basic block
+SYMBOL: defs-multi
+
+: compute-insn-defs ( bb insn -- )
+    defs-vreg dup [
+        defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 2tri
+        [ defs-multi get conjoin ] [ drop ] if
+    ] [ 2drop ] if ;
+
+: compute-defs ( cfg -- )
+    H{ } clone defs set
+    H{ } clone defs-multi set
+    [
+        dup instructions>> [
+            compute-insn-defs
+        ] with each
+    ] each-basic-block ;
+
 ! Maps basic blocks to sequences of vregs
 SYMBOL: inserting-phi-nodes
 
@@ -36,15 +57,11 @@ SYMBOL: inserting-phi-nodes
     ] [ 2drop ] if ;
 
 : compute-phi-nodes-for ( vreg bbs -- )
-    dup length 2 >= [
-        [
-            insert-phi-node-later
-        ] with merge-set-each
-    ] [ 2drop ] if ;
+    keys [ insert-phi-node-later ] with merge-set-each ;
 
 : compute-phi-nodes ( -- )
     H{ } clone inserting-phi-nodes set
-    defs get [ compute-phi-nodes-for ] assoc-each ;
+    defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ;
 
 : insert-phi-nodes-in ( phis bb -- )
     [ append ] change-instructions drop ;

basis/compiler/cfg/ssa/destruction/forest/forest.factor

@@ -10,7 +10,7 @@ TUPLE: dom-forest-node vreg bb children ;
 <PRIVATE
 
 : sort-vregs-by-bb ( vregs -- alist )
-    defs-1 get
+    defs get
     '[ dup _ at ] { } map>assoc
     [ [ second pre-of ] compare ] sort ;
 

basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs fry kernel namespaces sequences math
-compiler.cfg.def-use compiler.cfg.instructions
+arrays compiler.cfg.def-use compiler.cfg.instructions
 compiler.cfg.liveness compiler.cfg.rpo ;
 IN: compiler.cfg.ssa.destruction.live-ranges
 
@@ -11,8 +11,8 @@ IN: compiler.cfg.ssa.destruction.live-ranges
 
 SYMBOLS: local-def-indices local-kill-indices ;
 
-: record-defs ( n vregs -- )
-    local-def-indices get '[ _ set-at ] with each ;
+: record-def ( n vregs -- )
+    dup [ local-def-indices get set-at ] [ 2drop ] if ;
 
 : record-uses ( n vregs -- )
     local-kill-indices get '[ _ set-at ] with each ;
@@ -24,9 +24,9 @@ SYMBOLS: local-def-indices local-kill-indices ;
     ! this instruction and before the next one, ensuring that outputs
     ! interfere with inputs.
     2 *
-    [ swap defs-vregs record-defs ]
+    [ swap defs-vreg record-def ]
     [ swap uses-vregs record-uses ]
-    [ over def-is-use-insn? [ 1 + swap defs-vregs record-uses ] [ 2drop ] if ]
+    [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ]
     2tri ;
 
 SYMBOLS: def-indices kill-indices ;