: 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? ;
+
<PRIVATE
: tuple-layout ( class -- layout )
compose compose ; inline
! Booleans
-: not ( obj -- ? )
- #! Not inline because its special-cased by compiler.
- f eq? ;
+: not ( obj -- ? ) f t ? ; inline
-: and ( obj1 obj2 -- ? )
- #! Not inline because its special-cased by compiler.
- over ? ;
+: and ( obj1 obj2 -- ? ) over ? ; inline
: >boolean ( obj -- ? ) t f ? ; inline
]
} cond ;
+: intervals-intersect? ( i1 i2 -- ? )
+ interval-intersect empty-interval eq? not ;
+
: interval-union ( i1 i2 -- i3 )
{
{ [ dup empty-interval eq? ] [ drop ] }
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 )
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 ;
] [ ] 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 ;
} 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 ;
"parsing" "inline" "recursive" "foldable" "flushable"
"predicating"
"reading" "writing"
+ "reader" "writer"
"constructing"
"declared-effect" "constructor-quot" "delimiter"
} reset-props ;
! 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+
! 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<=
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*
: <sequence-info> ( value -- info )
<value-info>
object >>class
- [-inf,inf] >>interval
swap value-info >>length
init-value-info ; foldable
+: <tuple-info> ( slots class -- info )
+ <value-info>
+ swap >>class
+ swap >>slots
+ init-value-info ;
+
: >literal< ( info -- literal literal? )
[ literal>> ] [ literal?>> ] bi ;
[ 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 )
[ <value-info> ] 2dip
{
[ [ interval>> ] bi@ interval-intersect >>interval ]
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
[ intersect-lengths >>length ]
+ [ intersect-slots >>slots ]
} 2cleave
init-value-info ;
[ 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 )
[ <value-info> ] 2dip
{
[ [ interval>> ] bi@ interval-union >>interval ]
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
[ union-lengths >>length ]
+ [ union-slots >>slots ]
} 2cleave
init-value-info ;
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 ;
'[ , fold-comparison ] +outputs+ set-word-prop
] each
+: maybe-or-never ( ? -- info )
+ [ object <class-info> ] [ \ f <class-info> ] 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 }
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
[ [ 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 <array> length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] 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 } ] [
+ [ <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 ] [ <complex> ] 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
! 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
[ word>> +outputs+ word-prop ]
bi with-datastack ;
+: foldable-word? ( #call -- ? )
+ dup word>> "foldable" word-prop [
+ drop t
+ ] [
+ dup word>> \ <tuple-boa> 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?
out-d>> length object <class-info> <repetition>
] ?if ;
-UNION: fixed-length-sequence array byte-array string ;
-
-: sequence-constructor? ( node -- ? )
- word>> { <array> <byte-array> <string> } memq? ;
-
-: propagate-sequence-constructor ( node -- infos )
- [ default-output-value-infos first ]
- [ in-d>> first <sequence-info> ]
- 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 <class-info> ] 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 ] }
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 ;
--- /dev/null
+! 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>> { <array> <byte-array> <string> } memq? ;
+
+: constructor-output-class ( word -- class )
+ {
+ { <array> array }
+ { <byte-array> byte-array }
+ { <string> string }
+ } at ;
+
+: propagate-sequence-constructor ( node -- infos )
+ [ word>> constructor-output-class <class-info> ]
+ [ in-d>> first <sequence-info> ]
+ 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 <class-info> ] unless* 1array ;
+
+: tuple-constructor? ( node -- ? )
+ word>> { <tuple-boa> <complex> } memq? ;
+
+: 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 ;
+
+: propagate-<complex> ( node -- info )
+ in-d>> [ value-info ] map complex <tuple-info> ;
+
+: propagate-tuple-constructor ( node -- infos )
+ dup word>> {
+ { \ <tuple-boa> [ propagate-<tuple-boa> ] }
+ { \ <complex> [ propagate-<complex> ] }
+ } 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 <class-info> ;
+
+: 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
+ <class-info> ;
+
+: 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 ;
+
+: 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
+ <class-info>
+ ] bi
+ refine-value-info ;
IN: stack-checker.branches
: balanced? ( seq -- ? )
- [ first2 length - ] map all-equal? ;
+ [ second ] filter [ first2 length - ] map all-equal? ;
: phi-inputs ( seq -- newseq )
dup empty? [
] unless ;
: unify-values ( values -- phi-out )
- dup [ known ] map dup all-eq?
+ dup sift [ known ] map dup all-eq?
[ nip first make-known ] [ 2drop <value> ] if ;
: phi-outputs ( phi-in -- stack )
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 ]
projects / factor.git / commitdiff