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? ;
|