More optimization intended to reduce compile time. Another 10% speedup on compiling empty PEG parser

- new map-flat combinator replaces usages of 'map flatten' in compiler
- compiler.tree.def-use.simplified uses an explicit accumulator instead of flatten
- compiler.tree.tuple-unboxing uses an explicit accumulator instead of flatten
- fix inlining regression from last time: custom inlining results would sometimes be discarded
- compiler.tree's 3each and 3map combinators rewritten to not use flip
- rewrite math.partial-dispatch without locals (purely stylistic, no performance increase)
- hand-optimize flip for common arrays-of-arrays case
- don't run escape analysis and tuple unboxing if there are no allocations in the IR

basis/bootstrap/compiler/compiler.factor

@@ -60,7 +60,7 @@ nl
 "." write flush
 
 {
-    new-sequence nth push pop peek
+    new-sequence nth push pop peek flip
 } compile-uncompiled
 
 "." write flush

basis/compiler/cfg/two-operand/two-operand.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel sequences sequences.deep
+USING: accessors arrays kernel sequences compiler.utilities
 compiler.cfg.instructions cpu.architecture ;
 IN: compiler.cfg.two-operand
 
@@ -55,6 +55,6 @@ M: insn convert-two-operand* ;
 : convert-two-operand ( mr -- mr' )
     [
         two-operand? [
-            [ convert-two-operand* ] map flatten
+            [ convert-two-operand* ] map-flat
         ] when
     ] change-instructions ;

basis/compiler/tree/cleanup/cleanup.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors sequences sequences.deep combinators fry
+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
@@ -33,7 +34,7 @@ GENERIC: cleanup* ( node -- node/nodes )
 : 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 ;
 
 : cleanup-folding? ( #call -- ? )
     node-output-infos

basis/compiler/tree/combinators/combinators.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs fry kernel accessors sequences sequences.deep arrays
+USING: assocs fry kernel accessors sequences compiler.utilities
-stack-checker.inlining namespaces compiler.tree ;
+arrays stack-checker.inlining namespaces compiler.tree
+math.order ;
 IN: compiler.tree.combinators
 
 : each-node ( nodes quot: ( node -- ) -- )
@@ -27,7 +28,7 @@ IN: compiler.tree.combinators
                 [ _ map-nodes ] change-child
             ] when
         ] if
-    ] map flatten ; inline recursive
+    ] map-flat ; inline recursive
 
 : contains-node? ( nodes quot: ( node -- ? ) -- ? )
     dup dup '[
