compiler.cfg.stacks.local: to simplify, end-local-analysis can take the block it operates on as argument

basis/compiler/cfg/builder/blocks/blocks.factor

@@ -12,7 +12,7 @@ IN: compiler.cfg.builder.blocks
     begin-local-analysis ;
 
 : end-basic-block ( -- )
-    basic-block get [ end-local-analysis ] when
+    basic-block get [ end-local-analysis ] when*
     building off
     basic-block off ;
 
@@ -20,7 +20,7 @@ IN: compiler.cfg.builder.blocks
     <basic-block> basic-block get [ over connect-bbs ] when* set-basic-block ;
 
 : begin-basic-block ( -- )
-    basic-block get [ end-local-analysis ] when
+    basic-block get [ end-local-analysis ] when*
     (begin-basic-block) ;
 
 : emit-trivial-block ( quot -- )
@@ -50,7 +50,7 @@ IN: compiler.cfg.builder.blocks
         ##branch,
         end-local-analysis
         height-state get clone-height-state 2array
-    ] when ;
+    ] when* ;
 
 : with-branch ( quot -- pair/f )
     [ begin-branch call end-branch ] with-scope ; inline

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

@@ -1,9 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs combinators compiler.cfg.dataflow-analysis
-compiler.cfg.stacks.local kernel ;
+compiler.cfg.stacks.local kernel namespaces ;
 IN: compiler.cfg.stacks.global
 
+: peek-set ( bb -- assoc ) peek-sets get at ;
+: replace-set ( bb -- assoc ) replace-sets get at ;
+: kill-set ( bb -- assoc ) kill-sets get at ;
+
 : transfer-peeked-locs ( assoc bb -- assoc' )
     [ replace-set assoc-diff ] [ peek-set assoc-union ] bi ;
 

basis/compiler/cfg/stacks/local/local-tests.factor

@@ -1,9 +1,41 @@
 USING: accessors assocs biassocs combinators compiler.cfg
 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.stacks
 compiler.cfg.stacks.height compiler.cfg.stacks.local compiler.cfg.utilities
-compiler.test cpu.architecture namespaces kernel tools.test ;
+compiler.test cpu.architecture make namespaces kernel tools.test ;
 IN: compiler.cfg.stacks.local.tests
 
+! loc>vreg
+{ 1 } [
+    D 0 loc>vreg
+] cfg-unit-test
+
+! stack-changes
+{
+    {
+        T{ ##copy { dst 1 } { src 25 } { rep any-rep } }
+        T{ ##copy { dst 2 } { src 26 } { rep any-rep } }
+    }
+} [
+    { { D 0 25 } { R 0 26 } } stack-changes
+] cfg-unit-test
+
+! replace-loc
+{ 80 } [
+    80 D 77 replace-loc
+    D 77 peek-loc
+] cfg-unit-test
+
+! end-local-analysis
+{
+    H{ }
+    H{ }
+    H{ }
+} [
+    "foo" [ "eh" , end-local-analysis ] V{ } make drop
+    "foo" [ peek-sets ] [ replace-sets ] [ kill-sets ] tri [ get at ] 2tri@
+] cfg-unit-test
+
+! height-state
 {
     { { 3 3 } { 0 0 } }
 } [
@@ -23,23 +55,7 @@ IN: compiler.cfg.stacks.local.tests
     { { 0 4  } { 0 -2 } } height-state>insns
 ] unit-test
 
-{ 1 } [
-    D 0 loc>vreg
-] cfg-unit-test
 
-{
-    {
-        T{ ##copy { dst 1 } { src 25 } { rep any-rep } }
-        T{ ##copy { dst 2 } { src 26 } { rep any-rep } }
-    }
-} [
-    { { D 0 25 } { R 0 26 } } stack-changes
-] cfg-unit-test
-
-{ 80 } [
-    80 D 77 replace-loc
-    D 77 peek-loc
-] cfg-unit-test
 
 { H{ { D -1 40 } } } [
     D 1 inc-stack 40 D 0 replace-loc replace-mapping get

basis/compiler/cfg/stacks/local/local.factor

@@ -84,15 +84,9 @@ SYMBOLS: local-peek-set local-replace-set replace-mapping ;
     replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
     [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
 
-: end-local-analysis ( -- )
+: end-local-analysis ( basic-block -- )
     remove-redundant-replaces
     emit-changes
-    basic-block get {
-        [ [ local-peek-set get ] dip peek-sets get set-at ]
-        [ [ local-replace-set get ] dip replace-sets get set-at ]
-        [ [ compute-local-kill-set ] dip kill-sets get set-at ]
-    } cleave ;
-
-: peek-set ( bb -- assoc ) peek-sets get at ;
-: replace-set ( bb -- assoc ) replace-sets get at ;
-: kill-set ( bb -- assoc ) kill-sets get at ;
+    [ [ local-peek-set get ] dip peek-sets get set-at ]
+    [ [ local-replace-set get ] dip replace-sets get set-at ]
+    [ [ compute-local-kill-set ] dip kill-sets get set-at ] tri ;