Various fixes

unfinished/compiler/tree/checker/checker.factor

@@ -0,0 +1,61 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel sets namespaces accessors assocs
+arrays combinators continuations
+compiler.tree
+compiler.tree.def-use
+compiler.tree.combinators ;
+IN: compiler.tree.checker
+
+! Check some invariants.
+ERROR: check-use-error value message ;
+
+: check-use ( value uses -- )
+    [ empty? [ "No use" check-use-error ] [ drop ] if ]
+    [ all-unique? [ drop ] [ "Uses not all unique" check-use-error ] if ] 2bi ;
+
+: check-def-use ( -- )
+    def-use get [ uses>> check-use ] assoc-each ;
+
+GENERIC: check-node ( node -- )
+
+M: #shuffle check-node
+    [ [ mapping>> values ] [ in-d>> ] bi subset? [ "Bad mapping inputs" throw ] unless ]
+    [ [ mapping>> keys ] [ out-d>> ] bi set= [ "Bad mapping outputs" throw ] unless ]
+    bi ;
+
+: check-lengths ( seq -- )
+    [ length ] map all-equal? [ "Bad lengths" throw ] unless ;
+
+M: #copy check-node inputs/outputs 2array check-lengths ;
+
+M: #>r check-node inputs/outputs 2array check-lengths ;
+
+M: #r> check-node inputs/outputs 2array check-lengths ;
+
+M: #return-recursive check-node inputs/outputs 2array check-lengths ;
+
+M: #phi check-node
+    {
+        [ [ phi-in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+        [ [ phi-in-r>> ] [ out-r>> ] bi 2array check-lengths ]
+        [ phi-in-d>> check-lengths ]
+        [ phi-in-r>> check-lengths ]
+    } cleave ;
+
+M: #enter-recursive check-node
+    [ [ in-d>> ] [ out-d>> ] bi 2array check-lengths ]
+    [ [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix check-lengths ]
+    bi ;
+
+M: #push check-node
+    out-d>> length 1 = [ "Bad #push" throw ] unless ;
+
+M: node check-node drop ;
+
+ERROR: check-node-error node error ;
+
+: check-nodes ( nodes -- )
+    compute-def-use
+    check-def-use
+    [ [ check-node ] [ check-node-error ] recover ] each-node ;

unfinished/compiler/tree/cleanup/cleanup.factor

@@ -105,10 +105,10 @@ SYMBOL: live-branches
 
 M: #branch cleanup*
     {
-        [ live-branches>> live-branches set ]
         [ delete-unreachable-branches ]
         [ cleanup-children ]
         [ fold-only-branch ]
+        [ live-branches>> live-branches set ]
     } cleave ;
 
 : cleanup-phi-in ( phi-in live-branches -- phi-in' )
@@ -122,7 +122,8 @@ M: #phi cleanup*
         [ '[ , cleanup-phi-in ] change-phi-in-r ]
         [ '[ , cleanup-phi-in ] change-phi-info-d ]
         [ '[ , cleanup-phi-in ] change-phi-info-r ]
-    } cleave ;
+    } cleave
+    live-branches off ;
 
 : >copy ( node -- #copy ) [ in-d>> ] [ out-d>> ] bi #copy ;
 

unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry accessors namespaces assocs dequeues search-dequeues
-kernel sequences words sets stack-checker.inlining compiler.tree
+kernel sequences words sets
-compiler.tree.def-use compiler.tree.combinators ;
+stack-checker.branches stack-checker.inlining
+compiler.tree compiler.tree.def-use compiler.tree.combinators ;
 IN: compiler.tree.dataflow-analysis
 
 ! Dataflow analysis
@@ -34,5 +35,5 @@ SYMBOL: work-list
 : dfa ( node mark-quot iterate-quot -- assoc )
     init-dfa
     [ each-node ] dip
-    work-list get H{ { f f } } clone
+    work-list get H{ { +bottom+ f } } clone
     [ rot '[ , , iterate-dfa ] slurp-dequeue ] keep ; inline

unfinished/compiler/tree/def-use/def-use-tests.factor

@@ -1,7 +1,9 @@
 USING: accessors namespaces assocs kernel sequences math
 tools.test words sets combinators.short-circuit
 stack-checker.state compiler.tree compiler.tree.builder
-compiler.tree.def-use arrays kernel.private ;
+compiler.tree.normalization compiler.tree.propagation
+compiler.tree.cleanup compiler.tree.def-use arrays kernel.private
+sorting math.order binary-search compiler.tree.checker ;
 IN: compiler.tree.def-use.tests
 
 \ compute-def-use must-infer
@@ -14,8 +16,16 @@ IN: compiler.tree.def-use.tests
     } 1&&
 ] unit-test
 
-! compute-def-use checks for SSA violations, so we make sure
+: test-def-use ( quot -- )
-! some common patterns are generated correctly.
+    build-tree
+    normalize
+    propagate
+    cleanup
+    compute-def-use
+    check-nodes ;
+
+! compute-def-use checks for SSA violations, so we use that to
+! ensure we generate some common patterns correctly.
 {
     [ [ drop ] each-integer ]
     [ [ 2drop ] curry each-integer ]
@@ -28,6 +38,10 @@ IN: compiler.tree.def-use.tests
     [ [ 1 ] 2 [ + ] curry compose call + ]
     [ [ 1 ] [ call 2 ] curry call + ]
     [ [ 1 ] [ 2 ] compose swap [ 1 ] [ 2 ] if + * ]
+    [ dup slice? [ dup array? [ ] [ ] if ] [ ] if ]
+    [ dup [ drop f ] [ "A" throw ] if ]
+    [ [ <=> ] sort ]
+    [ [ <=> ] with search ]
 } [
-    [ ] swap [ build-tree compute-def-use drop ] curry unit-test
+    [ ] swap [ test-def-use ] curry unit-test
 ] each

unfinished/compiler/tree/def-use/def-use.factor

@@ -1,8 +1,11 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays namespaces assocs sequences kernel generic assocs
-classes vectors accessors combinators sets stack-checker.state
+classes vectors accessors combinators sets
-compiler.tree compiler.tree.combinators ;
+stack-checker.state
+stack-checker.branches
+compiler.tree
+compiler.tree.combinators ;
 IN: compiler.tree.def-use
 
 SYMBOL: def-use
@@ -37,7 +40,8 @@ M: #introduce node-uses-values drop f ;
 M: #push node-uses-values drop f ;
 M: #r> node-uses-values in-r>> ;
 M: #phi node-uses-values
-    [ phi-in-d>> ] [ phi-in-r>> ] bi append concat sift prune ;
+    [ phi-in-d>> ] [ phi-in-r>> ] bi
+    append concat remove-bottom prune ;
 M: #declare node-uses-values declaration>> keys ;
 M: node node-uses-values in-d>> ;
 
@@ -57,14 +61,6 @@ M: node node-defs-values out-d>> ;
     [ dup node-uses-values [ use-value ] with each ]
     [ dup node-defs-values [ def-value ] with each ] bi ;
 
-: check-use ( uses -- )
-    [ empty? [ "No use" throw ] when ]
-    [ all-unique? [ "Uses not all unique" throw ] unless ] bi ;
-
-: check-def-use ( -- )
-    def-use get [ nip uses>> check-use ] assoc-each ;
-
 : compute-def-use ( node -- node )
     H{ } clone def-use set
-    dup [ node-def-use ] each-node
+    dup [ node-def-use ] each-node ;
-    check-def-use ;

unfinished/compiler/tree/escape-analysis/branches/branches.factor

@@ -9,7 +9,9 @@ compiler.tree.escape-analysis.allocations ;
 IN: compiler.tree.escape-analysis.branches
 
 M: #branch escape-analysis*
-    live-children sift [ (escape-analysis) ] each ;
+    [ in-d>> add-escaping-values ]
+    [ live-children sift [ (escape-analysis) ] each ]
+    bi ;
 
 : (merge-allocations) ( values -- allocation )
     [
@@ -25,7 +27,7 @@ M: #branch escape-analysis*
     ] map ;
 
 : merge-allocations ( in-values out-values -- )
-    [ [ sift ] map ] dip
+    [ [ remove-bottom ] map ] dip
     [ [ merge-values ] 2each ]
     [ [ (merge-allocations) ] dip record-allocations ]
     2bi ;

unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor

@@ -5,7 +5,8 @@ compiler.tree.normalization math.functions
 compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.combinators compiler.tree sequences math math.private
 kernel tools.test accessors slots.private quotations.private
-prettyprint classes.tuple.private classes classes.tuple ;
+prettyprint classes.tuple.private classes classes.tuple
+compiler.tree.intrinsics ;
 
 \ escape-analysis must-infer
 
@@ -15,7 +16,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n )
     out-d>> first escaping-allocation? [ 1+ ] unless ;
 
 M: #call count-unboxed-allocations*
-    dup word>> { <tuple-boa> <complex> } memq?
+    dup word>> { <immutable-tuple-boa> <complex> } memq?
     [ (count-unboxed-allocations) ] [ drop ] if ;
 
 M: #push count-unboxed-allocations*

unfinished/compiler/tree/escape-analysis/recursive/recursive.factor

@@ -18,9 +18,7 @@ IN: compiler.tree.escape-analysis.recursive
     } cond ;
 
 : check-fixed-point ( node alloc1 alloc2 -- )
-    [ congruent? ] 2all? [ drop ] [
+    [ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
-        label>> f >>fixed-point drop
-    ] if ;
 
 : node-input-allocations ( node -- allocations )
     in-d>> [ allocation ] map ;
@@ -44,13 +42,14 @@ IN: compiler.tree.escape-analysis.recursive
     ] 2bi ;
 
 M: #recursive escape-analysis* ( #recursive -- )
-    [
+    { 0 } clone [ USE: math
+        dup first 10 = [ "OOPS" throw ] [ dup first 1+ swap set-first ] if
         child>>
         [ first out-d>> introduce-values ]
         [ first analyze-recursive-phi ]
         [ (escape-analysis) ]
         tri
-    ] until-fixed-point ;
+    ] curry until-fixed-point ;
 
 M: #enter-recursive escape-analysis* ( #enter-recursive -- )
     #! Handled by #recursive

unfinished/compiler/tree/escape-analysis/simple/simple.factor

@@ -33,8 +33,10 @@ DEFER: record-literal-allocation
     } cond ;
 
 : record-literal-allocation ( value object -- )
-    object-slots dup
+    object-slots
-    [ make-literal-slots swap record-allocation ] [ 2drop ] if ;
+    [ make-literal-slots swap record-allocation ]
+    [ unknown-allocation ]
+    if* ;
 
 M: #push escape-analysis*
     #! Delegation.

unfinished/compiler/tree/normalization/normalization-tests.factor

@@ -1,6 +1,6 @@
 IN: compiler.tree.normalization.tests
 USING: compiler.tree.builder compiler.tree.normalization
-compiler.tree sequences accessors tools.test kernel ;
+compiler.tree sequences accessors tools.test kernel math ;
 
 \ count-introductions must-infer
 \ fixup-enter-recursive must-infer
@@ -25,3 +25,5 @@ compiler.tree sequences accessors tools.test kernel ;
     [ recursive-inputs ]
     [ normalize recursive-inputs ] bi
 ] unit-test
+
+[ ] [ [ [ 1 ] [ 2 ] if + * ] build-tree normalize drop ] unit-test

unfinished/compiler/tree/normalization/normalization.factor

@@ -1,7 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces sequences math accessors kernel arrays
-stack-checker.backend stack-checker.inlining compiler.tree
+stack-checker.backend
+stack-checker.branches
+stack-checker.inlining
+compiler.tree
 compiler.tree.combinators ;
 IN: compiler.tree.normalization
 
@@ -97,7 +100,12 @@ M: #branch eliminate-introductions*
     bi ;
 
 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
-    [ flip ] dip [ [ nip ] [ over length tail append ] if ] 3map flip ;
+    [ flip ] dip [
+        [ nip ] [
+            dup [ +bottom+ eq? ] left-trim
+            [ [ length ] bi@ - tail* ] keep append
+        ] if
+    ] 3map flip ;
 
 M: #phi eliminate-introductions*
     remaining-introductions get swap dup terminated>>

unfinished/compiler/tree/propagation/branches/branches.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry kernel sequences assocs accessors namespaces
 math.intervals arrays classes.algebra combinators
+stack-checker.branches
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators
@@ -59,7 +60,14 @@ SYMBOL: infer-children-data
 
 : compute-phi-input-infos ( phi-in -- phi-info )
     infer-children-data get
-    '[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
+    '[
+        , [
+            [
+                dup +bottom+ eq?
+                [ drop null-info ] [ value-info ] if
+            ] bind
+        ] 2map
+    ] map ;
 
 : annotate-phi-inputs ( #phi -- )
     dup phi-in-d>> compute-phi-input-infos >>phi-info-d
@@ -139,10 +147,10 @@ M: #phi propagate-before ( #phi -- )
 M: #phi propagate-after ( #phi -- )
     condition-value get [
         [ out-d>> ] [ phi-in-d>> ] [ phi-info-d>> ] tri
-        3array flip [
+        [
-            first3 [ possible-boolean-values ] map
+            [ possible-boolean-values ] map
             branch-phi-constraints
-        ] each
+        ] 3each
     ] [ drop ] if ;
 
 M: #phi propagate-around ( #phi -- )

unfinished/compiler/tree/propagation/copy/copy.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences assocs math kernel accessors fry
 combinators sets locals
+stack-checker.branches
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators ;
@@ -42,7 +43,7 @@ M: #renaming compute-copy-equiv* inputs/outputs are-copies-of ;
     #! An output is a copy of every input if all inputs are
     #! copies of the same original value.
     [
-        swap sift [ resolve-copy ] map
+        swap remove-bottom [ resolve-copy ] map
         dup [ all-equal? ] [ empty? not ] bi and
         [ first swap is-copy-of ] [ 2drop ] if
     ] 2each ;

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -39,7 +39,7 @@ IN: compiler.tree.propagation.recursive
 : unify-recursive-stacks ( stacks initial -- infos )
     over empty? [ nip ] [
         [
-            [ sift value-infos-union ] dip
+            [ value-infos-union ] dip
             [ generalize-counter ] keep
             value-info-union
         ] 2map

unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor

@@ -1,24 +1,22 @@
 IN: compiler.tree.tuple-unboxing.tests
-USING: tools.test compiler.tree.tuple-unboxing
+USING: tools.test compiler.tree.tuple-unboxing compiler.tree
-compiler.tree compiler.tree.builder compiler.tree.normalization
+compiler.tree.builder compiler.tree.normalization
 compiler.tree.propagation compiler.tree.cleanup
 compiler.tree.escape-analysis compiler.tree.tuple-unboxing
-compiler.tree.def-use kernel accessors sequences math
+compiler.tree.checker compiler.tree.def-use kernel accessors
-sorting math.order binary-search ;
+sequences math math.private sorting math.order binary-search
+sequences.private slots.private ;
 
 \ unbox-tuples must-infer
 
 : test-unboxing ( quot -- )
-    #! Just make sure it doesn't throw errors; compute def use
-    #! for kicks.
     build-tree
     normalize
     propagate
     cleanup
     escape-analysis
     unbox-tuples
-    compute-def-use
+    check-nodes ;
-    drop ;
 
 TUPLE: cons { car read-only } { cdr read-only } ;
 
@@ -30,6 +28,12 @@ TUPLE: empty-tuple ;
     [ cons boa [ car>> ] [ cdr>> ] bi ]
     [ [ 1 cons boa ] [ 2 cons boa ] if car>> ]
     [ dup cons boa 10 [ nip dup cons boa ] each-integer car>> ]
+    [ 2 cons boa { [ ] [ ] } dispatch ]
+    [ dup [ drop f ] [ "A" throw ] if ]
+    [ [ ] [ ] curry curry dup 3 slot swap 4 slot dup 3 slot swap 4 slot drop ]
+    [ [ ] [ ] curry curry call ]
+    [ <complex> <complex> dup 1 slot drop 2 slot drop ]
+    [ 1 cons boa over [ "A" throw ] when car>> ]
     [ [ <=> ] sort ]
     [ [ <=> ] with search ]
 } [ [ ] swap [ test-unboxing ] curry unit-test ] each

unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -3,6 +3,7 @@
 USING: namespaces assocs accessors kernel combinators
 classes.algebra sequences sequences.deep slots.private
 classes.tuple.private math math.private arrays
+stack-checker.branches
 compiler.tree
 compiler.tree.intrinsics
 compiler.tree.combinators
@@ -43,15 +44,13 @@ M: #push unbox-tuples* ( #push -- nodes )
 : flatten-values ( values -- values' )
     (flatten-values) flatten ;
 
-: flatten-value ( values -- values )
-    [ unboxed-allocation ] [ 1array ] bi or ;
-
 : prepare-slot-access ( #call -- tuple-values outputs slot-values )
-    [ in-d>> first flatten-value ]
+    [ in-d>> flatten-values ]
     [ out-d>> flatten-values ]
     [
         out-d>> first slot-accesses get at
-        [ slot#>> ] [ value>> ] bi allocation nth flatten-value
+        [ slot#>> ] [ value>> ] bi allocation nth
+        1array flatten-values
     ] tri ;
 
 : slot-access-shuffle ( tuple-values outputs slot-values -- #shuffle )
@@ -73,7 +72,8 @@ M: #call unbox-tuples*
     } case ;
 
 M: #declare unbox-tuples*
-    [ unzip [ flatten-values ] dip zip ] change-declaration ;
+    #! We don't look at declarations after propagation anyway.
+    f >>declaration ;
 
 M: #copy unbox-tuples*
     [ flatten-values ] change-in-d
@@ -96,9 +96,9 @@ M: #terminate unbox-tuples*
     [ flatten-values ] change-in-d ;
 
 M: #phi unbox-tuples*
-    [ flip [ flatten-values ] map flip ] change-phi-in-d
+    [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d
-    [ flip [ flatten-values ] map flip ] change-phi-in-r
+    [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r
-    [ flatten-values ] change-out-d
+    [ flatten-values ] change-out-d 
     [ flatten-values ] change-out-r ;
 
 M: #recursive unbox-tuples*

unfinished/stack-checker/branches/branches.factor

@@ -9,21 +9,30 @@ IN: stack-checker.branches
 : balanced? ( pairs -- ? )
     [ second ] filter [ first2 length - ] map all-equal? ;
 
-: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
+SYMBOL: +bottom+
-    dup [ [ - f <repetition> ] dip append ] [ 3drop f ] if ;
 
-: pad-with-f ( seq -- newseq )
+: unify-inputs ( max-d-in d-in meta-d -- new-meta-d )
-    dup [ length ] map supremum '[ , f pad-left ] map ;
+    dup [ [ - +bottom+ <repetition> ] dip append ] [ 3drop f ] if ;
+
+: pad-with-bottom ( seq -- newseq )
+    dup empty? [
+        dup [ length ] map supremum
+        '[ , +bottom+ pad-left ] map
+    ] unless ;
 
 : phi-inputs ( max-d-in pairs -- newseq )
     dup empty? [ nip ] [
         swap '[ , _ first2 unify-inputs ] map
-        pad-with-f
+        pad-with-bottom
         flip
     ] if ;
 
+: remove-bottom ( seq -- seq' )
+    +bottom+ swap remove ;
+
 : unify-values ( values -- phi-out )
-    sift dup empty? [ drop <value> ] [
+    remove-bottom
+    dup empty? [ drop <value> ] [
         [ known ] map dup all-eq?
         [ first make-known ] [ drop <value> ] if
     ] if ;