factor/library/inference/kill-literals.factor

105 lines
2.5 KiB
Factor
Raw Normal View History

2005-08-07 00:00:57 -04:00
! 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 ;
2005-09-07 17:21:11 -04:00
GENERIC: literals* ( node -- seq )
2005-08-07 00:00:57 -04:00
: literals ( node -- seq )
2005-09-07 17:21:11 -04:00
[ [ literals* % ] each-node ] { } make ;
2005-08-07 00:00:57 -04:00
2005-09-07 17:21:11 -04:00
GENERIC: can-kill* ( literal node -- ? )
: can-kill? ( literals node -- ? )
dup [
2dup can-kill* [
node-successor can-kill?
] [
2drop f
] ifte
] [
2drop t
] ifte ;
2005-08-07 00:00:57 -04:00
: kill-set ( node -- list )
#! Push a list of literals that may be killed in the IR.
2005-09-07 17:21:11 -04:00
dup literals [ swap can-kill? ] subset-with ;
2005-08-07 00:00:57 -04:00
: 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 -- )
2005-09-07 17:21:11 -04:00
[ remove-values ] each-node-with ;
2005-08-07 00:00:57 -04:00
! Generic nodes
2005-09-07 17:21:11 -04:00
M: node literals* ( node -- ) drop { } ;
2005-08-07 00:00:57 -04:00
2005-09-07 17:21:11 -04:00
M: node can-kill* ( literal node -- ? ) uses-value? not ;
2005-08-07 00:00:57 -04:00
! #push
2005-09-07 17:21:11 -04:00
M: #push literals* ( node -- ) node-out-d ;
2005-08-07 00:00:57 -04:00
2005-09-07 17:21:11 -04:00
M: #push can-kill* ( literal node -- ? ) 2drop t ;
2005-08-07 00:00:57 -04:00
2005-09-04 17:07:59 -04:00
! #shuffle
2005-09-07 17:21:11 -04:00
M: #shuffle can-kill* ( literal node -- ? ) 2drop t ;
2005-08-07 00:00:57 -04:00
! #call-label
2005-09-07 17:21:11 -04:00
M: #call-label can-kill* ( literal node -- ? ) 2drop t ;
2005-08-07 00:00:57 -04:00
! #merge
2005-09-07 17:21:11 -04:00
M: #merge can-kill* ( literal node -- ? ) 2drop t ;
2005-08-07 00:00:57 -04:00
! #entry
2005-09-07 17:21:11 -04:00
M: #entry can-kill* ( literal node -- ? ) 2drop t ;
! #return
SYMBOL: branch-returns
M: #return can-kill* ( literal node -- ? )
#! Values returned by local labels can be killed.
dup node-param [
dupd uses-value? [
branch-returns get
[ memq? ] subset-with
[ [ eq? ] monotonic? ] all?
] [
drop t
] ifte
] [
delegate can-kill*
] ifte ;
: branch-values ( branches -- )
[ last-node node-in-d ] map
unify-lengths flip branch-returns set ;
: 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
] [
[
node-children dup branch-values
[ 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? ;