! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators fry hints kernel locals
math sequences sets sorting splitting namespaces
combinators.short-circuit compiler.utilities
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.allocation.splitting
compiler.cfg.linear-scan.live-intervals ;
IN: compiler.cfg.linear-scan.allocation.spilling

ERROR: bad-live-ranges interval ;

: check-ranges ( live-interval -- )
    check-allocation? get [
        dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
        [ drop ] [ bad-live-ranges ] if
    ] [ drop ] if ;

: trim-before-ranges ( live-interval -- )
    [ ranges>> ] [ uses>> last ] bi
    [ '[ from>> _ <= ] filter-here ]
    [ swap last (>>to) ]
    2bi ;

: trim-after-ranges ( live-interval -- )
    [ ranges>> ] [ uses>> first ] bi
    [ '[ to>> _ >= ] filter-here ]
    [ swap first (>>from) ]
    2bi ;

: split-for-spill ( live-interval n -- before after )
    split-interval
    {
        [ [ trim-before-ranges ] [ trim-after-ranges ] bi* ]
        [ [ compute-start/end ] bi@ ]
        [ [ check-ranges ] bi@ ]
        [ ]
    } 2cleave ;

: assign-spill ( live-interval -- )
    dup vreg>> assign-spill-slot >>spill-to f >>split-next drop ;

: assign-reload ( live-interval -- )
    dup vreg>> assign-spill-slot >>reload-from drop ;

: split-and-spill ( live-interval n -- before after )
    split-for-spill 2dup [ assign-spill ] [ assign-reload ] bi* ;

: find-use-position ( live-interval new -- n )
    [ uses>> ] [ start>> '[ _ >= ] ] bi* find nip 1/0. or ;

: find-use-positions ( live-intervals new assoc -- )
    '[ [ _ find-use-position ] [ reg>> ] bi _ add-use-position ] each ;

: active-positions ( new assoc -- )
    [ [ vreg>> active-intervals-for ] keep ] dip
    find-use-positions ;

: inactive-positions ( new assoc -- )
    [
        [ vreg>> inactive-intervals-for ] keep
        [ '[ _ intervals-intersect? ] filter ] keep
    ] dip
    find-use-positions ;

: spill-status ( new -- use-pos )
    H{ } clone
    [ inactive-positions ] [ active-positions ] [ nip ] 2tri
    >alist alist-max ;

: spill-new? ( new pair -- ? )
    [ uses>> first ] [ second ] bi* > ;

: spill-new ( new pair -- )
    drop
    {
        [ trim-after-ranges ]
        [ compute-start/end ]
        [ assign-reload ]
        [ add-unhandled ]
    } cleave ;

: split-intersecting? ( live-interval new reg -- ? )
    { [ [ drop reg>> ] dip = ] [ drop intervals-intersect? ] } 3&& ;

: split-live-out ( live-interval -- )
    {
        [ trim-before-ranges ]
        [ compute-start/end ]
        [ assign-spill ]
        [ add-handled ]
    } cleave ;

: split-live-in ( live-interval -- )
    {
        [ trim-after-ranges ]
        [ compute-start/end ]
        [ assign-reload ]
        [ add-unhandled ]
    } cleave ;

: (split-intersecting) ( live-interval new -- )
    start>> {
        { [ 2dup [ uses>> last ] dip < ] [ drop split-live-out ] }
        { [ 2dup [ uses>> first ] dip > ] [ drop split-live-in ] }
        [ split-and-spill [ add-handled ] [ add-unhandled ] bi* ]
    } cond ;

: (split-intersecting-active) ( active new -- )
    [ drop delete-active ]
    [ (split-intersecting) ] 2bi ;

: split-intersecting-active ( new reg -- )
    [ [ vreg>> active-intervals-for ] keep ] dip
    [ '[ _ _ split-intersecting? ] filter ] 2keep drop
    '[ _ (split-intersecting-active) ] each ;

: (split-intersecting-inactive) ( inactive new -- )
    [ drop delete-inactive ]
    [ (split-intersecting) ] 2bi ;

: split-intersecting-inactive ( new reg -- )
    [ [ vreg>> inactive-intervals-for ] keep ] dip
    [ '[ _ _ split-intersecting? ] filter ] 2keep drop
    '[ _ (split-intersecting-inactive) ] each ;

: split-intersecting ( new reg -- )
    [ split-intersecting-active ]
    [ split-intersecting-inactive ]
    2bi ;

: spill-available ( new pair -- )
    [ first split-intersecting ] [ register-available ] 2bi ;

: spill-partially-available ( new pair -- )
    [ second 1 - split-and-spill add-unhandled ] keep
    spill-available ;

: assign-blocked-register ( new -- )
    dup spill-status {
        { [ 2dup spill-new? ] [ spill-new ] }
        { [ 2dup register-available? ] [ spill-available ] }
        [ spill-partially-available ]
    } cond ;