60 lines
1.9 KiB
Factor
60 lines
1.9 KiB
Factor
! Copyright (C) 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors slots.private kernel namespaces disjoint-sets
|
|
math sequences assocs classes.tuple.private combinators fry sets
|
|
compiler.tree compiler.tree.combinators compiler.tree.copy-equiv
|
|
compiler.tree.dataflow-analysis
|
|
compiler.tree.dataflow-analysis.backward ;
|
|
IN: compiler.tree.untupling
|
|
|
|
SYMBOL: escaping-values
|
|
|
|
: mark-escaping-values ( node -- )
|
|
in-d>> escaping-values get '[ resolve-copy , conjoin ] each ;
|
|
|
|
SYMBOL: untupling-candidates
|
|
|
|
: untupling-candidate ( #call class -- )
|
|
#! 1- for delegate
|
|
size>> 1- swap out-d>> first resolve-copy
|
|
untupling-candidates get set-at ;
|
|
|
|
GENERIC: compute-untupling* ( node -- )
|
|
|
|
M: #call compute-untupling*
|
|
dup word>> {
|
|
{ \ <tuple-boa> [ dup in-d>> peek untupling-candidate ] }
|
|
{ \ curry [ \ curry tuple-layout untupling-candidate ] }
|
|
{ \ compose [ \ compose tuple-layout untupling-candidate ] }
|
|
{ \ slot [ drop ] }
|
|
[ drop mark-escaping-values ]
|
|
} case ;
|
|
|
|
M: #return compute-untupling* mark-escaping-values ;
|
|
|
|
M: node compute-untupling* drop ;
|
|
|
|
GENERIC: check-consistency* ( node -- )
|
|
|
|
: check-value-consistency ( out-value in-values -- )
|
|
swap escaping-values get key? [
|
|
escaping-values get '[ , conjoin ] each
|
|
] [
|
|
untupling-candidates get 2dup '[ , at ] map all-equal?
|
|
[ 2drop ] [ '[ , delete-at ] each ] if
|
|
] if ;
|
|
|
|
M: #phi check-consistency*
|
|
[ [ out-d>> ] [ phi-in-d>> ] bi [ check-value-consistency ] 2each ]
|
|
[ [ out-r>> ] [ phi-in-r>> ] bi [ check-value-consistency ] 2each ]
|
|
bi ;
|
|
|
|
M: node check-consistency* drop ;
|
|
|
|
: compute-untupling ( node -- assoc )
|
|
H{ } clone escaping-values set
|
|
H{ } clone untupling-candidates set
|
|
[ [ compute-untupling* ] each-node ]
|
|
[ [ check-consistency* ] each-node ] bi
|
|
untupling-candidates get escaping-values get assoc-diff ;
|