From 65df4739ceec6713dc26ea27f0bfbab28ba9420b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jul 2008 15:37:40 -0500 Subject: [PATCH] Working on propagation, move some tests that don't apply out of cleanup-tests --- .../tree/cleanup/cleanup-tests.factor | 145 ------------------ .../compiler/tree/cleanup/cleanup.factor | 29 +++- .../tree/propagation/branches/branches.factor | 2 +- .../tree/propagation/info/info-tests.factor | 3 +- .../tree/propagation/info/info.factor | 24 +-- .../known-words/known-words.factor | 33 ++-- .../tree/propagation/propagation-tests.factor | 47 +++++- .../propagation/recursive/recursive.factor | 8 +- .../tree/propagation/simple/simple.factor | 16 +- .../tree/propagation/slots/slots.factor | 22 +-- .../strength-reduction-tests.factor | 119 ++++++++++++++ .../partial-dispatch/partial-dispatch.factor | 42 ++--- 12 files changed, 269 insertions(+), 221 deletions(-) create mode 100644 unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor diff --git a/unfinished/compiler/tree/cleanup/cleanup-tests.factor b/unfinished/compiler/tree/cleanup/cleanup-tests.factor index 75477508c9..22f53e2488 100644 --- a/unfinished/compiler/tree/cleanup/cleanup-tests.factor +++ b/unfinished/compiler/tree/cleanup/cleanup-tests.factor @@ -166,19 +166,6 @@ M: object xyz ; \ +-integer-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 ] [ [ { array-capacity } declare 0 < ] \ < inlined? ] unit-test @@ -277,11 +264,6 @@ cell-bits 32 = [ ] unit-test ] when -[ f ] [ - [ { integer } declare -63 shift 4095 bitand ] - \ shift inlined? -] unit-test - [ t ] [ [ B{ 1 0 } *short 0 number= ] \ number= inlined? @@ -328,36 +310,6 @@ cell-bits 32 = [ ] \ + 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 - [ t ] [ [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? ] unit-test @@ -393,21 +345,6 @@ cell-bits 32 = [ [ 27/2 fib ] { < - } inlined? ] unit-test -: hang-regression ( m n -- x ) - over 0 number= [ - nip - ] [ - dup [ - drop 1 hang-regression - ] [ - dupd hang-regression hang-regression - ] if - ] if ; inline recursive - -[ t ] [ - [ dup fixnum? [ 3 over hang-regression ] [ 3 over hang-regression ] if -] { } inlined? ] unit-test - [ t ] [ [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? ] unit-test @@ -421,16 +358,6 @@ cell-bits 32 = [ \ fixnum-bitand inlined? ] unit-test -[ t ] [ - [ { integer } declare 127 bitand 3 + ] - { + +-integer-fixnum +-integer-fixnum-fast bitand } inlined? -] unit-test - -[ f ] [ - [ { integer } declare 127 bitand 3 + ] - { >fixnum } inlined? -] unit-test - [ t ] [ [ { fixnum } declare [ drop ] each-integer ] { < <-integer-fixnum +-integer-fixnum + } inlined? @@ -456,22 +383,6 @@ cell-bits 32 = [ \ +-integer-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 - [ f ] [ [ { integer } declare [ ] map @@ -490,56 +401,6 @@ cell-bits 32 = [ ] \ >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 ] [ - [ hashtable new ] \ new inlined? -] unit-test - -[ t ] [ - [ dup hashtable eq? [ new ] when ] \ new inlined? -] unit-test - -[ t ] [ - [ { hashtable } declare hashtable instance? ] \ instance? inlined? -] unit-test - -[ t ] [ - [ { vector } declare hashtable instance? ] \ instance? inlined? -] unit-test - -[ f ] [ - [ { assoc } declare hashtable instance? ] \ instance? inlined? -] 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 - [ t ] [ [ { array } declare length @@ -565,12 +426,6 @@ TUPLE: declared-fixnum { x fixnum } ; [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test -[ t ] [ - [ - { integer } declare [ 256 mod ] map - ] { mod fixnum-mod } inlined? -] unit-test - [ t ] [ [ { integer } declare [ 0 >= ] map diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor index 7b4727ffcf..40a8da1562 100644 --- a/unfinished/compiler/tree/cleanup/cleanup.factor +++ b/unfinished/compiler/tree/cleanup/cleanup.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences sequences.deep combinators fry -namespaces +classes.algebra namespaces assocs math math.private +math.partial-dispatch compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -20,7 +21,12 @@ GENERIC: cleanup* ( node -- node/nodes ) #! do it since the logic is a bit more involved [ cleanup* ] map flatten ; -: cleanup-constant-folding ( #call -- nodes ) +: cleanup-folding? ( #call -- ? ) + node-output-infos [ literal?>> ] all? ; + +: cleanup-folding ( #call -- nodes ) + #! Replace a #call having a known result with a #drop of its + #! inputs followed by #push nodes for the outputs. [ [ node-output-infos ] [ out-d>> ] bi [ [ literal>> ] dip #push ] 2map @@ -30,10 +36,27 @@ GENERIC: cleanup* ( node -- node/nodes ) : cleanup-inlining ( #call -- nodes ) body>> cleanup ; +! 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 -- ? ) + dup word>> no-overflow-variant + [ node-output-infos first class>> fixnum class<= ] [ drop f ] if ; + +: remove-overflow-check ( #call -- #call ) + [ in-d>> ] [ out-d>> ] [ word>> no-overflow-variant ] tri #call cleanup* ; + M: #call cleanup* { - { [ dup node-output-infos [ literal?>> ] all? ] [ cleanup-constant-folding ] } { [ dup body>> ] [ cleanup-inlining ] } + { [ dup cleanup-folding? ] [ cleanup-folding ] } + { [ dup remove-overflow-check? ] [ remove-overflow-check ] } [ ] } cond ; diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index 2442a796f2..bba920949b 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -24,7 +24,7 @@ GENERIC: live-branches ( #branch -- indices ) M: #if live-branches in-d>> first value-info class>> { - { [ dup null class<= ] [ { f f } ] } + { [ dup null-class? ] [ { f f } ] } { [ dup true-class? ] [ { t f } ] } { [ dup false-class? ] [ { f t } ] } [ { t t } ] diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor index 5991af92ee..24f4ca59dc 100644 --- a/unfinished/compiler/tree/propagation/info/info-tests.factor +++ b/unfinished/compiler/tree/propagation/info/info-tests.factor @@ -68,6 +68,5 @@ TUPLE: test-tuple { x read-only } ; [ t ] [ f f 3 3array test-tuple dup - object - value-info-intersect = + object-info value-info-intersect = ] unit-test diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 93057aebc1..3d79840f7e 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -5,6 +5,12 @@ accessors math math.intervals namespaces sequences words combinators arrays compiler.tree.copy-equiv ; IN: compiler.tree.propagation.info +: false-class? ( class -- ? ) \ f class<= ; + +: true-class? ( class -- ? ) \ f class-not class<= ; + +: null-class? ( class -- ? ) null class<= ; + SYMBOL: +interval+ GENERIC: eql? ( obj1 obj2 -- ? ) @@ -29,6 +35,8 @@ slots ; : null-info T{ value-info f null empty-interval } ; inline +: object-info T{ value-info f object T{ interval f { -1.0/0.0 t } { 1.0/0.0 t } } } ; inline + : class-interval ( class -- interval ) dup real class<= [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; @@ -57,7 +65,7 @@ slots ; dup literal>> class >>class dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval ] [ - dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [ + dup [ class>> null-class? ] [ interval>> empty-interval eq? ] bi or [ null >>class empty-interval >>interval ] [ @@ -154,8 +162,8 @@ DEFER: (value-info-intersect) : value-info-intersect ( info1 info2 -- info ) { - { [ dup class>> null class<= ] [ nip ] } - { [ over class>> null class<= ] [ drop ] } + { [ dup class>> null-class? ] [ nip ] } + { [ over class>> null-class? ] [ drop ] } [ (value-info-intersect) ] } cond ; @@ -200,8 +208,8 @@ DEFER: (value-info-union) : value-info-union ( info1 info2 -- info ) { - { [ dup class>> null class<= ] [ drop ] } - { [ over class>> null class<= ] [ nip ] } + { [ dup class>> null-class? ] [ drop ] } + { [ over class>> null-class? ] [ nip ] } [ (value-info-union) ] } cond ; @@ -225,16 +233,12 @@ SYMBOL: value-infos : value-literal ( value -- obj ? ) value-info >literal< ; -: false-class? ( class -- ? ) \ f class<= ; - -: true-class? ( class -- ? ) \ f class-not class<= ; - : possible-boolean-values ( info -- values ) dup literal?>> [ literal>> 1array ] [ class>> { - { [ dup null class<= ] [ { } ] } + { [ dup null-class? ] [ { } ] } { [ dup true-class? ] [ { t } ] } { [ dup false-class? ] [ { f } ] } [ { t f } ] diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index af9d9bab4a..08fdb36cae 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor @@ -5,10 +5,12 @@ math.partial-dispatch math.intervals math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private -compiler.tree.propagation.info compiler.tree.propagation.nodes -compiler.tree.propagation.constraints +compiler.tree.comparisons +compiler.tree.propagation.info +compiler.tree.propagation.nodes compiler.tree.propagation.slots -compiler.tree.comparisons ; +compiler.tree.propagation.simple +compiler.tree.propagation.constraints ; IN: compiler.tree.propagation.known-words \ fixnum @@ -76,7 +78,7 @@ most-negative-fixnum most-positive-fixnum [a,b] : binary-op-class ( info1 info2 -- newclass ) [ class>> ] bi@ - 2dup [ null class<= ] either? [ 2drop null ] [ + 2dup [ null-class? ] either? [ 2drop null ] [ [ math-closure ] bi@ math-class-max ] if ; @@ -87,13 +89,13 @@ most-negative-fixnum most-positive-fixnum [a,b] [ fixnum class<= ] [ fixnum fits? ] bi* and ; : may-overflow ( class interval -- class' interval' ) - over null class<= [ + over null-class? [ 2dup won't-overflow? [ [ integer math-class-max ] dip ] unless ] unless ; : may-be-rational ( class interval -- class' interval' ) - over null class<= [ + over null-class? [ [ rational math-class-max ] dip ] unless ; @@ -107,7 +109,7 @@ most-negative-fixnum most-positive-fixnum [a,b] [ real math-class-min ] dip ; : float-valued ( class interval -- class' interval' ) - over null class<= [ + over null-class? [ [ drop float ] dip ] unless ; @@ -167,7 +169,7 @@ generic-comparison-ops [ ! Remove redundant comparisons : fold-comparison ( info1 info2 word -- info ) [ [ interval>> ] bi@ ] dip interval-comparison { - { incomparable [ object ] } + { incomparable [ object-info ] } { t [ t ] } { f [ f ] } } case ; @@ -184,7 +186,7 @@ generic-comparison-ops [ ] each : maybe-or-never ( ? -- info ) - [ object ] [ \ f ] if ; + [ object-info ] [ f ] if ; : info-intervals-intersect? ( info1 info2 -- ? ) [ interval>> ] bi@ intervals-intersect? ; @@ -259,5 +261,16 @@ generic-comparison-ops [ \ slot [ dup literal?>> - [ literal>> swap value-info-slot ] [ 2drop object ] if + [ literal>> swap value-info-slot ] [ 2drop object-info ] if +] +outputs+ set-word-prop + +\ instance? [ + [ value-info ] dip over literal>> class? [ + [ literal>> ] dip predicate-constraints + ] [ 2drop f ] if +] +constraints+ set-word-prop + +\ instance? [ + dup literal>> class? + [ literal>> predicate-output-infos ] [ 2drop f ] if ] +outputs+ set-word-prop diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 3c85665ba7..de6d6c72cb 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -5,7 +5,8 @@ accessors sequences arrays kernel.private vectors alien.accessors alien.c-types sequences.private byte-arrays classes.algebra classes.tuple.private math.functions math.private strings layouts -compiler.tree.propagation.info slots.private ; +compiler.tree.propagation.info slots.private words hashtables +classes assocs ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -475,3 +476,47 @@ M: array iterate first t ; iterate [ dead-loop ] when ; inline recursive [ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test + +: hang-1 ( m -- x ) + dup 0 number= [ hang-1 ] unless ; inline recursive + +[ ] [ [ 3 hang-1 ] final-info drop ] unit-test + +: hang-2 ( m n -- x ) + over 0 number= [ + nip + ] [ + dup [ + drop 1 hang-2 + ] [ + dupd hang-2 hang-2 + ] if + ] if ; inline recursive + +[ ] [ [ 3 over hang-2 ] final-info drop ] unit-test + +[ ] [ + [ + dup fixnum? [ 3 over hang-2 ] [ 3 over hang-2 ] if + ] final-info drop +] unit-test + +[ V{ word } ] [ + [ { hashtable } declare hashtable instance? ] final-classes +] unit-test + +[ V{ POSTPONE: f } ] [ + [ { vector } declare hashtable instance? ] final-classes +] unit-test + +[ V{ object } ] [ + [ { assoc } declare hashtable instance? ] final-classes +] unit-test + +[ V{ word } ] [ + [ { string } declare string? ] final-classes +] unit-test + +[ V{ POSTPONE: f } ] [ + [ 3 string? ] final-classes +] unit-test diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 97801e289e..425d5fb26f 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor @@ -29,8 +29,10 @@ IN: compiler.tree.propagation.recursive } cond nip interval-union ; : generalize-counter ( info' initial -- info ) - [ drop clone ] [ [ interval>> ] bi@ ] 2bi - generalize-counter-interval >>interval ; + 2dup [ class>> null-class? ] either? [ drop ] [ + [ drop clone ] [ [ interval>> ] bi@ ] 2bi + generalize-counter-interval >>interval + ] if ; : unify-recursive-stacks ( stacks initial -- infos ) over empty? [ nip ] [ @@ -65,7 +67,7 @@ M: #recursive propagate-around ( #recursive -- ) ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ; : generalize-return-interval ( info -- info' ) - dup literal?>> [ + dup [ literal?>> ] [ class>> null-class? ] bi or [ clone [-inf,inf] >>interval ] unless ; diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index d0e2426b0c..589ad6db4c 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -17,7 +17,7 @@ IN: compiler.tree.propagation.simple ! Propagation for straight-line code. M: #introduce propagate-before - value>> object swap set-value-info ; + value>> object-info swap set-value-info ; M: #push propagate-before [ literal>> ] [ out-d>> first ] bi @@ -67,15 +67,27 @@ M: #declare propagate-before bi* with-datastack [ ] map ; +: predicate-output-infos ( info class -- info ) + [ class>> ] dip { + { [ 2dup class<= ] [ t ] } + { [ 2dup classes-intersect? not ] [ f ] } + [ object-info ] + } cond 2nip ; + +: propagate-predicate ( #call word -- infos ) + [ in-d>> first value-info ] [ "predicating" word-prop ] bi* + predicate-output-infos 1array ; + : default-output-value-infos ( #call word -- infos ) "default-output-classes" word-prop - [ class-infos ] [ out-d>> length object ] ?if ; + [ class-infos ] [ out-d>> length object-info ] ?if ; : output-value-infos ( #call word -- infos ) { { [ 2dup foldable-call? ] [ fold-call ] } { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } + { [ dup predicate? ] [ propagate-predicate ] } { [ dup +outputs+ word-prop ] [ call-outputs-quot ] } [ default-output-value-infos ] } cond ; diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor index 8a23d360cc..713ac1703f 100644 --- a/unfinished/compiler/tree/propagation/slots/slots.factor +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -3,7 +3,7 @@ USING: fry assocs arrays byte-arrays strings accessors sequences kernel slots classes.algebra classes.tuple classes.tuple.private words math math.private combinators sequences.private namespaces -classes compiler.tree.propagation.info ; +slots.private classes compiler.tree.propagation.info ; IN: compiler.tree.propagation.slots ! Propagation of immutable slots and array lengths @@ -60,27 +60,13 @@ UNION: fixed-length-sequence array byte-array string ; { \ [ propagate- ] } } case 1array ; -: tuple>array* ( tuple -- array ) - prepare-tuple>array - >r copy-tuple-slots r> - prefix ; - : read-only-slot? ( n class -- ? ) all-slots [ offset>> = ] with find nip dup [ read-only>> ] when ; : literal-info-slot ( slot object -- info/f ) - 2dup class read-only-slot? [ - { - { [ dup tuple? ] [ - [ 1- ] [ tuple>array* ] bi* nth - ] } - { [ dup complex? ] [ - [ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi* - 2array nth - ] } - } cond - ] [ 2drop f ] if ; + 2dup class read-only-slot? + [ swap slot ] [ 2drop f ] if ; : length-accessor? ( slot info -- ? ) [ 1 = ] [ length>> ] bi* and ; @@ -92,4 +78,4 @@ UNION: fixed-length-sequence array byte-array string ; { [ 2dup length-accessor? ] [ nip length>> ] } { [ dup literal?>> ] [ literal>> literal-info-slot ] } [ [ 1- ] [ slots>> ] bi* ?nth ] - } cond [ object ] unless* ; + } cond [ object-info ] unless* ; diff --git a/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor b/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor new file mode 100644 index 0000000000..a940a63421 --- /dev/null +++ b/unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor @@ -0,0 +1,119 @@ +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 + +[ t ] [ + [ hashtable new ] \ new inlined? +] unit-test + +[ t ] [ + [ dup hashtable eq? [ new ] when ] \ new inlined? +] unit-test + +[ f ] [ + [ { integer } declare -63 shift 4095 bitand ] + \ shift inlined? +] unit-test + +[ t ] [ + [ { integer } declare 127 bitand 3 + ] + { + +-integer-fixnum +-integer-fixnum-fast 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 diff --git a/unfinished/math/partial-dispatch/partial-dispatch.factor b/unfinished/math/partial-dispatch/partial-dispatch.factor index 625770e09f..9211a41aa7 100644 --- a/unfinished/math/partial-dispatch/partial-dispatch.factor +++ b/unfinished/math/partial-dispatch/partial-dispatch.factor @@ -44,28 +44,23 @@ PREDICATE: math-partial < word bi ] "" make "math.partial-dispatch" lookup ; -: integer-op-word ( triple fix-word big-word -- word ) - [ - drop - name>> "fast" tail? >r - [ "-" % ] [ name>> % ] interleave - r> [ "-fast" % ] when - ] "" make "math.partial-dispatch" create ; +: integer-op-word ( triple -- word ) + [ name>> ] map "-" join "math.partial-dispatch" create ; -: integer-op-quot ( word fix-word big-word -- quot ) +: integer-op-quot ( triple fix-word big-word -- quot ) rot integer-op-combinator 1quotation 2curry ; -: define-integer-op-word ( word fix-word big-word -- ) +: define-integer-op-word ( triple fix-word big-word -- ) [ - [ integer-op-word ] [ integer-op-quot ] 3bi + [ 2drop integer-op-word ] [ integer-op-quot ] 3bi (( x y -- z )) define-declared - ] - [ - [ integer-op-word ] [ 2drop ] 3bi + ] [ + 2drop + [ integer-op-word ] keep "derived-from" set-word-prop ] 3bi ; -: define-integer-op-words ( words fix-word big-word -- ) +: define-integer-op-words ( triples fix-word big-word -- ) [ define-integer-op-word ] 2curry each ; : integer-op-triples ( word -- triples ) @@ -78,7 +73,7 @@ PREDICATE: math-partial < word : define-integer-ops ( word fix-word big-word -- ) >r >r integer-op-triples r> r> [ define-integer-op-words ] - [ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ] + [ 2drop [ dup integer-op-word ] { } map>assoc % ] 3bi ; : define-math-ops ( op -- ) @@ -160,15 +155,10 @@ SYMBOL: fast-math-ops \ number= \ eq? \ bignum= define-integer-ops ] { } make >hashtable math-ops set-global - [ - { { + fixnum fixnum } fixnum+fast } , - { { - fixnum fixnum } fixnum-fast } , - { { * fixnum fixnum } fixnum*fast } , - { { shift fixnum fixnum } fixnum-shift-fast } , - - \ + \ fixnum+fast \ bignum+ define-integer-ops - \ - \ fixnum-fast \ bignum- define-integer-ops - \ * \ fixnum*fast \ bignum* define-integer-ops - \ shift \ fixnum-shift-fast \ bignum-shift define-integer-ops - ] { } make >hashtable fast-math-ops set-global + H{ + { { + fixnum fixnum } fixnum+fast } + { { - fixnum fixnum } fixnum-fast } + { { * fixnum fixnum } fixnum*fast } + { { shift fixnum fixnum } fixnum-shift-fast } + } fast-math-ops set-global ] with-compilation-unit