Working on global optimizations

basis/compiler/cfg/builder/builder.factor

@@ -81,30 +81,33 @@ GENERIC: emit-node ( node -- next )
     basic-block get successors>> push
     stop-iterating ;
 
-: emit-call ( word -- next )
+: emit-call ( word height -- next )
     {
-        { [ dup loops get key? ] [ loops get at local-recursive-call ] }
+        { [ over loops get key? ] [ drop loops get at local-recursive-call ] }
         { [ tail-call? not ] [ ##call ##branch begin-basic-block iterate-next ] }
-        { [ dup current-label get eq? ] [ drop first-basic-block get local-recursive-call ] }
-        [ ##epilogue ##jump stop-iterating ]
+        { [ dup current-label get eq? ] [ 2drop first-basic-block get local-recursive-call ] }
+        [ drop ##epilogue ##jump stop-iterating ]
     } cond ;
 
 ! #recursive
-: compile-recursive ( node -- next )
-    [ label>> id>> emit-call ]
+: recursive-height ( #recursive -- n )
+    [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
+
+: emit-recursive ( #recursive -- next )
+    [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 
 : remember-loop ( label -- )
     basic-block get swap loops get set-at ;
 
-: compile-loop ( node -- next )
+: emit-loop ( node -- next )
     ##loop-entry
     begin-basic-block
     [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi
     iterate-next ;
 
 M: #recursive emit-node
-    dup label>> loop?>> [ compile-loop ] [ compile-recursive ] if ;
+    dup label>> loop?>> [ emit-loop ] [ emit-recursive ] if ;
 
 ! #if
 : emit-branch ( obj -- final-bb )
@@ -191,28 +194,34 @@ M: #if emit-node
     ds-pop ^^offset>slot i 0 ##dispatch
     dispatch-branches ;
 
-: <dispatch-block> ( -- word )
+! 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? [
         emit-dispatch stop-iterating
     ] [
-        current-word get <dispatch-block> [
-            [
-                begin-word
-                emit-dispatch
-            ] with-cfg-builder
-        ] keep emit-call
+       <non-tail-dispatch> f emit-call
     ] if ;
 
 ! #call
 M: #call emit-node
     dup word>> dup "intrinsic" word-prop
-    [ emit-intrinsic ] [ nip emit-call ] if ;
+    [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 
 ! #call-recursive
-M: #call-recursive emit-node label>> id>> emit-call ;
+M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 
 ! #push
 M: #push emit-node

basis/compiler/cfg/cfg.factor

@@ -10,6 +10,8 @@ number
 { successors vector }
 { predecessors vector } ;
 
+M: basic-block hashcode* nip id>> ;
+
 : <basic-block> ( -- basic-block )
     basic-block new
         V{ } clone >>instructions

basis/compiler/cfg/copy-prop/copy-prop.factor

@@ -6,7 +6,7 @@ IN: compiler.cfg.copy-prop
 SYMBOL: copies
 
 : resolve ( vreg -- vreg )
-    dup copies get at swap or ;
+    [ copies get at ] keep or ;
 
 : record-copy ( insn -- )
     [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline

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

@@ -43,6 +43,7 @@ M: _conditional-branch uses-vregs [ src1>> ] [ src2>> ] bi 2array ;
 M: _compare-imm-branch uses-vregs src1>> 1array ;
 M: insn uses-vregs drop f ;
 
+! Instructions that use vregs
 UNION: vreg-insn
 ##flushable
 ##write-barrier

basis/compiler/cfg/dominance/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/compiler/cfg/dominance/dominance.factor

@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators compiler.cfg.rpo
+compiler.cfg.stack-analysis fry kernel math.order namespaces
+sequences ;
+IN: compiler.cfg.dominance
+
+! Reference:
+
+! A Simple, Fast Dominance Algorithm
+! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy
+! http://www.cs.rice.edu/~keith/EMBED/dom.pdf
+
+SYMBOL: idoms
+
+: idom ( bb -- bb' ) idoms get at ;
+
+<PRIVATE
+
+: set-idom ( idom bb -- changed? ) idoms get maybe-set-at ;
+
+: intersect ( finger1 finger2 -- bb )
+    2dup [ number>> ] compare {
+        { +lt+ [ [ idom ] dip intersect ] }
+        { +gt+ [ idom intersect ] }
+        [ 2drop ]
+    } case ;
+
+: compute-idom ( bb -- idom )
+    predecessors>> [ idom ] map sift
+    [ ] [ intersect ] map-reduce ;
+
+: iterate ( rpo -- changed? )
+    [ [ compute-idom ] keep set-idom ] map [ ] any? ;
+
+PRIVATE>
+
+: compute-dominance ( cfg -- cfg )
+    H{ } clone idoms set
+    dup entry>> reverse-post-order
+    unclip dup set-idom drop '[ _ iterate ] loop ;

basis/compiler/cfg/instructions/instructions.factor

@@ -57,7 +57,7 @@ TUPLE: stack-frame
 spill-counts ;
 
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word ;
+INSN: ##call word height ;
 INSN: ##jump word ;
 INSN: ##return ;
 

basis/compiler/cfg/stack-analysis/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

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

@@ -0,0 +1,238 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs kernel namespaces math sequences fry deques
+search-deques dlists sets make combinators compiler.cfg.copy-prop
+compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.rpo ;
+IN: compiler.cfg.stack-analysis
+
+! Convert stack operations to register operations
+
+! If 'poisoned' is set, disregard height information. This is set if we don't have
+! height change information for an instruction.
+TUPLE: state locs>vregs vregs>locs changed-locs d-height r-height poisoned? ;
+
+: <state> ( -- state )
+    state new
+        H{ } clone >>locs>vregs
+        H{ } clone >>vregs>locs
+        H{ } clone >>changed-locs
+        0 >>d-height
+        0 >>r-height ;
+
+M: state clone
+    call-next-method
+        [ clone ] change-locs>vregs
+        [ clone ] change-vregs>locs
+        [ clone ] change-changed-locs ;
+
+: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ;
+
+: record-peek ( dst loc -- )
+    state get
+    [ locs>vregs>> set-at ]
+    [ swapd vregs>locs>> set-at ]
+    3bi ;
+
+: delete-old-vreg ( loc -- )
+    state get locs>vregs>> at [ state get vregs>locs>> delete-at ] when* ;
+
+: changed-loc ( loc -- )
+    state get changed-locs>> conjoin ;
+
+: redundant-replace? ( src loc -- ? )
+    loc>vreg = ;
+
+: record-replace ( src loc -- )
+    ! Locs are not single assignment, which means we have to forget
+    ! that the previous vreg, if any, points at this loc. Also, record
+    ! that the loc changed so that all the right ##replace instructions
+    ! are emitted at a sync point.
+    2dup redundant-replace? [ 2drop ] [
+        dup delete-old-vreg dup changed-loc record-peek
+    ] if ;
+
+: save-changed-locs ( state -- )
+    [ changed-locs>> ] [ locs>vregs>> ] bi '[
+        _ at swap 2dup redundant-replace?
+        [ 2drop ] [ ##replace ] if
+    ] assoc-each ;
+
+: clear-state ( state -- )
+    {
+        [ 0 >>d-height drop ]
+        [ 0 >>r-height drop ]
+        [ changed-locs>> clear-assoc ]
+        [ locs>vregs>> clear-assoc ]
+        [ vregs>locs>> clear-assoc ]
+    } cleave ;
+
+: sync-state ( -- )
+    ! also: update height
+    ! but first, sync outputs
+    state get {
+        [ save-changed-locs ]
+        [ d-height>> dup 0 = [ drop ] [ ##inc-d ] if ]
+        [ r-height>> dup 0 = [ drop ] [ ##inc-r ] if ]
+        [ clear-state ]
+    } cleave ;
+
+: poison-state ( -- ) state get t >>poisoned? drop ;
+
+GENERIC: translate-loc ( loc -- loc' )
+
+M: ds-loc translate-loc n>> state get d-height>> + <ds-loc> ;
+
+M: rs-loc translate-loc n>> state get r-height>> + <rs-loc> ;
+
+! Abstract interpretation
+GENERIC: visit ( insn -- )
+
+! Instructions which don't have any effect on the stack
+UNION: neutral-insn
+    ##flushable
+    ##effect
+    ##branch
+    ##loop-entry
+    ##conditional-branch ;
+
+M: neutral-insn visit , ;
+
+: adjust-d ( n -- ) state get [ + ] change-d-height drop ;
+
+M: ##inc-d visit n>> adjust-d ;
+
+: adjust-r ( n -- ) state get [ + ] change-r-height drop ;
+
+M: ##inc-r visit n>> adjust-r ;
+
+: eliminate-peek ( dst src -- )
+    ! the requested stack location is already in 'src'
+    [ ##copy ] [ swap copies get set-at ] 2bi ;
+
+M: ##peek visit
+    dup
+    [ dst>> ] [ loc>> translate-loc ] bi
+    dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+
+M: ##replace visit
+    [ src>> resolve ] [ loc>> translate-loc ] bi
+    record-replace ;
+
+M: ##copy visit
+    [ call-next-method ] [ record-copy ] bi ;
+
+M: ##call visit
+    [ call-next-method ] [ height>> [ adjust-d ] [ poison-state ] if* ] 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
+    ##dispatch-label
+    ##alien-callback
+    ##callback-return
+    ##fixnum-mul-tail
+    ##fixnum-add-tail
+    ##fixnum-sub-tail ;
+
+M: poison-insn visit call-next-method poison-state ;
+
+! Instructions that kill all live vregs
+UNION: kill-vreg-insn
+    poison-insn
+    ##stack-frame
+    ##call
+    ##prologue
+    ##epilogue
+    ##fixnum-mul
+    ##fixnum-add
+    ##fixnum-sub
+    ##alien-invoke
+    ##alien-indirect ;
+
+M: kill-vreg-insn visit sync-state , ;
+
+: visit-alien-node ( node -- )
+    params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;
+
+M: ##alien-invoke visit
+    [ call-next-method ] [ visit-alien-node ] bi ;
+
+M: ##alien-indirect visit
+    [ call-next-method ] [ visit-alien-node ] bi ;
+
+! Basic blocks we still need to look at
+SYMBOL: work-list
+
+: add-to-work-list ( basic-block -- )
+    work-list get push-front ;
+
+! Maps basic-blocks to states
+SYMBOLS: state-in state-out ;
+
+: merge-states ( seq -- state )
+    [ <state> ] [ first ] if-empty ;
+
+: block-in-state ( bb -- states )
+    predecessors>> state-out get '[ _ at ] map merge-states ;
+
+: maybe-set-at ( value key assoc -- changed? )
+    3dup at* [ = [ 3drop f ] [ set-at t ] if ] [ 2drop set-at t ] if ;
+
+: set-block-in-state ( state b -- )
+    state-in get set-at ;
+
+: set-block-out-state ( bb state -- changed? )
+    swap state-out get maybe-set-at ;
+
+: finish-block ( bb state -- )
+    [ drop ] [ set-block-out-state ] 2bi
+    [ successors>> [ add-to-work-list ] each ] [ drop ] if ;
+
+: visit-block ( bb -- )
+    dup block-in-state
+    [ swap set-block-in-state ] [
+        state [
+            [ [ [ [ visit ] each ] V{ } make ] change-instructions drop ]
+            [ state get finish-block ]
+            bi
+        ] with-variable
+    ] 2bi ;
+
+: visit-blocks ( bb -- )
+    reverse-post-order work-list get
+    [ '[ _ push-front ] each ] [ [ visit-block ] slurp-deque ] bi ;
+
+: optimize-stack ( cfg -- cfg )
+    [
+        H{ } clone copies set
+        H{ } clone state-in set
+        H{ } clone state-out set
+        <hashed-dlist> work-list set
+        dup entry>> visit-blocks
+    ] with-scope ;
+
+! To do:
+! - implement merge-states
+! - insert loads to convert partially available values into available values
+
+! if any state is poisoned, then we need to sync in every predecessor that didn't sync
+! and begin with a new state.
+
+! if heights differ, throw an error.
+
+! changed-locs is the union of the changed-locs of all predecessors
+! locs>vregs: take the union, then for each predecessor, diff its locs>vregs against the union.
+! those are the ones that need to be loaded in.
+! think about phi insertion.

basis/compiler/cfg/utilities/utilities.factor

@@ -35,5 +35,8 @@ IN: compiler.cfg.utilities
 
 : stop-iterating ( -- next ) end-basic-block f ;
 
+: call-height ( ##call -- n )
+    [ out-d>> length ] [ in-d>> length ] bi - ;
+
 : emit-primitive ( node -- )
-    word>> ##call ##branch begin-basic-block ;
+    [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;