From e5b9c8287eeb2765cea16e420d48bd7f07fbeb2b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 26 Jul 2008 19:01:43 -0500
Subject: [PATCH] Debugging slot propagation, starting recursive propagation
---
.../tree/propagation/info/info-tests.factor | 2 +
.../tree/propagation/info/info.factor | 26 +++++++-
.../known-words/known-words.factor | 8 ++-
.../tree/propagation/propagation-tests.factor | 64 ++++++++++++++++++-
.../propagation/recursive/recursive.factor | 56 +++++++++++-----
.../tree/propagation/slots/slots.factor | 55 ++++++++++------
6 files changed, 172 insertions(+), 39 deletions(-)
diff --git a/unfinished/compiler/tree/propagation/info/info-tests.factor b/unfinished/compiler/tree/propagation/info/info-tests.factor
index 41da9e6014..64d32ce458 100644
--- a/unfinished/compiler/tree/propagation/info/info-tests.factor
+++ b/unfinished/compiler/tree/propagation/info/info-tests.factor
@@ -61,3 +61,5 @@ IN: compiler.tree.propagation.info.tests
3 <literal-info>
null <class-info> value-info-union >literal<
] unit-test
+
+[ ] [ { } value-infos-union drop ] unit-test
diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor
index dc24b58bce..6f78ba645e 100644
--- a/unfinished/compiler/tree/propagation/info/info.factor
+++ b/unfinished/compiler/tree/propagation/info/info.factor
@@ -113,6 +113,8 @@ slots ;
DEFER: value-info-intersect
+DEFER: (value-info-intersect)
+
: intersect-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ drop ] }
@@ -120,10 +122,17 @@ DEFER: value-info-intersect
[ value-info-intersect ]
} cond ;
+: intersect-slot ( info1 info2 -- info )
+ {
+ { [ dup not ] [ nip ] }
+ { [ over not ] [ drop ] }
+ [ (value-info-intersect) ]
+ } cond ;
+
: intersect-slots ( info1 info2 -- slots )
[ slots>> ] bi@
2dup [ length ] bi@ =
- [ [ value-info-intersect ] 2map ] [ 2drop f ] if ;
+ [ [ intersect-slot ] 2map ] [ 2drop f ] if ;
: (value-info-intersect) ( info1 info2 -- info )
[ <value-info> ] 2dip
@@ -150,6 +159,8 @@ DEFER: value-info-intersect
DEFER: value-info-union
+DEFER: (value-info-union)
+
: union-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ nip ] }
@@ -157,10 +168,17 @@ DEFER: value-info-union
[ value-info-union ]
} cond ;
+: union-slot ( info1 info2 -- info )
+ {
+ { [ dup not ] [ nip ] }
+ { [ over not ] [ drop ] }
+ [ (value-info-union) ]
+ } cond ;
+
: union-slots ( info1 info2 -- slots )
[ slots>> ] bi@
2dup [ length ] bi@ =
- [ [ value-info-union ] 2map ] [ 2drop f ] if ;
+ [ [ union-slot ] 2map ] [ 2drop f ] if ;
: (value-info-union) ( info1 info2 -- info )
[ <value-info> ] 2dip
@@ -181,7 +199,9 @@ DEFER: value-info-union
} cond ;
: value-infos-union ( infos -- info )
- dup first [ value-info-union ] reduce ;
+ dup empty?
+ [ drop null <class-info> ]
+ [ dup first [ value-info-union ] reduce ] if ;
! Current value --> info mapping
SYMBOL: value-infos
diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor
index bfdcff51c5..eef34f6f8f 100644
--- a/unfinished/compiler/tree/propagation/known-words/known-words.factor
+++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor
@@ -4,9 +4,10 @@ USING: kernel effects accessors math math.private math.libm
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
+classes.tuple alien.accessors classes.tuple.private slots.private
compiler.tree.propagation.info compiler.tree.propagation.nodes
compiler.tree.propagation.constraints
+compiler.tree.propagation.slots
compiler.tree.comparisons ;
IN: compiler.tree.propagation.known-words
@@ -258,3 +259,8 @@ generic-comparison-ops [
! the output of clone has the same type as the input
{ clone (clone) } [ [ ] +outputs+ set-word-prop ] each
+
+\ slot [
+ dup literal?>>
+ [ literal>> swap value-info-slot ] [ 2drop object <class-info> ] if
+] +outputs+ set-word-prop
diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor
index 82f8ce1e4d..659f9d6e76 100644
--- a/unfinished/compiler/tree/propagation/propagation-tests.factor
+++ b/unfinished/compiler/tree/propagation/propagation-tests.factor
@@ -3,8 +3,8 @@ compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.def-use tools.test math math.order
accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private
-byte-arrays classes.algebra math.functions math.private
-strings ;
+byte-arrays classes.algebra classes.tuple.private
+math.functions math.private strings layouts ;
IN: compiler.tree.propagation.tests
\ propagate must-infer
@@ -235,12 +235,39 @@ IN: compiler.tree.propagation.tests
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test
+[ V{ object } ] [
+ [ 0 * 10 < ] final-classes
+] unit-test
+
[ V{ string string } ] [
[
2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop
] final-classes
] unit-test
+[ V{ float } ] [
+ [ { real float } declare + ] final-classes
+] unit-test
+
+[ V{ float } ] [
+ [ { float real } declare + ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+ [ { fixnum } declare 1 swap 7 bitand shift ] final-classes
+] unit-test
+
+cell-bits 32 = [
+ [ V{ integer } ] [
+ [ { fixnum } declare 1 swap 31 bitand shift ]
+ final-classes
+ ] unit-test
+] when
+
! Array length propagation
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
@@ -323,6 +350,10 @@ TUPLE: mutable-tuple-test { x sequence } ;
[ T{ mutable-tuple-test f "hey" } x>> ] final-classes
] unit-test
+[ V{ tuple-layout } ] [
+ [ T{ mutable-tuple-test f "hey" } layout-of ] final-classes
+] unit-test
+
! Mixed mutable and immutable slots
TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
@@ -332,3 +363,32 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ;
[ x>> ] [ y>> ] bi
] final-classes
] unit-test
+
+! Recursive propagation
+: recursive-test-1 ( a -- b ) recursive-test-1 ; inline recursive
+
+[ V{ null } ] [ [ recursive-test-1 ] final-classes ] unit-test
+
+: recursive-test-2 ( a -- b ) dup 10 < [ recursive-test-2 ] when ; inline recursive
+
+[ V{ real } ] [ [ recursive-test-2 ] final-classes ] unit-test
+
+: recursive-test-3 ( a -- b ) dup 10 < drop ; inline recursive
+
+[ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test
+
+[ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test
+
+[ V{ float } ] [
+ [ { float } declare 10 [ 2.3 * ] times ] final-classes
+] unit-test
+
+: recursive-test-4 ( i n -- )
+ 2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive
+
+[ ] [ [ recursive-test-4 ] final-info drop ] unit-test
+
+: recursive-test-5 ( a -- b )
+ dup 2 > [ dup 1 - recursive-test-5 * ] when ; inline recursive
+
+[ V{ integer } ] [ [ recursive-test-5 ] final-info drop ] unit-test
diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor
index 731b0d06f7..1871717036 100644
--- a/unfinished/compiler/tree/propagation/recursive/recursive.factor
+++ b/unfinished/compiler/tree/propagation/recursive/recursive.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors
+USING: kernel sequences accessors arrays
+stack-checker.inlining
compiler.tree
compiler.tree.propagation.info
compiler.tree.propagation.nodes
@@ -14,23 +15,48 @@ IN: compiler.tree.propagation.recursive
! We need to compute scalar evolution so that sccp doesn't
! evaluate loops
-: (merge-value-infos) ( inputs -- infos )
+! row polymorphism is causing problems
+
+! infer-branch cloning and subsequent loss of state causing problems
+
+: merge-value-infos ( inputs -- infos )
[ [ value-info ] map value-infos-union ] map ;
+USE: io
+: compute-fixed-point ( label infos outputs -- )
+ 2dup [ length ] bi@ = [ "Wrong length" throw ] unless
+ "compute-fixed-point" print USE: prettyprint
+ 2dup [ value-info ] map 2dup . . [ = ] 2all? [ 3drop ] [
+ [ set-value-info ] 2each
+ f >>fixed-point drop
+ ] if ;
-: merge-value-infos ( inputs outputs -- fixed-point? )
- [ (merge-value-infos) ] dip
- [ 2dup value-info = [ 2drop t ] [ set-value-info f ] if ] 2all? ;
-
-: propagate-recursive-phi ( #phi -- fixed-point? )
- [ [ phi-in-d>> ] [ out-d>> ] bi merge-value-infos ]
- [ [ phi-in-r>> ] [ out-r>> ] bi merge-value-infos ]
- bi and ;
+: propagate-recursive-phi ( label #phi -- )
+ "propagate-recursive-phi" print
+ [ [ phi-in-d>> merge-value-infos ] [ out-d>> ] bi compute-fixed-point ]
+ [ [ phi-in-r>> merge-value-infos ] [ out-r>> ] bi compute-fixed-point ] 2bi ;
+USING: namespaces math ;
+SYMBOL: iter-counter
+0 iter-counter set-global
M: #recursive propagate-around ( #recursive -- )
- dup
- node-child
- [ first>> (propagate) ] [ propagate-recursive-phi ] bi
- [ drop ] [ propagate-around ] if ;
+ "#recursive" print
+ iter-counter inc
+ iter-counter get 10 > [ "Oops" throw ] when
+ [ label>> ] keep
+ [ node-child first>> propagate-recursive-phi ]
+ [ [ t >>fixed-point drop ] [ node-child first>> (propagate) ] bi* ]
+ [ swap fixed-point>> [ drop ] [ propagate-around ] if ]
+ 2tri ; USE: assocs
M: #call-recursive propagate-before ( #call-label -- )
- [ label>> returns>> flip ] [ out-d>> ] bi merge-value-infos drop ;
+ [ label>> ] [ label>> return>> [ value-info ] map ] [ out-d>> ] tri
+ dup [ dup value-infos get at [ drop ] [ object <class-info> swap set-value-info ] if ] each
+ 2dup min-length [ tail* ] curry bi@
+ compute-fixed-point ;
+
+M: #return propagate-before ( #return -- )
+ "#return" print
+ dup label>> [
+ [ label>> ] [ in-d>> [ value-info ] map ] [ in-d>> ] tri
+ compute-fixed-point
+ ] [ drop ] if ;
diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor
index df10626967..663b0e12b8 100644
--- a/unfinished/compiler/tree/propagation/slots/slots.factor
+++ b/unfinished/compiler/tree/propagation/slots/slots.factor
@@ -39,15 +39,25 @@ UNION: fixed-length-sequence array byte-array string ;
: tuple-constructor? ( node -- ? )
word>> { <tuple-boa> <complex> } memq? ;
+: read-only-slots ( values class -- slots )
+ #! Delegation.
+ all-slots rest-slice
+ [ read-only>> [ drop f ] unless ] 2map
+ { f f } prepend ;
+
+: fold-<tuple-boa> ( values class -- info )
+ [ , f , [ literal>> ] map % ] { } make >tuple
+ <literal-info> ;
+
: propagate-<tuple-boa> ( node -- info )
#! Delegation
in-d>> [ value-info ] map unclip-last
- literal>> class>> dup immutable-tuple-class? [
- over [ literal?>> ] all?
- [ [ , f , [ literal>> ] map % ] { } make >tuple <literal-info> ]
- [ <tuple-info> ]
- if
- ] [ nip <class-info> ] if ;
+ literal>> class>> [ read-only-slots ] keep
+ over 2 tail-slice [ dup [ literal?>> ] when ] all? [
+ [ 2 tail-slice ] dip fold-<tuple-boa>
+ ] [
+ <tuple-info>
+ ] if ;
: propagate-<complex> ( node -- info )
in-d>> [ value-info ] map complex <tuple-info> ;
@@ -79,20 +89,29 @@ UNION: fixed-length-sequence array byte-array string ;
[ [ class>> ] [ object ] if* class-or ] reduce
<class-info> ;
+: tuple>array* ( tuple -- array )
+ prepare-tuple>array
+ >r copy-tuple-slots r>
+ prefix ;
+
+: literal-info-slot ( slot info -- info' )
+ {
+ { [ dup tuple? ] [
+ tuple>array* nth <literal-info>
+ ] }
+ { [ dup complex? ] [
+ [ real-part ] [ imaginary-part ] bi
+ 2array nth <literal-info>
+ ] }
+ } cond ;
+
: value-info-slot ( slot info -- info' )
#! Delegation.
- [ class>> complex class<= 1 3 ? - ] keep
- dup literal?>> [
- literal>> {
- { [ dup tuple? ] [
- tuple-slots 1 tail-slice nth <literal-info>
- ] }
- { [ dup complex? ] [
- [ real-part ] [ imaginary-part ] bi
- 2array nth <literal-info>
- ] }
- } cond
- ] [ slots>> ?nth ] if ;
+ {
+ { [ over 0 = ] [ 2drop fixnum <class-info> ] }
+ { [ dup literal?>> ] [ [ 1- ] [ literal>> ] bi* literal-info-slot ] }
+ [ [ 1- ] [ slots>> ] bi* ?nth ]
+ } cond ;
: reader-word-outputs ( node -- infos )
[ relevant-slots ] [ in-d>> first ] bi