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

Working on propagation, move some tests that don't apply out of cleanup-tests

db4
Slava Pestov 2008-07-30 15:37:40 -05:00
parent a202812ba0
commit 65df4739ce
12 changed files with 269 additions and 221 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

145
unfinished/compiler/tree/cleanup/cleanup-tests.factor
View File

@ -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

29
unfinished/compiler/tree/cleanup/cleanup.factor
View File

@ -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 ;

2
unfinished/compiler/tree/propagation/branches/branches.factor
View File

@ -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 } ]

3
unfinished/compiler/tree/propagation/info/info-tests.factor
View File

@ -68,6 +68,5 @@ TUPLE: test-tuple { x read-only } ;
[ t ] [
f f 3 <literal-info> 3array test-tuple <tuple-info> dup
object <class-info>
value-info-intersect =
object-info value-info-intersect =
] unit-test

24
unfinished/compiler/tree/propagation/info/info.factor
View File

@ -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 } ]

33
unfinished/compiler/tree/propagation/known-words/known-words.factor
View File

@ -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 <class-info> ] }
{ incomparable [ object-info ] }
{ t [ t <literal-info> ] }
{ f [ f <literal-info> ] }
} case ;
@ -184,7 +186,7 @@ generic-comparison-ops [
] each
: maybe-or-never ( ? -- info )
[ object <class-info> ] [ \ f <class-info> ] if ;
[ object-info ] [ f <literal-info> ] 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 <class-info> ] 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

47
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -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

8
unfinished/compiler/tree/propagation/recursive/recursive.factor
View File

@ -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 ;

16
unfinished/compiler/tree/propagation/simple/simple.factor
View File

@ -17,7 +17,7 @@ IN: compiler.tree.propagation.simple
! Propagation for straight-line code.
M: #introduce propagate-before
value>> object <class-info> swap set-value-info ;
value>> object-info swap set-value-info ;
M: #push propagate-before
[ literal>> <literal-info> ] [ out-d>> first ] bi
@ -67,15 +67,27 @@ M: #declare propagate-before
bi* with-datastack
[ <literal-info> ] map ;
: predicate-output-infos ( info class -- info )
[ class>> ] dip {
{ [ 2dup class<= ] [ t <literal-info> ] }
{ [ 2dup classes-intersect? not ] [ f <literal-info> ] }
[ 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 <class-info> <repetition> ] ?if ;
[ class-infos ] [ out-d>> length object-info <repetition> ] ?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 ;

22
unfinished/compiler/tree/propagation/slots/slots.factor
View File

@ -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 ;
{ \ <complex> [ propagate-<complex> ] }
} 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 <literal-info>
] }
{ [ dup complex? ] [
[ 1- ] [ [ real-part ] [ imaginary-part ] bi ] bi*
2array nth <literal-info>
] }
} cond
] [ 2drop f ] if ;
2dup class read-only-slot?
[ swap slot <literal-info> ] [ 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 <class-info> ] unless* ;
} cond [ object-info ] unless* ;

119
unfinished/compiler/tree/strength-reduction/strength-reduction-tests.factor Normal file
View File

@ -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

42
unfinished/math/partial-dispatch/partial-dispatch.factor
View File

@ -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