diff --git a/unfinished/compiler/cfg/instructions/instructions.factor b/unfinished/compiler/cfg/instructions/instructions.factor index 83532d6038..ac3b3b75a0 100644 --- a/unfinished/compiler/cfg/instructions/instructions.factor +++ b/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: %replace vreg loc ; +INSN: %load-literal < %nullary obj ; +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: 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: %nullary defs-vregs dst>> 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 ; diff --git a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor b/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor index 4e75957990..d0b1176c68 100644 --- a/unfinished/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/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? [ - [ retire-interval ] [ deallocate-register ] bi - ] [ add-active ] if ; + dup uses>> empty? [ deallocate-register ] [ 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 - [ retire-interval ] - [ add-unhandled ] - bi* - ] tri ; + [ split-and-spill [ drop ] [ 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 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 ) - #! After register allocation is done, we retire all - #! 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. +: allocate-registers ( live-intervals machine-registers -- ) + #! This modifies the input live-intervals. [ init-allocator init-unhandled (allocate-registers) - finish-allocator ] with-scope ; diff --git a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor b/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor index b9bfb17cf6..88cff9e95f 100644 --- a/unfinished/compiler/cfg/linear-scan/debugger/debugger.factor +++ b/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 ; - -: 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 ; + ] [ 1array ] if ; : 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 ; diff --git a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index 77222518fa..f3f20680e6 100644 --- a/unfinished/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/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 ) - H{ } clone [ - live-intervals [ - [ compute-live-intervals* ] each-index - ] with-variable - ] keep finalize-live-intervals ; +: compute-live-intervals ( instructions -- ) + H{ } clone live-intervals set + [ compute-live-intervals* ] each-index + finalize-live-intervals ; diff --git a/unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor b/unfinished/compiler/cfg/linear-scan/rewriting/rewriting-tests.factor new file mode 100644 index 0000000000..63a411c777 --- /dev/null +++ b/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 diff --git a/unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor b/unfinished/compiler/cfg/linear-scan/rewriting/rewriting.factor new file mode 100644 index 0000000000..ad9e58c2ec --- /dev/null +++ b/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 ; diff --git a/unfinished/compiler/cfg/linearization/linearization.factor b/unfinished/compiler/cfg/linearization/linearization.factor index 2c4a62d3be..7c25a1b3bf 100644 --- a/unfinished/compiler/cfg/linearization/linearization.factor +++ b/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 ; diff --git a/unfinished/compiler/cfg/stacks/stacks.factor b/unfinished/compiler/cfg/stacks/stacks.factor index ae421f30f8..3cff5da37e 100755 --- a/unfinished/compiler/cfg/stacks/stacks.factor +++ b/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 ] }