Fixing copy-equiv

db4
Slava Pestov 2008-08-01 20:00:12 -05:00
parent ecacdf7014
commit f86fbccfb0
2 changed files with 48 additions and 9 deletions

View File

@ -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

View File

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