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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Doug Coleman 2008-07-30 22:57:23 -05:00
parent 84de1f9369 e61f2321d0
commit 554247dab5
14 changed files with 322 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
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
@ -208,17 +195,17 @@ GENERIC: annotate-entry-test-1 ( x -- )
M: fixnum annotate-entry-test-1 drop ; M: fixnum annotate-entry-test-1 drop ;
: (annotate-entry-test-2) ( from to quot: ( -- ) -- ) : (annotate-entry-test-2) ( from to -- )
2over >= [ 2dup >= [
3drop 2drop
] [ ] [
[ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2) >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
] if ; inline recursive ] if ; inline recursive
: annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
[ f ] [ [ f ] [
[ { bignum } declare [ ] annotate-entry-test-2 ] [ { bignum } declare annotate-entry-test-2 ]
\ annotate-entry-test-1 inlined? \ annotate-entry-test-1 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?
@ -448,7 +375,7 @@ cell-bits 32 = [
[ t ] [ [ t ] [
[ { fixnum } declare 0 [ + ] reduce ] [ { fixnum } declare 0 [ + ] reduce ]
{ < <-integer-fixnum } inlined? { < <-integer-fixnum nth-unsafe } inlined?
] unit-test ] unit-test
[ f ] [ [ f ] [
@ -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

30
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,13 @@ 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 dup empty?
[ drop f ] [ [ literal?>> ] all? ] if ;
: 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 +37,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

55
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,55 @@ 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
[ V{ fixnum } ] [
[ { fixnum } declare [ ] curry obj>> ] final-classes
] unit-test
[ V{ fixnum } ] [
[ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
] unit-test

19
unfinished/compiler/tree/propagation/recursive/recursive-tests.factor Normal file
View File

@ -0,0 +1,19 @@
IN: compiler.tree.propagation.recursive.tests
USING: tools.test compiler.tree.propagation.recursive
math.intervals kernel ;
[ T{ interval f { 0 t } { 1/0. t } } ] [
T{ interval f { 1 t } { 1 t } }
T{ interval f { 0 t } { 0 t } } generalize-counter-interval
] unit-test
[ T{ interval f { -1/0. t } { 10 t } } ] [
T{ interval f { -1 t } { -1 t } }
T{ interval f { 10 t } { 10 t } } generalize-counter-interval
] unit-test
[ t ] [
T{ interval f { 1 t } { 268435455 t } }
T{ interval f { -268435456 t } { 268435455 t } } tuck
generalize-counter-interval =
] unit-test

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

@ -21,16 +21,18 @@ IN: compiler.tree.propagation.recursive
: generalize-counter-interval ( interval initial-interval -- interval' ) : generalize-counter-interval ( interval initial-interval -- interval' )
{ {
{ [ 2dup = ] [ empty-interval ] } { [ 2dup interval-subset? ] [ empty-interval ] }
{ [ over empty-interval eq? ] [ empty-interval ] } { [ over empty-interval eq? ] [ empty-interval ] }
{ [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] } { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
{ [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] } { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
[ [-inf,inf] ] [ [-inf,inf] ]
} cond nip interval-union ; } cond interval-union nip ;
: 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 ;

43
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
@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ;
bi* value-info-intersect 1array ; bi* value-info-intersect 1array ;
: tuple-constructor? ( word -- ? ) : tuple-constructor? ( word -- ? )
{ <tuple-boa> <complex> } memq? ; { <tuple-boa> curry compose <complex> } memq? ;
: read-only-slots ( values class -- slots ) : read-only-slots ( values class -- slots )
#! Delegation. #! Delegation.
@ -41,46 +41,43 @@ UNION: fixed-length-sequence array byte-array string ;
[ , f , [ literal>> ] map % ] { } make >tuple [ , f , [ literal>> ] map % ] { } make >tuple
<literal-info> ; <literal-info> ;
: propagate-<tuple-boa> ( #call -- info ) : (propagate-tuple-constructor) ( values class -- info )
#! Delegation [ [ value-info ] map ] dip [ read-only-slots ] keep
in-d>> [ value-info ] map unclip-last
literal>> class>> [ read-only-slots ] keep
over 2 tail-slice [ dup [ literal?>> ] when ] all? [ over 2 tail-slice [ dup [ literal?>> ] when ] all? [
[ 2 tail-slice ] dip fold-<tuple-boa> [ 2 tail-slice ] dip fold-<tuple-boa>
] [ ] [
<tuple-info> <tuple-info>
] if ; ] if ;
: propagate-<tuple-boa> ( #call -- info )
#! Delegation
in-d>> unclip-last
value-info literal>> class>> (propagate-tuple-constructor) ;
: propagate-curry ( #call -- info )
in-d>> \ curry (propagate-tuple-constructor) ;
: propagate-compose ( #call -- info )
in-d>> \ compose (propagate-tuple-constructor) ;
: propagate-<complex> ( #call -- info ) : propagate-<complex> ( #call -- info )
in-d>> [ value-info ] map complex <tuple-info> ; in-d>> [ value-info ] map complex <tuple-info> ;
: propagate-tuple-constructor ( #call word -- infos ) : propagate-tuple-constructor ( #call word -- infos )
{ {
{ \ <tuple-boa> [ propagate-<tuple-boa> ] } { \ <tuple-boa> [ propagate-<tuple-boa> ] }
{ \ curry [ propagate-curry ] }
{ \ compose [ propagate-compose ] }
{ \ <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 +89,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

2
unfinished/stack-checker/stack-checker-tests.factor
View File

@ -6,7 +6,7 @@ quotations effects tools.test continuations generic.standard
sorting assocs definitions prettyprint io inspector sorting assocs definitions prettyprint io inspector
classes.tuple classes.union classes.predicate debugger classes.tuple classes.union classes.predicate debugger
threads.private io.streams.string io.timeouts io.thread threads.private io.streams.string io.timeouts io.thread
sequences.private destructors combinators ; sequences.private destructors combinators eval ;
IN: stack-checker.tests IN: stack-checker.tests
: short-effect ( effect -- pair ) : short-effect ( effect -- pair )