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

Fold class predicates applied to literals

db4
Slava Pestov 2008-10-02 05:12:38 -05:00
parent 2e48915f9c
commit f539406ee1
2 changed files with 16 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,7 +8,7 @@ math.functions math.private strings layouts
compiler.tree.propagation.info compiler.tree.def-use compiler.tree.propagation.info compiler.tree.def-use
compiler.tree.debugger compiler.tree.checker compiler.tree.debugger compiler.tree.checker
slots.private words hashtables classes assocs locals slots.private words hashtables classes assocs locals
float-arrays ; float-arrays system ;
IN: compiler.tree.propagation.tests IN: compiler.tree.propagation.tests
\ propagate must-infer \ propagate must-infer
@ -590,6 +590,8 @@ MIXIN: empty-mixin
[ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test [ V{ float-array } ] [ [| | F{ } ] final-classes ] unit-test
[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
! [ V{ string } ] [ ! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes ! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test ! ] unit-test

14
basis/compiler/tree/propagation/simple/simple.factor
View File

@ -76,13 +76,25 @@ M: #declare propagate-before
: fold-call ( #call word -- ) : fold-call ( #call word -- )
[ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ; [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
: predicate-output-infos ( info class -- info ) : predicate-output-infos/literal ( info class -- info )
[ literal>> ] dip
'[ _ _ instance? <literal-info> ]
[ drop object-info ]
recover ;
: predicate-output-infos/class ( info class -- info )
[ class>> ] dip { [ class>> ] dip {
{ [ 2dup class<= ] [ t <literal-info> ] } { [ 2dup class<= ] [ t <literal-info> ] }
{ [ 2dup classes-intersect? not ] [ f <literal-info> ] } { [ 2dup classes-intersect? not ] [ f <literal-info> ] }
[ object-info ] [ object-info ]
} cond 2nip ; } cond 2nip ;
: predicate-output-infos ( info class -- info )
over literal?>>
[ predicate-output-infos/literal ]
[ predicate-output-infos/class ]
if ;
: propagate-predicate ( #call word -- infos ) : propagate-predicate ( #call word -- infos )
#! We need to force the caller word to recompile when the class #! We need to force the caller word to recompile when the class
#! is redefined, since now we're making assumptions but the #! is redefined, since now we're making assumptions but the