compiler.tree: remove some code duplication concerning #alien nodes
							parent
							
								
									89e9f77b44
								
							
						
					
					
						commit
						44a604fdbe
					
				| 
						 | 
					@ -185,9 +185,7 @@ M: #recursive check-stack-flow*
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 | 
					M: #copy check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-invoke check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 | 
					M: #alien-node check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 | 
				
			||||||
 | 
					 | 
				
			||||||
M: #alien-indirect check-stack-flow* [ check-in-d ] [ check-out-d ] bi ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-callback check-stack-flow* drop ;
 | 
					M: #alien-callback check-stack-flow* drop ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -28,9 +28,7 @@ M: method-body flushable? "method-generic" word-prop flushable? ;
 | 
				
			||||||
M: #call mark-live-values*
 | 
					M: #call mark-live-values*
 | 
				
			||||||
    dup flushable-call? [ drop ] [ look-at-inputs ] if ;
 | 
					    dup flushable-call? [ drop ] [ look-at-inputs ] if ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-invoke mark-live-values* look-at-inputs ;
 | 
					M: #alien-node mark-live-values* look-at-inputs ;
 | 
				
			||||||
 | 
					 | 
				
			||||||
M: #alien-indirect mark-live-values* look-at-inputs ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #return mark-live-values* look-at-inputs ;
 | 
					M: #return mark-live-values* look-at-inputs ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					@ -47,9 +45,7 @@ M: #call compute-live-values* nip look-at-inputs ;
 | 
				
			||||||
M: #shuffle compute-live-values*
 | 
					M: #shuffle compute-live-values*
 | 
				
			||||||
    mapping>> at look-at-value ;
 | 
					    mapping>> at look-at-value ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-invoke compute-live-values* nip look-at-inputs ;
 | 
					M: #alien-node compute-live-values* nip look-at-inputs ;
 | 
				
			||||||
 | 
					 | 
				
			||||||
M: #alien-indirect compute-live-values* nip look-at-inputs ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
: filter-mapping ( assoc -- assoc' )
 | 
					: filter-mapping ( assoc -- assoc' )
 | 
				
			||||||
    live-values get '[ drop _ key? ] assoc-filter ;
 | 
					    live-values get '[ drop _ key? ] assoc-filter ;
 | 
				
			||||||
| 
						 | 
					@ -127,8 +123,5 @@ M: #terminate remove-dead-code*
 | 
				
			||||||
    [ filter-live ] change-in-d
 | 
					    [ filter-live ] change-in-d
 | 
				
			||||||
    [ filter-live ] change-in-r ;
 | 
					    [ filter-live ] change-in-r ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-invoke remove-dead-code*
 | 
					M: #alien-node remove-dead-code*
 | 
				
			||||||
    maybe-drop-dead-outputs ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
M: #alien-indirect remove-dead-code*
 | 
					 | 
				
			||||||
    maybe-drop-dead-outputs ;
 | 
					    maybe-drop-dead-outputs ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -86,12 +86,7 @@ M: #call escape-analysis*
 | 
				
			||||||
M: #return escape-analysis*
 | 
					M: #return escape-analysis*
 | 
				
			||||||
    in-d>> add-escaping-values ;
 | 
					    in-d>> add-escaping-values ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-invoke escape-analysis*
 | 
					M: #alien-node escape-analysis*
 | 
				
			||||||
    [ in-d>> add-escaping-values ]
 | 
					 | 
				
			||||||
    [ out-d>> unknown-allocations ]
 | 
					 | 
				
			||||||
    bi ;
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
M: #alien-indirect escape-analysis*
 | 
					 | 
				
			||||||
    [ in-d>> add-escaping-values ]
 | 
					    [ in-d>> add-escaping-values ]
 | 
				
			||||||
    [ out-d>> unknown-allocations ]
 | 
					    [ out-d>> unknown-allocations ]
 | 
				
			||||||
    bi ;
 | 
					    bi ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -153,8 +153,6 @@ M: #call propagate-after
 | 
				
			||||||
    [ out-d>> ] [ params>> return>> ] bi
 | 
					    [ out-d>> ] [ params>> return>> ] bi
 | 
				
			||||||
    [ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
 | 
					    [ drop ] [ c-type-class <class-info> swap first set-value-info ] if-void ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-invoke propagate-before propagate-alien-invoke ;
 | 
					M: #alien-node propagate-before propagate-alien-invoke ;
 | 
				
			||||||
 | 
					 | 
				
			||||||
M: #alien-indirect propagate-before propagate-alien-invoke ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #return annotate-node dup in-d>> (annotate-node) ;
 | 
					M: #return annotate-node dup in-d>> (annotate-node) ;
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -149,7 +149,7 @@ TUPLE: #alien-indirect < #alien-node in-d out-d ;
 | 
				
			||||||
: #alien-indirect ( params -- node )
 | 
					: #alien-indirect ( params -- node )
 | 
				
			||||||
    \ #alien-indirect new-alien-node ;
 | 
					    \ #alien-indirect new-alien-node ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
TUPLE: #alien-callback < #alien-node ;
 | 
					TUPLE: #alien-callback < node params ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
: #alien-callback ( params -- node )
 | 
					: #alien-callback ( params -- node )
 | 
				
			||||||
    \ #alien-callback new
 | 
					    \ #alien-callback new
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -164,9 +164,7 @@ M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
 | 
					M: #return unbox-tuples* dup in-d>> assert-not-unboxed ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-invoke unbox-tuples* dup in-d>> assert-not-unboxed ;
 | 
					M: #alien-node unbox-tuples* dup in-d>> assert-not-unboxed ;
 | 
				
			||||||
 | 
					 | 
				
			||||||
M: #alien-indirect unbox-tuples* dup in-d>> assert-not-unboxed ;
 | 
					 | 
				
			||||||
 | 
					
 | 
				
			||||||
M: #alien-callback unbox-tuples* ;
 | 
					M: #alien-callback unbox-tuples* ;
 | 
				
			||||||
 | 
					
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Loading…
	
		Reference in New Issue