use reject instead of [ ... not ] filter.

[factor.git] / basis / compiler / tree / cleanup / cleanup.factor

diff --git a/basis/compiler/tree/cleanup/cleanup.factor b/basis/compiler/tree/cleanup/cleanup.factor
index 8ed83188e5ddd6841f019340e4081501e78513be..d610ef17650b2a21994facd2b490f71f6011472f 100644 (file)
--- a/basis/compiler/tree/cleanup/cleanup.factor
+++ b/basis/compiler/tree/cleanup/cleanup.factor
@@ -1,26 +1,18 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences 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.utilities
-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>> calls>> [ node>> eq? not ] with filter! drop ;
+    dup label>> calls>> [ node>> eq? ] with reject! drop ;
 
 M: #return-recursive delete-node
     label>> f >>return drop ;
@@ -36,32 +28,56 @@ GENERIC: cleanup* ( node -- node/nodes )
     #! do it since the logic is a bit more involved
     [ 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 -- ? )
@@ -101,8 +117,8 @@ M: #call cleanup*
     #! 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 [ drop in-d>> #drop ] }
-        { 1 [ first swap in-d>> #drop prefix ] }
+        { 0 [ drop in-d>> <#drop> ] }
+        { 1 [ first swap in-d>> <#drop> prefix ] }
         [ 2drop ]
     } case ;
 
@@ -120,12 +136,12 @@ M: #branch cleanup*
     } 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 )
@@ -144,7 +160,7 @@ M: #phi cleanup*
     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
@@ -158,4 +174,7 @@ M: #recursive cleanup*
     [ cleanup ] change-child
     dup label>> calls>> empty? [ flatten-recursive ] when ;
 
+M: #alien-callback cleanup*
+    [ cleanup ] change-child ;
+
 M: node cleanup* ;