! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: inference
USING: generic hashtables inference kernel lists
matrices namespaces sequences vectors ;

GENERIC: literals* ( node -- seq )

: literals ( node -- seq )
    [ [ literals* % ] each-node ] { } make prune ;

GENERIC: can-kill* ( literal node -- ? )

: can-kill? ( literal node -- ? )
    dup [
        2dup can-kill* [
            node-successor can-kill?
        ] [
            2drop f
        ] ifte
    ] [
        2drop t
    ] ifte ;

: kill-set ( node -- list )
    #! Push a list of literals that may be killed in the IR.
    dup literals [ swap can-kill? ] subset-with ;

: remove-values ( values node -- )
    2dup [ node-in-d seq-diff ] keep set-node-in-d
    2dup [ node-out-d seq-diff ] keep set-node-out-d
    2dup [ node-in-r seq-diff ] keep set-node-in-r
    [ node-out-r seq-diff ] keep set-node-out-r ;

: kill-node ( literals node -- )
    [ remove-values ] each-node-with ;

! Generic nodes
M: node literals* ( node -- ) drop { } ;

M: node can-kill* ( literal node -- ? )
    uses-value? not ;

! #shuffle
M: #shuffle literals* ( node -- )
    node-out-d [ literal? ] subset ;

M: #shuffle can-kill* ( literal node -- ? ) 2drop t ;

! #call-label
M: #call-label can-kill* ( literal node -- ? ) 2drop t ;

! #merge
M: #merge can-kill* ( literal node -- ? ) 2drop t ;

! #entry
M: #entry can-kill* ( literal node -- ? ) 2drop t ;

! #values
M: #values can-kill* ( literal node -- ? ) 2drop t ;

! #return
SYMBOL: branch-returns

GENERIC: returns*

UNION: #branch #ifte #dispatch ;

M: #branch returns*
    node-children [ last-node returns* ] each ;

M: #return returns* , ;

M: node returns* node-successor returns* ;

: returns ( node -- seq )
    #! Trace all control flow paths, build a sequence of
    #! final #return nodes.
    [ returns* ] { } make ;

: branch-values ( branches -- )
    returns [ node-in-d ] map unify-lengths flip \ returns set ;

M: #return can-kill* ( literal node -- ? )
    #! Values returned by local labels can be killed.
    dup node-param [
        dupd uses-value? [
            \ returns get
            [ memq? ] subset-with
            [ [ eq? ] monotonic? ] all?
        ] [
            drop t
        ] ifte
    ] [
        delegate can-kill*
    ] ifte ;

: can-kill-branches? ( literal node -- ? )
    #! Check if the literal appears in either branch. This
    #! assumes that the last element of each branch is a #return
    #! node.
    2dup uses-value? [
        2drop f
    ] [
        [
            dup branch-values
            node-children [ can-kill? ] all-with?
        ] with-scope
    ] ifte ;

! #ifte
M: #ifte can-kill* ( literal node -- ? )
    can-kill-branches? ;

! #dispatch
M: #dispatch can-kill* ( literal node -- ? )
    can-kill-branches? ;

! #label
M: #label can-kill* ( literal node -- ? )
    node-child can-kill? ;