2008-07-24 00:50:21 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Copyright (C) 2008 Slava Pestov.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! See http://factorcode.org/license.txt for BSD license.
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-01 21:00:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								USING: namespaces sequences assocs math kernel accessors fry
							 | 
						
					
						
							
								
									
										
										
										
											2009-01-16 16:14:30 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								combinators sets locals columns grouping
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-10 00:00:27 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								stack-checker.branches
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-01 21:00:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								compiler.tree
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								compiler.tree.def-use
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								compiler.tree.combinators ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-07 07:34:28 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: compiler.tree.propagation.copy
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-07 02:08:11 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-30 04:38:10 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Two values are copy-equivalent if they are always identical
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-04 05:35:31 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! at run-time ("DS" relation). This is just a weak form of
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! value numbering.
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-30 04:38:10 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-01 21:00:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Mapping from values to their canonical leader
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								SYMBOL: copies
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-01 21:00:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								:: 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
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-07 02:08:11 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: resolve-copy ( copy -- val ) copies get compress-path ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-01 21:00:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: is-copy-of ( val copy -- ) copies get set-at ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-01 21:00:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: are-copies-of ( vals copies -- ) [ is-copy-of ] 2each ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-01 21:00:12 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: introduce-value ( val -- ) copies get conjoin ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								GENERIC: compute-copy-equiv* ( node -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-07 07:34:28 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-27 03:32:40 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-28 07:31:26 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: compute-phi-equiv ( inputs outputs -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    #! An output is a copy of every input if all inputs are
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    #! copies of the same original value.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-10 00:00:27 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        swap remove-bottom [ resolve-copy ] map
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-28 07:31:26 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        dup [ all-equal? ] [ empty? not ] bi and
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ first swap is-copy-of ] [ 2drop ] if
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] 2each ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: #phi compute-copy-equiv*
							 | 
						
					
						
							
								
									
										
										
										
											2008-12-06 12:17:19 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    [ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-28 07:31:26 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-07-24 00:50:21 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: node compute-copy-equiv* drop ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-08-07 02:08:11 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: compute-copy-equiv ( node -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ node-defs-values [ introduce-value ] each ]
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ compute-copy-equiv* ]
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    bi ;
							 |