Fixing copy-equiv
parent
ecacdf7014
commit
f86fbccfb0
unfinished/compiler/tree/copy-equiv
|
@ -0,0 +1,25 @@
|
|||
IN: compiler.tree.copy-equiv.tests
|
||||
USING: compiler.tree.copy-equiv tools.test namespaces kernel
|
||||
assocs ;
|
||||
|
||||
H{ } clone copies set
|
||||
|
||||
[ ] [ 0 introduce-value ] unit-test
|
||||
[ ] [ 1 introduce-value ] unit-test
|
||||
[ ] [ 1 2 is-copy-of ] unit-test
|
||||
[ ] [ 2 3 is-copy-of ] unit-test
|
||||
[ ] [ 2 4 is-copy-of ] unit-test
|
||||
[ ] [ 4 5 is-copy-of ] unit-test
|
||||
[ ] [ 0 6 is-copy-of ] unit-test
|
||||
|
||||
[ 0 ] [ 0 resolve-copy ] unit-test
|
||||
[ 1 ] [ 5 resolve-copy ] unit-test
|
||||
|
||||
! Make sure that we did path compression
|
||||
[ 1 ] [ 5 copies get at ] unit-test
|
||||
|
||||
[ 1 ] [ 1 resolve-copy ] unit-test
|
||||
[ 1 ] [ 2 resolve-copy ] unit-test
|
||||
[ 1 ] [ 3 resolve-copy ] unit-test
|
||||
[ 1 ] [ 4 resolve-copy ] unit-test
|
||||
[ 0 ] [ 6 resolve-copy ] unit-test
|
|
@ -1,23 +1,37 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces disjoint-sets sequences assocs math
|
||||
kernel accessors fry
|
||||
compiler.tree compiler.tree.def-use compiler.tree.combinators ;
|
||||
USING: namespaces sequences assocs math kernel accessors fry
|
||||
combinators sets locals
|
||||
compiler.tree
|
||||
compiler.tree.def-use
|
||||
compiler.tree.combinators ;
|
||||
IN: compiler.tree.copy-equiv
|
||||
|
||||
! Two values are copy-equivalent if they are always identical
|
||||
! at run-time ("DS" relation).
|
||||
|
||||
! Disjoint set of copy equivalence
|
||||
! Mapping from values to their canonical leader
|
||||
SYMBOL: copies
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get equate ;
|
||||
:: compress-path ( source assoc -- destination )
|
||||
[let | destination [ source assoc at ] |
|
||||
source destination = [ source ] [
|
||||
[let | destination' [ destination assoc compress-path ] |
|
||||
destination' destination = [
|
||||
destination' source assoc set-at
|
||||
] unless
|
||||
destination'
|
||||
]
|
||||
] if
|
||||
] ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get compress-path ;
|
||||
|
||||
: is-copy-of ( val copy -- ) copies get set-at ;
|
||||
|
||||
: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
|
||||
|
||||
: resolve-copy ( copy -- val ) copies get representative ;
|
||||
|
||||
: introduce-value ( val -- ) copies get add-atom ;
|
||||
: introduce-value ( val -- ) copies get conjoin ;
|
||||
|
||||
GENERIC: compute-copy-equiv* ( node -- )
|
||||
|
||||
|
@ -60,5 +74,5 @@ M: node compute-copy-equiv* drop ;
|
|||
] each-node ;
|
||||
|
||||
: compute-copy-equiv ( node -- node )
|
||||
<disjoint-set> copies set
|
||||
H{ } clone copies set
|
||||
dup amend-copy-equiv ;
|
||||
|
|
Loading…
Reference in New Issue