Inserting spills and reloads

unfinished/compiler/cfg/instructions/instructions.factor

@@ -6,15 +6,16 @@ IN: compiler.cfg.instructions
 
 ! Virtual CPU instructions, used by CFG and machine IRs
 
-INSN: %cond-branch vreg ;
+INSN: %cond-branch src ;
 INSN: %unary dst src ;
+INSN: %nullary dst ;
 
 ! Stack operations
-INSN: %peek vreg loc ;
+INSN: %load-literal < %nullary obj ;
-INSN: %replace vreg loc ;
+INSN: %peek < %nullary loc ;
+INSN: %replace src loc ;
 INSN: %inc-d n ;
 INSN: %inc-r n ;
-INSN: %load-literal obj vreg ;
 
 ! Calling convention
 INSN: %return ;
@@ -22,7 +23,7 @@ INSN: %return ;
 ! Subroutine calls
 INSN: %call word ;
 INSN: %jump word ;
-INSN: %intrinsic quot vregs ;
+INSN: %intrinsic quot regs ;
 
 ! Jump tables
 INSN: %dispatch-label label ;
@@ -49,17 +50,13 @@ INSN: %alien-callback params ;
 GENERIC: defs-vregs ( insn -- seq )
 GENERIC: uses-vregs ( insn -- seq )
 
-M: insn defs-vregs drop f ;
+M: %nullary defs-vregs dst>> 1array ;
-M: insn uses-vregs drop f ;
-
-M: %peek defs-vregs vreg>> 1array ;
-
-M: %replace uses-vregs vreg>> 1array ;
-
-M: %load-literal defs-vregs vreg>> 1array ;
-
 M: %unary defs-vregs dst>> 1array ;
+M: insn defs-vregs drop f ;
+
+M: %replace uses-vregs src>> 1array ;
 M: %unary uses-vregs src>> 1array ;
+M: insn uses-vregs drop f ;
 
 ! M: %intrinsic uses-vregs vregs>> values ;
 
@@ -72,9 +69,9 @@ INSN: %branch ;
 INSN: %branch-f < %cond-branch ;
 INSN: %branch-t < %cond-branch ;
 INSN: %if-intrinsic quot vregs ;
-INSN: %boolean-intrinsic quot vregs out ;
+INSN: %boolean-intrinsic quot vregs dst ;
 
-M: %cond-branch uses-vregs vreg>> 1array ;
+M: %cond-branch uses-vregs src>> 1array ;
 
 ! M: %if-intrinsic uses-vregs vregs>> values ;
 
@@ -97,12 +94,15 @@ INSN: _label label ;
 : resolve-label ( label/name -- )
     dup label? [ get ] unless _label ;
 
-TUPLE: _cond-branch vreg label ;
+TUPLE: _cond-branch src label ;
 
 INSN: _branch label ;
 INSN: _branch-f < _cond-branch ;
 INSN: _branch-t < _cond-branch ;
 INSN: _if-intrinsic label quot vregs ;
 
-M: _cond-branch uses-vregs vreg>> 1array ;
+M: _cond-branch uses-vregs src>> 1array ;
 ! M: _if-intrinsic uses-vregs vregs>> values ;
+
+INSN: _spill src n ;
+INSN: _reload dst n ;

unfinished/compiler/cfg/linear-scan/allocation/allocation.factor

@@ -6,15 +6,6 @@ compiler.cfg.linear-scan.live-intervals
 compiler.backend ;
 IN: compiler.cfg.linear-scan.allocation
 
-! Vector of live intervals we have already processed
-SYMBOL: retired-intervals
-
-: retire-interval ( live-interval -- )
-    retired-intervals get push ;
-
-: retire-intervals ( live-intervals -- )
-    retired-intervals get push-all ;
-
 ! Mapping from register classes to sequences of machine registers
 SYMBOL: free-registers
 
@@ -37,7 +28,7 @@ SYMBOL: active-intervals
     active-intervals get
     swap '[ end>> _ < ] partition
     active-intervals set
-    [ [ retire-interval ] [ deallocate-register ] bi ] each ;
+    [ deallocate-register ] each ;
 
 : expire-old-uses ( n -- )
     active-intervals get
@@ -112,9 +103,7 @@ SYMBOL: spill-counter
 
 : reuse-register ( new existing -- )
     reg>> >>reg
