2008-09-11 03:05:22 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Copyright (C) 2008 Slava Pestov.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! See http://factorcode.org/license.txt for BSD license.
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								USING: kernel words sequences quotations namespaces io
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-20 02:56:28 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								classes.tuple accessors prettyprint prettyprint.config
							 | 
						
					
						
							
								
									
										
										
										
											2008-12-08 15:58:00 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								prettyprint.backend prettyprint.custom prettyprint.sections
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								parser compiler.tree.builder compiler.tree.optimizer
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-07 21:00:38 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								compiler.cfg.builder compiler.cfg.linearization
							 | 
						
					
						
							
								
									
										
										
										
											2008-12-08 15:58:00 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								compiler.cfg.registers compiler.cfg.stack-frame
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								compiler.cfg.linear-scan compiler.cfg.two-operand
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								compiler.cfg.optimizer ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-11 03:05:22 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								IN: compiler.cfg.debugger
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								GENERIC: test-cfg ( quot -- cfgs )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: callable test-cfg
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-17 01:46:38 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    build-tree optimize-tree gensym build-cfg ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-11 03:05:22 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: word test-cfg
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-17 01:46:38 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ build-tree-from-word nip optimize-tree ] keep build-cfg ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-11 03:05:22 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-20 02:56:28 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								SYMBOL: allocate-registers?
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-07 21:00:38 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								: test-mr ( quot -- mrs )
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-20 02:56:28 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								    test-cfg [
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-22 19:39:41 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        optimize-cfg
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-20 02:56:28 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        build-mr
							 | 
						
					
						
							
								
									
										
										
										
											2008-11-02 02:49:57 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        convert-two-operand
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-20 02:56:28 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        allocate-registers? get
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        [ linear-scan build-stack-frame ] when
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] map ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: insn. ( insn -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    tuple>array allocate-registers? get [ but-last ] unless
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [ pprint bl ] each nl ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-11 03:05:22 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: mr. ( mrs -- )
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    [
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        "=== word: " write
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        dup word>> pprint
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        ", label: " write
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        dup label>> pprint nl nl
							 | 
						
					
						
							
								
									
										
										
										
											2008-10-20 02:56:28 -04:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								        instructions>> [ insn. ] each
							 | 
						
					
						
							
								
									
										
										
										
											2008-09-11 03:05:22 -04:00
										 
									 
								 
							 | 
							
								
							 | 
							
								
							 | 
							
							
								        nl
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    ] each ;
							 | 
						
					
						
							
								
									
										
										
										
											2008-12-08 15:58:00 -05:00
										 
									 
								 
							 | 
							
								
									
										
									
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								! Prettyprinting
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: vreg pprint*
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    <block
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    \ V pprint-word [ reg-class>> pprint* ] [ n>> pprint* ] bi
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								    block> ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: ds-loc pprint* \ D pprint-loc ;
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								
							 | 
						
					
						
							| 
								
							 | 
							
								
							 | 
							
								
							 | 
							
							
								M: rs-loc pprint* \ R pprint-loc ;
							 |