diff --git a/unfinished/compiler/tree/checker/checker.factor b/unfinished/compiler/tree/checker/checker.factor new file mode 100644 index 0000000000..08beec8b8f --- /dev/null +++ b/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 ; diff --git a/unfinished/compiler/tree/cleanup/cleanup.factor b/unfinished/compiler/tree/cleanup/cleanup.factor index 45a916b984..1ea31fe815 100644 --- a/unfinished/compiler/tree/cleanup/cleanup.factor +++ b/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 ; diff --git a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor index c7d558f4bf..54b10e9612 100644 --- a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor +++ b/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 -compiler.tree.def-use compiler.tree.combinators ; +kernel sequences words sets +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 diff --git a/unfinished/compiler/tree/def-use/def-use-tests.factor b/unfinished/compiler/tree/def-use/def-use-tests.factor index 34e28761ac..88172443ad 100755 --- a/unfinished/compiler/tree/def-use/def-use-tests.factor +++ b/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 -! some common patterns are generated correctly. +: test-def-use ( quot -- ) + 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 diff --git a/unfinished/compiler/tree/def-use/def-use.factor b/unfinished/compiler/tree/def-use/def-use.factor index 189dd292a2..c0cc240fd4 100755 --- a/unfinished/compiler/tree/def-use/def-use.factor +++ b/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 -compiler.tree compiler.tree.combinators ; +classes vectors accessors combinators sets +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 - check-def-use ; + dup [ node-def-use ] each-node ; diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor index 391649fcb2..910726e069 100644 --- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor +++ b/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 ; diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor index a0c27ac069..532c5a9ac3 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/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>> { } memq? + dup word>> { } memq? [ (count-unboxed-allocations) ] [ drop ] if ; M: #push count-unboxed-allocations* diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor index 604bed6b6d..1ea89787df 100644 --- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor +++ b/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 ] [ - label>> f >>fixed-point drop - ] if ; + [ congruent? ] 2all? [ drop ] [ 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 diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor index d7699cfc73..c6c407b048 100644 --- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor +++ b/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 - [ make-literal-slots swap record-allocation ] [ 2drop ] if ; + object-slots + [ make-literal-slots swap record-allocation ] + [ unknown-allocation ] + if* ; M: #push escape-analysis* #! Delegation. diff --git a/unfinished/compiler/tree/normalization/normalization-tests.factor b/unfinished/compiler/tree/normalization/normalization-tests.factor index 91c11f3be6..6986439dcc 100644 --- a/unfinished/compiler/tree/normalization/normalization-tests.factor +++ b/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 diff --git a/unfinished/compiler/tree/normalization/normalization.factor b/unfinished/compiler/tree/normalization/normalization.factor index 4eb28be917..285964e393 100644 --- a/unfinished/compiler/tree/normalization/normalization.factor +++ b/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>> diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index 00a7833655..25b4775b8e 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/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 -- ) diff --git a/unfinished/compiler/tree/propagation/copy/copy.factor b/unfinished/compiler/tree/propagation/copy/copy.factor index ee2d6e7415..1f4e5c0a86 100644 --- a/unfinished/compiler/tree/propagation/copy/copy.factor +++ b/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 ; diff --git a/unfinished/compiler/tree/propagation/recursive/recursive.factor b/unfinished/compiler/tree/propagation/recursive/recursive.factor index 0e3af85b20..6b266c4ea8 100644 --- a/unfinished/compiler/tree/propagation/recursive/recursive.factor +++ b/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 diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 5b06b37638..0dd8f3e3de 100644 --- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/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 -compiler.tree compiler.tree.builder compiler.tree.normalization +USING: tools.test compiler.tree.tuple-unboxing compiler.tree +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 -sorting math.order binary-search ; +compiler.tree.checker compiler.tree.def-use kernel accessors +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 - drop ; + check-nodes ; 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 ] + [ 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 diff --git a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 71ff79d95b..3b832917d8 100644 --- a/unfinished/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/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 flip ] change-phi-in-r - [ flatten-values ] change-out-d + [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-d + [ flip [ flatten-values ] map pad-with-bottom flip ] change-phi-in-r + [ flatten-values ] change-out-d [ flatten-values ] change-out-r ; M: #recursive unbox-tuples* diff --git a/unfinished/stack-checker/branches/branches.factor b/unfinished/stack-checker/branches/branches.factor index c4a89deb05..72a32574e1 100644 --- a/unfinished/stack-checker/branches/branches.factor +++ b/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 ) - dup [ [ - f ] dip append ] [ 3drop f ] if ; +SYMBOL: +bottom+ -: pad-with-f ( seq -- newseq ) - dup [ length ] map supremum '[ , f pad-left ] map ; +: unify-inputs ( max-d-in d-in meta-d -- new-meta-d ) + dup [ [ - +bottom+ ] 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 ] [ + remove-bottom + dup empty? [ drop ] [ [ known ] map dup all-eq? [ first make-known ] [ drop ] if ] if ;