@@ -48,12 +49,6 @@ IN: compiler.tree.combinators
 : sift-children ( seq flags -- seq' )
     zip [ nip ] assoc-filter keys ;
 
-: (3each) [ 3array flip ] dip '[ first3 @ ] ; inline
-
-: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
-
-: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
-
 : until-fixed-point ( #recursive quot: ( node -- ) -- )
     over label>> t >>fixed-point drop
     [ with-scope ] 2keep

basis/compiler/tree/dead-code/liveness/liveness.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors namespaces assocs deques search-deques
-dlists kernel sequences sequences.deep words sets
+dlists kernel sequences compiler.utilities words sets
 stack-checker.branches compiler.tree compiler.tree.def-use
 compiler.tree.combinators ;
 IN: compiler.tree.dead-code.liveness
@@ -49,4 +49,4 @@ GENERIC: remove-dead-code* ( node -- node' )
 M: node remove-dead-code* ;
 
 : (remove-dead-code) ( nodes -- nodes' )
-    [ remove-dead-code* ] map flatten ;
+    [ remove-dead-code* ] map-flat ;

basis/compiler/tree/def-use/simplified/simplified.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: sequences sequences.deep kernel
+USING: sequences kernel fry vectors
 compiler.tree compiler.tree.def-use ;
 IN: compiler.tree.def-use.simplified
 
@@ -9,8 +9,6 @@ IN: compiler.tree.def-use.simplified
 ! A 'real' usage is a usage of a value that is not a #renaming.
 TUPLE: real-usage value node ;
 
-GENERIC: actually-used-by* ( value node -- real-usages )
-
 ! Def
 GENERIC: actually-defined-by* ( value node -- real-usage )
 
@@ -25,16 +23,18 @@ M: #return-recursive actually-defined-by* real-usage boa ;
 M: node actually-defined-by* real-usage boa ;
 
 ! Use
-: (actually-used-by) ( value -- real-usages )
+GENERIC# actually-used-by* 1 ( value node accum -- )
-    dup used-by [ actually-used-by* ] with map ;
+
+: (actually-used-by) ( value accum -- )
+    [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
 
 M: #renaming actually-used-by*
-    inputs/outputs [ indices ] dip nths
+    [ inputs/outputs [ indices ] dip nths ] dip
-    [ (actually-used-by) ] map ;
+    '[ _ (actually-used-by) ] each ;
 
-M: #return-recursive actually-used-by* real-usage boa ;
+M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
 
-M: node actually-used-by* real-usage boa ;
+M: node actually-used-by* [ real-usage boa ] dip push ;
 
 : actually-used-by ( value -- real-usages )
-    (actually-used-by) flatten ;
+    10 <vector> [ (actually-used-by) ] keep ;

basis/compiler/tree/escape-analysis/branches/branches.factor

@@ -33,4 +33,4 @@ M: #branch escape-analysis*
     2bi ;
 
 M: #phi escape-analysis*
-    [ phi-in-d>> <flipped> ] [ out-d>> ] bi merge-allocations ;
+    [ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ;

basis/compiler/tree/escape-analysis/check/check.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes classes.tuple math math.private accessors
+combinators kernel compiler.tree compiler.tree.combinators
+compiler.tree.propagation.info ;
+IN: compiler.tree.escape-analysis.check
+
+GENERIC: run-escape-analysis* ( node -- ? )
+
+M: #push run-escape-analysis*
+    literal>> [ class immutable-tuple-class? ] [ complex? ] bi or ;
+
+M: #call run-escape-analysis*
+    {
+        { [ dup word>> \ <complex> eq? ] [ t ] }
+        { [ dup immutable-tuple-boa? ] [ t ] }
+        [ f ] 
+    } cond nip ;
+
+M: node run-escape-analysis* drop f ;
+
+: run-escape-analysis? ( nodes -- ? )
+    [ run-escape-analysis* ] contains-node? ;

basis/compiler/tree/normalization/normalization.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces sequences math accessors kernel arrays
-combinators sequences.deep assocs
+combinators compiler.utilities assocs
 stack-checker.backend
 stack-checker.branches
 stack-checker.inlining
+compiler.utilities
 compiler.tree
 compiler.tree.combinators
 compiler.tree.normalization.introductions
@@ -46,7 +47,7 @@ M: #branch normalize*
     [
         [
             [
-                [ normalize* ] map flatten
+                [ normalize* ] map-flat
                 introduction-stack get
                 2array
             ] with-scope
@@ -70,7 +71,7 @@ M: #phi normalize*
 
 : (normalize) ( nodes introductions -- nodes )
     introduction-stack [
-        [ normalize* ] map flatten
+        [ normalize* ] map-flat
     ] with-variable ;
 
 M: #recursive normalize*

basis/compiler/tree/optimizer/optimizer.factor

@@ -6,6 +6,7 @@ compiler.tree.normalization
 compiler.tree.propagation
 compiler.tree.cleanup
 compiler.tree.escape-analysis
+compiler.tree.escape-analysis.check
 compiler.tree.tuple-unboxing
 compiler.tree.identities
 compiler.tree.def-use
@@ -22,8 +23,10 @@ SYMBOL: check-optimizer?
     normalize
     propagate
     cleanup
-    escape-analysis
+    dup run-escape-analysis? [
-    unbox-tuples
+        escape-analysis
+        unbox-tuples
+    ] when
     apply-identities
     compute-def-use
     remove-dead-code

basis/compiler/tree/propagation/branches/branches.factor

@@ -3,6 +3,7 @@
 USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra combinators columns
 stack-checker.branches
+compiler.utilities
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -78,7 +79,7 @@ SYMBOL: condition-value
 
 M: #phi propagate-before ( #phi -- )
     [ annotate-phi-inputs ]
-    [ [ phi-info-d>> <flipped> ] [ out-d>> ] bi merge-value-infos ]
+    [ [ phi-info-d>> flip ] [ out-d>> ] bi merge-value-infos ]
     bi ;
 
 : branch-phi-constraints ( output values booleans -- )
@@ -137,8 +138,8 @@ M: #phi propagate-before ( #phi -- )
 M: #phi propagate-after ( #phi -- )
     condition-value get [
         [ out-d>> ]
-        [ phi-in-d>> <flipped> ]
+        [ phi-in-d>> flip ]
-        [ phi-info-d>> <flipped> ] tri
+        [ phi-info-d>> flip ] tri
         [
             [ possible-boolean-values ] map
             branch-phi-constraints

basis/compiler/tree/propagation/copy/copy.factor

@@ -49,7 +49,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
     ] 2each ;
 
 M: #phi compute-copy-equiv*
-    [ phi-in-d>> <flipped> ] [ out-d>> ] bi compute-phi-equiv ;
+    [ phi-in-d>> flip ] [ out-d>> ] bi compute-phi-equiv ;
 
 M: node compute-copy-equiv* drop ;
 

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -184,7 +184,7 @@ SYMBOL: history
     over in-d>> second value-info literal>> dup class?
     [ "predicate" word-prop '[ drop @ ] inline-word-def ] [ 3drop f ] if ;
 
-: do-inlining ( #call word -- ? )
+: (do-inlining) ( #call word -- ? )
     #! If the generic was defined in an outer compilation unit,
     #! then it doesn't have a definition yet; the definition
     #! is built at the end of the compilation unit. We do not
@@ -193,14 +193,19 @@ SYMBOL: history
     #! of bounds value. This case comes up if a parsing word
     #! calls the compiler at parse time (doing so is
     #! discouraged, but it should still work.)
-    dup custom-inlining? [ 2dup inline-custom ] [ f ] if [ 2drop f ] [
+    {
-        {
+        { [ dup deferred? ] [ 2drop f ] }
-            { [ dup deferred? ] [ 2drop f ] }
+        { [ dup \ instance? eq? ] [ inline-instance-check ] }
-            { [ dup \ instance? eq? ] [ inline-instance-check ] }
+        { [ dup always-inline-word? ] [ inline-word ] }
-            { [ dup always-inline-word? ] [ inline-word ] }
+        { [ dup standard-generic? ] [ inline-standard-method ] }
-            { [ dup standard-generic? ] [ inline-standard-method ] }
+        { [ dup math-generic? ] [ inline-math-method ] }
-            { [ dup math-generic? ] [ inline-math-method ] }
+        { [ dup method-body? ] [ inline-method-body ] }
-            { [ dup method-body? ] [ inline-method-body ] }
+        [ 2drop f ]
-            [ 2drop f ]
+    } cond ;
-        } cond
+
-    ] if ;
+: do-inlining ( #call word -- ? )
+    #! Note the logic here: if there's a custom inlining hook,
+    #! it is permitted to return f, which means that we try the
+    #! normal inlining heuristic.
+    dup custom-inlining? [ 2dup inline-custom ] [ f ] if
+    [ 2drop t ] [ (do-inlining) ] if ;

basis/compiler/tree/propagation/propagation-tests.factor

@@ -8,7 +8,8 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-specialized-arrays.double system sorting math.libm ;
+specialized-arrays.double system sorting math.libm
+math.intervals ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -599,6 +600,10 @@ MIXIN: empty-mixin
 
 [ V{ t } ] [ [ { fixnum } declare 10 mod >float -20 > ] final-literals ] unit-test
 
+[ T{ interval f { 0 t } { 127 t } } ] [
+    [ { integer } declare 127 bitand ] final-info first interval>>
+] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces assocs accessors kernel combinators
-classes.algebra sequences sequences.deep slots.private
+classes.algebra sequences slots.private fry vectors
 classes.tuple.private math math.private arrays
 stack-checker.branches
+compiler.utilities
 compiler.tree
 compiler.tree.combinators
 compiler.tree.propagation.info
@@ -21,7 +22,7 @@ GENERIC: unbox-tuples* ( node -- node/nodes )
 : (expand-#push) ( object value -- nodes )
     dup unboxed-allocation dup [
         [ object-slots ] [ drop ] [ ] tri*
-        [ (expand-#push) ] 2map
+        [ (expand-#push) ] 2map-flat
     ] [
         drop #push
     ] if ;
@@ -38,11 +39,16 @@ M: #push unbox-tuples* ( #push -- nodes )
 : unbox-<complex> ( #call -- nodes )
     dup unbox-output? [ drop { } ] when ;
 
-: (flatten-values) ( values -- values' )
+: (flatten-values) ( values accum -- )
-    [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
+    dup '[
+        dup unboxed-allocation
+        [ _ (flatten-values) ] [ _ push ] ?if
+    ] each ;
 
 : flatten-values ( values -- values' )
-    dup empty? [ (flatten-values) flatten ] unless ;
+    dup empty? [
+        10 <vector> [ (flatten-values) ] keep
+    ] unless ;
 
 : prepare-slot-access ( #call -- tuple-values outputs slot-values )
     [ in-d>> flatten-values ]

basis/compiler/utilities/utilities.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences sequences.private arrays vectors fry
+math.order ;
+IN: compiler.utilities
+
+: flattener ( seq quot -- seq vector quot' )
+    over length <vector> [
+        dup
+        '[
+            @ [
+                dup array?
+                [ _ push-all ] [ _ push ] if
+            ] when*
+        ]
+    ] keep ; inline
+
+: flattening ( seq quot combinator -- seq' )
+    [ flattener ] dip dip { } like ; inline
+
+: map-flat ( seq quot -- seq' ) [ each ] flattening ; inline
+
+: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
+
+: (3each) ( seq1 seq2 seq3 quot -- n quot' )
+    [ [ [ length ] tri@ min min ] 3keep ] dip
+    '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
+
+: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
+
+: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline

basis/math/partial-dispatch/partial-dispatch.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel kernel.private math math.private words
-sequences parser namespaces make assocs quotations arrays locals
+sequences parser namespaces make assocs quotations arrays
 generic generic.math hashtables effects compiler.units
 classes.algebra fry combinators ;
 IN: math.partial-dispatch
@@ -45,29 +45,29 @@ M: word integer-op-input-classes
         { bitnot fixnum-bitnot }
     } at swap or ;
 
-:: integer-fixnum-op-quot ( fix-word big-word -- quot )
+: integer-fixnum-op-quot ( fix-word big-word -- quot )
     [
         [ over fixnum? ] %
-        fix-word '[ _ execute ] ,
+        [ '[ _ execute ] , ]
-        big-word '[ fixnum>bignum _ execute ] ,
+        [ '[ fixnum>bignum _ execute ] , ] bi*
         \ if ,
     ] [ ] make ;
 
-:: fixnum-integer-op-quot ( fix-word big-word -- quot )
+: fixnum-integer-op-quot ( fix-word big-word -- quot )
     [
         [ dup fixnum? ] %
-        fix-word '[ _ execute ] ,
+        [ '[ _ execute ] , ]
-        big-word '[ [ fixnum>bignum ] dip _ execute ] ,
+        [ '[ [ fixnum>bignum ] dip _ execute ] , ] bi*
         \ if ,
     ] [ ] make ;
 
-:: integer-integer-op-quot ( fix-word big-word -- quot )
+: integer-integer-op-quot ( fix-word big-word -- quot )
     [
         [ dup fixnum? ] %
-        fix-word big-word integer-fixnum-op-quot ,
+        2dup integer-fixnum-op-quot ,
         [
             [ over fixnum? [ [ fixnum>bignum ] dip ] when ] %
-            big-word ,
+            nip ,
         ] [ ] make ,
         \ if ,
     ] [ ] make ;

core/sequences/sequences.factor

@@ -835,12 +835,35 @@ PRIVATE>
 
 : supremum ( seq -- n ) dup first [ max ] reduce ;
 
-: flip ( matrix -- newmatrix )
-    dup empty? [
-        dup [ length ] map infimum
-        swap [ [ nth-unsafe ] with { } map-as ] curry { } map-as
-    ] unless ;
-
 : sigma ( seq quot -- n ) [ + ] compose 0 swap reduce ; inline
 
 : count ( seq quot -- n ) [ 1 0 ? ] compose sigma ; inline
+
+! We hand-optimize flip to such a degree because type hints
+! cannot express that an array is an array of arrays yet, and
+! this word happens to be performance-critical since the compiler
+! itself uses it. Optimizing it like this reduced compile time.
+<PRIVATE
+
+: generic-flip ( matrix -- newmatrix )
+    [ dup first length [ length min ] reduce ] keep
+    [ [ nth-unsafe ] with { } map-as ] curry { } map-as ; inline
+
+USE: arrays
+
+: array-length ( array -- len )
+    { array } declare length>> ;
+
+: array-flip ( matrix -- newmatrix )
+    [ dup first array-length [ array-length min ] reduce ] keep
+    [ [ array-nth ] with { } map-as ] curry { } map-as ;
+
+PRIVATE>
+
+: flip ( matrix -- newmatrix )
+    dup empty? [
+        dup array? [
+            dup [ array? ] all?
+            [ array-flip ] [ generic-flip ] if
+        ] [ generic-flip ] if
+    ] unless ;