From a5efaa49a0eda2165dfadb2cf4c91a042b19da0a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jul 2008 17:34:08 -0500 Subject: [PATCH] Array length propagation --- .../constraints/constraints.factor | 6 +- .../tree/propagation/info/info.factor | 98 ++++++++++++++----- .../tree/propagation/propagation-tests.factor | 9 +- .../tree/propagation/simple/simple.factor | 25 ++++- 4 files changed, 106 insertions(+), 32 deletions(-) diff --git a/unfinished/compiler/tree/propagation/constraints/constraints.factor b/unfinished/compiler/tree/propagation/constraints/constraints.factor index e49e478ec4..42c094db5a 100644 --- a/unfinished/compiler/tree/propagation/constraints/constraints.factor +++ b/unfinished/compiler/tree/propagation/constraints/constraints.factor @@ -26,11 +26,9 @@ M: true-constraint assume [ \ f class-not swap value>> refine-value-info ] bi ; -M: true-constraint satisfied? - value>> value-info class>> \ f class-not class<= ; +M: true-constraint satisfied? value>> \ f class-not value-is? ; -M: true-constraint satisfiable? - value>> value-info class>> \ f class-not classes-intersect? ; +M: true-constraint satisfiable? value>> \ f class-not value-is? ; TUPLE: false-constraint value ; diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 90ef41754a..2572e167a1 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -22,7 +22,8 @@ TUPLE: value-info { class initial: null } { interval initial: empty-interval } literal -literal? ; +literal? +length ; : class-interval ( class -- interval ) dup real class<= @@ -45,36 +46,54 @@ literal? ; } cond ] if ; -: ( class interval literal literal? -- info ) - [ - 2nip - [ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri - t +: ( -- info ) \ value-info new ; + +: init-value-info ( info -- info ) + dup literal?>> [ + dup literal>> class >>class + dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval ] [ - drop - 2dup [ null class<= ] [ empty-interval eq? ] bi* or [ - 2drop null empty-interval f f + dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [ + null >>class + empty-interval >>interval ] [ - over integer class<= [ integral-closure ] when - 2dup interval>literal + dup class>> integer class<= [ [ integral-closure ] change-interval ] when + dup [ class>> ] [ interval>> ] bi interval>literal + [ >>literal ] [ >>literal? ] bi* ] if - ] if - \ value-info boa ; foldable + ] if ; : ( class interval -- info ) - f f ; foldable + + swap >>interval + swap >>class + init-value-info ; foldable : ( class -- info ) dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or ; foldable : ( interval -- info ) - real swap ; foldable + + real >>class + swap >>interval + init-value-info ; foldable : ( literal -- info ) - f f rot t ; foldable + + swap >>literal + t >>literal? + init-value-info ; foldable -: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ; +: ( value -- info ) + + object >>class + [-inf,inf] >>interval + swap value-info >>length + init-value-info ; foldable + +: >literal< ( info -- literal literal? ) + [ literal>> ] [ literal?>> ] bi ; : intersect-literals ( info1 info2 -- literal literal? ) { @@ -84,11 +103,24 @@ literal? ; [ drop >literal< ] } cond ; +DEFER: value-info-intersect + +: intersect-lengths ( info1 info2 -- length ) + [ length>> ] bi@ { + { [ dup not ] [ drop ] } + { [ over not ] [ nip ] } + [ value-info-intersect ] + } cond ; + : (value-info-intersect) ( info1 info2 -- info ) - [ [ class>> ] bi@ class-and ] - [ [ interval>> ] bi@ interval-intersect ] - [ intersect-literals ] - 2tri ; + [ ] 2dip + { + [ [ class>> ] bi@ class-and >>class ] + [ [ interval>> ] bi@ interval-intersect >>interval ] + [ intersect-literals [ >>literal ] [ >>literal? ] bi* ] + [ intersect-lengths >>length ] + } 2cleave + init-value-info ; : value-info-intersect ( info1 info2 -- info ) { @@ -102,11 +134,24 @@ literal? ; [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if ] [ 2drop f f ] if ; +DEFER: value-info-union + +: union-lengths ( info1 info2 -- length ) + [ length>> ] bi@ { + { [ dup not ] [ nip ] } + { [ over not ] [ drop ] } + [ value-info-union ] + } cond ; + : (value-info-union) ( info1 info2 -- info ) - [ [ class>> ] bi@ class-or ] - [ [ interval>> ] bi@ interval-union ] - [ union-literals ] - 2tri ; + [ ] 2dip + { + [ [ class>> ] bi@ class-or >>class ] + [ [ interval>> ] bi@ interval-union >>interval ] + [ union-literals [ >>literal ] [ >>literal? ] bi* ] + [ union-lengths >>length ] + } 2cleave + init-value-info ; : value-info-union ( info1 info2 -- info ) { @@ -144,3 +189,6 @@ SYMBOL: value-infos [ { t f } ] } cond nip ] if ; + +: value-is? ( value class -- ? ) + [ value-info class>> ] dip class<= ; diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 9fcfbdefff..5d278b27b0 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -2,7 +2,8 @@ USING: kernel compiler.tree.builder compiler.tree 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 ; +alien.accessors alien.c-types sequences.private +byte-arrays ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -232,3 +233,9 @@ IN: compiler.tree.propagation.tests [ V{ 2 } ] [ [ [ 1 ] [ 1 ] if 1 + ] final-literals ] unit-test + +[ V{ t } ] [ [ 10 f length 10 = ] final-literals ] unit-test + +[ V{ t } ] [ [ [ 10 f ] [ 10 ] if length 10 = ] final-literals ] unit-test + +[ V{ t } ] [ [ [ 1 f ] [ 2 f ] if length 3 < ] final-literals ] unit-test diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index b02f7700a6..6b8efd77e9 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors kernel sequences assocs words namespaces -classes.algebra combinators classes continuations +USING: fry accessors kernel sequences sequences.private assocs +words namespaces classes.algebra combinators classes +continuations arrays byte-arrays strings compiler.tree compiler.tree.def-use compiler.tree.propagation.info @@ -72,9 +73,29 @@ M: #declare propagate-before out-d>> length object ] ?if ; +UNION: fixed-length-sequence array byte-array string ; + +: sequence-constructor? ( node -- ? ) + word>> { } memq? ; + +: propagate-sequence-constructor ( node -- infos ) + [ default-output-value-infos first ] + [ in-d>> first ] + bi value-info-intersect 1array ; + +: length-accessor? ( node -- ? ) + dup in-d>> first fixed-length-sequence value-is? + [ word>> \ length eq? ] [ drop f ] if ; + +: propagate-length ( node -- infos ) + in-d>> first value-info length>> + [ array-capacity ] unless* 1array ; + : output-value-infos ( node -- infos ) { { [ dup foldable-call? ] [ fold-call ] } + { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } + { [ dup length-accessor? ] [ propagate-length ] } { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] } [ default-output-value-infos ] } cond ;