-    dup uses>> empty? [
+    dup uses>> empty? [ deallocate-register ] [ add-active ] if ;
-        [ retire-interval ] [ deallocate-register ] bi
-    ] [ add-active ] if ;
 
 : spill-existing ( new existing -- )
     #! Our new interval will be used before the active interval
@@ -123,12 +112,7 @@ SYMBOL: spill-counter
     #! of the existing interval again.
     [ reuse-register ]
     [ delete-active ]
-    [
+    [ split-and-spill [ drop ] [ add-unhandled ] bi* ] tri ;
-        split-and-spill
-        [ retire-interval ]
-        [ add-unhandled ]
-        bi*
-    ] tri ;
 
 : spill-new ( new existing -- )
     #! Our new interval will be used after the active interval
@@ -153,13 +137,7 @@ SYMBOL: spill-counter
     ] if-empty ;
 
 ! Main loop
-: slurp-heap ( heap quot: ( elt -- ) -- )
-    over heap-empty? [ 2drop ] [
-        [ [ heap-pop drop ] dip call ] [ slurp-heap ] 2bi
-    ] if ; inline recursive
-
 : init-allocator ( registers -- )
-    V{ } clone retired-intervals set
     V{ } clone active-intervals set
     <min-heap> unhandled-intervals set
     [ >vector ] assoc-map free-registers set
@@ -172,17 +150,10 @@ SYMBOL: spill-counter
 : (allocate-registers) ( -- )
     unhandled-intervals get [ handle-interval ] slurp-heap ;
 
-: finish-allocator ( -- live-intervals )
+: allocate-registers ( live-intervals machine-registers -- )
-    #! After register allocation is done, we retire all
+    #! This modifies the input live-intervals.
-    #! live intervals which are still active.
-    active-intervals get retire-intervals
-    retired-intervals get ;
-
-: allocate-registers ( live-intervals machine-registers -- live-intervals' )
-    #! This destroys the input live-intervals.
     [
         init-allocator
         init-unhandled
         (allocate-registers)
-        finish-allocator
     ] with-scope ;

unfinished/compiler/cfg/linear-scan/debugger/debugger.factor

@@ -11,28 +11,13 @@ IN: compiler.cfg.linear-scan.debugger
         [ "Not all intervals have registers" throw ] unless
     ] each ;
 
-: check-split ( live-intervals -- )
-    [
-        split-before>>
-        [ "Split intervals returned" throw ] when
-    ] each ;
-
 : split-children ( live-interval -- seq )
     dup split-before>> [
         [ split-before>> ] [ split-after>> ] bi
         [ split-children ] bi@
         append
-    ] [
+    ] [ 1array ] if ;
-        1array
-    ] if ;
-
-: check-retired ( original live-intervals -- )
-    #! All original live intervals should have either been
-    #! split, or ended up in the output set.
-    [ [ split-children ] map concat ] dip
-    2dup subset? [ "We lost some intervals" throw ] unless
-    swap subset? [ "We didn't record all splits" throw ] unless ;
 
 : check-linear-scan ( live-intervals machine-registers -- )
     [ [ clone ] map dup ] dip allocate-registers
-    [ check-assigned ] [ check-split ] [ check-retired ] tri ;
+    [ split-children ] map concat check-assigned ;

unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor

