Paste: linear-scan resolve

IN: compiler.cfg.instructions
SYMBOL: temp-spill


! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.parser classes.tuple
combinators combinators.short-circuit compiler.cfg.instructions
compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
fry hashtables kernel locals make math math.order
namespaces parser prettyprint random sequences sets
sorting.functor sorting.slots words ;
IN: compiler.cfg.linear-scan.resolve

<<

TUPLE: operation from to reg-class ;

SYNTAX: OPERATION:
    CREATE-CLASS dup save-location
    [ operation { } define-tuple-class ]
    [
        [ scan-word scan-word ] keep
        '[
            [ [ _ execute ] [ _ execute ] bi* ]
            [ vreg>> reg-class>> ]
            bi _ boa ,
        ] (( from to -- )) define-declared
    ] bi ;

>>

: reload-from ( bb live-interval -- n/f )
    2dup [ block-from ] [ start>> ] bi* =
    [ nip reload-from>> ] [ 2drop f ] if ;

: spill-to ( bb live-interval -- n/f )
    2dup [ block-to ] [ end>> ] bi* =
    [ nip spill-to>> ] [ 2drop f ] if ;

OPERATION: memory->memory spill-to>> reload-from>>
OPERATION: register->memory reg>> reload-from>>
OPERATION: memory->register spill-to>> reg>>
OPERATION: register->register reg>> reg>>

:: add-mapping ( bb1 bb2 li1 li2 -- )
    bb2 li2 reload-from [
        bb1 li1 spill-to
        [ li1 li2 memory->memory ]
        [ li1 li2 register->memory ] if
    ] [
        bb1 li1 spill-to
        [ li1 li2 memory->register ]
        [ li1 li2 register->register ] if
    ] if ;

: resolve-value-data-flow ( bb to vreg -- )
    [ 2dup ] dip
    live-intervals get at
    [ [ block-to ] dip child-interval-at ]
    [ [ block-from ] dip child-interval-at ]
    bi-curry bi* 2dup eq? [ 2drop 2drop ] [ add-mapping ] if ;

: compute-mappings ( bb to -- mappings )
    [
        dup live-in keys
        [ resolve-value-data-flow ] with with each
    ] { } make ;

GENERIC: >insn ( operation -- )

M: memory->memory >insn
    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;

M: register->memory >insn
    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;

M: memory->register >insn
    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;

M: register->register >insn
    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;

GENERIC: >collision-table ( operation -- )

M: memory->memory >collision-table
    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;

M: register->memory >collision-table
    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;

M: memory->register >collision-table
    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;

M: register->register >collision-table
    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;

SYMBOL: froms
SYMBOL: tos

SINGLETONS: memory register ;

GENERIC: from-loc ( operation -- obj )
M: memory->memory from-loc drop memory ;
M: register->memory from-loc drop register ;
M: memory->register from-loc drop memory ;
M: register->register from-loc drop register ;

GENERIC: to-loc ( operation -- obj )
M: memory->memory to-loc drop memory ;
M: register->memory to-loc drop memory ;
M: memory->register to-loc drop register ;
M: register->register to-loc drop register ;

