"." write flush
{
- new-sequence nth push pop peek
+ new-sequence nth push pop peek flip
} compile-uncompiled
"." write flush
! 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
: convert-two-operand ( mr -- mr' )
[
two-operand? [
- [ convert-two-operand* ] map flatten
+ [ convert-two-operand* ] map-flat
] when
] change-instructions ;
! 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
: 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
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs fry kernel accessors sequences sequences.deep arrays
-stack-checker.inlining namespaces compiler.tree ;
+USING: assocs fry kernel accessors sequences compiler.utilities
+arrays stack-checker.inlining namespaces compiler.tree
+math.order ;
IN: compiler.tree.combinators
: each-node ( nodes quot: ( node -- ) -- )
[ _ map-nodes ] change-child
] when
] if
- ] map flatten ; inline recursive
+ ] map-flat ; inline recursive
: contains-node? ( nodes quot: ( node -- ? ) -- ? )
dup dup '[
: 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
! 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
M: node remove-dead-code* ;
: (remove-dead-code) ( nodes -- nodes' )
- [ remove-dead-code* ] map flatten ;
+ [ remove-dead-code* ] map-flat ;
! 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
! 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 )
M: node actually-defined-by* real-usage boa ;
! Use
-: (actually-used-by) ( value -- real-usages )
- dup used-by [ actually-used-by* ] with map ;
+GENERIC# actually-used-by* 1 ( value node accum -- )
+
+: (actually-used-by) ( value accum -- )
+ [ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
M: #renaming actually-used-by*
- inputs/outputs [ indices ] dip nths
- [ (actually-used-by) ] map ;
+ [ inputs/outputs [ indices ] dip nths ] dip
+ '[ _ (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 ;
2bi ;
M: #phi escape-analysis*
- [ phi-in-d>> <flipped> ] [ out-d>> ] bi merge-allocations ;
+ [ phi-in-d>> flip ] [ out-d>> ] bi merge-allocations ;
--- /dev/null
+! 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? ;
! 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
[
[
[
- [ normalize* ] map flatten
+ [ normalize* ] map-flat
introduction-stack get
2array
] with-scope
: (normalize) ( nodes introductions -- nodes )
introduction-stack [
- [ normalize* ] map flatten
+ [ normalize* ] map-flat
] with-variable ;
M: #recursive normalize*
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
normalize
propagate
cleanup
- escape-analysis
- unbox-tuples
+ dup run-escape-analysis? [
+ escape-analysis
+ unbox-tuples
+ ] when
apply-identities
compute-def-use
remove-dead-code
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
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 -- )
M: #phi propagate-after ( #phi -- )
condition-value get [
[ out-d>> ]
- [ phi-in-d>> <flipped> ]
- [ phi-info-d>> <flipped> ] tri
+ [ phi-in-d>> flip ]
+ [ phi-info-d>> flip ] tri
[
[ possible-boolean-values ] map
branch-phi-constraints
] 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 ;
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
#! 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 \ instance? eq? ] [ inline-instance-check ] }
- { [ dup always-inline-word? ] [ inline-word ] }
- { [ dup standard-generic? ] [ inline-standard-method ] }
- { [ dup math-generic? ] [ inline-math-method ] }
- { [ dup method-body? ] [ inline-method-body ] }
- [ 2drop f ]
- } cond
- ] if ;
+ {
+ { [ dup deferred? ] [ 2drop f ] }
+ { [ dup \ instance? eq? ] [ inline-instance-check ] }
+ { [ dup always-inline-word? ] [ inline-word ] }
+ { [ dup standard-generic? ] [ inline-standard-method ] }
+ { [ dup math-generic? ] [ inline-math-method ] }
+ { [ dup method-body? ] [ inline-method-body ] }
+ [ 2drop f ]
+ } cond ;
+
+: 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 ;
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
[ 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
! 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
: (expand-#push) ( object value -- nodes )
dup unboxed-allocation dup [
[ object-slots ] [ drop ] [ ] tri*
- [ (expand-#push) ] 2map
+ [ (expand-#push) ] 2map-flat
] [
drop #push
] if ;
: unbox-<complex> ( #call -- nodes )
dup unbox-output? [ drop { } ] when ;
-: (flatten-values) ( values -- values' )
- [ dup unboxed-allocation [ (flatten-values) ] [ ] ?if ] map ;
+: (flatten-values) ( values accum -- )
+ 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 ]
--- /dev/null
+! 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
! 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
{ 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 ] ,
- big-word '[ fixnum>bignum _ execute ] ,
+ [ '[ _ 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 ] ,
- big-word '[ [ fixnum>bignum ] dip _ execute ] ,
+ [ '[ _ 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 ;
: 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 ;
projects / factor.git / commitdiff