@@ -37,13 +37,11 @@ SYMBOL: live-intervals
     [ [ defs-vregs ] 2dip '[ _ swap >vreg _ new-live-interval ] each ]
     3bi ;
 
-: finalize-live-intervals ( assoc -- seq' )
+: finalize-live-intervals ( -- )
     #! Reverse uses lists so that we can pop values off.
-    values dup [ uses>> reverse-here ] each ;
+    live-intervals get [ nip uses>> reverse-here ] assoc-each ;
 
-: compute-live-intervals ( instructions -- live-intervals )
+: compute-live-intervals ( instructions -- )
-    H{ } clone [
+    H{ } clone live-intervals set
-        live-intervals [
+    [ compute-live-intervals* ] each-index
-            [ compute-live-intervals* ] each-index
+    finalize-live-intervals ;
-        ] with-variable
-    ] keep finalize-live-intervals ;

unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor

@@ -0,0 +1,4 @@
+USING: compiler.cfg.linear-scan.rewriting tools.test ;
+IN: compiler.cfg.linear-scan.rewriting.tests
+
+\ rewrite-instructions must-infer

unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor

@@ -0,0 +1,100 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel math assocs namespaces sequences heaps
+fry make
+compiler.cfg.registers
+compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals ;
+IN: compiler.cfg.linear-scan.rewriting
+
+! A vector of live intervals. There is linear searching involved
+! but since we never have too many machine registers (around 30
+! at most) and we probably won't have that many live at any one
+! time anyway, it is not a problem to check each element.
+SYMBOL: active-intervals
+
+: add-active ( live-interval -- )
+    active-intervals get push ;
+
+: lookup-register ( vreg -- reg )
+    active-intervals get [ vreg>> = ] with find nip reg>> ;
+
+! Minheap of live intervals which still need a register allocation
+SYMBOL: unhandled-intervals
+
+: add-unhandled ( live-interval -- )
+    dup split-before>> [
+        [ split-before>> ] [ split-after>> ] bi
+        [ add-unhandled ] bi@
+    ] [
+        dup start>> unhandled-intervals get heap-push
+    ] if ;
+
+: init-unhandled ( live-intervals -- )
+    [ add-unhandled ] each ;
+
+: insert-spill ( live-interval -- )
+    [ reg>> ] [ spill-to>> ] bi dup [ _spill ] [ 2drop ] if ;
+
+: expire-old-intervals ( n -- )
+    active-intervals get
+    swap '[ end>> _ = ] partition
+    active-intervals set
+    [ insert-spill ] each ;
+
+: insert-reload ( live-interval -- )
+    [ reg>> ] [ reload-from>> ] bi dup [ _reload ] [ 2drop ] if ;
+
+: activate-new-intervals ( n -- )
+    #! Any live intervals which start on the current instruction
+    #! are added to the active set.
+    unhandled-intervals get dup heap-empty? [ 2drop ] [
+        2dup heap-peek drop start>> = [
+            heap-pop drop [ add-active ] [ insert-reload ] bi
+            activate-new-intervals
+        ] [ 2drop ] if
+    ] if ;
+
+GENERIC: rewrite-instruction ( insn -- )
+
+M: %cond-branch rewrite-instruction
+    [ lookup-register ] change-vreg
+    drop ;
+
+M: %unary rewrite-instruction
+    [ lookup-register ] change-dst
+    [ lookup-register ] change-src
+    drop ;
+
+M: %peek rewrite-instruction
+    [ lookup-register ] change-vreg
+    drop ;
+
+M: %replace rewrite-instruction
+    [ lookup-register ] change-vreg
+    drop ;
+
+M: %load-literal rewrite-instruction
+    [ lookup-register ] change-vreg
+    drop ;
+
+: lookup-registers ( assoc -- assoc' )
+    [ dup vreg? [ lookup-register ] when ] assoc-map ;
+
+M: %intrinsic rewrite-instruction
+    [ lookup-registers ] change-vregs
+    drop ;
+
+M: _if-intrinsic rewrite-instruction
+    [ lookup-registers ] change-vregs
+    drop ;
+
+: rewrite-instructions ( insns -- insns' )
+    [
+        [
+            [ activate-new-intervals ]
+            [ drop [ rewrite-instruction ] [ , ] bi ]
+            [ expire-old-intervals ]
+            tri
+        ] each-index
+    ] { } make ;

unfinished/compiler/cfg/linearization/linearization.factor

@@ -56,7 +56,7 @@ M: %branch linearize-insn
     dup successors>> first2 swap label>> ; inline
 
 : boolean-conditional ( basic-block insn -- basic-block successor vreg label2 )
-    [ conditional ] [ vreg>> ] bi* swap ; inline
+    [ conditional ] [ dst>> ] bi* swap ; inline
 
 M: %branch-f linearize-insn
     boolean-conditional _branch-f emit-branch ;
@@ -73,10 +73,10 @@ M: %boolean-intrinsic linearize-insn
         "false" define-label
         "end" define-label
         "false" get over [ quot>> ] [ vregs>> ] bi _if-intrinsic
-        t over out>> %load-literal
+        dup out>> t %load-literal
         "end" get _branch
         "false" resolve-label
-        f over out>> %load-literal
+        dup out>> f %load-literal
         "end" resolve-label
     ] with-scope
     2drop ;

unfinished/compiler/cfg/stacks/stacks.factor

@@ -127,7 +127,7 @@ M: constant move-spec class ;
         { { f unboxed-c-ptr } [ %move-bug ] }
         { { f unboxed-byte-array } [ %move-bug ] }
 
-        { { f constant } [ value>> swap %load-literal ] }
+        { { f constant } [ value>> %load-literal ] }
 
         { { f float } [ %box-float ] }
         { { f unboxed-alien } [ %box-alien ] }