-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences sequences.deep combinators fry
-classes.algebra namespaces assocs words math math.private
-math.partial-dispatch math.intervals classes classes.tuple
-classes.tuple.private layouts definitions stack-checker.state
-stack-checker.branches
-compiler.intrinsics
-compiler.tree
-compiler.tree.combinators
-compiler.tree.propagation.info
-compiler.tree.propagation.branches ;
+USING: accessors classes classes.algebra combinators
+compiler.tree compiler.tree.combinators
+compiler.tree.propagation.branches
+compiler.tree.propagation.info compiler.utilities fry kernel
+layouts math math.intervals math.partial-dispatch math.private
+namespaces sequences stack-checker.branches
+stack-checker.dependencies words ;
IN: compiler.tree.cleanup
-! A phase run after propagation to finish the job, so to speak.
-! Codifies speculative inlining decisions, deletes branches
-! marked as never taken, and flattens local recursive blocks
-! that do not call themselves.
-
GENERIC: delete-node ( node -- )
M: #call-recursive delete-node
- dup label>> [ [ eq? not ] with filter ] change-calls drop ;
+ dup label>> calls>> [ node>> eq? ] with reject! drop ;
M: #return-recursive delete-node
label>> f >>return drop ;
: cleanup ( nodes -- nodes' )
#! We don't recurse into children here, instead the methods
#! do it since the logic is a bit more involved
- [ cleanup* ] map flatten ;
+ [ cleanup* ] map-flat ;
+! Constant folding
: cleanup-folding? ( #call -- ? )
node-output-infos
[ f ] [ [ literal?>> ] all? ] if-empty ;
-: cleanup-folding ( #call -- nodes )
+: (cleanup-folding) ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
- [ word>> inlined-dependency depends-on ]
[
[ node-output-infos ] [ out-d>> ] bi
- [ [ literal>> ] dip #push ] 2map
+ [ [ literal>> ] dip <#push> ] 2map
]
- [ in-d>> #drop ]
- tri prefix ;
+ [ in-d>> <#drop> ]
+ bi prefix ;
+
+: >predicate-folding< ( #call -- value-info class result )
+ [ node-input-infos first ]
+ [ word>> "predicating" word-prop ]
+ [ node-output-infos first literal>> ] tri ;
+
+: record-predicate-folding ( #call -- )
+ >predicate-folding< pick literal?>>
+ [ [ literal>> ] 2dip add-depends-on-instance-predicate ]
+ [ [ class>> ] 2dip add-depends-on-class-predicate ]
+ if ;
+: record-folding ( #call -- )
+ dup word>> predicate?
+ [ record-predicate-folding ]
+ [ word>> add-depends-on-definition ]
+ if ;
+
+: cleanup-folding ( #call -- nodes )
+ [ (cleanup-folding) ] [ record-folding ] bi ;
+
+! Method inlining
: add-method-dependency ( #call -- )
dup method>> word? [
- [ word>> ] [ class>> ] bi depends-on-generic
+ [ [ class>> ] [ word>> ] bi add-depends-on-generic ]
+ [ [ class>> ] [ word>> ] [ method>> ] tri add-depends-on-method ]
+ bi
] [ drop ] if ;
+: record-inlining ( #call -- )
+ dup method>>
+ [ add-method-dependency ]
+ [ word>> add-depends-on-definition ] if ;
+
: cleanup-inlining ( #call -- nodes )
- [
- dup method>>
- [ add-method-dependency ]
- [ word>> inlined-dependency depends-on ] if
- ] [ body>> cleanup ] bi ;
+ [ record-inlining ] [ body>> cleanup ] bi ;
! Removing overflow checks
: (remove-overflow-check?) ( #call -- ? )
} cond ;
: remove-overflow-check ( #call -- #call )
- [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ;
+ [ no-overflow-variant ] change-word cleanup* ;
M: #call cleanup*
{
[ ]
} cond ;
-M: #declare cleanup* drop f ;
-
: delete-unreachable-branches ( #branch -- )
dup live-branches>> '[
_
#! If only one branch is live we don't need to branch at
#! all; just drop the condition value.
dup live-children sift dup length {
- { 0 [ 2drop f ] }
- { 1 [ first swap in-d>> #drop prefix ] }
+ { 0 [ drop in-d>> <#drop> ] }
+ { 1 [ first swap in-d>> <#drop> prefix ] }
[ 2drop ]
} case ;
} cleave ;
: output-fs ( values -- nodes )
- [ f swap #push ] map ;
+ [ f swap <#push> ] map ;
: eliminate-single-phi ( #phi -- node )
[ phi-in-d>> first ] [ out-d>> ] bi over [ +bottom+ eq? ] all?
[ [ drop ] [ output-fs ] bi* ]
- [ #copy ]
+ [ <#copy> ]
if ;
: eliminate-phi ( #phi -- node )
eliminate-phi
live-branches off ;
-: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
+: >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi <#copy> ;
: flatten-recursive ( #recursive -- nodes )
#! convert #enter-recursive and #return-recursive into
[ cleanup ] change-child
dup label>> calls>> empty? [ flatten-recursive ] when ;
+M: #alien-callback cleanup*
+ [ cleanup ] change-child ;
+
M: node cleanup* ;