compiler.cfg: if a block has an instruction that kills values it must be the only instruction in the block

basis/compiler/cfg/block-joining/block-joining.factor

@@ -8,20 +8,14 @@ IN: compiler.cfg.block-joining
 ! Joining blocks that are not calls and are connected by a single CFG edge.
 ! Predecessors must be recomputed after this. Also this pass does not
 ! update ##phi nodes and should therefore only run before stack analysis.
-
-: kill-vreg-block? ( bb -- ? )
-    instructions>> {
-        [ length 2 >= ]
-        [ penultimate kill-vreg-insn? ]
-    } 1&& ;
-
 : predecessor ( bb -- pred )
     predecessors>> first ; inline
 
 : join-block? ( bb -- ? )
     {
+        [ kill-block? not ]
         [ predecessors>> length 1 = ]
-        [ predecessor kill-vreg-block? not ]
+        [ predecessor kill-block? not ]
         [ predecessor successors>> length 1 = ]
         [ [ predecessor ] keep back-edge? not ]
     } 1&& ;

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

@@ -13,10 +13,16 @@ SYMBOL: spill-counts
 GENERIC: compute-stack-frame* ( insn -- )
 
 : request-stack-frame ( stack-frame -- )
+    frame-required? on
     stack-frame [ max-stack-frame ] change ;
 
-M: ##stack-frame compute-stack-frame*
+M: ##alien-invoke compute-stack-frame*
-    frame-required? on
+    stack-frame>> request-stack-frame ;
+
+M: ##alien-indirect compute-stack-frame*
+    stack-frame>> request-stack-frame ;
+
+M: ##alien-callback compute-stack-frame*
     stack-frame>> request-stack-frame ;
 
 M: ##call compute-stack-frame*
@@ -45,8 +51,6 @@ M: insn compute-stack-frame*
 
 GENERIC: insert-pro/epilogues* ( insn -- )
 
-M: ##stack-frame insert-pro/epilogues* drop ;
-
 M: ##prologue insert-pro/epilogues*
     drop frame-required? get [ stack-frame get _prologue ] when ;
 

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

@@ -1,12 +1,13 @@
 IN: compiler.cfg.builder.tests
-USING: tools.test kernel sequences
+USING: tools.test kernel sequences words sequences.private fry
-words sequences.private fry prettyprint alien alien.accessors
+prettyprint alien alien.accessors math.private compiler.tree.builder
-math.private compiler.tree.builder compiler.tree.optimizer
+compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
-compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
+compiler.cfg.predecessors compiler.cfg.checker arrays locals
-kernel.private math ;
+byte-arrays kernel.private math slots.private ;
 
 ! Just ensure that various CFGs build correctly.
-: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
+: unit-test-cfg ( quot -- )
+    '[ _ test-cfg [ compute-predecessors check-cfg ] each ] [ ] swap unit-test ;
 
 {
     [ ]
@@ -49,6 +50,8 @@ kernel.private math ;
     [ "int" f "malloc" { "int" } alien-invoke ]
     [ "int" { "int" } "cdecl" alien-indirect ]
     [ "int" { "int" } "cdecl" [ ] alien-callback ]
+    [ swap - + * ]
+    [ swap slot ]
 } [
     unit-test-cfg
 ] each

basis/compiler/cfg/builder/builder.factor

@@ -63,10 +63,15 @@ GENERIC: emit-node ( node -- )
     basic-block get successors>> push
     basic-block off ;
 
+: emit-trivial-block ( quot -- )
+    basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
+    call
+    ##branch begin-basic-block ; inline
+
 : emit-call ( word height -- )
     over loops get key?
     [ drop loops get at emit-loop-call ]
