From 0fd34b4a4b8050a9f0d62ecf7c89205a3d6ceed4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 24 Jul 2008 21:47:09 -0500 Subject: [PATCH 1/2] Fix and --- extra/io/launcher/launcher.factor | 4 ++-- extra/io/unix/launcher/launcher-tests.factor | 13 +++++++++++-- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index f556bac35c..09f240c53a 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -183,7 +183,7 @@ M: object run-pipeline-element [ |dispose drop ] [ swap >process - [ swap in>> or ] change-stdout + [ swap in>> or ] change-stdin run-detached ] [ in>> dispose ] @@ -200,8 +200,8 @@ M: object run-pipeline-element [ [ |dispose drop ] bi@ ] [ rot >process - [ swap out>> or ] change-stdout [ swap in>> or ] change-stdin + [ swap out>> or ] change-stdout run-detached ] [ [ out>> dispose ] [ in>> dispose ] bi* ] diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index 6d1f7f1796..33988c273b 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,7 +1,8 @@ IN: io.unix.launcher.tests USING: io.files tools.test io.launcher arrays io namespaces continuations math io.encodings.binary io.encodings.ascii -accessors kernel sequences io.encodings.utf8 destructors ; +accessors kernel sequences io.encodings.utf8 destructors +io.streams.duplex ; [ ] [ [ "launcher-test-1" temp-file delete-file ] ignore-errors @@ -111,4 +112,12 @@ accessors kernel sequences io.encodings.utf8 destructors ; "append-test" temp-file utf8 file-contents ] unit-test -[ ] [ "ls" utf8 contents drop ] unit-test +[ t ] [ "ls" utf8 contents >boolean ] unit-test + +[ "Hello world.\n" ] [ + "cat" utf8 [ + "Hello world.\n" write + output-stream get dispose + input-stream get contents + ] with-stream +] unit-test From c6915b10231f6291dcf388c86d34106f9e1c3d50 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 25 Jul 2008 02:07:45 -0500 Subject: [PATCH 2/2] Working on tuple slot propagation --- core/classes/tuple/tuple.factor | 4 + core/kernel/kernel.factor | 8 +- core/math/intervals/intervals.factor | 3 + core/slots/slots.factor | 26 +++- core/words/words.factor | 1 + .../tree/propagation/info/info.factor | 39 ++++-- .../known-words/known-words.factor | 21 ++++ .../tree/propagation/propagation-tests.factor | 95 ++++++++++++++- .../tree/propagation/simple/simple.factor | 49 ++++---- .../tree/propagation/slots/slots.factor | 111 ++++++++++++++++++ .../stack-checker/branches/branches.factor | 6 +- 11 files changed, 314 insertions(+), 49 deletions(-) create mode 100644 unfinished/compiler/tree/propagation/slots/slots.factor diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 4216a5dc3d..42b5826e95 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -20,6 +20,10 @@ ERROR: not-a-tuple object ; : all-slots ( class -- slots ) superclasses [ "slots" word-prop ] map concat ; +PREDICATE: immutable-tuple-class < tuple-class ( class -- ? ) + #! Delegation + all-slots rest-slice [ read-only>> ] all? ; + boolean ( obj -- ? ) t f ? ; inline diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 1896943a71..8afbee3478 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -135,6 +135,9 @@ TUPLE: interval { from read-only } { to read-only } ; ] } cond ; +: intervals-intersect? ( i1 i2 -- ? ) + interval-intersect empty-interval eq? not ; + : interval-union ( i1 i2 -- i3 ) { { [ dup empty-interval eq? ] [ drop ] } diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 73d674782d..8754444ce0 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -8,13 +8,17 @@ IN: slots TUPLE: slot-spec name offset class initial read-only reader writer ; +PREDICATE: reader < word "reader" word-prop ; + +PREDICATE: writer < word "writer" word-prop ; + : ( -- slot-spec ) slot-spec new object bootstrap-word >>class ; : define-typecheck ( class generic quot props -- ) [ dup define-simple-generic create-method ] 2dip - [ [ props>> ] [ drop ] [ [ t ] H{ } map>assoc ] tri* update ] + [ [ props>> ] [ drop ] [ ] tri* update ] [ drop define ] 3bi ; @@ -31,17 +35,23 @@ TUPLE: slot-spec name offset class initial read-only reader writer ; ] [ ] make ; : reader-word ( name -- word ) - ">>" append (( object -- value )) create-accessor ; + ">>" append (( object -- value )) create-accessor + dup t "reader" set-word-prop ; -: reader-props ( slot-spec -- seq ) - read-only>> { "foldable" "flushable" } { "flushable" } ? ; +: reader-props ( slot-spec -- assoc ) + [ + [ "reading" set ] + [ read-only>> [ t "foldable" set ] when ] bi + t "flushable" set + ] H{ } make-assoc ; : define-reader ( class slot-spec -- ) [ name>> reader-word ] [ reader-quot ] [ reader-props ] tri define-typecheck ; : writer-word ( name -- word ) - "(>>" swap ")" 3append (( value object -- )) create-accessor ; + "(>>" swap ")" 3append (( value object -- )) create-accessor + dup t "writer" set-word-prop ; ERROR: bad-slot-value value class ; @@ -77,8 +87,12 @@ ERROR: bad-slot-value value class ; } cond ] [ ] make ; +: writer-props ( slot-spec -- assoc ) + [ "writing" set ] H{ } make-assoc ; + : define-writer ( class slot-spec -- ) - [ name>> writer-word ] [ writer-quot ] bi { } define-typecheck ; + [ name>> writer-word ] [ writer-quot ] [ writer-props ] tri + define-typecheck ; : setter-word ( name -- word ) ">>" prepend (( object value -- object )) create-accessor ; diff --git a/core/words/words.factor b/core/words/words.factor index 5cf15abfa4..535295007e 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -187,6 +187,7 @@ M: word reset-word "parsing" "inline" "recursive" "foldable" "flushable" "predicating" "reading" "writing" + "reader" "writer" "constructing" "declared-effect" "constructor-quot" "delimiter" } reset-props ; diff --git a/unfinished/compiler/tree/propagation/info/info.factor b/unfinished/compiler/tree/propagation/info/info.factor index 2572e167a1..dc24b58bce 100644 --- a/unfinished/compiler/tree/propagation/info/info.factor +++ b/unfinished/compiler/tree/propagation/info/info.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs classes classes.algebra kernel accessors math -math.intervals namespaces sequences words combinators arrays -compiler.tree.copy-equiv ; +USING: assocs classes classes.algebra kernel +accessors math math.intervals namespaces sequences words +combinators arrays compiler.tree.copy-equiv ; IN: compiler.tree.propagation.info SYMBOL: +interval+ @@ -17,13 +17,15 @@ M: complex eql? over complex? [ = ] [ 2drop f ] if ; ! Value info represents a set of objects. Don't mutate value infos ! you receive, always construct new ones. We don't declare the -! slots read-only to allow cloning followed by writing. +! slots read-only to allow cloning followed by writing, and to +! simplify constructors. TUPLE: value-info -{ class initial: null } -{ interval initial: empty-interval } +class +interval literal literal? -length ; +length +slots ; : class-interval ( class -- interval ) dup real class<= @@ -57,6 +59,7 @@ length ; null >>class empty-interval >>interval ] [ + [ [-inf,inf] or ] change-interval dup class>> integer class<= [ [ integral-closure ] change-interval ] when dup [ class>> ] [ interval>> ] bi interval>literal [ >>literal ] [ >>literal? ] bi* @@ -88,10 +91,15 @@ length ; : ( value -- info ) object >>class - [-inf,inf] >>interval swap value-info >>length init-value-info ; foldable +: ( slots class -- info ) + + swap >>class + swap >>slots + init-value-info ; + : >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ; @@ -112,6 +120,11 @@ DEFER: value-info-intersect [ value-info-intersect ] } cond ; +: intersect-slots ( info1 info2 -- slots ) + [ slots>> ] bi@ + 2dup [ length ] bi@ = + [ [ value-info-intersect ] 2map ] [ 2drop f ] if ; + : (value-info-intersect) ( info1 info2 -- info ) [ ] 2dip { @@ -119,6 +132,7 @@ DEFER: value-info-intersect [ [ interval>> ] bi@ interval-intersect >>interval ] [ intersect-literals [ >>literal ] [ >>literal? ] bi* ] [ intersect-lengths >>length ] + [ intersect-slots >>slots ] } 2cleave init-value-info ; @@ -143,6 +157,11 @@ DEFER: value-info-union [ value-info-union ] } cond ; +: union-slots ( info1 info2 -- slots ) + [ slots>> ] bi@ + 2dup [ length ] bi@ = + [ [ value-info-union ] 2map ] [ 2drop f ] if ; + : (value-info-union) ( info1 info2 -- info ) [ ] 2dip { @@ -150,6 +169,7 @@ DEFER: value-info-union [ [ interval>> ] bi@ interval-union >>interval ] [ union-literals [ >>literal ] [ >>literal? ] bi* ] [ union-lengths >>length ] + [ union-slots >>slots ] } 2cleave init-value-info ; @@ -167,7 +187,8 @@ DEFER: value-info-union SYMBOL: value-infos : value-info ( value -- info ) - resolve-copy value-infos get at T{ value-info } or ; + resolve-copy value-infos get at + T{ value-info f null empty-interval } or ; : set-value-info ( info value -- ) resolve-copy value-infos get set-at ; diff --git a/unfinished/compiler/tree/propagation/known-words/known-words.factor b/unfinished/compiler/tree/propagation/known-words/known-words.factor index e358dd5be1..bfdcff51c5 100644 --- a/unfinished/compiler/tree/propagation/known-words/known-words.factor +++ b/unfinished/compiler/tree/propagation/known-words/known-words.factor @@ -185,6 +185,27 @@ generic-comparison-ops [ '[ , fold-comparison ] +outputs+ set-word-prop ] each +: maybe-or-never ( ? -- info ) + [ object ] [ \ f ] if ; + +: info-intervals-intersect? ( info1 info2 -- ? ) + [ interval>> ] bi@ intervals-intersect? ; + +{ number= bignum= float= } [ + [ + info-intervals-intersect? maybe-or-never + ] +outputs+ set-word-prop +] each + +: info-classes-intersect? ( info1 info2 -- ? ) + [ class>> ] bi@ classes-intersect? ; + +\ eq? [ + [ info-intervals-intersect? ] + [ info-classes-intersect? ] + bi or maybe-or-never +] +outputs+ set-word-prop + { { >fixnum fixnum } { >bignum bignum } diff --git a/unfinished/compiler/tree/propagation/propagation-tests.factor b/unfinished/compiler/tree/propagation/propagation-tests.factor index 5d278b27b0..82f8ce1e4d 100644 --- a/unfinished/compiler/tree/propagation/propagation-tests.factor +++ b/unfinished/compiler/tree/propagation/propagation-tests.factor @@ -3,7 +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 ; +byte-arrays classes.algebra math.functions math.private +strings ; IN: compiler.tree.propagation.tests \ propagate must-infer @@ -234,8 +235,100 @@ IN: compiler.tree.propagation.tests [ [ 1 ] [ 1 ] if 1 + ] final-literals ] unit-test +[ V{ string string } ] [ + [ + 2dup [ dup string? [ "Oops" throw ] unless ] bi@ 2drop + ] final-classes +] unit-test + +! Array length propagation [ 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 + +! Slot propagation +TUPLE: prop-test-tuple { x integer } ; + +[ V{ integer } ] [ [ { prop-test-tuple } declare x>> ] final-classes ] unit-test + +TUPLE: another-prop-test-tuple { x ratio initial: 1/2 } ; + +UNION: prop-test-union prop-test-tuple another-prop-test-tuple ; + +[ t ] [ + [ { prop-test-union } declare x>> ] final-classes first + rational class= +] unit-test + +TUPLE: fold-boa-test-tuple { x read-only } { y read-only } { z read-only } ; + +[ V{ T{ fold-boa-test-tuple f 1 2 3 } } ] +[ [ 1 2 3 fold-boa-test-tuple boa ] final-literals ] +unit-test + +TUPLE: immutable-prop-test-tuple { x sequence read-only } ; + +[ V{ T{ immutable-prop-test-tuple f "hey" } } ] [ + [ "hey" immutable-prop-test-tuple boa ] final-literals +] unit-test + +[ V{ { 1 2 } } ] [ + [ { 1 2 } immutable-prop-test-tuple boa x>> ] final-literals +] unit-test + +[ V{ array } ] [ + [ { array } declare immutable-prop-test-tuple boa x>> ] final-classes +] unit-test + +[ V{ complex } ] [ + [ ] final-classes +] unit-test + +[ V{ complex } ] [ + [ { float float } declare dup 0.0 <= [ "Oops" throw ] [ rect> ] if ] final-classes +] unit-test + +[ V{ float float } ] [ + [ + { float float } declare + dup 0.0 <= [ "Oops" throw ] when rect> + [ real>> ] [ imaginary>> ] bi + ] final-classes +] unit-test + +[ V{ complex } ] [ + [ + { float float object } declare + [ "Oops" throw ] [ ] if + ] final-classes +] unit-test + +[ V{ number } ] [ [ [ "Oops" throw ] [ 2 + ] if ] final-classes ] unit-test +[ V{ number } ] [ [ [ 2 + ] [ "Oops" throw ] if ] final-classes ] unit-test + +[ V{ POSTPONE: f } ] [ + [ dup 1.0 <= [ drop f ] [ 0 number= ] if ] final-classes +] unit-test + +! Don't fold this +TUPLE: mutable-tuple-test { x sequence } ; + +[ V{ sequence } ] [ + [ "hey" mutable-tuple-test boa x>> ] final-classes +] unit-test + +[ V{ sequence } ] [ + [ T{ mutable-tuple-test f "hey" } x>> ] final-classes +] unit-test + +! Mixed mutable and immutable slots +TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; + +[ V{ integer array } ] [ + [ + 3 { 2 1 } mixed-mutable-immutable boa + [ x>> ] [ y>> ] bi + ] final-classes +] unit-test diff --git a/unfinished/compiler/tree/propagation/simple/simple.factor b/unfinished/compiler/tree/propagation/simple/simple.factor index 6b8efd77e9..10beb6f6e0 100644 --- a/unfinished/compiler/tree/propagation/simple/simple.factor +++ b/unfinished/compiler/tree/propagation/simple/simple.factor @@ -2,11 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors kernel sequences sequences.private assocs words namespaces classes.algebra combinators classes -continuations arrays byte-arrays strings +classes.tuple classes.tuple.private continuations arrays +byte-arrays strings math math.private slots compiler.tree compiler.tree.def-use compiler.tree.propagation.info compiler.tree.propagation.nodes +compiler.tree.propagation.slots compiler.tree.propagation.constraints ; IN: compiler.tree.propagation.simple @@ -53,6 +55,17 @@ M: #declare propagate-before [ word>> +outputs+ word-prop ] bi with-datastack ; +: foldable-word? ( #call -- ? ) + dup word>> "foldable" word-prop [ + drop t + ] [ + dup word>> \ eq? [ + in-d>> peek value-info literal>> immutable-tuple-class? + ] [ + drop f + ] if + ] if ; + : foldable-call? ( #call -- ? ) dup word>> "foldable" word-prop [ in-d>> [ value-info literal?>> ] all? @@ -73,27 +86,11 @@ 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 tuple-constructor? ] [ propagate-tuple-constructor ] } + { [ dup word>> reader? ] [ reader-word-outputs ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } { [ dup length-accessor? ] [ propagate-length ] } { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] } @@ -107,12 +104,16 @@ M: #call propagate-before M: node propagate-before drop ; +: propagate-input-classes ( node -- ) + [ word>> "input-classes" word-prop class-infos ] [ in-d>> ] bi + refine-value-infos ; + M: #call propagate-after - dup word>> "input-classes" word-prop dup [ - class-infos swap in-d>> refine-value-infos - ] [ - 2drop - ] if ; + { + { [ dup reader? ] [ reader-word-inputs ] } + { [ dup word>> "input-classes" word-prop ] [ propagate-input-classes ] } + [ drop ] + } cond ; M: node propagate-after drop ; diff --git a/unfinished/compiler/tree/propagation/slots/slots.factor b/unfinished/compiler/tree/propagation/slots/slots.factor new file mode 100644 index 0000000000..df10626967 --- /dev/null +++ b/unfinished/compiler/tree/propagation/slots/slots.factor @@ -0,0 +1,111 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: fry assocs arrays byte-arrays strings accessors sequences +kernel slots classes.algebra classes.tuple classes.tuple.private +words math math.private combinators sequences.private namespaces +compiler.tree.propagation.info ; +IN: compiler.tree.propagation.slots + +! Propagation of immutable slots and array lengths + +! Revisit this code when delegation is removed and when complex +! numbers become tuples. + +UNION: fixed-length-sequence array byte-array string ; + +: sequence-constructor? ( node -- ? ) + word>> { } memq? ; + +: constructor-output-class ( word -- class ) + { + { array } + { byte-array } + { string } + } at ; + +: propagate-sequence-constructor ( node -- infos ) + [ word>> constructor-output-class ] + [ 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 ; + +: tuple-constructor? ( node -- ? ) + word>> { } memq? ; + +: propagate- ( node -- info ) + #! Delegation + in-d>> [ value-info ] map unclip-last + literal>> class>> dup immutable-tuple-class? [ + over [ literal?>> ] all? + [ [ , f , [ literal>> ] map % ] { } make >tuple ] + [ ] + if + ] [ nip ] if ; + +: propagate- ( node -- info ) + in-d>> [ value-info ] map complex ; + +: propagate-tuple-constructor ( node -- infos ) + dup word>> { + { \ [ propagate- ] } + { \ [ propagate- ] } + } case 1array ; + +: relevant-methods ( node -- methods ) + [ word>> "methods" word-prop ] + [ in-d>> first value-info class>> ] bi + '[ drop , classes-intersect? ] assoc-filter ; + +: relevant-slots ( node -- slots ) + relevant-methods [ nip "reading" word-prop ] { } assoc>map ; + +: no-reader-methods ( input slots -- info ) + 2drop null ; + +: same-offset ( slots -- slot/f ) + dup [ dup [ read-only>> ] when ] all? [ + [ offset>> ] map dup all-equal? [ first ] [ drop f ] if + ] [ drop f ] if ; + +: (reader-word-outputs) ( reader -- info ) + null + [ [ class>> ] [ object ] if* class-or ] reduce + ; + +: value-info-slot ( slot info -- info' ) + #! Delegation. + [ class>> complex class<= 1 3 ? - ] keep + dup literal?>> [ + literal>> { + { [ dup tuple? ] [ + tuple-slots 1 tail-slice nth + ] } + { [ dup complex? ] [ + [ real-part ] [ imaginary-part ] bi + 2array nth + ] } + } cond + ] [ slots>> ?nth ] if ; + +: reader-word-outputs ( node -- infos ) + [ relevant-slots ] [ in-d>> first ] bi + over empty? [ no-reader-methods ] [ + over same-offset dup + [ swap value-info value-info-slot ] [ 2drop f ] if + [ ] [ (reader-word-outputs) ] ?if + ] if 1array ; + +: reader-word-inputs ( node -- ) + [ in-d>> first ] [ + relevant-slots keys + object [ class>> [ class-and ] when* ] reduce + + ] bi + refine-value-info ; diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor index 613cf31161..711fb3f151 100644 --- a/unfinished/stack-checker/branches/branches.factor +++ b/unfinished/stack-checker/branches/branches.factor @@ -7,7 +7,7 @@ stack-checker.backend stack-checker.errors stack-checker.visitor IN: stack-checker.branches : balanced? ( seq -- ? ) - [ first2 length - ] map all-equal? ; + [ second ] filter [ first2 length - ] map all-equal? ; : phi-inputs ( seq -- newseq ) dup empty? [ @@ -16,7 +16,7 @@ IN: stack-checker.branches ] unless ; : unify-values ( values -- phi-out ) - dup [ known ] map dup all-eq? + dup sift [ known ] map dup all-eq? [ nip first make-known ] [ 2drop ] if ; : phi-outputs ( phi-in -- stack ) @@ -25,7 +25,7 @@ IN: stack-checker.branches SYMBOL: quotations : unify-branches ( ins stacks -- in phi-in phi-out ) - zip [ second ] filter dup empty? [ drop 0 { } { } ] [ + zip dup empty? [ drop 0 { } { } ] [ dup balanced? [ [ keys supremum ] [ values phi-inputs dup phi-outputs ] bi ] [ quotations get unbalanced-branches-error ]