diff --git a/basis/compiler/tree/propagation/info/info-tests.factor b/basis/compiler/tree/propagation/info/info-tests.factor index 23a6d0ae39..cb0cf946a6 100644 --- a/basis/compiler/tree/propagation/info/info-tests.factor +++ b/basis/compiler/tree/propagation/info/info-tests.factor @@ -96,7 +96,7 @@ STRUCT: self { s self* } ; value-info<= ] unit-test -{ f f f f } [ +{ f f f f f } [ ! Checking intervals fixnum 20 value-info<= @@ -108,4 +108,15 @@ STRUCT: self { s self* } ; f c-ptr 2array self f byte-array 2array self value-info<= + + ! If one value-info has a slot specified and the other doesn't, + ! then it can't be smaller because that other slot could be + ! anything! + self + f byte-array 2array self value-info<= +] unit-test + +{ t f } [ + 10 f value-info<= + f 10 value-info<= ] unit-test diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index e3637eb9f7..23471e4cf3 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -3,7 +3,7 @@ USING: accessors arrays assocs byte-arrays classes classes.algebra classes.singleton classes.tuple classes.tuple.private combinators combinators.short-circuit -compiler.tree.propagation.copy kernel layouts math +compiler.tree.propagation.copy compiler.utilities kernel layouts math math.intervals namespaces sequences sequences.private strings words ; IN: compiler.tree.propagation.info @@ -265,19 +265,13 @@ DEFER: (value-info-union) } cond ; : value-info<= ( info1 info2 -- ? ) + [ [ object-info ] unless* ] bi@ { - { [ dup not ] [ 2drop t ] } - { [ over not ] [ 2drop f ] } - [ - { - { [ 2dup [ class>> ] bi@ class<= not ] [ f ] } - { [ 2dup [ interval>> ] bi@ interval-subset? not ] [ f ] } - { [ 2dup literals<= not ] [ f ] } - { [ 2dup [ slots>> ] bi@ [ value-info<= ] 2all? not ] [ f ] } - [ t ] - } cond 2nip - ] - } cond ; + [ [ class>> ] bi@ class<= ] + [ [ interval>> ] bi@ interval-subset? ] + [ literals<= ] + [ [ slots>> ] bi@ f pad-tail-shorter [ value-info<= ] 2all? ] + } 2&& ; SYMBOL: value-infos diff --git a/basis/compiler/utilities/utilities-docs.factor b/basis/compiler/utilities/utilities-docs.factor index 66b2d77955..e85e0efb32 100644 --- a/basis/compiler/utilities/utilities-docs.factor +++ b/basis/compiler/utilities/utilities-docs.factor @@ -1,7 +1,17 @@ -USING: assocs compiler.cfg.ssa.destruction.leaders help.markup help.syntax math -sequences ; +USING: assocs compiler.cfg.ssa.destruction.leaders help.markup help.syntax +kernel math sequences ; IN: compiler.utilities HELP: compress-path { $values { "source" integer } { "assoc" assoc } { "destination" integer } } { $description "Gets the original definer for a vreg number. Then inserts a direct path from 'source' to that definer. For example if the assoc is " { $code "{ { 1 2 } { 2 3 } { 3 4 } { 4 4 } }" } "then the original definer of 1 is 4. The word is used by " { $link leader } " to figure out what the top leader of a vreg is." } ; + +HELP: pad-tail-shorter +{ $values + { "seq1" sequence } + { "seq2" sequence } + { "elt" object } + { "seq1'" sequence } + { "seq2'" sequence } +} +{ $description "Pads the tail of the shorter sequence so that both sequences have the same length." } ; diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index a00dba4aff..4fb30e8c2b 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -22,6 +22,9 @@ IN: compiler.utilities : 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline +: pad-tail-shorter ( seq1 seq2 elt -- seq1' seq2' ) + 2over longer length swap [ pad-tail ] 2curry bi@ ; + SYMBOL: yield-hook yield-hook [ [ ] ] initialize