factor/library/compiler/optimizer/kill-literals.factor

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

: node-union ( node quot -- hash | quot: node -- )
    [
        swap [ swap call [ dup set ] each ] each-node-with
    ] make-hash ; inline

GENERIC: literals* ( node -- seq )

: literals ( node -- hash )
    [ literals* ] node-union ;

! GENERIC: flushable-values* ( node -- seq )
! 
! : flushable-values ( node -- hash )
!     [ flushable-values* ] node-union ;

GENERIC: live-values* ( node -- seq )

: live-values ( node -- hash )
    #! All values that are returned or passed to calls.
    [ live-values* ] node-union ;

: kill-node* ( values node -- )
    2dup [ node-in-d remove-all ] keep set-node-in-d
    2dup [ node-out-d remove-all ] keep set-node-out-d
    2dup [ node-in-r remove-all ] keep set-node-in-r
    [ node-out-r remove-all ] keep set-node-out-r ;

: kill-node ( values node -- )
    over hash-empty?
    [ 2drop ] [ [ kill-node* ] each-node-with ] if ;

: kill-unused-literals ( node -- )
    \ live-values get over literals hash-diff swap kill-node ;

: kill-values ( node -- )
    dup live-values over literals hash-diff swap kill-node ;

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

! M: node flushable-values* ( node -- ) drop { } ;

M: node live-values* ( node -- ) node-values ;

! #shuffle
M: #shuffle literals* ( node -- seq )
    dup node-out-d swap node-out-r
    [ [ value? ] subset ] 2apply append ;

! #push
M: #push literals* ( node -- seq )
    node-values ;

! #call
! M: #call flushable-values* ( node -- )
!     dup node-param "flushable" word-prop
!     [ node-out-d ] [ drop { } ] if ;

! #return
M: #return live-values* ( node -- seq )
    #! Values returned by local labels can be killed.
    dup node-param [ drop { } ] [ delegate live-values* ] if ;

! nodes that don't use their values directly
UNION: #killable
    #push #shuffle #call-label #merge #values #entry ;

M: #killable live-values* ( node -- seq ) drop { } ;

: purge-invariants ( stacks -- seq )
    #! Output a sequence of values which are not present in the
    #! same position in each sequence of the stacks sequence.
    unify-lengths flip [ all-eq? not ] subset concat ;

! #label
M: #label live-values* ( node -- seq )
    dup node-child node-in-d over node-in-d 2array
    swap collect-recursion append purge-invariants ;

! branching
UNION: #branch #if #dispatch ;

M: #branch live-values* ( node -- )
    #! This assumes that the last element of each branch is a
    #! #return node.
    dup delegate live-values* >r
    node-children [ last-node node-in-d ] map purge-invariants
    r> append ;