-    [ ##call ##branch begin-basic-block ]
+    [ [ ##call ] emit-trivial-block ]
     if ;
 
 ! #recursive
@@ -157,7 +162,7 @@ M: #shuffle emit-node
 
 ! #return
 M: #return emit-node
-    drop ##epilogue ##return ;
+    drop ##branch begin-basic-block ##epilogue ##return ;
 
 M: #return-recursive emit-node
     label>> id>> loops get key?
@@ -181,12 +186,10 @@ M: #terminate emit-node drop ##no-tco basic-block off ;
         [ return>> return-size >>return ]
         [ alien-parameters parameter-sizes drop >>params ] bi ;
 
-: alien-stack-frame ( params -- )
-    <alien-stack-frame> ##stack-frame ;
-
 : emit-alien-node ( node quot -- )
-    [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi
+    [
-    ##branch begin-basic-block ; inline
+        [ params>> dup <alien-stack-frame> ] dip call
+    ] emit-trivial-block ; inline
 
 M: #alien-invoke emit-node
     [ ##alien-invoke ] emit-alien-node ;

basis/compiler/cfg/checker/checker.factor

@@ -1,34 +1,51 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel compiler.cfg.instructions compiler.cfg.rpo
+USING: kernel combinators.short-circuit accessors math sequences sets
-compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.liveness
+assocs compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.def-use
-combinators.short-circuit accessors math sequences sets assocs ;
+compiler.cfg.linearization compiler.cfg.liveness
+compiler.cfg.utilities ;
 IN: compiler.cfg.checker
 
-ERROR: last-insn-not-a-jump insn ;
+ERROR: bad-kill-block bb ;
+
+: check-kill-block ( bb -- )
+    dup instructions>> first2
+    swap ##epilogue? [ [ ##return? ] [ ##callback-return? ] bi or ] [ ##branch? ] if
+    [ drop ] [ bad-kill-block ] if ;
+
+ERROR: last-insn-not-a-jump bb ;
 
 : check-last-instruction ( bb -- )
-    last dup {
+    dup instructions>> last {
         [ ##branch? ]
         [ ##dispatch? ]
         [ ##conditional-branch? ]
         [ ##compare-imm-branch? ]
-        [ ##return? ]
-        [ ##callback-return? ]
-        [ ##jump? ]
         [ ##fixnum-add? ]
         [ ##fixnum-sub? ]
         [ ##fixnum-mul? ]
         [ ##no-tco? ]
     } 1|| [ drop ] [ last-insn-not-a-jump ] if ;
 
-ERROR: bad-loop-entry ;
+ERROR: bad-loop-entry bb ;
 
 : check-loop-entry ( bb -- )
-    dup length 2 >= [
+    dup instructions>> dup length 2 >= [
         2 head* [ ##loop-entry? ] any?
-        [ bad-loop-entry ] when
+        [ bad-loop-entry ] [ drop ] if
-    ] [ drop ] if ;
+    ] [ 2drop ] if ;
+
+ERROR: bad-kill-insn bb ;
+
+: check-kill-instructions ( bb -- )
+    dup instructions>> [ kill-vreg-insn? ] any?
+    [ bad-kill-insn ] [ drop ] if ;
+
+: check-normal-block ( bb -- )
+    [ check-loop-entry ]
+    [ check-last-instruction ]
+    [ check-kill-instructions ]
+    tri ;
 
 ERROR: bad-successors ;
 
@@ -37,10 +54,9 @@ ERROR: bad-successors ;
     [ bad-successors ] unless ;
 
 : check-basic-block ( bb -- )
-    [ instructions>> check-last-instruction ]
+    [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ]
-    [ instructions>> check-loop-entry ]
     [ check-successors ]
-    tri ;
+    bi ;
 
 ERROR: bad-live-in ;
 

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

@@ -2,6 +2,7 @@ IN: compiler.cfg.dcn.tests
 USING: tools.test kernel accessors namespaces assocs
 cpu.architecture vectors sequences
 compiler.cfg
+compiler.cfg.utilities
 compiler.cfg.debugger
 compiler.cfg.registers
 compiler.cfg.predecessors

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

@@ -9,6 +9,7 @@ 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: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
@@ -47,18 +48,3 @@ M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: _dispatch uses-vregs src>> 1array ;
 M: insn uses-vregs drop f ;
-
-! Instructions that use vregs
-UNION: vreg-insn
-##flushable
-##write-barrier
-##dispatch
-##effect
-##fixnum-overflow
-##conditional-branch
-##compare-imm-branch
-##phi
-##gc
-_conditional-branch
-_compare-imm-branch
-_dispatch ;

basis/compiler/cfg/instructions/instructions.factor

@@ -52,7 +52,6 @@ INSN: ##inc-d { n integer } ;
 INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
-INSN: ##stack-frame stack-frame ;
 INSN: ##call word { height integer } ;
 INSN: ##jump word ;
 INSN: ##return ;
@@ -160,9 +159,9 @@ INSN: ##write-barrier < ##effect card# table ;
 INSN: ##alien-global < ##flushable symbol library ;
 
 ! FFI
-INSN: ##alien-invoke params ;
+INSN: ##alien-invoke params stack-frame ;
-INSN: ##alien-indirect params ;
+INSN: ##alien-indirect params stack-frame ;
-INSN: ##alien-callback params ;
+INSN: ##alien-callback params stack-frame ;
 INSN: ##callback-return params ;
 
 ! Instructions used by CFG IR only.
@@ -230,16 +229,23 @@ INSN: _reload dst class n ;
 INSN: _copy dst src class ;
 INSN: _spill-counts counts ;
 
-! Instructions that poison the stack state
+! Instructions that use vregs
-UNION: poison-insn
+UNION: vreg-insn
-    ##jump
+    ##flushable
-    ##return
+    ##write-barrier
-    ##callback-return ;
+    ##dispatch
+    ##effect
+    ##fixnum-overflow
+    ##conditional-branch
+    ##compare-imm-branch
+    ##phi
+    ##gc
+    _conditional-branch
+    _compare-imm-branch
+    _dispatch ;
 
 ! Instructions that kill all live vregs
 UNION: kill-vreg-insn
-    poison-insn
-    ##stack-frame
     ##call
     ##prologue
     ##epilogue

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

@@ -26,19 +26,14 @@ SYMBOL: global-optimization?
         [ 2drop ] [ state get untranslate-loc ##replace ] if
     ] each ;
 
-ERROR: poisoned-state state ;
-
 : sync-state ( -- )
     state get {
-        [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
         [ ds-height>> save-ds-height ]
         [ rs-height>> save-rs-height ]
         [ save-changed-locs ]
         [ clear-state ]
     } cleave ;
 
-: poison-state ( -- ) state get t >>poisoned? drop ;
-
 ! Abstract interpretation
 GENERIC: visit ( insn -- )
 
@@ -87,7 +82,11 @@ M: ##replace visit
 M: ##copy visit
     [ call-next-method ] [ record-copy ] bi ;
 
-M: poison-insn visit call-next-method poison-state ;
+M: ##jump visit sync-state , ;
+
+M: ##return visit sync-state , ;
+
+M: ##callback-return visit sync-state , ;
 
 M: kill-vreg-insn visit sync-state , ;
 

basis/compiler/cfg/utilities/utilities.factor

@@ -33,11 +33,16 @@ IN: compiler.cfg.utilities
     building off
     basic-block off ;
 
+: emit-trivial-block ( quot -- )
+    basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
+    call
+    ##branch begin-basic-block ; inline
+
 : call-height ( #call -- n )
     [ out-d>> length ] [ in-d>> length ] bi - ;
 
 : emit-primitive ( node -- )
-    [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
+    [ [ word>> ] [ call-height ] bi ##call ] emit-trivial-block ;
 
 : with-branch ( quot -- final-bb )
     [