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? \ +-integer-fixnum inlined?
] unit-test ] 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 ] [ [ t ] [
[ { array-capacity } declare 0 < ] \ < inlined? [ { array-capacity } declare 0 < ] \ < inlined?
] unit-test ] unit-test
@ -277,11 +264,6 @@ cell-bits 32 = [
] unit-test ] unit-test
] when ] when
[ f ] [
[ { integer } declare -63 shift 4095 bitand ]
\ shift inlined?
] unit-test
[ t ] [ [ t ] [
[ B{ 1 0 } *short 0 number= ] [ B{ 1 0 } *short 0 number= ]
\ number= inlined? \ number= inlined?
@ -328,36 +310,6 @@ cell-bits 32 = [
] \ + inlined? ] \ + inlined?
] unit-test ] 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 ] [ [ t ] [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined? [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test ] unit-test
@ -393,21 +345,6 @@ cell-bits 32 = [
[ 27/2 fib ] { < - } inlined? [ 27/2 fib ] { < - } inlined?
] unit-test ] 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 ] [ [ t ] [
[ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined? [ { fixnum } declare 10 [ -1 shift ] times ] \ shift inlined?
] unit-test ] unit-test
@ -421,16 +358,6 @@ cell-bits 32 = [
\ fixnum-bitand inlined? \ fixnum-bitand inlined?
] unit-test ] 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 ] [ [ t ] [
[ { fixnum } declare [ drop ] each-integer ] [ { fixnum } declare [ drop ] each-integer ]
{ < <-integer-fixnum +-integer-fixnum + } inlined? { < <-integer-fixnum +-integer-fixnum + } inlined?
@ -456,22 +383,6 @@ cell-bits 32 = [
\ +-integer-fixnum inlined? \ +-integer-fixnum inlined?
] unit-test ] 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 ] [ [ f ] [
[ [
{ integer } declare [ ] map { integer } declare [ ] map
@ -490,56 +401,6 @@ cell-bits 32 = [
] \ >fixnum inlined? ] \ >fixnum inlined?
] unit-test ] 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 ] [ [ t ] [
[ [
{ array } declare length { array } declare length
@ -565,12 +426,6 @@ TUPLE: declared-fixnum { x fixnum } ;
[ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test [ t ] [ [ { 1 2 } length ] { length length>> slot } inlined? ] unit-test
[ t ] [
[
{ integer } declare [ 256 mod ] map
] { mod fixnum-mod } inlined?
] unit-test
[ t ] [ [ t ] [
[ [
{ integer } declare [ 0 >= ] map { integer } declare [ 0 >= ] map

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

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences sequences.deep combinators fry USING: kernel accessors sequences sequences.deep combinators fry
namespaces classes.algebra namespaces assocs math math.private
math.partial-dispatch
compiler.tree compiler.tree
compiler.tree.combinators compiler.tree.combinators
compiler.tree.propagation.info compiler.tree.propagation.info
@ -20,7 +21,12 @@ GENERIC: cleanup* ( node -- node/nodes )
#! do it since the logic is a bit more involved #! do it since the logic is a bit more involved
[ cleanup* ] map flatten ; [ 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 [ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map [ [ literal>> ] dip #push ] 2map
@ -30,10 +36,27 @@ GENERIC: cleanup* ( node -- node/nodes )
: cleanup-inlining ( #call -- nodes ) : cleanup-inlining ( #call -- nodes )
body>> cleanup ; 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* M: #call cleanup*
{ {
{ [ dup node-output-infos [ literal?>> ] all? ] [ cleanup-constant-folding ] }
{ [ dup body>> ] [ cleanup-inlining ] } { [ dup body>> ] [ cleanup-inlining ] }
{ [ dup cleanup-folding? ] [ cleanup-folding ] }
{ [ dup remove-overflow-check? ] [ remove-overflow-check ] }
[ ] [ ]
} cond ; } cond ;

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

@ -24,7 +24,7 @@ GENERIC: live-branches ( #branch -- indices )
M: #if live-branches M: #if live-branches
in-d>> first value-info class>> { in-d>> first value-info class>> {
{ [ dup null class<= ] [ { f f } ] } { [ dup null-class? ] [ { f f } ] }
{ [ dup true-class? ] [ { t f } ] } { [ dup true-class? ] [ { t f } ] }
{ [ dup false-class? ] [ { f t } ] } { [ dup false-class? ] [ { f t } ] }
[ { t 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 ] [ [ t ] [
f f 3 <literal-info> 3array test-tuple <tuple-info> dup f f 3 <literal-info> 3array test-tuple <tuple-info> dup
object <class-info> object-info value-info-intersect =
value-info-intersect =
] unit-test ] 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 ; combinators arrays compiler.tree.copy-equiv ;
IN: compiler.tree.propagation.info IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
: true-class? ( class -- ? ) \ f class-not class<= ;
: null-class? ( class -- ? ) null class<= ;
SYMBOL: +interval+ SYMBOL: +interval+
GENERIC: eql? ( obj1 obj2 -- ? ) GENERIC: eql? ( obj1 obj2 -- ? )
@ -29,6 +35,8 @@ slots ;
: null-info T{ value-info f null empty-interval } ; inline : 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 ) : class-interval ( class -- interval )
dup real class<= dup real class<=
[ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
@ -57,7 +65,7 @@ slots ;
dup literal>> class >>class dup literal>> class >>class
dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval 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 null >>class
empty-interval >>interval empty-interval >>interval
] [ ] [
@ -154,8 +162,8 @@ DEFER: (value-info-intersect)
: value-info-intersect ( info1 info2 -- info ) : value-info-intersect ( info1 info2 -- info )
{ {
{ [ dup class>> null class<= ] [ nip ] } { [ dup class>> null-class? ] [ nip ] }
{ [ over class>> null class<= ] [ drop ] } { [ over class>> null-class? ] [ drop ] }
[ (value-info-intersect) ] [ (value-info-intersect) ]
} cond ; } cond ;
@ -200,8 +208,8 @@ DEFER: (value-info-union)
: value-info-union ( info1 info2 -- info ) : value-info-union ( info1 info2 -- info )
{ {
{ [ dup class>> null class<= ] [ drop ] } { [ dup class>> null-class? ] [ drop ] }
{ [ over class>> null class<= ] [ nip ] } { [ over class>> null-class? ] [ nip ] }
[ (value-info-union) ] [ (value-info-union) ]
} cond ; } cond ;
@ -225,16 +233,12 @@ SYMBOL: value-infos
: value-literal ( value -- obj ? ) : value-literal ( value -- obj ? )
value-info >literal< ; value-info >literal< ;
: false-class? ( class -- ? ) \ f class<= ;
: true-class? ( class -- ? ) \ f class-not class<= ;
: possible-boolean-values ( info -- values ) : possible-boolean-values ( info -- values )
dup literal?>> [ dup literal?>> [
literal>> 1array literal>> 1array
] [ ] [
class>> { class>> {
{ [ dup null class<= ] [ { } ] } { [ dup null-class? ] [ { } ] }
{ [ dup true-class? ] [ { t } ] } { [ dup true-class? ] [ { t } ] }
{ [ dup false-class? ] [ { f } ] } { [ dup false-class? ] [ { f } ] }
[ { t 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 layouts words sequences sequences.private arrays assocs classes
classes.algebra combinators generic.math splitting fry locals classes.algebra combinators generic.math splitting fry locals
classes.tuple alien.accessors classes.tuple.private slots.private classes.tuple alien.accessors classes.tuple.private slots.private
compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.comparisons
compiler.tree.propagation.constraints compiler.tree.propagation.info
compiler.tree.propagation.nodes
compiler.tree.propagation.slots compiler.tree.propagation.slots
compiler.tree.comparisons ; compiler.tree.propagation.simple
compiler.tree.propagation.constraints ;
IN: compiler.tree.propagation.known-words IN: compiler.tree.propagation.known-words
\ fixnum \ fixnum
@ -76,7 +78,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
: binary-op-class ( info1 info2 -- newclass ) : binary-op-class ( info1 info2 -- newclass )
[ class>> ] bi@ [ class>> ] bi@
2dup [ null class<= ] either? [ 2drop null ] [ 2dup [ null-class? ] either? [ 2drop null ] [
[ math-closure ] bi@ math-class-max [ math-closure ] bi@ math-class-max
] if ; ] if ;
@ -87,13 +89,13 @@ most-negative-fixnum most-positive-fixnum [a,b]
[ fixnum class<= ] [ fixnum fits? ] bi* and ; [ fixnum class<= ] [ fixnum fits? ] bi* and ;
: may-overflow ( class interval -- class' interval' ) : may-overflow ( class interval -- class' interval' )
over null class<= [ over null-class? [
2dup won't-overflow? 2dup won't-overflow?
[ [ integer math-class-max ] dip ] unless [ [ integer math-class-max ] dip ] unless
] unless ; ] unless ;
: may-be-rational ( class interval -- class' interval' ) : may-be-rational ( class interval -- class' interval' )
over null class<= [ over null-class? [
[ rational math-class-max ] dip [ rational math-class-max ] dip
] unless ; ] unless ;
@ -107,7 +109,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
[ real math-class-min ] dip ; [ real math-class-min ] dip ;
: float-valued ( class interval -- class' interval' ) : float-valued ( class interval -- class' interval' )
over null class<= [ over null-class? [
[ drop float ] dip [ drop float ] dip
] unless ; ] unless ;
@ -167,7 +169,7 @@ generic-comparison-ops [
! Remove redundant comparisons ! Remove redundant comparisons
: fold-comparison ( info1 info2 word -- info ) : fold-comparison ( info1 info2 word -- info )
[ [ interval>> ] bi@ ] dip interval-comparison { [ [ interval>> ] bi@ ] dip interval-comparison {
{ incomparable [ object <class-info> ] } { incomparable [ object-info ] }
{ t [ t <literal-info> ] } { t [ t <literal-info> ] }
{ f [ f <literal-info> ] } { f [ f <literal-info> ] }
} case ; } case ;
@ -184,7 +186,7 @@ generic-comparison-ops [
] each ] each
: maybe-or-never ( ? -- info ) : maybe-or-never ( ? -- info )
[ object <class-info> ] [ \ f <class-info> ] if ; [ object-info ] [ f <literal-info> ] if ;
: info-intervals-intersect? ( info1 info2 -- ? ) : info-intervals-intersect? ( info1 info2 -- ? )
[ interval>> ] bi@ intervals-intersect? ; [ interval>> ] bi@ intervals-intersect? ;
@ -259,5 +261,16 @@ generic-comparison-ops [
\ slot [ \ slot [
dup literal?>> 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 ] +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 alien.accessors alien.c-types sequences.private
byte-arrays classes.algebra classes.tuple.private byte-arrays classes.algebra classes.tuple.private
math.functions math.private strings layouts 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 IN: compiler.tree.propagation.tests
\ propagate must-infer \ propagate must-infer
@ -475,3 +476,47 @@ M: array iterate first t ;
iterate [ dead-loop ] when ; inline recursive iterate [ dead-loop ] when ; inline recursive
[ V{ fixnum } ] [ [ { fixnum } declare dead-loop ] final-classes ] unit-test [ 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

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

@ -29,8 +29,10 @@ IN: compiler.tree.propagation.recursive
} cond nip interval-union ; } cond nip interval-union ;
: generalize-counter ( info' initial -- info ) : generalize-counter ( info' initial -- info )
2dup [ class>> null-class? ] either? [ drop ] [
[ drop clone ] [ [ interval>> ] bi@ ] 2bi [ drop clone ] [ [ interval>> ] bi@ ] 2bi
generalize-counter-interval >>interval ; generalize-counter-interval >>interval
] if ;
: unify-recursive-stacks ( stacks initial -- infos ) : unify-recursive-stacks ( stacks initial -- infos )
over empty? [ nip ] [ over empty? [ nip ] [
@ -65,7 +67,7 @@ M: #recursive propagate-around ( #recursive -- )
] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ; ] [ dup label>> fixed-point>> [ drop ] [ propagate-around ] if ] bi ;
: generalize-return-interval ( info -- info' ) : generalize-return-interval ( info -- info' )
dup literal?>> [ dup [ literal?>> ] [ class>> null-class? ] bi or [
clone [-inf,inf] >>interval clone [-inf,inf] >>interval
] unless ; ] 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. ! Propagation for straight-line code.
M: #introduce propagate-before M: #introduce propagate-before
value>> object <class-info> swap set-value-info ; value>> object-info swap set-value-info ;
M: #push propagate-before M: #push propagate-before
[ literal>> <literal-info> ] [ out-d>> first ] bi [ literal>> <literal-info> ] [ out-d>> first ] bi
@ -67,15 +67,27 @@ M: #declare propagate-before
bi* with-datastack bi* with-datastack
[ <literal-info> ] map ; [ <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-value-infos ( #call word -- infos )
"default-output-classes" word-prop "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 ) : output-value-infos ( #call word -- infos )
{ {
{ [ 2dup foldable-call? ] [ fold-call ] } { [ 2dup foldable-call? ] [ fold-call ] }
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup predicate? ] [ propagate-predicate ] }
{ [ dup +outputs+ word-prop ] [ call-outputs-quot ] } { [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ] [ default-output-value-infos ]
} cond ; } cond ;

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

@ -3,7 +3,7 @@
USING: fry assocs arrays byte-arrays strings accessors sequences USING: fry assocs arrays byte-arrays strings accessors sequences
kernel slots classes.algebra classes.tuple classes.tuple.private kernel slots classes.algebra classes.tuple classes.tuple.private
words math math.private combinators sequences.private namespaces 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 IN: compiler.tree.propagation.slots
! Propagation of immutable slots and array lengths ! Propagation of immutable slots and array lengths
@ -60,27 +60,13 @@ UNION: fixed-length-sequence array byte-array string ;
{ \ <complex> [ propagate-<complex> ] } { \ <complex> [ propagate-<complex> ] }
} case 1array ; } case 1array ;
: tuple>array* ( tuple -- array )
prepare-tuple>array
>r copy-tuple-slots r>
prefix ;
: read-only-slot? ( n class -- ? ) : read-only-slot? ( n class -- ? )
all-slots [ offset>> = ] with find nip all-slots [ offset>> = ] with find nip
dup [ read-only>> ] when ; dup [ read-only>> ] when ;
: literal-info-slot ( slot object -- info/f ) : literal-info-slot ( slot object -- info/f )
2dup class read-only-slot? [ 2dup class read-only-slot?
{ [ swap slot <literal-info> ] [ 2drop f ] if ;
{ [ 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 ;
: length-accessor? ( slot info -- ? ) : length-accessor? ( slot info -- ? )
[ 1 = ] [ length>> ] bi* and ; [ 1 = ] [ length>> ] bi* and ;
@ -92,4 +78,4 @@ UNION: fixed-length-sequence array byte-array string ;
{ [ 2dup length-accessor? ] [ nip length>> ] } { [ 2dup length-accessor? ] [ nip length>> ] }
{ [ dup literal?>> ] [ literal>> literal-info-slot ] } { [ dup literal?>> ] [ literal>> literal-info-slot ] }
[ [ 1- ] [ slots>> ] bi* ?nth ] [ [ 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 bi
] "" make "math.partial-dispatch" lookup ; ] "" make "math.partial-dispatch" lookup ;
: integer-op-word ( triple fix-word big-word -- word ) : integer-op-word ( triple -- word )
[ [ name>> ] map "-" join "math.partial-dispatch" create ;
drop
name>> "fast" tail? >r
[ "-" % ] [ name>> % ] interleave
r> [ "-fast" % ] when
] "" make "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 ; 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 (( x y -- z )) define-declared
] ] [
[ 2drop
[ integer-op-word ] [ 2drop ] 3bi [ integer-op-word ] keep
"derived-from" set-word-prop "derived-from" set-word-prop
] 3bi ; ] 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 ; [ define-integer-op-word ] 2curry each ;
: integer-op-triples ( word -- triples ) : integer-op-triples ( word -- triples )
@ -78,7 +73,7 @@ PREDICATE: math-partial < word
: define-integer-ops ( word fix-word big-word -- ) : define-integer-ops ( word fix-word big-word -- )
>r >r integer-op-triples r> r> >r >r integer-op-triples r> r>
[ define-integer-op-words ] [ define-integer-op-words ]
[ [ 2drop ] [ [ integer-op-word ] 2curry map ] 3bi zip % ] [ 2drop [ dup integer-op-word ] { } map>assoc % ]
3bi ; 3bi ;
: define-math-ops ( op -- ) : define-math-ops ( op -- )
@ -160,15 +155,10 @@ SYMBOL: fast-math-ops
\ number= \ eq? \ bignum= define-integer-ops \ number= \ eq? \ bignum= define-integer-ops
] { } make >hashtable math-ops set-global ] { } make >hashtable math-ops set-global
[ H{
{ { + fixnum fixnum } fixnum+fast } , { { + fixnum fixnum } fixnum+fast }
{ { - fixnum fixnum } fixnum-fast } , { { - fixnum fixnum } fixnum-fast }
{ { * fixnum fixnum } fixnum*fast } , { { * fixnum fixnum } fixnum*fast }
{ { shift fixnum fixnum } fixnum-shift-fast } , { { shift fixnum fixnum } fixnum-shift-fast }
} fast-math-ops set-global
\ + \ 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
] with-compilation-unit ] with-compilation-unit