Fixing various bugs; alias analysis wasn't handling ##phi nodes, stack analysis incorrectly handled height-changing back edges and ##fixnum-*, clean up ##dispatch generation

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -215,13 +215,7 @@ GENERIC: analyze-aliases* ( insn -- insn' )
 M: ##load-immediate analyze-aliases*
     dup [ val>> ] [ dst>> ] bi constants get set-at ;
 
-M: ##peek analyze-aliases*
+M: ##flushable analyze-aliases*
-    dup dst>> set-heap-ac ;
-
-M: ##load-reference analyze-aliases*
-    dup dst>> set-heap-ac ;
-
-M: ##alien-global analyze-aliases*
     dup dst>> set-heap-ac ;
 
 M: ##allocation analyze-aliases*
@@ -230,7 +224,7 @@ M: ##allocation analyze-aliases*
     dup dst>> set-new-ac ;
 
 M: ##read analyze-aliases*
-    dup dst>> set-heap-ac
+    call-next-method
     dup [ dst>> ] [ insn-slot# ] [ insn-object ] tri
     2dup live-slot dup [
         2nip f \ ##copy boa analyze-aliases* nip

basis/compiler/cfg/builder/builder.factor

@@ -159,63 +159,8 @@ M: #if emit-node
     } cond iterate-next ;
 
 ! #dispatch
-: trivial-dispatch-branch? ( nodes -- ? )
-    dup length 1 = [
-        first dup #call? [
-            word>> "intrinsic" word-prop not
-        ] [ drop f ] if
-    ] [ drop f ] if ;
-
-: dispatch-branch ( nodes word -- label )
-    over trivial-dispatch-branch? [
-        drop first word>>
-    ] [
-        gensym [
-            [
-                V{ } clone node-stack set
-                ##prologue
-                begin-basic-block
-                emit-nodes
-                basic-block get [
-                    ##epilogue
-                    ##return
-                    end-basic-block
-                ] when
-            ] with-cfg-builder
-        ] keep
-    ] if ;
-
-: dispatch-branches ( node -- )
-    children>> [
-        current-word get dispatch-branch
-        ##dispatch-label
-    ] each ;
-
-: emit-dispatch ( node -- )
-    ##epilogue
-    ds-pop ^^offset>slot i 0 ##dispatch
-    dispatch-branches ;
-
-! If a dispatch is not in tail position, we compile a new word where the dispatch is in
-! tail position, then call this word.
-
-: (non-tail-dispatch) ( -- word )
-    gensym dup t "inlined-block" set-word-prop ;
-
-: <non-tail-dispatch> ( node -- word )
-    current-word get (non-tail-dispatch) [
-        [
-            begin-word
-            emit-dispatch
-        ] with-cfg-builder
-    ] keep ;
-
 M: #dispatch emit-node
-    tail-call? [
+    ds-pop ^^offset>slot i ##dispatch emit-if iterate-next ;
-        emit-dispatch stop-iterating
-    ] [
-       <non-tail-dispatch> f emit-call
-    ] if ;
 
 ! #call
 M: #call emit-node

basis/compiler/cfg/checker/checker.factor

@@ -10,13 +10,13 @@ ERROR: last-insn-not-a-jump insn ;
 : check-last-instruction ( bb -- )
     peek dup {
         [ ##branch? ]
+        [ ##dispatch? ]
         [ ##conditional-branch? ]
         [ ##compare-imm-branch? ]
         [ ##return? ]
         [ ##callback-return? ]
         [ ##jump? ]
         [ ##call? ]
-        [ ##dispatch-label? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
 ERROR: bad-loop-entry ;

basis/compiler/cfg/instructions/instructions.factor

@@ -57,13 +57,12 @@ TUPLE: stack-frame
 spill-counts ;
 
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word height ;
+INSN: ##call word { height integer } ;
 INSN: ##jump word ;
 INSN: ##return ;
 
 ! Jump tables
-INSN: ##dispatch src temp offset ;
+INSN: ##dispatch src temp ;
-INSN: ##dispatch-label label ;
 
 ! Slot access
 INSN: ##slot < ##read { obj vreg } { slot vreg } { tag integer } { temp vreg } ;
@@ -165,7 +164,7 @@ UNION: ##allocation ##allot ##box-float ##box-alien ##integer>bignum ;
 
 INSN: ##write-barrier < ##effect card# table ;
 
-INSN: ##alien-global < ##read symbol library ;
+INSN: ##alien-global < ##flushable symbol library ;
 
 ! FFI
 INSN: ##alien-invoke params ;

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

@@ -1,14 +1,33 @@
 USING: arrays sequences tools.test compiler.cfg.checker compiler.cfg.debugger
-compiler.cfg.def-use sets kernel kernel.private fry slots.private ;
+compiler.cfg.def-use sets kernel kernel.private fry slots.private vectors
+sequences.private math sbufs math.private slots.private strings ;
 IN: compiler.cfg.optimizer.tests
 
 ! Miscellaneous tests
 
+: more? ( x -- ? ) ;
+
+: test-case-1 ( -- ? ) f ;
+
+: test-case-2 ( -- )
+    test-case-1 [ test-case-2 ] [ ] if ; inline recursive
+
 {
     [ 1array ]
     [ 1 2 ? ]
     [ { array } declare [ ] map ]
     [ { array } declare dup 1 slot [ 1 slot ] when ]
+    [ [ dup more? ] [ dup ] produce ]
+    [ vector new over test-case-1 [ test-case-2 ] [ ] if ]
+    [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
+    [
+        { fixnum sbuf } declare 2dup 3 slot fixnum> [
+            over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
+        ] [ ] if
+    ]
+    [ [ 2 fixnum* ] when 3 ]
+    [ [ 2 fixnum+ ] when 3 ]
+    [ [ 2 fixnum- ] when 3 ]
 } [
     [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
 ] each

basis/compiler/cfg/stack-analysis/stack-analysis.factor

@@ -91,7 +91,8 @@ UNION: neutral-insn
     ##branch
     ##loop-entry
     ##conditional-branch
-    ##compare-imm-branch ;
+    ##compare-imm-branch
+    ##dispatch ;
 
 M: neutral-insn visit , ;
 
@@ -130,22 +131,12 @@ M: ##copy visit
     [ call-next-method ] [ record-copy ] bi ;
 
 M: ##call visit
-    [ call-next-method ] [ height>> [ adjust-d ] [ poison-state ] if* ] bi ;
+    [ call-next-method ] [ height>> adjust-d ] bi ;
-
-M: ##fixnum-mul visit
-    call-next-method -1 adjust-d ;
-
-M: ##fixnum-add visit
-    call-next-method -1 adjust-d ;
-
-M: ##fixnum-sub visit
-    call-next-method -1 adjust-d ;
 
 ! Instructions that poison the stack state
 UNION: poison-insn
     ##jump
     ##return
-    ##dispatch
     ##callback-return
     ##fixnum-mul-tail
     ##fixnum-add-tail
@@ -179,8 +170,6 @@ M: ##alien-indirect visit
 
 M: ##alien-callback visit , ;
 
-M: ##dispatch-label visit , ;
-
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
@@ -245,7 +234,8 @@ ERROR: cannot-merge-poisoned states ;
         [
             drop
             dup [ not ] any? [
-                2drop <state>
+                [ <state> ] 2dip
+                sift merge-heights
             ] [
                 dup [ poisoned?>> ] any? [
                     cannot-merge-poisoned

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

@@ -50,7 +50,7 @@ sequences compiler.cfg vectors arrays ;
 [ t ] [
     {
         T{ ##peek f V int-regs 1 D 0 }
-        T{ ##dispatch f V int-regs 1 V int-regs 2 0 }
+        T{ ##dispatch f V int-regs 1 V int-regs 2 }
     } dup test-value-numbering =
 ] unit-test
 

basis/compiler/codegen/codegen.factor

@@ -92,10 +92,8 @@ M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
 
 M: ##return generate-insn drop %return ;
 
-M: ##dispatch-label generate-insn label>> %dispatch-label ;
-
 M: ##dispatch generate-insn
-    [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
+    [ src>> register ] [ temp>> register ] bi %dispatch ;
 
 : >slot< ( insn -- dst obj slot tag )
     {

basis/cpu/architecture/architecture.factor

@@ -51,8 +51,7 @@ HOOK: %jump cpu ( word -- )
 HOOK: %jump-label cpu ( label -- )
 HOOK: %return cpu ( -- )
 
-HOOK: %dispatch cpu ( src temp offset -- )
+HOOK: %dispatch cpu ( src temp -- )
-HOOK: %dispatch-label cpu ( word -- )
 
 HOOK: %slot cpu ( dst obj slot tag temp -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )

basis/cpu/ppc/ppc.factor

@@ -124,16 +124,13 @@ M: ppc %jump ( word -- )
 M: ppc %jump-label ( label -- ) B ;
 M: ppc %return ( -- ) BLR ;
 
-M:: ppc %dispatch ( src temp offset -- )
+M:: ppc %dispatch ( src temp -- )
     0 temp LOAD32
-    4 offset + cells rc-absolute-ppc-2/2 rel-here
+    4 cells rc-absolute-ppc-2/2 rel-here
     temp temp src LWZX
     temp MTCTR
     BCTR ;
 
-M: ppc %dispatch-label ( word -- )
-    B{ 0 0 0 0 } % rc-absolute-cell rel-word ;
-
 :: (%slot) ( obj slot tag temp -- reg offset )
     temp slot obj ADD
     temp tag neg ; inline

basis/cpu/x86/32/32.factor

@@ -26,10 +26,10 @@ M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg-1 ECX ;
 M: x86.32 temp-reg-2 EDX ;
 
-M:: x86.32 %dispatch ( src temp offset -- )
+M:: x86.32 %dispatch ( src temp -- )
     ! Load jump table base.
     src HEX: ffffffff ADD
-    offset cells rc-absolute-cell rel-here
+    0 rc-absolute-cell rel-here
     ! Go
     src HEX: 7f [+] JMP
     ! Fix up the displacement above

basis/cpu/x86/64/64.factor

@@ -22,10 +22,10 @@ M: x86.64 ds-reg R14 ;
 M: x86.64 rs-reg R15 ;
 M: x86.64 stack-reg RSP ;
 
-M:: x86.64 %dispatch ( src temp offset -- )
+M:: x86.64 %dispatch ( src temp -- )
     ! Load jump table base.
     temp HEX: ffffffff MOV
-    offset cells rc-absolute-cell rel-here
+    0 rc-absolute-cell rel-here
     ! Add jump table base
     src temp ADD
     src HEX: 7f [+] JMP

basis/cpu/x86/x86.factor

@@ -79,9 +79,6 @@ M: x86 %return ( -- ) 0 RET ;
 : align-code ( n -- )
     0 <repetition> % ;
 
-M: x86 %dispatch-label ( word -- )
-    0 cell, rc-absolute-cell rel-word ;
-
 :: (%slot) ( obj slot tag temp -- op )
     temp slot obj [+] LEA
     temp tag neg [+] ; inline