steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

New modular arithmetic optimization pass

db4
Slava Pestov 2008-09-12 18:08:38 -05:00
parent 8d7ebc5106
commit 10c68ebb21
16 changed files with 482 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
basis/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -13,10 +13,8 @@ compiler.tree.builder
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
@ -34,12 +32,6 @@ compiler.tree.checker ;
[ 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?
@ -498,3 +490,7 @@ cell-bits 32 = [
[ 2 swap >fixnum ribs ]
{ <-integer-fixnum +-integer-fixnum } inlined?
] unit-test
[ t ] [
[ hashtable new ] \ new inlined?
] unit-test

8
basis/compiler/tree/cleanup/cleanup.factor
View File

@ -64,14 +64,6 @@ GENERIC: cleanup* ( node -- node/nodes )
] [ 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<= ;

2
basis/compiler/tree/dead-code/branches/branches.factor
View File

@ -36,7 +36,7 @@ M: #branch remove-dead-code*
'[ _ 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 ;

45
basis/compiler/tree/debugger/debugger.factor
View File

@ -1,13 +1,21 @@
! 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
@ -42,7 +50,7 @@ MATCH-VARS: ?a ?b ?c ;
{ { { ?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 } ;
@ -146,3 +154,32 @@ SYMBOL: node-count
: 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 ;

10
basis/compiler/tree/def-use/simplified/simplified-tests.factor Normal file
View File

@ -0,0 +1,10 @@
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

40
basis/compiler/tree/def-use/simplified/simplified.factor Normal file
View File

@ -0,0 +1,40 @@
! 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 ;

31
basis/compiler/tree/finalization/finalization.factor
View File

@ -6,27 +6,20 @@ classes.tuple.private slots.private combinators layouts
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 )
@ -37,18 +30,6 @@ M: #shuffle finalize*
[ 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? ;

29
basis/compiler/tree/late-optimizations/late-optimizations.factor Normal file
View File

@ -0,0 +1,29 @@
! 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 ;

130
basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor Normal file
View File

@ -0,0 +1,130 @@
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

108
basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor Normal file
View File

@ -0,0 +1,108 @@
! 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 ;

5
basis/compiler/tree/optimizer/optimizer.factor
View File

@ -10,7 +10,7 @@ compiler.tree.tuple-unboxing
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
@ -27,9 +27,10 @@ SYMBOL: check-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 ;

13
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -3,7 +3,7 @@
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
@ -33,7 +33,7 @@ M: quotation splicing-nodes
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 ] [
@ -156,12 +156,19 @@ SYMBOL: history
: 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 ;

26
basis/compiler/tree/propagation/known-words/known-words.factor
View File

@ -230,6 +230,32 @@ generic-comparison-ops [
] "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

27
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -6,27 +6,12 @@ alien.accessors alien.c-types sequences.private
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
@ -594,6 +579,14 @@ MIXIN: empty-mixin
[ { 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

17
basis/math/partial-dispatch/partial-dispatch-tests.factor
View File

@ -1,5 +1,6 @@
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
@ -10,3 +11,17 @@ USING: math.partial-dispatch tools.test math kernel sequences ;
[ 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

50
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -6,13 +6,41 @@ generic generic.math hashtables effects compiler.units
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
@ -69,10 +97,17 @@ PREDICATE: math-partial < word
} swap [ prefix ] curry map ;
: define-integer-ops ( word fix-word big-word -- )
>r >r integer-op-triples r> r>
[
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
] 3bi ;
: define-math-ops ( op -- )
{ fixnum bignum float }
@ -125,6 +160,9 @@ SYMBOL: fast-math-ops
: 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