: from-reg ( operation -- seq )
    [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;

: to-reg ( operation -- seq )
    [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;

: (trace-chain) ( pair -- )
    to-reg froms get at [
        dup length 1 = [
            first [ , ] [ (trace-chain) ] bi
        ] [
            drop
        ] if
    ] when* ;

: trace-chain ( pair -- seq )
    [ [ , ] [ (trace-chain) ] bi ] { } make reverse ;

: start? ( operations -- pair )
    from-reg tos get key? not ;

: init-temp-spill ( operations -- )
    [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
    1 + temp-spill set ;

: collect-values ( seq quot: ( obj hashtable -- ) -- hash )
    '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline

: set-tos/froms ( operations -- )
    {
        [ [ from-reg ] collect-values froms set ]
        [ [ to-reg ] collect-values tos set ]
    } cleave ;

: trace-chains ( operations -- operations' )
    [ set-tos/froms ]
    [ [ start? ] filter [ trace-chain ] map concat ] bi ;

: break-cycle ( operations -- operations )
    unclip [ trace-chains ] dip
    [
        [ from>> temp-spill get ]
        [ reg-class>> ] bi \ register->memory boa
    ] [
        [ to>> temp-spill [ get ] [ inc ] bi swap ]
        [ reg-class>> ] bi \ memory->register boa
    ] bi [ 1array ] bi@ surround ;

: follow-cycle ( obj -- seq )
   dup dup associate [
        [ to-reg froms get at first dup dup ] dip
        [ maybe-set-at ] keep swap
    ] loop nip keys ;

: (group-cycles) ( seq -- )
    [
        unclip follow-cycle [ diff ] keep , (group-cycles)
    ] unless-empty ;

: group-cycles ( seq -- seqs )
    [ (group-cycles) ] { } make ;

: partition-mappings ( mappings -- no-cycles cycles )
    [ start? not ] partition
    [ trace-chain ] map concat tuck diff ;

: parallel-mappings ( operations -- seq )
    partition-mappings [
        group-cycles [ break-cycle ] map concat append
    ] unless-empty ;

: mapping-instructions ( mappings -- insns )
    [
        [ init-temp-spill ] ! can go away
        [ set-tos/froms ]
        [ parallel-mappings ] tri
        [ [ >insn ] each ] { } make
    ] with-scope ;

: fork? ( from to -- ? )
    [ successors>> length 1 >= ]
    [ predecessors>> length 1 = ] bi* and ; inline

: insert-position/fork ( from to -- before after )
    nip instructions>> [ >array ] [ dup delete-all ] bi swap ;

: join? ( from to -- ? )
    [ successors>> length 1 = ]
    [ predecessors>> length 1 >= ] bi* and ; inline

: insert-position/join ( from to -- before after )
    drop instructions>> dup pop 1array ;

: insert-position ( bb to -- before after )
    {
        { [ 2dup fork? ] [ insert-position/fork ] }
        { [ 2dup join? ] [ insert-position/join ] }
    } cond ;

: 3append-here ( seq2 seq1 seq3 -- )
    #! Mutate seq1
    swap '[ _ push-all ] bi@ ;

: perform-mappings ( mappings bb to -- )
    pick empty? [ 3drop ] [
        [ mapping-instructions ] 2dip
        insert-position 3append-here
    ] if ;

: resolve-edge-data-flow ( bb to -- )
    [ compute-mappings ] [ perform-mappings ] 2bi ;

: resolve-block-data-flow ( bb -- )
    dup successors>> [ resolve-edge-data-flow ] with each ;

: resolve-data-flow ( rpo -- )
    [ resolve-block-data-flow ] each ;


[
    {
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    }
] [
    {
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
    } trace-chains
] unit-test

[
    {
        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    }
] [
    {
        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    } trace-chains
] unit-test

[
    {
        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    }
] [
    {
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    } trace-chains
] unit-test

[
    {
        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    }
] [
    {
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    } trace-chains
] unit-test

[
    {
        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    }
] [
    {
        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    } trace-chains
] unit-test

[
    {
        T{ _copy { dst 5 } { src 4 } { class int-regs } }
        T{ _spill { src 1 } { class int-regs } { n 6 } }
        T{ _copy { dst 1 } { src 0 } { class int-regs } }
        T{ _reload { dst 0 } { class int-regs } { n 6 } }
        T{ _spill { src 1 } { class float-regs } { n 7 } }
        T{ _copy { dst 1 } { src 0 } { class float-regs } }
        T{ _reload { dst 0 } { class float-regs } { n 7 } }
    }
] [
    {
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
        T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
        T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
        T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
    } mapping-instructions
] unit-test

[
    {
        T{ _spill { src 1 } { class int-regs } { n 3 } }
        T{ _copy { dst 1 } { src 0 } { class int-regs } }
        T{ _copy { dst 0 } { src 2 } { class int-regs } }
        T{ _reload { dst 2 } { class int-regs } { n 3 } }
    }
] [
    {
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
    } mapping-instructions
] unit-test

[
    {
        T{ _spill { src 1 } { class int-regs } { n 3 } }
        T{ _copy { dst 1 } { src 0 } { class int-regs } }
        T{ _copy { dst 0 } { src 2 } { class int-regs } }
        T{ _reload { dst 2 } { class int-regs } { n 3 } }
    }
] [
    {
        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
    } mapping-instructions
] unit-test

[
    {
        T{ _copy { dst 1 } { src 0 } { class int-regs } }
        T{ _copy { dst 2 } { src 0 } { class int-regs } }
    }
] [
    {
        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
    } mapping-instructions
] unit-test