| 
									
										
										
										
											2010-01-14 10:10:13 -05:00
										 |  |  | ! Copyright (C) 2008, 2010 Slava Pestov. | 
					
						
							| 
									
										
										
										
											2008-07-20 05:24:37 -04:00
										 |  |  | ! See http://factorcode.org/license.txt for BSD license. | 
					
						
							| 
									
										
										
										
											2008-11-12 20:08:40 -05:00
										 |  |  | USING: assocs arrays namespaces sequences kernel definitions | 
					
						
							|  |  |  | math effects accessors words fry classes.algebra | 
					
						
							| 
									
										
										
										
											2009-11-09 01:17:24 -05:00
										 |  |  | compiler.units stack-checker.values stack-checker.visitor | 
					
						
							|  |  |  | stack-checker.errors ;
 | 
					
						
							| 
									
										
										
										
											2008-07-20 05:24:37 -04:00
										 |  |  | IN: stack-checker.state | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! Did the current control-flow path throw an error? | 
					
						
							|  |  |  | SYMBOL: terminated? | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! Number of inputs current word expects from the stack | 
					
						
							| 
									
										
										
										
											2009-11-09 01:17:24 -05:00
										 |  |  | SYMBOL: input-count | 
					
						
							| 
									
										
										
										
											2008-07-20 05:24:37 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-12-04 07:02:49 -05:00
										 |  |  | DEFER: commit-literals | 
					
						
							|  |  |  | 
 | 
					
						
							| 
									
										
										
										
											2008-07-20 05:24:37 -04:00
										 |  |  | ! Compile-time data stack | 
					
						
							| 
									
										
										
										
											2008-12-04 07:02:49 -05:00
										 |  |  | : meta-d ( -- stack ) commit-literals \ meta-d get ;
 | 
					
						
							| 
									
										
										
										
											2008-07-20 05:24:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | ! Compile-time retain stack | 
					
						
							| 
									
										
										
										
											2008-12-04 07:02:49 -05:00
										 |  |  | : meta-r ( -- stack ) \ meta-r get ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | ! Uncommitted literals. This is a form of local dead-code | 
					
						
							|  |  |  | ! elimination; the goal is to reduce the number of IR nodes | 
					
						
							|  |  |  | ! which get constructed. Technically it is redundant since | 
					
						
							|  |  |  | ! we do global DCE later, but it speeds up compile time. | 
					
						
							|  |  |  | SYMBOL: literals | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : (push-literal) ( obj -- )
 | 
					
						
							|  |  |  |     dup <literal> make-known | 
					
						
							|  |  |  |     [ nip \ meta-d get push ] [ #push, ] 2bi ;
 | 
					
						
							|  |  |  | 
 | 
					
						
							|  |  |  | : commit-literals ( -- )
 | 
					
						
							|  |  |  |     literals get [ | 
					
						
							|  |  |  |         [ [ (push-literal) ] each ] [ delete-all ] bi
 | 
					
						
							|  |  |  |     ] unless-empty ;
 | 
					
						
							| 
									
										
										
										
											2008-07-20 05:24:37 -04:00
										 |  |  | 
 | 
					
						
							| 
									
										
										
										
											2009-11-09 01:17:24 -05:00
										 |  |  | : current-stack-height ( -- n ) meta-d length input-count get - ;
 | 
					
						
							| 
									
										
										
										
											2008-07-20 05:24:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : current-effect ( -- effect )
 | 
					
						
							| 
									
										
										
										
											2010-01-14 10:10:13 -05:00
										 |  |  |     input-count get "x" <array>
 | 
					
						
							|  |  |  |     meta-d length "x" <array>
 | 
					
						
							|  |  |  |     terminated? get effect boa ;
 | 
					
						
							| 
									
										
										
										
											2008-07-20 05:24:37 -04:00
										 |  |  | 
 | 
					
						
							|  |  |  | : init-inference ( -- )
 | 
					
						
							|  |  |  |     terminated? off
 | 
					
						
							| 
									
										
										
										
											2008-12-04 07:02:49 -05:00
										 |  |  |     V{ } clone \ meta-d set
 | 
					
						
							|  |  |  |     V{ } clone literals set
 | 
					
						
							| 
									
										
										
										
											2009-11-09 01:17:24 -05:00
										 |  |  |     0 input-count set ;
 |