compiler: cleanup cfg passes to have stack effect ( cfg -- )

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -67,8 +67,8 @@ M: insn compute-stack-frame* drop ;
     [ frame-required? get [ <stack-frame> ] [ drop f ] if ]
     bi ;
 
-: build-stack-frame ( cfg -- cfg )
+: build-stack-frame ( cfg -- )
     0 param-area-size set
     0 allot-area-size set
     cell allot-area-align set
-    dup compute-stack-frame >>stack-frame ;
+    [ compute-stack-frame ] keep stack-frame<< ;

basis/compiler/cfg/builder/builder-tests.factor

@@ -13,7 +13,13 @@ IN: compiler.cfg.builder.tests
 
 ! Just ensure that various CFGs build correctly.
 : unit-test-builder ( quot -- )
-    '[ _ test-builder [ [ optimize-cfg check-cfg ] with-cfg ] each ] [ ] swap unit-test ;
+    '[
+        _ test-builder [
+            [
+                [ optimize-cfg ] [ check-cfg ] bi
+            ] with-cfg
+        ] each
+    ] [ ] swap unit-test ;
 
 : blahblah ( nodes -- ? )
     { fixnum } declare [

basis/compiler/cfg/debugger/debugger.factor

@@ -30,25 +30,25 @@ M: word test-builder
 : test-ssa ( quot -- cfgs )
     test-builder [
         [
-            optimize-cfg
+            dup optimize-cfg
         ] with-cfg
     ] map ;
 
 : test-flat ( quot -- cfgs )
     test-builder [
         [
-            optimize-cfg
+            dup optimize-cfg
-            select-representations
+            dup select-representations
-            insert-gc-checks
+            dup insert-gc-checks
-            insert-save-contexts
+            dup insert-save-contexts
         ] with-cfg
     ] map ;
 
 : test-regs ( quot -- cfgs )
     test-builder [
         [
-            optimize-cfg
+            dup optimize-cfg
-            finalize-cfg
+            dup finalize-cfg
         ] with-cfg
     ] map ;
 

basis/compiler/cfg/finalization/finalization.factor

@@ -4,16 +4,19 @@ USING: kernel compiler.cfg.representations
 compiler.cfg.scheduling compiler.cfg.gc-checks
 compiler.cfg.write-barrier compiler.cfg.save-contexts
 compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
-compiler.cfg.linear-scan compiler.cfg.stacks.vacant ;
+compiler.cfg.linear-scan compiler.cfg.stacks.vacant
+compiler.cfg.utilities ;
 IN: compiler.cfg.finalization
 
-: finalize-cfg ( cfg -- cfg' )
+: finalize-cfg ( cfg -- )
+    {
         select-representations
         schedule-instructions
         insert-gc-checks
         eliminate-write-barriers
-    dup compute-vacant-sets
+        compute-vacant-sets
         insert-save-contexts
         destruct-ssa
         linear-scan
-    build-stack-frame ;
+        build-stack-frame
+    } apply-passes ;

basis/compiler/cfg/gc-checks/gc-checks-docs.factor

@@ -5,7 +5,7 @@ IN: compiler.cfg.gc-checks
 <PRIVATE
 
 HELP: insert-gc-checks
-{ $values { "cfg" cfg } { "cfg'" cfg } }
+{ $values { "cfg" cfg }  }
 { $description "Inserts gc checks in each " { $link basic-block } " in the cfg where they are needed." } ;
 
 HELP: insert-gc-check?

basis/compiler/cfg/gc-checks/gc-checks-tests.factor

@@ -167,7 +167,7 @@ H{
     { 2 tagged-rep }
 } representations set
 
-[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ cfg get insert-gc-checks ] unit-test
 
 [ ] [ 1 get successors>> first successors>> first 2 set ] unit-test
 
@@ -222,7 +222,7 @@ H{
     { 3 tagged-rep }
 } representations set
 
-[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ cfg get insert-gc-checks ] unit-test
 [ ] [ 1 get successors>> first successors>> first 3 set ] unit-test
 [ t ] [ 2 get successors>> first instructions>> first ##phi? ] unit-test
 [ 2 ] [ 3 get instructions>> length ] unit-test
@@ -248,7 +248,7 @@ V{
 
 [ ] [ test-gc-checks ] unit-test
 
-[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ cfg get insert-gc-checks ] unit-test
 
 [ ] [
     0 get successors>> first predecessors>>
@@ -294,7 +294,7 @@ V{
 
 [ ] [ test-gc-checks ] unit-test
 
-[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ cfg get insert-gc-checks ] unit-test
 
 ! The GC check should come after the alien-invoke
 [
@@ -330,7 +330,7 @@ V{
 
 [ ] [ test-gc-checks ] unit-test
 
-[ ] [ cfg get insert-gc-checks drop ] unit-test
+[ ] [ cfg get insert-gc-checks ] unit-test
 
 [
     V{

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -127,9 +127,9 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
 
 PRIVATE>
 
-: insert-gc-checks ( cfg -- cfg' )
+:: insert-gc-checks ( cfg -- )
-    dup blocks-with-gc [
+    cfg blocks-with-gc [
-        [ dup needs-predecessors ] dip
+        cfg needs-predecessors
         [ process-block ] each
-        dup cfg-changed
+        cfg cfg-changed
     ] unless-empty ;

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

@@ -43,5 +43,5 @@ IN: compiler.cfg.linear-scan
         [ [ frame-reg = not ] filter ] assoc-map
     ] when ;
 
-: linear-scan ( cfg -- cfg' )
+: linear-scan ( cfg -- )
-    dup dup admissible-registers (linear-scan) ;
+    dup admissible-registers (linear-scan) ;

basis/compiler/cfg/linearization/linearization.factor

@@ -75,12 +75,17 @@ SYMBOLS: work-list loop-heads visited ;
 PRIVATE>
 
 : linearization-order ( cfg -- bbs )
-    needs-post-order needs-loops dup needs-predecessors
+    {
-
+        [ needs-post-order ]
+        [ needs-loops ]
+        [ needs-predecessors ]
+        [
             dup linear-order>> [ ] [
                 dup (linearization-order)
                 >>linear-order linear-order>>
-    ] ?if ;
+            ] ?if
+        ]
+    } cleave ;
 
 SYMBOL: numbers
 

basis/compiler/cfg/loop-detection/loop-detection-tests.factor

@@ -11,7 +11,7 @@ V{ } 2 test-bb
 2 0 edge
 
 : test-loop-detection ( -- )
-    0 get block>cfg needs-loops drop ;
+    0 get block>cfg needs-loops ;
 
 [ ] [ test-loop-detection ] unit-test
 

basis/compiler/cfg/loop-detection/loop-detection.factor

@@ -77,6 +77,7 @@ PRIVATE>
 
 : current-loop-nesting ( -- n ) basic-block get loop-nesting-at ;
 
-: needs-loops ( cfg -- cfg' )
+: needs-loops ( cfg -- )
     dup needs-predecessors
-    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
+    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless
+    drop ;

basis/compiler/cfg/optimizer/optimizer.factor

@@ -15,8 +15,8 @@ compiler.cfg.value-numbering
 kernel sequences ;
 IN: compiler.cfg.optimizer
 
-: optimize-cfg ( cfg -- cfg' )
+: optimize-cfg ( cfg -- )
-    dup {
+    {
         optimize-tail-calls
         delete-useless-conditionals
         split-branches

basis/compiler/cfg/representations/representations-tests.factor

@@ -52,7 +52,7 @@ H{ } clone representations set
 ] unit-test
 
 : test-representations ( -- )
-    0 get block>cfg dup cfg set select-representations drop ;
+    0 get block>cfg dup cfg set select-representations ;
 
 ! Make sure cost calculation isn't completely wrong
 V{

basis/compiler/cfg/representations/representations.factor

@@ -18,9 +18,9 @@ IN: compiler.cfg.representations
 ! are made. The appropriate conversion operations inserted
 ! after a cost analysis.
 
-: select-representations ( cfg -- cfg' )
+: select-representations ( cfg -- )
+    {
         needs-loops
-    dup {
         needs-predecessors
         compute-components
         compute-possibilities

basis/compiler/cfg/rpo/rpo.factor

@@ -49,5 +49,5 @@ IN: compiler.cfg.rpo
 : simple-analysis ( ... cfg quot: ( ... insns -- ... ) -- ... )
     '[ _ analyze-basic-block ] each-basic-block ; inline
 
-: needs-post-order ( cfg -- cfg' )
+: needs-post-order ( cfg -- )
-    dup post-order drop ;
+    post-order drop ;

basis/compiler/cfg/save-contexts/save-contexts-docs.factor

@@ -2,7 +2,7 @@ USING: compiler.cfg compiler.cfg.instructions help.markup help.syntax ;
 IN: compiler.cfg.save-contexts
 
 HELP: insert-save-contexts
-{ $values { "cfg" cfg } { "cfg'" cfg } }
+{ $values { "cfg" cfg } }
 { $description "Inserts " { $link ##save-context } " instructions in each " { $link basic-block } " in the cfg that needs them. Save contexts are needed after instructions that modify the context, or instructions that read parameter registers." }
 { $see-also needs-save-context? } ;
 

basis/compiler/cfg/save-contexts/save-contexts.factor

@@ -43,5 +43,5 @@ M: insn modifies-context? drop f ;
         [ insert-nth ] change-instructions drop
     ] [ drop ] if ;
 
-: insert-save-contexts ( cfg -- cfg' )
+: insert-save-contexts ( cfg -- )
-    dup [ insert-save-context ] each-basic-block ;
+    [ insert-save-context ] each-basic-block ;

basis/compiler/cfg/scheduling/scheduling-docs.factor

@@ -2,5 +2,5 @@ USING: compiler.cfg compiler.cfg.height help.markup help.syntax sequences ;
 IN: compiler.cfg.scheduling
 
 HELP: schedule-instructions
-{ $values { "cfg" cfg } { "cfg'" cfg } }
+{ $values { "cfg" cfg } }
 { $description "Performs a instruction scheduling optimization pass over the CFG to attempt to reduce the number of spills. The step must be performed after " { $link normalize-height } " or else invalid peeks might be inserted into the CFG." } ;

basis/compiler/cfg/scheduling/scheduling-tests.factor

@@ -55,7 +55,7 @@ IN: compiler.cfg.scheduling.tests
         T{ ##load-tagged }
         T{ ##allot }
         T{ ##set-slot-imm }
-    } insns>cfg schedule-instructions cfg>insns [ insn#>> ] all?
+    } insns>cfg dup schedule-instructions cfg>insns [ insn#>> ] all?
 ] unit-test
 
 : test-1187 ( -- insns )

basis/compiler/cfg/scheduling/scheduling.factor

@@ -71,8 +71,10 @@ conditional-branch-insn
 : schedule-block ( bb -- )
     [ reorder ] change-instructions drop ;
 
-! TODO: stack effect should be ( cfg -- )
+: schedule-instructions ( cfg --  )
-: schedule-instructions ( cfg --  cfg' )
+    [ number-instructions ]
-    dup number-instructions
+    [
-    dup reverse-post-order [ kill-block?>> not ] filter
+        reverse-post-order
-    [ schedule-block ] each ;
+        [ kill-block?>> not ] filter
+        [ schedule-block ] each
+    ] bi ;

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

@@ -1,8 +1,7 @@
 ! Copyright (C) 2009, 2011 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs fry locals kernel make
+USING: accessors arrays assocs combinators fry locals kernel
-namespaces sequences sequences.deep
+make namespaces sequences sequences.deep sets vectors
-sets vectors
 cpu.architecture
 compiler.cfg.rpo
 compiler.cfg.def-use
@@ -153,14 +152,16 @@ M: insn cleanup-insn , ;
 
 PRIVATE>
 
-: destruct-ssa ( cfg -- cfg' )
+: destruct-ssa ( cfg -- )
-    dup needs-dominance
+    {
-    dup construct-cssa
+        [ needs-dominance ]
-    dup compute-defs
+        [ construct-cssa ]
-    dup compute-insns
+        [ compute-defs ]
-    dup compute-live-sets
+        [ compute-insns ]
-    dup compute-live-ranges
+        [ compute-live-sets ]
-    dup prepare-coalescing
+        [ compute-live-ranges ]
-    process-copies
+        [ prepare-coalescing ]
-    dup cleanup-cfg
+        [ drop process-copies ]
-    dup compute-live-sets ;
+        [ cleanup-cfg ]
+        [ compute-live-sets ]
+    } cleave ;

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -51,8 +51,7 @@ ERROR: bad-peek dst loc ;
 : visit-block ( bb -- )
     [ predecessors>> ] keep '[ _ visit-edge ] each ;
 
-: finalize-stack-shuffling ( cfg -- cfg' )
+: finalize-stack-shuffling ( cfg -- )
-    dup
     [ needs-predecessors ]
     [ [ visit-block ] each-basic-block ]
     [ cfg-changed ] tri ;

basis/compiler/cfg/stacks/global/global.factor

@@ -48,12 +48,11 @@ M: dead-analysis transfer-set
     [ replace-set assoc-union ] bi ;
 
 ! Main word
-: compute-global-sets ( cfg -- cfg' )
+: compute-global-sets ( cfg -- )
     {
         [ compute-anticip-sets ]
         [ compute-live-sets ]
         [ compute-pending-sets ]
         [ compute-dead-sets ]
         [ compute-avail-sets ]
-        [ ]
     } cleave ;

basis/compiler/cfg/stacks/stacks.factor

@@ -18,9 +18,8 @@ IN: compiler.cfg.stacks
 
 : end-stack-analysis ( -- )
     cfg get
-    compute-global-sets
+    [ compute-global-sets ]
-    finalize-stack-shuffling
+    [ finalize-stack-shuffling ] bi ;
-    drop ;
 
 : ds-drop ( -- ) -1 inc-d ;
 

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -2748,9 +2748,9 @@ test-diamond
 
 [ ] [
     0 get block>cfg dup cfg set
-    dup value-numbering
+    [ value-numbering ]
-    select-representations
+    [ select-representations ]
-    destruct-ssa drop
+    [ destruct-ssa ] tri
 ] unit-test
 
 [ 1 ] [ 1 get successors>> length ] unit-test

basis/compiler/cfg/write-barrier/write-barrier.factor

@@ -60,5 +60,5 @@ M: insn eliminate-write-barrier drop t ;
     H{ } clone copies set
     [ eliminate-write-barrier ] filter! ;
 
-: eliminate-write-barriers ( cfg -- cfg )
+: eliminate-write-barriers ( cfg -- )
-    dup [ write-barriers-step ] simple-optimization ;
+    [ write-barriers-step ] simple-optimization ;

basis/compiler/compiler.factor

@@ -128,8 +128,10 @@ M: word combinator? inline? ;
 : backend ( tree word -- )
     build-cfg [
         [
-            optimize-cfg finalize-cfg
+            [ optimize-cfg ]
-            [ generate ] [ label>> ] bi compiled get set-at
+            [ finalize-cfg ]
+            [ [ generate ] [ label>> ] bi compiled get set-at ]
+            tri
         ] with-cfg
     ] each ;
 

basis/compiler/tests/low-level-ir.factor

@@ -1,4 +1,4 @@
-USING: accessors assocs compiler compiler.cfg
+USING: accessors assocs combinators compiler compiler.cfg
 compiler.cfg.debugger compiler.cfg.instructions
 compiler.cfg.registers compiler.cfg.linear-scan
 compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
@@ -8,16 +8,18 @@ literals math arrays alien.c-types alien.syntax math.private ;
 IN: compiler.tests.low-level-ir
 
 : compile-cfg ( cfg -- word )
-    gensym
+    gensym [
-    [ linear-scan build-stack-frame generate ] dip
+        [ linear-scan ] [ build-stack-frame ] [ generate ] tri
+    ] dip
     [ associate >alist t t modify-code-heap ] keep ;
 
 : compile-test-cfg ( -- word )
-    0 get block>cfg
+    0 get block>cfg {
-    dup cfg set
+        [ cfg set ]
-    dup fake-representations
+        [ fake-representations ]
-    destruct-ssa
+        [ destruct-ssa ]
-    compile-cfg ;
+        [ compile-cfg ]
+    } cleave ;
 
 : compile-test-bb ( insns -- result )
     V{ T{ ##prologue } T{ ##branch } } [ clone ] map 0 test-bb

extra/compiler/cfg/graphviz/graphviz.factor

@@ -54,8 +54,8 @@ IN: compiler.cfg.graphviz
             [ add-cfg-vertex ] [ add-cfg-edges ] bi
         ] each-basic-block ;
 
-: perform-pass ( cfg pass pass# -- cfg' )
+: perform-pass ( cfg pass pass# -- )
-    drop def>> call( cfg -- cfg' ) ;
+    drop def>> call( cfg -- ) ;
 
 : draw-cfg ( cfg pass pass# -- cfg )
     [ dup cfgviz ]
@@ -66,7 +66,7 @@ IN: compiler.cfg.graphviz
 SYMBOL: passes
 
 : watch-pass ( cfg pass pass# -- cfg' )
-    [ perform-pass ] 2keep draw-cfg ;
+    [ perform-pass ] 3keep draw-cfg ;
 
 : begin-watching-passes ( cfg -- cfg )
     \ build-cfg 0 draw-cfg ;

extra/compiler/cfg/gvn/gvn.factor

@@ -118,8 +118,8 @@ M: insn gcse
     dup compute-avail-sets
     [ gcse-step ] simple-optimization ;
 
-: value-numbering ( cfg -- cfg )
+: value-numbering ( cfg -- )
-    dup {
+    {
         needs-predecessors
         determine-value-numbers
         eliminate-common-subexpressions