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