compiler.tree.recursive
compiler.tree.normalization
compiler.tree.propagation
-compiler.tree.checker ;
-
-: cleaned-up-tree ( quot -- nodes )
- build-tree analyze-recursive normalize propagate cleanup dup check-nodes ;
+compiler.tree.checker
+compiler.tree.debugger ;
[ t ] [ [ [ 1 ] [ 2 ] if ] cleaned-up-tree [ #if? ] contains-node? ] unit-test
[ t ] [ [ t recursive-test ] cleaned-up-tree [ #recursive? ] contains-node? ] unit-test
-: inlined? ( quot seq/word -- ? )
- [ cleaned-up-tree ] dip
- dup word? [ 1array ] when
- '[ dup #call? [ word>> _ member? ] [ drop f ] if ]
- contains-node? not ;
-
[ f ] [
[ { integer } declare >fixnum ]
\ >fixnum inlined?
[ 2 swap >fixnum ribs ]
{ <-integer-fixnum +-integer-fixnum } inlined?
] unit-test
+
+[ t ] [
+ [ hashtable new ] \ new inlined?
+] unit-test
] [ body>> cleanup ] bi ;
! Removing overflow checks
-: no-overflow-variant ( op -- fast-op )
- H{
- { fixnum+ fixnum+fast }
- { fixnum- fixnum-fast }
- { fixnum* fixnum*fast }
- { fixnum-shift fixnum-shift-fast }
- } at ;
-
: (remove-overflow-check?) ( #call -- ? )
node-output-infos first class>> fixnum class<= ;
'[ _ nth _ key? ] filter ; inline
: drop-indexed-values ( values indices -- node )
- [ drop filter-live ] [ nths ] 2bi
+ [ drop filter-live ] [ swap nths ] 2bi
[ make-values ] keep
[ drop ] [ zip ] 2bi
#shuffle ;
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel assocs fry match accessors namespaces make effects
+USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.sections math words
-combinators io sorting hints
+combinators io sorting hints qualified
compiler.tree
+compiler.tree.recursive
+compiler.tree.normalization
+compiler.tree.cleanup
+compiler.tree.propagation
+compiler.tree.propagation.info
+compiler.tree.def-use
compiler.tree.builder
compiler.tree.optimizer
-compiler.tree.combinators ;
+compiler.tree.combinators
+compiler.tree.checker ;
+RENAME: _ match => __
IN: compiler.tree.debugger
! A simple tool for turning tree IR into quotations and
{ { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] }
{ { { ?a ?b } { ?b } } [ nip ] }
{ { { ?a ?b ?c } { ?c } } [ 2nip ] }
- { _ f }
+ { __ f }
} match-choose ;
TUPLE: shuffle-node { effect effect } ;
: optimizer-report. ( word -- )
make-report report. ;
+
+! More utilities
+
+: final-info ( quot -- seq )
+ build-tree
+ analyze-recursive
+ normalize
+ propagate
+ compute-def-use
+ dup check-nodes
+ peek node-input-infos ;
+
+: final-classes ( quot -- seq )
+ final-info [ class>> ] map ;
+
+: final-literals ( quot -- seq )
+ final-info [ literal>> ] map ;
+
+: cleaned-up-tree ( quot -- nodes )
+ [
+ check-optimizer? on
+ build-tree optimize-tree
+ ] with-scope ;
+
+: inlined? ( quot seq/word -- ? )
+ [ cleaned-up-tree ] dip
+ dup word? [ 1array ] when
+ '[ dup #call? [ word>> _ member? ] [ drop f ] if ]
+ contains-node? not ;
--- /dev/null
+USING: kernel tools.test compiler.tree compiler.tree.builder
+compiler.tree.def-use compiler.tree.def-use.simplified accessors
+sequences sorting classes ;
+IN: compiler.tree.def-use.simplified
+
+[ { #call #return } ] [
+ [ 1 dup reverse ] build-tree compute-def-use
+ first out-d>> first actually-used-by
+ [ node>> class ] map natural-sort
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences sequences.deep kernel
+compiler.tree compiler.tree.def-use ;
+IN: compiler.tree.def-use.simplified
+
+! Simplified def-use follows chains of copies.
+
+! 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 )
+
+: actually-defined-by ( value -- real-usage )
+ dup defined-by actually-defined-by* ;
+
+M: #renaming actually-defined-by*
+ inputs/outputs swap [ index ] dip nth actually-defined-by ;
+
+M: #return-recursive actually-defined-by* real-usage boa ;
+
+M: node actually-defined-by* real-usage boa ;
+
+! Use
+: (actually-used-by) ( value -- real-usages )
+ dup used-by [ actually-used-by* ] with map ;
+
+M: #renaming actually-used-by*
+ inputs/outputs [ indices ] dip nths
+ [ (actually-used-by) ] map ;
+
+M: #return-recursive actually-used-by* real-usage boa ;
+
+M: node actually-used-by* real-usage boa ;
+
+: actually-used-by ( value -- real-usages )
+ (actually-used-by) flatten ;
byte-arrays alien.accessors
compiler.intrinsics
compiler.tree
-compiler.tree.builder
-compiler.tree.recursive
-compiler.tree.normalization
-compiler.tree.propagation
+compiler.tree.combinators
compiler.tree.propagation.info
-compiler.tree.cleanup
-compiler.tree.def-use
-compiler.tree.dead-code
-compiler.tree.combinators ;
+compiler.tree.late-optimizations ;
IN: compiler.tree.finalization
+! This is a late-stage optimization.
+! See the comment in compiler.tree.late-optimizations.
+
! This pass runs after propagation, so that it can expand
! built-in type predicates and memory allocation; these cannot
! be expanded before propagation since we need to see 'fixnum?'
! instead of 'tag 0 eq?' and so on, for semantic reasoning.
! We also delete empty stack shuffles and copies to facilitate
-! tail call optimization in the code generator. After this pass
-! runs, stack flow information is no longer accurate, since we
-! punt in 'splice-quot' and don't update everything that we
-! should; this simplifies the code, improves performance, and we
-! don't need the stack flow information after this pass anyway.
+! tail call optimization in the code generator.
GENERIC: finalize* ( node -- nodes )
[ in>> ] [ out>> ] bi sequence=
[ drop f ] when ;
-: splice-quot ( quot -- nodes )
- [
- build-tree
- analyze-recursive
- normalize
- propagate
- cleanup
- compute-def-use
- remove-dead-code
- but-last
- ] with-scope ;
-
: builtin-predicate? ( #call -- ? )
word>> "predicating" word-prop builtin-class? ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences namespaces compiler.tree.builder
+compiler.tree.recursive
+compiler.tree.normalization
+compiler.tree.propagation
+compiler.tree.propagation.info
+compiler.tree.cleanup
+compiler.tree.def-use
+compiler.tree.dead-code ;
+IN: compiler.tree.late-optimizations
+
+! Late optimizations modify the tree such that stack flow
+! information is no longer accurate, since we punt in
+! 'splice-quot' and don't update everything that we should;
+! this simplifies the code, improves performance, and we
+! don't need the stack flow information after this pass anyway.
+
+: splice-quot ( quot -- nodes )
+ [
+ build-tree
+ analyze-recursive
+ normalize
+ propagate
+ cleanup
+ compute-def-use
+ remove-dead-code
+ but-last
+ ] with-scope ;
--- /dev/null
+IN: compiler.tree.modular-arithmetic.tests
+USING: kernel kernel.private tools.test math math.partial-dispatch
+math.private accessors slots.private sequences strings sbufs
+compiler.tree.builder
+compiler.tree.optimizer
+compiler.tree.debugger ;
+
+: test-modular-arithmetic ( quot -- quot' )
+ build-tree optimize-tree nodes>quot ;
+
+[ [ >r >fixnum r> >fixnum fixnum+fast ] ]
+[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
+
+[ [ +-integer-integer dup >fixnum ] ]
+[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
+
+[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ]
+[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
+
+TUPLE: declared-fixnum { x fixnum } ;
+
+[ t ] [
+ [ { declared-fixnum } declare [ 1 + ] change-x ]
+ { + fixnum+ >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { declared-fixnum } declare x>> drop ]
+ { slot } inlined?
+] unit-test
+
+[ f ] [
+ [ { integer } declare -63 shift 4095 bitand ]
+ \ shift inlined?
+] unit-test
+
+[ t ] [
+ [ { integer } declare 127 bitand 3 + ]
+ { + +-integer-fixnum bitand } inlined?
+] unit-test
+
+[ f ] [
+ [ { integer } declare 127 bitand 3 + ]
+ { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare
+ dup 0 >= [
+ 615949 * 797807 + 20 2^ mod dup 19 2^ -
+ ] [ dup ] if
+ ] { * + shift mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { fixnum } declare
+ 615949 * 797807 + 20 2^ mod dup 19 2^ -
+ ] { >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare 0 swap
+ [
+ drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+ ] map
+ ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { fixnum } declare 0 swap
+ [
+ drop 615949 * 797807 + 20 2^ rem dup 19 2^ -
+ ] map
+ ] { * + shift rem mod fixnum-mod fixnum* fixnum+ fixnum- >fixnum } inlined?
+] unit-test
+
+[ t ] [
+ [ { string sbuf } declare ] \ push-all def>> append \ + inlined?
+] unit-test
+
+[ t ] [
+ [ { string sbuf } declare ] \ push-all def>> append \ fixnum+ inlined?
+] unit-test
+
+[ t ] [
+ [ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
+] unit-test
+
+
+
+[ t ] [
+ [
+ { integer } declare [ 256 mod ] map
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+
+[ f ] [
+ [
+ 256 mod
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ f ] [
+ [
+ dup 0 >= [ 256 mod ] when
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare dup 0 >= [ 256 mod ] when
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare 256 rem
+ ] { mod fixnum-mod } inlined?
+] unit-test
+
+[ t ] [
+ [
+ { integer } declare [ 256 rem ] map
+ ] { mod fixnum-mod rem } inlined?
+] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math math.partial-dispatch namespaces sequences sets
+accessors assocs words kernel memoize fry combinators
+compiler.tree
+compiler.tree.combinators
+compiler.tree.def-use
+compiler.tree.def-use.simplified
+compiler.tree.late-optimizations ;
+IN: compiler.tree.modular-arithmetic
+
+! This is a late-stage optimization.
+! See the comment in compiler.tree.late-optimizations.
+
+! Modular arithmetic optimization pass.
+!
+! { integer integer } declare + >fixnum
+! ==>
+! [ >fixnum ] bi@ fixnum+fast
+
+{ + - * bitand bitor bitxor } [
+ [
+ t "modular-arithmetic" set-word-prop
+ ] each-integer-derived-op
+] each
+
+{ bitand bitor bitxor bitnot }
+[ t "modular-arithmetic" set-word-prop ] each
+
+SYMBOL: modularize-values
+
+: modular-value? ( value -- ? )
+ modularize-values get key? ;
+
+: modularize-value ( value -- ) modularize-values get conjoin ;
+
+GENERIC: maybe-modularize* ( value node -- )
+
+: maybe-modularize ( value -- )
+ actually-defined-by [ value>> ] [ node>> ] bi
+ over actually-used-by length 1 = [
+ maybe-modularize*
+ ] [ 2drop ] if ;
+
+M: #call maybe-modularize*
+ dup word>> "modular-arithmetic" word-prop [
+ [ modularize-value ]
+ [ in-d>> [ maybe-modularize ] each ] bi*
+ ] [ 2drop ] if ;
+
+M: node maybe-modularize* 2drop ;
+
+GENERIC: compute-modularized-values* ( node -- )
+
+M: #call compute-modularized-values*
+ dup word>> {
+ { [ \ >fixnum eq? ] [ in-d>> first maybe-modularize ] }
+ ! { [
+ ! {
+ ! mod-integer-fixnum
+ ! mod-integer-integer
+ ! mod-fixnum-integer
+ ! } memq?
+ ! ] [ ] }
+ [ drop ]
+ } cond ;
+
+M: node compute-modularized-values* drop ;
+
+: compute-modularized-values ( nodes -- )
+ [ compute-modularized-values* ] each-node ;
+
+GENERIC: optimize-modular-arithmetic* ( node -- nodes )
+
+: redundant->fixnum? ( #call -- ? )
+ in-d>> first actually-defined-by value>> modular-value? ;
+
+: optimize->fixnum ( #call -- nodes )
+ dup redundant->fixnum? [ drop f ] when ;
+
+MEMO: fixnum-coercion ( flags -- nodes )
+ [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
+
+: optimize-modular-op ( #call -- nodes )
+ dup out-d>> first modular-value? [
+ [ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
+ [
+ [
+ [ actually-defined-by value>> modular-value? ]
+ [ fixnum eq? ]
+ bi* or
+ ] 2map fixnum-coercion
+ ] [ [ modular-variant ] change-word ] bi* suffix
+ ] when ;
+
+M: #call optimize-modular-arithmetic*
+ dup word>> {
+ { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+ { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
+ [ drop ]
+ } cond ;
+
+M: node optimize-modular-arithmetic* ;
+
+: optimize-modular-arithmetic ( nodes -- nodes' )
+ H{ } clone modularize-values set
+ dup compute-modularized-values
+ [ optimize-modular-arithmetic* ] map-nodes ;
compiler.tree.identities
compiler.tree.def-use
compiler.tree.dead-code
-compiler.tree.strength-reduction
+compiler.tree.modular-arithmetic
compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer
apply-identities
compute-def-use
remove-dead-code
- ! strength-reduce
check-optimizer? get [
compute-def-use
dup check-nodes
] when
+ compute-def-use
+ optimize-modular-arithmetic
finalize ;
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
-words namespaces
+words namespaces continuations
compiler.tree
compiler.tree.builder
compiler.tree.recursive
body>> (propagate) ;
! Dispatch elimination
-: eliminate-dispatch ( #call class/f word/f -- ? )
+: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
[ >>class ] dip
over method>> over = [ drop ] [
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
+: custom-inlining? ( word -- ? )
+ "custom-inlining" word-prop ;
+
+: inline-custom ( #call word -- ? )
+ [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
+ first object swap eliminate-dispatch ;
+
: do-inlining ( #call word -- ? )
{
+ { [ dup custom-inlining? ] [ inline-custom ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
{ [ dup math-generic? ] [ inline-math-method ] }
- { [ dup math-partial? ] [ inline-math-partial ] }
{ [ dup method-body? ] [ inline-method-body ] }
[ 2drop f ]
} cond ;
] "outputs" set-word-prop
] assoc-each
+{
+ mod-integer-integer
+ mod-integer-fixnum
+ mod-fixnum-integer
+ fixnum-mod
+ rem
+} [
+ [
+ in-d>> second value-info >literal<
+ [ power-of-2? [ 1- bitand ] f ? ] when
+ ] "custom-inlining" set-word-prop
+] each
+
+{
+ bitand-integer-integer
+ bitand-integer-fixnum
+ bitand-fixnum-integer
+} [
+ [
+ in-d>> second value-info >literal< [
+ 0 most-positive-fixnum between?
+ [ [ >fixnum ] bi@ fixnum-bitand ] f ?
+ ] when
+ ] "custom-inlining" set-word-prop
+] each
+
{
alien-signed-1
alien-unsigned-1
byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use
-compiler.tree.checker slots.private words hashtables
-classes assocs ;
+compiler.tree.debugger compiler.tree.checker
+slots.private words hashtables classes assocs ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
-: final-info ( quot -- seq )
- build-tree
- analyze-recursive
- normalize
- propagate
- compute-def-use
- dup check-nodes
- peek node-input-infos ;
-
-: final-classes ( quot -- seq )
- final-info [ class>> ] map ;
-
-: final-literals ( quot -- seq )
- final-info [ literal>> ] map ;
-
[ V{ } ] [ [ ] final-classes ] unit-test
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
[ { float } declare 0 eq? ] final-classes
] unit-test
+[ V{ integer } ] [
+ [ { integer fixnum } declare mod ] final-classes
+] unit-test
+
+[ V{ integer } ] [
+ [ { fixnum integer } declare bitand ] final-classes
+] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
IN: math.partial-dispatch.tests
-USING: math.partial-dispatch tools.test math kernel sequences ;
+USING: math.partial-dispatch math.private
+tools.test math kernel sequences ;
[ t ] [ \ + integer fixnum math-both-known? ] unit-test
[ t ] [ \ + bignum fixnum math-both-known? ] unit-test
[ f ] [ \ number= fixnum object math-both-known? ] unit-test
[ t ] [ \ number= integer fixnum math-both-known? ] unit-test
[ f ] [ \ >fixnum \ shift derived-ops memq? ] unit-test
+
+[ { integer fixnum } ] [ \ +-integer-fixnum integer-op-input-classes ] unit-test
+[ { fixnum fixnum } ] [ \ fixnum+ integer-op-input-classes ] unit-test
+[ { fixnum fixnum } ] [ \ fixnum+fast integer-op-input-classes ] unit-test
+[ { integer } ] [ \ bitnot integer-op-input-classes ] unit-test
+
+[ shift ] [ \ fixnum-shift generic-variant ] unit-test
+[ fixnum-shift-fast ] [ \ fixnum-shift no-overflow-variant ] unit-test
+
+[ fixnum-shift-fast ] [ \ shift modular-variant ] unit-test
+[ fixnum-bitnot ] [ \ bitnot modular-variant ] unit-test
+[ fixnum+fast ] [ \ fixnum+ modular-variant ] unit-test
+[ fixnum+fast ] [ \ fixnum+fast modular-variant ] unit-test
+
classes.algebra ;
IN: math.partial-dispatch
-! Partial dispatch.
-
-! This code will be overhauled and generalized when
-! multi-methods go into the core.
PREDICATE: math-partial < word
"derived-from" word-prop >boolean ;
+GENERIC: integer-op-input-classes ( word -- classes )
+
+M: math-partial integer-op-input-classes
+ "derived-from" word-prop rest ;
+
+M: word integer-op-input-classes
+ "input-classes" word-prop
+ [ "Bug: integer-op-input-classes" throw ] unless* ;
+
+: generic-variant ( op -- generic-op/f )
+ dup "derived-from" word-prop [ first ] [ ] ?if ;
+
+: no-overflow-variant ( op -- fast-op )
+ H{
+ { fixnum+ fixnum+fast }
+ { fixnum- fixnum-fast }
+ { fixnum* fixnum*fast }
+ { fixnum-shift fixnum-shift-fast }
+ } at ;
+
+: modular-variant ( op -- fast-op )
+ generic-variant dup H{
+ { + fixnum+fast }
+ { - fixnum-fast }
+ { * fixnum*fast }
+ { shift fixnum-shift-fast }
+ { bitand fixnum-bitand }
+ { bitor fixnum-bitor }
+ { bitxor fixnum-bitxor }
+ { bitnot fixnum-bitnot }
+ } at swap or ;
+
:: fixnum-integer-op ( a b fix-word big-word -- c )
b tag 0 eq? [
a b fix-word execute
} swap [ prefix ] curry map ;
: define-integer-ops ( word fix-word big-word -- )
- >r >r integer-op-triples r> r>
- [ define-integer-op-words ]
- [ 2drop [ dup integer-op-word ] { } map>assoc % ]
- 3bi ;
+ [
+ rot tuck
+ [ fixnum fixnum 3array "derived-from" set-word-prop ]
+ [ bignum bignum 3array "derived-from" set-word-prop ]
+ 2bi*
+ ] [
+ [ integer-op-triples ] 2dip
+ [ define-integer-op-words ]
+ [ 2drop [ dup integer-op-word ] { } map>assoc % ]
+ 3bi
+ ] 3bi ;
: define-math-ops ( op -- )
{ fixnum bignum float }
: each-fast-derived-op ( word quot -- )
>r fast-derived-ops r> each ; inline
+: each-integer-derived-op ( word quot -- )
+ >r integer-derived-ops r> each ; inline
+
[
[
\ + define-math-ops
projects / factor.git / commitdiff