From b5473d7f142b098c2355aa3002edd09373114fd6 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 9 Aug 2008 12:40:17 -0400 Subject: [PATCH 01/13] Persistent deques --- basis/persistent/deques/authors.txt | 1 + basis/persistent/deques/deques-docs.factor | 56 +++++++++++++++ basis/persistent/deques/deques-tests.factor | 35 ++++++++++ basis/persistent/deques/deques.factor | 76 +++++++++++++++++++++ basis/persistent/deques/summary.txt | 1 + basis/persistent/deques/tags.txt | 1 + 6 files changed, 170 insertions(+) create mode 100644 basis/persistent/deques/authors.txt create mode 100644 basis/persistent/deques/deques-docs.factor create mode 100644 basis/persistent/deques/deques-tests.factor create mode 100644 basis/persistent/deques/deques.factor create mode 100644 basis/persistent/deques/summary.txt create mode 100644 basis/persistent/deques/tags.txt diff --git a/basis/persistent/deques/authors.txt b/basis/persistent/deques/authors.txt new file mode 100644 index 0000000000..f990dd0ed2 --- /dev/null +++ b/basis/persistent/deques/authors.txt @@ -0,0 +1 @@ +Daniel Ehrenberg diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor new file mode 100644 index 0000000000..56ee46a6a9 --- /dev/null +++ b/basis/persistent/deques/deques-docs.factor @@ -0,0 +1,56 @@ +USING: help.markup help.syntax kernel sequences ; +IN: persistent.deques + +ARTICLE: "persistent.deques" "Persistent deques" +"A deque is a data structure that can be used as both a queue and a stack. That is, there are two ends, the left and the right, and values can be pushed onto and popped off of both ends. These operations take O(1) amortized time and space in a normal usage pattern." +$nl +"This vocabulary provides a deque implementation which is persistent and purely functional: old versions of deques are not modified by operations. Instead, each push and pop operation creates a new deque based off the old one." +$nl +"The class of persistent deques:" +{ $subsection deque } +"To create a deque:" +{ $subsection } +{ $subsection sequence>deque } +"To test if a deque is empty:" +{ $subsection deque-empty? } +"To manipulate deques:" +{ $subsection push-left } +{ $subsection push-right } +{ $subsection pop-left } +{ $subsection pop-right } +{ $subsection deque>sequence } ; + +HELP: deque +{ $class-description "This is the class of persistent (functional) double-ended queues. All deque operations can be done in O(1) amortized time for single-threaded access while maintaining the old version. For more information, see " { $link "persistent.deques" } "." } ; + +HELP: +{ $values { "deque" "an empty deque" } } +{ $description "Creates an empty deque." } ; + +HELP: sequence>deque +{ $values { "sequence" sequence } { "deque" deque } } +{ $description "Given a sequence, creates a deque containing those elements in the order such that the beginning of the sequence is on the left and the end is on the right." } ; + +HELP: deque>sequence +{ $values { "deque" deque } { "sequence" sequence } } +{ $description "Given a deque, creates a sequence containing those elements, such that the left side of the deque is the beginning of the sequence." } ; + +HELP: deque-empty? +{ $values { "deque" deque } { "?" "t/f" } } +{ $description "Returns true if the deque is empty. This takes constant time." } ; + +HELP: push-left +{ $values { "deque" deque } { "item" object } { "newdeque" deque } } +{ $description "Creates a new deque with the given object pushed onto the left side. This takes constant time." } ; + +HELP: push-right +{ $values { "deque" deque } { "item" object } { "newdeque" deque } } +{ $description "Creates a new deque with the given object pushed onto the right side. This takes constant time." } ; + +HELP: pop-left +{ $values { "deque" object } { "item" object } { "newdeque" deque } } +{ $description "Creates a new deque with the leftmost item removed. This takes amortized constant time with single-threaded access." } ; + +HELP: pop-right +{ $values { "deque" object } { "item" object } { "newdeque" deque } } +{ $description "Creates a new deque with the rightmost item removed. This takes amortized constant time with single-threaded access." } ; diff --git a/basis/persistent/deques/deques-tests.factor b/basis/persistent/deques/deques-tests.factor new file mode 100644 index 0000000000..353828cb14 --- /dev/null +++ b/basis/persistent/deques/deques-tests.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test persistent.deques kernel math ; +IN: persistent.deques.tests + +[ 3 2 1 t ] +[ { 1 2 3 } sequence>deque 3 [ pop-right ] times deque-empty? ] unit-test + +[ 1 2 3 t ] +[ { 1 2 3 } sequence>deque 3 [ pop-left ] times deque-empty? ] unit-test + +[ 1 3 2 t ] +[ { 1 2 3 } sequence>deque pop-left 2 [ pop-right ] times deque-empty? ] +unit-test + +[ { 2 3 4 5 6 1 } ] +[ { 1 2 3 4 5 6 } sequence>deque pop-left swap push-right deque>sequence ] +unit-test + +[ 1 t ] [ 1 push-left pop-right deque-empty? ] unit-test +[ 1 t ] [ 1 push-left pop-left deque-empty? ] unit-test +[ 1 t ] [ 1 push-right pop-left deque-empty? ] unit-test +[ 1 t ] [ 1 push-right pop-right deque-empty? ] unit-test + +[ 1 f ] +[ 1 push-left 2 push-left pop-right deque-empty? ] unit-test + +[ 1 f ] +[ 1 push-right 2 push-right pop-left deque-empty? ] unit-test + +[ 2 f ] +[ 1 push-right 2 push-right pop-right deque-empty? ] unit-test + +[ 2 f ] +[ 1 push-left 2 push-left pop-left deque-empty? ] unit-test diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor new file mode 100644 index 0000000000..b30153aada --- /dev/null +++ b/basis/persistent/deques/deques.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors math qualified ; +QUALIFIED: sequences +IN: persistent.deques + +! Amortized O(1) push/pop on both ends for single-threaded access +! In a pathological case, if there are m modified versions from the +! same source, it could take O(m) amortized time per update. + + cons + +: each ( list quot -- ) + over + [ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ] + [ 2drop ] if ; inline + +: reduce ( list start quot -- end ) + swapd each ; inline + +: reverse ( list -- reversed ) + f [ swap ] reduce ; + +: length ( list -- length ) + 0 [ drop 1+ ] reduce ; + +: cut ( list index -- back front-reversed ) + f swap [ >r [ cdr>> ] [ car>> ] bi r> ] times ; + +: split-reverse ( list -- back-reversed front ) + dup length 2/ cut [ reverse ] bi@ ; +PRIVATE> + +TUPLE: deque { lhs read-only } { rhs read-only } ; +: ( -- deque ) T{ deque } ; + +: deque-empty? ( deque -- ? ) + [ lhs>> ] [ rhs>> ] bi or not ; + +: push-left ( deque item -- newdeque ) + swap [ lhs>> ] [ rhs>> ] bi deque boa ; + +: push-right ( deque item -- newdeque ) + swap [ rhs>> ] [ lhs>> ] bi swap deque boa ; + +> car>> ] [ [ lhs>> cdr>> ] [ rhs>> ] bi deque boa ] bi ; + +: transfer-left ( deque -- item newdeque ) + rhs>> [ split-reverse deque boa (pop-left) ] + [ "Popping from an empty deque" throw ] if* ; +PRIVATE> + +: pop-left ( deque -- item newdeque ) + dup lhs>> [ (pop-left) ] [ transfer-left ] if ; + +> car>> ] [ [ lhs>> ] [ rhs>> cdr>> ] bi deque boa ] bi ; + +: transfer-right ( deque -- newdeque item ) + lhs>> [ split-reverse deque boa (pop-left) ] + [ "Popping from an empty deque" throw ] if* ; +PRIVATE> + +: pop-right ( deque -- item newdeque ) + dup rhs>> [ (pop-right) ] [ transfer-right ] if ; + +: sequence>deque ( sequence -- deque ) + [ push-right ] sequences:reduce ; + +: deque>sequence ( deque -- sequence ) + [ dup deque-empty? not ] [ pop-left swap ] [ ] sequences:produce nip ; diff --git a/basis/persistent/deques/summary.txt b/basis/persistent/deques/summary.txt new file mode 100644 index 0000000000..021a1e3fef --- /dev/null +++ b/basis/persistent/deques/summary.txt @@ -0,0 +1 @@ +Persistent amortized O(1) deques diff --git a/basis/persistent/deques/tags.txt b/basis/persistent/deques/tags.txt new file mode 100644 index 0000000000..42d711b32b --- /dev/null +++ b/basis/persistent/deques/tags.txt @@ -0,0 +1 @@ +collections From d46b5387d506941bb3254098ead070a73e33f3a2 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Sat, 9 Aug 2008 22:33:58 -0400 Subject: [PATCH 02/13] backtrack: Added cut-amb --- extra/backtrack/backtrack.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/backtrack/backtrack.factor b/extra/backtrack/backtrack.factor index 3c1a794121..db2c50173c 100755 --- a/extra/backtrack/backtrack.factor +++ b/extra/backtrack/backtrack.factor @@ -66,3 +66,5 @@ MACRO: amb-execute ( seq -- quot ) tri* if ] with-scope ; inline +: cut-amb ( -- ) + f failure set ; From ca57e4386cdc39f8ae9cff36c33ce35cab2381b1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Aug 2008 23:00:27 -0500 Subject: [PATCH 03/13] Various fixes --- .../compiler/tree/checker/checker.factor | 61 +++++++++++++++++++ .../compiler/tree/cleanup/cleanup.factor | 5 +- .../dataflow-analysis.factor | 7 ++- .../tree/def-use/def-use-tests.factor | 22 +++++-- .../compiler/tree/def-use/def-use.factor | 20 +++--- .../escape-analysis/branches/branches.factor | 6 +- .../escape-analysis-tests.factor | 5 +- .../recursive/recursive.factor | 9 ++- .../tree/escape-analysis/simple/simple.factor | 6 +- .../normalization/normalization-tests.factor | 4 +- .../tree/normalization/normalization.factor | 12 +++- .../tree/propagation/branches/branches.factor | 16 +++-- .../tree/propagation/copy/copy.factor | 3 +- .../propagation/recursive/recursive.factor | 2 +- .../tuple-unboxing-tests.factor | 20 +++--- .../tree/tuple-unboxing/tuple-unboxing.factor | 18 +++--- .../stack-checker/branches/branches.factor | 21 +++++-- 17 files changed, 173 insertions(+), 64 deletions(-) create mode 100644 unfinished/compiler/tree/checker/checker.factor 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 ; From 4cf2b064c52934010843d1fda61a251919e37114 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Aug 2008 01:58:39 -0500 Subject: [PATCH 04/13] Loop detection --- .../loop/detection/detection-tests.factor | 150 ++++++++++++++++++ .../tree/loop/detection/detection.factor | 102 +++++++++++- .../stack-checker/inlining/inlining.factor | 12 +- 3 files changed, 259 insertions(+), 5 deletions(-) create mode 100644 unfinished/compiler/tree/loop/detection/detection-tests.factor diff --git a/unfinished/compiler/tree/loop/detection/detection-tests.factor b/unfinished/compiler/tree/loop/detection/detection-tests.factor new file mode 100644 index 0000000000..5864dc368f --- /dev/null +++ b/unfinished/compiler/tree/loop/detection/detection-tests.factor @@ -0,0 +1,150 @@ +IN: compiler.tree.loop.detection.tests +USING: compiler.tree.loop.detection tools.test +kernel combinators.short-circuit math sequences accessors +compiler.tree +compiler.tree.builder +compiler.tree.combinators ; + +[ { f f f f } ] [ f { f t f f } (tail-calls) ] unit-test +[ { f f f t } ] [ t { f t f f } (tail-calls) ] unit-test +[ { f t t t } ] [ t { f f t t } (tail-calls) ] unit-test +[ { f f f t } ] [ t { f f t f } (tail-calls) ] unit-test + +\ detect-loops must-infer + +: label-is-loop? ( nodes word -- ? ) + [ + { + [ drop #recursive? ] + [ drop label>> loop?>> ] + [ swap label>> word>> eq? ] + } 2&& + ] curry contains-node? ; + +\ label-is-loop? must-infer + +: label-is-not-loop? ( nodes word -- ? ) + [ + { + [ drop #recursive? ] + [ drop label>> loop?>> not ] + [ swap label>> word>> eq? ] + } 2&& + ] curry contains-node? ; + +\ label-is-not-loop? must-infer + +: loop-test-1 ( a -- ) + dup [ 1+ loop-test-1 ] [ drop ] if ; inline recursive + +[ t ] [ + [ loop-test-1 ] build-tree detect-loops + \ loop-test-1 label-is-loop? +] unit-test + +[ t ] [ + [ loop-test-1 1 2 3 ] build-tree detect-loops + \ loop-test-1 label-is-loop? +] unit-test + +[ t ] [ + [ [ loop-test-1 ] each ] build-tree detect-loops + \ loop-test-1 label-is-loop? +] unit-test + +[ t ] [ + [ [ loop-test-1 ] each ] build-tree detect-loops + \ (each-integer) label-is-loop? +] unit-test + +: loop-test-2 ( a -- ) + dup [ 1+ loop-test-2 1- ] [ drop ] if ; inline recursive + +[ t ] [ + [ loop-test-2 ] build-tree detect-loops + \ loop-test-2 label-is-not-loop? +] unit-test + +: loop-test-3 ( a -- ) + dup [ [ loop-test-3 ] each ] [ drop ] if ; inline recursive + +[ t ] [ + [ loop-test-3 ] build-tree detect-loops + \ loop-test-3 label-is-not-loop? +] unit-test + +: loop-test-4 ( a -- ) + dup [ + loop-test-4 + ] [ + drop + ] if ; inline recursive + +[ f ] [ + [ [ [ ] map ] map ] build-tree detect-loops + [ + dup #recursive? [ label>> loop?>> not ] [ drop f ] if + ] contains-node? +] unit-test + +: blah f ; + +DEFER: a + +: b ( -- ) + blah [ b ] [ a ] if ; inline recursive + +: a ( -- ) + blah [ b ] [ a ] if ; inline recursive + +[ t ] [ + [ a ] build-tree detect-loops + \ a label-is-loop? +] unit-test + +[ t ] [ + [ a ] build-tree detect-loops + \ b label-is-loop? +] unit-test + +[ t ] [ + [ b ] build-tree detect-loops + \ a label-is-loop? +] unit-test + +[ t ] [ + [ a ] build-tree detect-loops + \ b label-is-loop? +] unit-test + +DEFER: a' + +: b' ( -- ) + blah [ b' b' ] [ a' ] if ; inline recursive + +: a' ( -- ) + blah [ b' ] [ a' ] if ; inline recursive + +[ f ] [ + [ a' ] build-tree detect-loops + \ a' label-is-loop? +] unit-test + +[ f ] [ + [ b' ] build-tree detect-loops + \ b' label-is-loop? +] unit-test + +! I used to think this should be f, but doing this on pen and +! paper almost convinced me that a loop conversion here is +! sound. + +[ t ] [ + [ b' ] build-tree detect-loops + \ a' label-is-loop? +] unit-test + +[ f ] [ + [ a' ] build-tree detect-loops + \ b' label-is-loop? +] unit-test diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor index e29ae22f0d..1c881e9ee4 100644 --- a/unfinished/compiler/tree/loop/detection/detection.factor +++ b/unfinished/compiler/tree/loop/detection/detection.factor @@ -1,5 +1,103 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: compiler.tree.loop-detection +USING: kernel sequences namespaces assocs accessors fry +compiler.tree ; +IN: compiler.tree.loop.detection -: detect-loops ( nodes -- nodes' ) ; +! A loop is a #recursive which only tail calls itself, and those +! calls are nested inside other loops only. + +TUPLE: recursive-call tail? nesting ; + +! calls is a sequence of recursive-call instances +TUPLE: loop-info calls height ; + +! Mapping inline-recursive instances to loop-info instances +SYMBOL: loop-infos + +! A sequence of inline-recursive instances +SYMBOL: label-stack + +: (tail-calls) ( tail? seq -- seq' ) + reverse [ swap [ and ] keep ] map nip reverse ; + +: tail-calls ( tail? node -- seq ) + [ + [ #phi? ] + [ #return? ] + [ #return-recursive? ] + tri or or + ] map (tail-calls) ; + +GENERIC: collect-loop-info* ( tail? node -- ) + +: non-tail-label-info ( nodes -- ) + [ f swap collect-loop-info* ] each ; + +: (collect-loop-info) ( tail? nodes -- ) + [ tail-calls ] keep [ collect-loop-info* ] 2each ; + +: remember-loop-info ( #recursive -- ) + V{ } clone label-stack get length loop-info boa + swap label>> loop-infos get set-at ; + +M: #recursive collect-loop-info* + nip + [ + [ label-stack [ swap label>> suffix ] change ] + [ remember-loop-info ] + [ t swap child>> (collect-loop-info) ] + tri + ] with-scope ; + +M: #call-recursive collect-loop-info* + label>> loop-infos get at + [ label-stack get swap height>> tail recursive-call boa ] + [ calls>> ] + bi push ; + +M: #if collect-loop-info* + children>> [ (collect-loop-info) ] with each ; + +M: #dispatch collect-loop-info* + children>> [ (collect-loop-info) ] with each ; + +M: node collect-loop-info* 2drop ; + +: collect-loop-info ( node -- ) + { } label-stack set + H{ } clone loop-infos set + t swap (collect-loop-info) ; + +! Sub-assoc of loop-infos +SYMBOL: potential-loops + +: remove-non-tail-calls ( -- ) + loop-infos get + [ nip calls>> [ tail?>> ] all? ] assoc-filter + potential-loops set ; + +: (remove-non-loop-calls) ( loop-infos -- ) + f over [ + ! If label X is called from within a label Y that is + ! no longer a potential loop, then X is no longer a + ! potential loop either. + over potential-loops get key? [ + potential-loops get '[ , key? ] all? + [ drop ] [ potential-loops get delete-at t or ] if + ] [ 2drop ] if + ] assoc-each + [ (remove-non-loop-calls) ] [ drop ] if ; + +: remove-non-loop-calls ( -- ) + ! Boolean is set to t if something changed. + ! We recurse until a fixed point is reached. + loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map + (remove-non-loop-calls) ; + +: detect-loops ( nodes -- nodes ) + dup + collect-loop-info + remove-non-tail-calls + remove-non-loop-calls + potential-loops get [ drop t >>loop? drop ] assoc-each ; diff --git a/unfinished/stack-checker/inlining/inlining.factor b/unfinished/stack-checker/inlining/inlining.factor index 155baa7e65..6442bc5740 100644 --- a/unfinished/stack-checker/inlining/inlining.factor +++ b/unfinished/stack-checker/inlining/inlining.factor @@ -17,15 +17,21 @@ IN: stack-checker.inlining : (inline-word) ( word label -- ) [ [ def>> ] keep ] dip infer-quot-recursive ; -TUPLE: inline-recursive +TUPLE: inline-recursive < identity-tuple +id word enter-out enter-recursive return calls fixed-point -introductions ; +introductions +loop? ; + +M: inline-recursive hashcode* id>> hashcode* ; : ( word -- label ) - inline-recursive new swap >>word ; + inline-recursive new + gensym >>id + swap >>word ; : quotation-param? ( obj -- ? ) dup pair? [ second effect? ] [ drop f ] if ; From 215f6ef65b9ac75ffdf690c79abda92997e6d3f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Aug 2008 01:59:55 -0500 Subject: [PATCH 05/13] Add minimum and maximum float constants --- basis/math/constants/constants.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/math/constants/constants.factor b/basis/math/constants/constants.factor index c207eaa63c..118a8e8197 100755 --- a/basis/math/constants/constants.factor +++ b/basis/math/constants/constants.factor @@ -1,5 +1,6 @@ -! Copyright (C) 2004, 2005 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USE: math IN: math.constants : e ( -- e ) 2.7182818284590452354 ; inline @@ -7,3 +8,5 @@ IN: math.constants : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline +: smallest-float ( -- x ) HEX: 1 bits>double ; foldable +: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable From bbd05723a5a4725d01d9518ed8b1303115d10ec6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Aug 2008 19:22:13 -0500 Subject: [PATCH 06/13] Cleaner loop detection pass --- .../tree/loop/detection/detection.factor | 95 ++++++++----------- 1 file changed, 40 insertions(+), 55 deletions(-) diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor index 1c881e9ee4..5c21e8c237 100644 --- a/unfinished/compiler/tree/loop/detection/detection.factor +++ b/unfinished/compiler/tree/loop/detection/detection.factor @@ -1,22 +1,13 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences namespaces assocs accessors fry -compiler.tree ; +compiler.tree dequeues search-dequeues ; IN: compiler.tree.loop.detection ! A loop is a #recursive which only tail calls itself, and those -! calls are nested inside other loops only. - -TUPLE: recursive-call tail? nesting ; - -! calls is a sequence of recursive-call instances -TUPLE: loop-info calls height ; - -! Mapping inline-recursive instances to loop-info instances -SYMBOL: loop-infos - -! A sequence of inline-recursive instances -SYMBOL: label-stack +! calls are nested inside other loops only. We optimistically +! assume all #recursive nodes are loops, disqualifying them as +! we see evidence to the contrary. : (tail-calls) ( tail? seq -- seq' ) reverse [ swap [ and ] keep ] map nip reverse ; @@ -29,6 +20,11 @@ SYMBOL: label-stack tri or or ] map (tail-calls) ; +SYMBOL: loop-heights +SYMBOL: loop-calls +SYMBOL: label-stack +SYMBOL: work-list + GENERIC: collect-loop-info* ( tail? node -- ) : non-tail-label-info ( nodes -- ) @@ -37,24 +33,32 @@ GENERIC: collect-loop-info* ( tail? node -- ) : (collect-loop-info) ( tail? nodes -- ) [ tail-calls ] keep [ collect-loop-info* ] 2each ; -: remember-loop-info ( #recursive -- ) - V{ } clone label-stack get length loop-info boa - swap label>> loop-infos get set-at ; +: remember-loop-info ( label -- ) + label-stack get length swap loop-heights get set-at ; M: #recursive collect-loop-info* nip [ - [ label-stack [ swap label>> suffix ] change ] - [ remember-loop-info ] - [ t swap child>> (collect-loop-info) ] - tri + [ + label>> + [ label-stack [ swap suffix ] change ] + [ remember-loop-info ] + [ t >>loop? drop ] + tri + ] + [ t swap child>> (collect-loop-info) ] bi ] with-scope ; +: current-loop-nesting ( label -- labels ) + label-stack get swap loop-heights get at tail ; + +: disqualify-loop ( label -- ) + work-list get push-front ; + M: #call-recursive collect-loop-info* - label>> loop-infos get at - [ label-stack get swap height>> tail recursive-call boa ] - [ calls>> ] - bi push ; + label>> + swap [ dup disqualify-loop ] unless + dup current-loop-nesting [ loop-calls get push-at ] with each ; M: #if collect-loop-info* children>> [ (collect-loop-info) ] with each ; @@ -66,38 +70,19 @@ M: node collect-loop-info* 2drop ; : collect-loop-info ( node -- ) { } label-stack set - H{ } clone loop-infos set + H{ } clone loop-calls set + H{ } clone loop-heights set + work-list set t swap (collect-loop-info) ; -! Sub-assoc of loop-infos -SYMBOL: potential-loops - -: remove-non-tail-calls ( -- ) - loop-infos get - [ nip calls>> [ tail?>> ] all? ] assoc-filter - potential-loops set ; - -: (remove-non-loop-calls) ( loop-infos -- ) - f over [ - ! If label X is called from within a label Y that is - ! no longer a potential loop, then X is no longer a - ! potential loop either. - over potential-loops get key? [ - potential-loops get '[ , key? ] all? - [ drop ] [ potential-loops get delete-at t or ] if - ] [ 2drop ] if - ] assoc-each - [ (remove-non-loop-calls) ] [ drop ] if ; - -: remove-non-loop-calls ( -- ) - ! Boolean is set to t if something changed. - ! We recurse until a fixed point is reached. - loop-infos get [ calls>> [ nesting>> ] map concat ] assoc-map - (remove-non-loop-calls) ; +: disqualify-loops ( -- ) + work-list get [ + dup loop?>> [ + [ f >>loop? drop ] + [ loop-calls get at [ disqualify-loop ] each ] + bi + ] [ drop ] if + ] slurp-dequeue ; : detect-loops ( nodes -- nodes ) - dup - collect-loop-info - remove-non-tail-calls - remove-non-loop-calls - potential-loops get [ drop t >>loop? drop ] assoc-each ; + dup collect-loop-info disqualify-loops ; From 73ed573a05398c99ce2136dcd83b37296d58b9d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Aug 2008 22:20:14 -0500 Subject: [PATCH 07/13] Fix typo in docs --- core/kernel/kernel-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 0a1a3cb7f2..94f0ddea51 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -629,7 +629,7 @@ HELP: 2bi* "The following two lines are equivalent:" { $code "[ p ] [ q ] 2bi*" - ">r >r q r> r> q" + ">r >r p r> r> q" } } ; From fe16de52e030c47f074498743d365e504e5dc9dd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Aug 2008 22:22:26 -0500 Subject: [PATCH 08/13] Inference transforms can now give up; remove elaboration phase since we'll do that while building CFG --- .../compiler/tree/builder/builder.factor | 5 + .../tree/elaboration/elaboration.factor | 5 - .../tree/intrinsics/intrinsics.factor | 24 +++- .../tree/loop/detection/detection.factor | 10 +- .../compiler/tree/optimizer/optimizer.factor | 10 +- .../tree/propagation/inlining/inlining.factor | 5 +- .../known-words/known-words.factor | 9 +- .../transforms/transforms.factor | 114 +++++++++++++++--- 8 files changed, 138 insertions(+), 44 deletions(-) delete mode 100644 unfinished/compiler/tree/elaboration/elaboration.factor diff --git a/unfinished/compiler/tree/builder/builder.factor b/unfinished/compiler/tree/builder/builder.factor index afa57556ca..e2315dbdf7 100644 --- a/unfinished/compiler/tree/builder/builder.factor +++ b/unfinished/compiler/tree/builder/builder.factor @@ -22,6 +22,11 @@ IN: compiler.tree.builder ] with-tree-builder nip unclip-last in-d>> ; +: build-sub-tree ( #call quot -- nodes ) + [ [ out-d>> ] [ in-d>> ] bi ] dip + build-tree-with + rot #copy suffix ; + : (make-specializer) ( class picker -- quot ) swap "predicate" word-prop append ; diff --git a/unfinished/compiler/tree/elaboration/elaboration.factor b/unfinished/compiler/tree/elaboration/elaboration.factor deleted file mode 100644 index b0f4306964..0000000000 --- a/unfinished/compiler/tree/elaboration/elaboration.factor +++ /dev/null @@ -1,5 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: compiler.tree.elaboration - -: elaborate ( nodes -- nodes' ) ; diff --git a/unfinished/compiler/tree/intrinsics/intrinsics.factor b/unfinished/compiler/tree/intrinsics/intrinsics.factor index a3328114bd..322e0dabe1 100644 --- a/unfinished/compiler/tree/intrinsics/intrinsics.factor +++ b/unfinished/compiler/tree/intrinsics/intrinsics.factor @@ -1,6 +1,26 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; +USING: kernel classes.tuple classes.tuple.private math arrays +byte-arrays words stack-checker.known-words ; IN: compiler.tree.intrinsics -: ( ... class -- tuple ) "Intrinsic" throw ; +: ( ... class -- tuple ) + "BUG: missing intrinsic" throw ; + +: (tuple) ( layout -- tuple ) + "BUG: missing (tuple) intrinsic" throw ; + +\ (tuple) { tuple-layout } { tuple } define-primitive +\ (tuple) make-flushable + +: (array) ( n -- array ) + "BUG: missing (array) intrinsic" throw ; + +\ (array) { integer } { array } define-primitive +\ (array) make-flushable + +: (byte-array) ( n -- byte-array ) + "BUG: missing (byte-array) intrinsic" throw ; + +\ (byte-array) { integer } { byte-array } define-primitive +\ (byte-array) make-flushable diff --git a/unfinished/compiler/tree/loop/detection/detection.factor b/unfinished/compiler/tree/loop/detection/detection.factor index 5c21e8c237..21d7e2a694 100644 --- a/unfinished/compiler/tree/loop/detection/detection.factor +++ b/unfinished/compiler/tree/loop/detection/detection.factor @@ -22,7 +22,7 @@ IN: compiler.tree.loop.detection SYMBOL: loop-heights SYMBOL: loop-calls -SYMBOL: label-stack +SYMBOL: loop-stack SYMBOL: work-list GENERIC: collect-loop-info* ( tail? node -- ) @@ -34,14 +34,14 @@ GENERIC: collect-loop-info* ( tail? node -- ) [ tail-calls ] keep [ collect-loop-info* ] 2each ; : remember-loop-info ( label -- ) - label-stack get length swap loop-heights get set-at ; + loop-stack get length swap loop-heights get set-at ; M: #recursive collect-loop-info* nip [ [ label>> - [ label-stack [ swap suffix ] change ] + [ loop-stack [ swap suffix ] change ] [ remember-loop-info ] [ t >>loop? drop ] tri @@ -50,7 +50,7 @@ M: #recursive collect-loop-info* ] with-scope ; : current-loop-nesting ( label -- labels ) - label-stack get swap loop-heights get at tail ; + loop-stack get swap loop-heights get at tail ; : disqualify-loop ( label -- ) work-list get push-front ; @@ -69,7 +69,7 @@ M: #dispatch collect-loop-info* M: node collect-loop-info* 2drop ; : collect-loop-info ( node -- ) - { } label-stack set + { } loop-stack set H{ } clone loop-calls set H{ } clone loop-heights set work-list set diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor index e44cf44db7..24df9b5af3 100644 --- a/unfinished/compiler/tree/optimizer/optimizer.factor +++ b/unfinished/compiler/tree/optimizer/optimizer.factor @@ -8,7 +8,7 @@ compiler.tree.tuple-unboxing compiler.tree.def-use compiler.tree.dead-code compiler.tree.strength-reduction -compiler.tree.loop-detection +compiler.tree.loop.detection compiler.tree.branch-fusion ; IN: compiler.tree.optimizer @@ -16,11 +16,11 @@ IN: compiler.tree.optimizer normalize propagate cleanup + detect-loops + invert-loops + fuse-branches escape-analysis unbox-tuples compute-def-use remove-dead-code - strength-reduce - detect-loops - fuse-branches - elaborate ; + strength-reduce ; diff --git a/unfinished/compiler/tree/propagation/inlining/inlining.factor b/unfinished/compiler/tree/propagation/inlining/inlining.factor index 22e056ce60..d333842657 100644 --- a/unfinished/compiler/tree/propagation/inlining/inlining.factor +++ b/unfinished/compiler/tree/propagation/inlining/inlining.factor @@ -18,10 +18,7 @@ M: word splicing-nodes [ [ in-d>> ] [ out-d>> ] bi ] dip #call 1array ; M: quotation splicing-nodes - [ [ out-d>> ] [ in-d>> ] bi ] dip - build-tree-with - rot #copy suffix - normalize ; + build-sub-tree normalize ; : propagate-body ( #call -- ) body>> (propagate) ; diff --git a/unfinished/stack-checker/known-words/known-words.factor b/unfinished/stack-checker/known-words/known-words.factor index 01991147f7..2e0c979f98 100755 --- a/unfinished/stack-checker/known-words/known-words.factor +++ b/unfinished/stack-checker/known-words/known-words.factor @@ -165,24 +165,27 @@ M: object infer-call* { call execute dispatch load-locals get-local drop-locals } [ t "no-compile" set-word-prop ] each +SYMBOL: +primitive+ + : non-inline-word ( word -- ) dup +called+ depends-on { { [ dup +shuffle+ word-prop ] [ infer-shuffle-word ] } { [ dup +special+ word-prop ] [ infer-special ] } - { [ dup primitive? ] [ infer-primitive ] } + { [ dup +primitive+ word-prop ] [ infer-primitive ] } { [ dup +cannot-infer+ word-prop ] [ cannot-infer-effect ] } - { [ dup +inferred-effect+ word-prop ] [ cached-infer ] } { [ dup +transform-quot+ word-prop ] [ apply-transform ] } + { [ dup +inferred-effect+ word-prop ] [ cached-infer ] } { [ dup "macro" word-prop ] [ apply-macro ] } { [ dup recursive-label ] [ call-recursive-word ] } [ dup infer-word apply-word/effect ] } cond ; : define-primitive ( word inputs outputs -- ) + [ 2drop t +primitive+ set-word-prop ] [ drop "input-classes" set-word-prop ] [ nip "default-output-classes" set-word-prop ] - 3bi ; + 3tri ; ! Stack effects for all primitives \ fixnum< { fixnum fixnum } { object } define-primitive diff --git a/unfinished/stack-checker/transforms/transforms.factor b/unfinished/stack-checker/transforms/transforms.factor index 5ec3f5ad64..d9e889f188 100755 --- a/unfinished/stack-checker/transforms/transforms.factor +++ b/unfinished/stack-checker/transforms/transforms.factor @@ -11,31 +11,45 @@ IN: stack-checker.transforms SYMBOL: +transform-quot+ SYMBOL: +transform-n+ -: (apply-transform) ( quot n -- newquot ) - dup zero? [ - drop recursive-state get 1array - ] [ - consume-d - [ #drop, ] - [ [ literal value>> ] map ] - [ first literal recursion>> ] tri prefix - ] if - swap with-datastack ; +: give-up-transform ( word -- ) + dup recursive-label + [ call-recursive-word ] + [ dup infer-word apply-word/effect ] + if ; + +: ((apply-transform)) ( word quot stack -- ) + swap with-datastack first2 + dup [ swap infer-quot drop ] [ 2drop give-up-transform ] if ; + inline + +: (apply-transform) ( word quot n -- ) + consume-d dup [ known literal? ] all? [ + dup empty? [ + drop recursive-state get 1array + ] [ + [ #drop, ] + [ [ literal value>> ] map ] + [ first literal recursion>> ] tri prefix + ] if + ((apply-transform)) + ] [ 2drop give-up-transform ] if ; : apply-transform ( word -- ) [ +inlined+ depends-on ] [ + [ ] [ +transform-quot+ word-prop ] [ +transform-n+ word-prop ] - bi (apply-transform) - first2 swap infer-quot + tri + (apply-transform) ] bi ; : apply-macro ( word -- ) [ +inlined+ depends-on ] [ + [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] - bi (apply-transform) - first2 swap infer-quot + tri + (apply-transform) ] bi ; : define-transform ( word quot n -- ) @@ -66,20 +80,80 @@ SYMBOL: +transform-n+ \ spread [ spread>quot ] 1 define-transform +\ (call-next-method) [ + [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi +] 2 define-transform + +! Constructors \ boa [ dup tuple-class? [ dup +inlined+ depends-on [ "boa-check" word-prop ] [ tuple-layout '[ , ] ] bi append - ] [ - \ boa \ no-method boa time-bomb - ] if + ] [ drop f ] if ] 1 define-transform -\ (call-next-method) [ - [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi -] 2 define-transform +\ new [ + dup tuple-class? [ + dup +inlined+ depends-on + dup all-slots rest-slice ! delegate slot + [ [ initial>> literalize , ] each literalize , \ boa , ] [ ] make + ] [ drop f ] if +] 1 define-transform + +! Membership testing +: bit-member-n 256 ; inline + +: bit-member? ( seq -- ? ) + #! Can we use a fast byte array test here? + { + { [ dup length 8 < ] [ f ] } + { [ dup [ integer? not ] contains? ] [ f ] } + { [ dup [ 0 < ] contains? ] [ f ] } + { [ dup [ bit-member-n >= ] contains? ] [ f ] } + [ t ] + } cond nip ; + +: bit-member-seq ( seq -- flags ) + bit-member-n swap [ member? 1 0 ? ] curry B{ } map-as ; + +: exact-float? ( f -- ? ) + dup float? [ dup >integer >float = ] [ drop f ] if ; inline + +: bit-member-quot ( seq -- newquot ) + [ + [ drop ] % ! drop the sequence itself; we don't use it at run time + bit-member-seq , + [ + { + { [ over fixnum? ] [ ?nth 1 eq? ] } + { [ over bignum? ] [ ?nth 1 eq? ] } + { [ over exact-float? ] [ ?nth 1 eq? ] } + [ 2drop f ] + } cond + ] % + ] [ ] make ; + +: member-quot ( seq -- newquot ) + dup bit-member? [ + bit-member-quot + ] [ + [ literalize [ t ] ] { } map>assoc + [ drop f ] suffix [ nip case ] curry + ] if ; + +\ member? [ + dup sequence? [ member-quot ] [ drop f ] if +] 1 define-transform + +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ nip cond ] curry ; + +\ memq? [ + dup sequence? [ memq-quot ] [ drop f ] if +] 1 define-transform ! Deprecated \ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform From a483a5afd5d0cea839f9090278fd963498cbeb44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Aug 2008 23:36:46 -0500 Subject: [PATCH 09/13] Fix effect>string --- core/effects/effects.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index c221ad073b..022490a907 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math namespaces sequences strings words assocs -combinators accessors arrays ; +USING: kernel math math.parser namespaces sequences strings +words assocs combinators accessors arrays ; IN: effects TUPLE: effect in out terminated? ; @@ -25,7 +25,7 @@ TUPLE: effect in out terminated? ; GENERIC: effect>string ( obj -- str ) M: string effect>string ; M: word effect>string name>> ; -M: integer effect>string drop "object" ; +M: integer effect>string number>string ; M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; : stack-picture ( seq -- string ) From b411d896a4124416a3c659961d466cdbf9d01974 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 10 Aug 2008 23:37:12 -0500 Subject: [PATCH 10/13] Port optimizer report --- .../tree/debugger/debugger-tests.factor | 6 + .../compiler/tree/debugger/debugger.factor | 141 ++++++++++++++++++ .../tree/loop/inversion/inversion.factor | 5 + .../tree/optimizer/optimizer-tests.factor | 4 + .../compiler/tree/optimizer/optimizer.factor | 1 + 5 files changed, 157 insertions(+) create mode 100644 unfinished/compiler/tree/debugger/debugger-tests.factor create mode 100644 unfinished/compiler/tree/debugger/debugger.factor create mode 100644 unfinished/compiler/tree/loop/inversion/inversion.factor create mode 100644 unfinished/compiler/tree/optimizer/optimizer-tests.factor diff --git a/unfinished/compiler/tree/debugger/debugger-tests.factor b/unfinished/compiler/tree/debugger/debugger-tests.factor new file mode 100644 index 0000000000..e6a4385c3e --- /dev/null +++ b/unfinished/compiler/tree/debugger/debugger-tests.factor @@ -0,0 +1,6 @@ +IN: compiler.tree.debugger.tests +USING: compiler.tree.debugger tools.test ; + +\ optimized-quot. must-infer +\ optimized-word. must-infer +\ optimizer-report. must-infer diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor new file mode 100644 index 0000000000..804d6ea240 --- /dev/null +++ b/unfinished/compiler/tree/debugger/debugger.factor @@ -0,0 +1,141 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs fry match accessors namespaces effects +sequences sequences.private quotations generic macros arrays +prettyprint prettyprint.backend prettyprint.sections math words +combinators io sorting +compiler.tree +compiler.tree.builder +compiler.tree.optimizer +compiler.tree.combinators +compiler.tree.propagation.info ; +IN: compiler.tree.debugger + +! A simple tool for turning tree IR into quotations and +! printing reports, for debugging purposes. + +GENERIC: node>quot ( node -- ) + +MACRO: match-choose ( alist -- ) + [ '[ , ] ] assoc-map '[ , match-cond ] ; + +MATCH-VARS: ?a ?b ?c ; + +: pretty-shuffle ( in out -- word/f ) + 2array { + { { { ?a } { ?a } } [ ] } + { { { ?a ?b } { ?a ?b } } [ ] } + { { { ?a ?b ?c } { ?a ?b ?c } } [ ] } + { { { ?a } { } } [ drop ] } + { { { ?a ?b } { } } [ 2drop ] } + { { { ?a ?b ?c } { } } [ 3drop ] } + { { { ?a } { ?a ?a } } [ dup ] } + { { { ?a ?b } { ?a ?b ?a ?b } } [ 2dup ] } + { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] } + { { { ?a ?b } { ?a ?b ?a } } [ over ] } + { { { ?b ?a } { ?a ?b } } [ swap ] } + { { { ?a ?b } { ?b ?a ?b } } [ tuck ] } + { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } + { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } + { { { ?a ?b ?c } { ?b ?c ?a } } [ rot ] } + { { { ?a ?b } { ?b } } [ nip ] } + { { { ?a ?b ?c } { ?c } } [ 2nip ] } + { _ f } + } match-choose ; + +TUPLE: shuffle effect ; + +M: shuffle pprint* effect>> effect>string text ; + +: shuffle-inputs/outputs ( node -- in out ) + [ in-d>> ] [ out-d>> ] [ mapping>> ] tri + [ at ] curry map ; + +M: #shuffle node>quot + shuffle-inputs/outputs 2dup pretty-shuffle dup + [ 2nip % ] [ drop shuffle boa , ] if ; + +: pushed-literals ( node -- seq ) + dup out-d>> [ node-value-info literal>> literalize ] with map ; + +M: #push node>quot pushed-literals % ; + +M: #call node>quot word>> , ; + +M: #call-recursive node>quot label>> id>> , ; + +DEFER: nodes>quot + +DEFER: label + +M: #recursive node>quot + [ label>> id>> literalize , ] + [ child>> nodes>quot , \ label , ] + bi ; + +M: #if node>quot + children>> [ nodes>quot ] map % \ if , ; + +M: #dispatch node>quot + children>> [ nodes>quot ] map , \ dispatch , ; + +M: #>r node>quot in-d>> length \ >r % ; + +M: #r> node>quot out-d>> length \ r> % ; + +M: node node>quot drop ; + +: nodes>quot ( node -- quot ) + [ [ node>quot ] each ] [ ] make ; + +: optimized-quot. ( quot -- ) + dup word? [ specialized-def ] when + build-tree optimize-tree nodes>quot . ; + +SYMBOL: words-called +SYMBOL: generics-called +SYMBOL: methods-called +SYMBOL: intrinsics-called +SYMBOL: node-count + +: make-report ( word/quot -- assoc ) + [ + dup word? [ build-tree-from-word nip ] [ build-tree ] if + optimize-tree + + H{ } clone words-called set + H{ } clone generics-called set + H{ } clone methods-called set + H{ } clone intrinsics-called set + + 0 swap [ + >r 1+ r> + dup #call? [ + word>> { + { [ dup "intrinsics" word-prop over "if-intrinsics" word-prop or ] [ intrinsics-called ] } + { [ dup generic? ] [ generics-called ] } + { [ dup method-body? ] [ methods-called ] } + [ words-called ] + } cond 1 -rot get at+ + ] [ drop ] if + ] each-node + node-count set + ] H{ } make-assoc ; + +: report. ( report -- ) + [ + "==== Total number of IR nodes:" print + node-count get . + + { + { generics-called "==== Generic word calls:" } + { words-called "==== Ordinary word calls:" } + { methods-called "==== Non-inlined method calls:" } + { intrinsics-called "==== Open-coded intrinsic calls:" } + } [ + nl print get keys natural-sort stack. + ] assoc-each + ] bind ; + +: optimizer-report. ( word -- ) + make-report report. ; diff --git a/unfinished/compiler/tree/loop/inversion/inversion.factor b/unfinished/compiler/tree/loop/inversion/inversion.factor new file mode 100644 index 0000000000..719fc4ad70 --- /dev/null +++ b/unfinished/compiler/tree/loop/inversion/inversion.factor @@ -0,0 +1,5 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: compiler.tree.loop.inversion + +: invert-loops ( nodes -- nodes' ) ; diff --git a/unfinished/compiler/tree/optimizer/optimizer-tests.factor b/unfinished/compiler/tree/optimizer/optimizer-tests.factor new file mode 100644 index 0000000000..1075e441e7 --- /dev/null +++ b/unfinished/compiler/tree/optimizer/optimizer-tests.factor @@ -0,0 +1,4 @@ +USING: compiler.tree.optimizer tools.test ; +IN: compiler.tree.optimizer.tests + +\ optimize-tree must-infer diff --git a/unfinished/compiler/tree/optimizer/optimizer.factor b/unfinished/compiler/tree/optimizer/optimizer.factor index 24df9b5af3..2d2a376bc0 100644 --- a/unfinished/compiler/tree/optimizer/optimizer.factor +++ b/unfinished/compiler/tree/optimizer/optimizer.factor @@ -9,6 +9,7 @@ compiler.tree.def-use compiler.tree.dead-code compiler.tree.strength-reduction compiler.tree.loop.detection +compiler.tree.loop.inversion compiler.tree.branch-fusion ; IN: compiler.tree.optimizer From 1ef85fe1bc373996729f1287a041206566cbfcf4 Mon Sep 17 00:00:00 2001 From: William Schlieper Date: Mon, 11 Aug 2008 01:22:26 -0400 Subject: [PATCH 11/13] irc.ui: Various added features --- extra/irc/ui/commands/commands.factor | 11 +++- extra/irc/ui/ui.factor | 72 ++++++++++++++++----------- extra/ui/gadgets/tabs/tabs.factor | 5 +- 3 files changed, 56 insertions(+), 32 deletions(-) diff --git a/extra/irc/ui/commands/commands.factor b/extra/irc/ui/commands/commands.factor index 59f4526d23..ddae783f06 100755 --- a/extra/irc/ui/commands/commands.factor +++ b/extra/irc/ui/commands/commands.factor @@ -6,8 +6,15 @@ USING: accessors kernel irc.client irc.messages irc.ui namespaces ; IN: irc.ui.commands : say ( string -- ) - [ client get profile>> nickname>> print-irc ] - [ listener get write-message ] bi ; + irc-tab get + [ window>> client>> profile>> nickname>> print-irc ] + [ listener>> write-message ] 2bi ; + +: join ( string -- ) + irc-tab get window>> join-channel ; + +: query ( string -- ) + irc-tab get window>> query-nick ; : quote ( string -- ) drop ; ! THIS WILL CHANGE diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index a524168d54..4757e36660 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -19,9 +19,9 @@ SYMBOL: listener SYMBOL: client -TUPLE: ui-window client tabs ; +TUPLE: ui-window < tabbed client ; -TUPLE: irc-tab < frame listener client userlist ; +TUPLE: irc-tab < frame listener client window userlist ; : write-color ( str color -- ) foreground associate format ; @@ -161,44 +161,54 @@ M: object handle-inbox [ swap display ] 2keep ; -TUPLE: irc-editor < editor outstream listener client ; +TUPLE: irc-editor < editor outstream tab ; : ( tab pane -- tab editor ) - over irc-editor new-editor - swap listener>> >>listener swap >>outstream - over client>> >>client ; + irc-editor new-editor + swap >>outstream ; : editor-send ( irc-editor -- ) { [ outstream>> ] - [ listener>> ] - [ client>> ] + [ [ irc-tab? ] find-parent ] [ editor-string ] [ "" swap set-editor-string ] } cleave - '[ , listener set , client set , parse-message ] with-output-stream ; + '[ , irc-tab set , parse-message ] with-output-stream ; irc-editor "general" f { { T{ key-down f f "RET" } editor-send } { T{ key-down f f "ENTER" } editor-send } } define-command-map -: ( listener client -- irc-tab ) - irc-tab new-frame - swap client>> >>client swap >>listener +: new-irc-tab ( listener ui-window class -- irc-tab ) + new-frame + swap >>window + swap >>listener [ @center grid-add ] keep @bottom grid-add ; -: ( listener client -- irc-tab ) - - [ @right grid-add ] keep >>userlist ; - -: ( listener client -- irc-tab ) - ; - M: irc-tab graft* - [ listener>> ] [ client>> ] bi add-listener ; + [ listener>> ] [ window>> client>> ] bi add-listener ; M: irc-tab ungraft* - [ listener>> ] [ client>> ] bi remove-listener ; + [ listener>> ] [ window>> client>> ] bi remove-listener ; + +TUPLE: irc-channel-tab < irc-tab userlist ; + +: ( listener ui-window -- irc-tab ) + irc-tab new-irc-tab + [ @right grid-add ] keep >>userlist ; + +TUPLE: irc-server-tab < irc-tab ; + +: ( listener -- irc-tab ) + f irc-server-tab new-irc-tab ; + +M: irc-server-tab ungraft* + [ window>> client>> terminate-irc ] + [ listener>> ] [ window>> client>> ] tri remove-listener ; + +: ( listener ui-window -- irc-tab ) + irc-tab new-irc-tab ; M: irc-tab pref-dim* drop { 480 480 } ; @@ -206,19 +216,25 @@ M: irc-tab pref-dim* : join-channel ( name ui-window -- ) [ dup ] dip [ swap ] keep - tabs>> add-page ; + add-page ; + +: query-nick ( nick ui-window -- ) + [ dup ] dip + [ swap ] keep + add-page ; : irc-window ( ui-window -- ) - [ tabs>> ] + [ ] [ client>> profile>> server>> ] bi open-window ; : ui-connect ( profile -- ui-window ) - ui-window new over >>client swap - [ connect-irc ] - [ [ ] dip add-listener ] - [ listeners>> +server-listener+ swap at over - "Server" associate >>tabs ] tri ; + + { [ [ ] dip add-listener ] + [ listeners>> +server-listener+ swap at dup + "Server" associate ui-window new-tabbed [ swap (>>window) ] keep ] + [ >>client ] + [ connect-irc ] } cleave ; : server-open ( server port nick password channels -- ) [ ui-connect [ irc-window ] keep ] dip diff --git a/extra/ui/gadgets/tabs/tabs.factor b/extra/ui/gadgets/tabs/tabs.factor index 12031e5911..50e2df2e9e 100755 --- a/extra/ui/gadgets/tabs/tabs.factor +++ b/extra/ui/gadgets/tabs/tabs.factor @@ -48,8 +48,8 @@ DEFER: (del-page) : del-page ( name tabbed -- ) [ names>> index ] 2keep (del-page) ; -: ( assoc -- tabbed ) - tabbed new-frame +: new-tabbed ( assoc class -- tabbed ) + new-frame 0 >>model 1 >>fill >>toggler dup toggler>> @left grid-add @@ -59,3 +59,4 @@ DEFER: (del-page) bi dup redo-toggler ; +: ( assoc -- tabbed ) tabbed new-tabbed ; From 5e9a323ac1e6eadcef7c255b279c23d68120c1d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Aug 2008 02:49:37 -0500 Subject: [PATCH 12/13] Updating CFG builder --- .../compiler/cfg/builder/builder-tests.factor | 4 + .../compiler/cfg/builder/builder.factor | 176 ++++++++---------- .../debug.factor => debugger/debugger.factor} | 24 ++- .../compiler/tree/debugger/debugger.factor | 5 +- 4 files changed, 104 insertions(+), 105 deletions(-) create mode 100644 unfinished/compiler/cfg/builder/builder-tests.factor rename unfinished/compiler/machine/{debug/debug.factor => debugger/debugger.factor} (58%) diff --git a/unfinished/compiler/cfg/builder/builder-tests.factor b/unfinished/compiler/cfg/builder/builder-tests.factor new file mode 100644 index 0000000000..098919c868 --- /dev/null +++ b/unfinished/compiler/cfg/builder/builder-tests.factor @@ -0,0 +1,4 @@ +IN: compiler.cfg.builder.tests +USING: compiler.cfg.builder tools.test ; + +\ build-cfg must-infer diff --git a/unfinished/compiler/cfg/builder/builder.factor b/unfinished/compiler/cfg/builder/builder.factor index 2f68864e81..76a1b67dd2 100644 --- a/unfinished/compiler/cfg/builder/builder.factor +++ b/unfinished/compiler/cfg/builder/builder.factor @@ -1,29 +1,33 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel assocs sequences sequences.lib fry accessors -compiler.cfg compiler.vops compiler.vops.builder -namespaces math inference.dataflow optimizer.allot combinators -math.order ; +namespaces math combinators math.order +compiler.tree +compiler.tree.combinators +compiler.tree.propagation.info +compiler.cfg +compiler.vops +compiler.vops.builder ; IN: compiler.cfg.builder -! Convert dataflow IR to procedure CFG. +! Convert tree SSA IR to CFG SSA IR. + ! We construct the graph and set successors first, then we ! set predecessors in a separate pass. This simplifies the ! logic. SYMBOL: procedures -SYMBOL: values>vregs - SYMBOL: loop-nesting -GENERIC: convert* ( node -- ) +SYMBOL: values>vregs GENERIC: convert ( node -- ) +M: #introduce convert drop ; + : init-builder ( -- ) - H{ } clone values>vregs set - V{ } clone loop-nesting set ; + H{ } clone values>vregs set ; : end-basic-block ( -- ) basic-block get [ %b emit ] when ; @@ -40,15 +44,12 @@ GENERIC: convert ( node -- ) set-basic-block ; : convert-nodes ( node -- ) - dup basic-block get and [ - [ convert ] [ successor>> convert-nodes ] bi - ] [ drop ] if ; + [ convert ] each ; : (build-cfg) ( node word -- ) init-builder begin-basic-block basic-block get swap procedures get set-at - %prolog emit convert-nodes ; : build-cfg ( node word -- procedures ) @@ -73,10 +74,9 @@ GENERIC: convert ( node -- ) 2bi ] if ; -: load-inputs ( node -- ) - [ in-d>> %data (load-inputs) ] - [ in-r>> %retain (load-inputs) ] - bi ; +: load-in-d ( node -- ) in-d>> %data (load-inputs) ; + +: load-in-r ( node -- ) in-r>> %retain (load-inputs) ; : (store-outputs) ( seq stack -- ) over empty? [ 2drop ] [ @@ -86,40 +86,21 @@ GENERIC: convert ( node -- ) 2bi ] if ; -: store-outputs ( node -- ) - [ out-d>> %data (store-outputs) ] - [ out-r>> %retain (store-outputs) ] - bi ; +: store-out-d ( node -- ) out-d>> %data (store-outputs) ; -M: #push convert* - out-d>> [ - [ produce-vreg ] [ value-literal ] bi - emit-literal - ] each ; - -M: #shuffle convert* drop ; - -M: #>r convert* drop ; - -M: #r> convert* drop ; - -M: node convert - [ load-inputs ] - [ convert* ] - [ store-outputs ] - tri ; +: store-out-r ( node -- ) out-r>> %retain (store-outputs) ; : (emit-call) ( word -- ) begin-basic-block %call emit begin-basic-block ; : intrinsic-inputs ( node -- ) - [ load-inputs ] + [ load-in-d ] [ in-d>> { #1 #2 #3 #4 } [ [ value>vreg ] dip set ] 2each ] bi ; : intrinsic-outputs ( node -- ) [ out-d>> { ^1 ^2 ^3 ^4 } [ get output-vreg ] 2each ] - [ store-outputs ] + [ store-out-d ] bi ; : intrinsic ( node quot -- ) @@ -132,19 +113,17 @@ M: node convert tri ] with-scope ; inline -USING: kernel.private math.private slots.private -optimizer.allot ; +USING: kernel.private math.private slots.private ; : maybe-emit-fixnum-shift-fast ( node -- node ) - dup dup in-d>> second node-literal? [ - dup dup in-d>> second node-literal + dup dup in-d>> second node-value-info literal>> dup fixnum? [ '[ , emit-fixnum-shift-fast ] intrinsic ] [ - dup param>> (emit-call) + drop dup word>> (emit-call) ] if ; : emit-call ( node -- ) - dup param>> { + dup word>> { { \ tag [ [ emit-tag ] intrinsic ] } { \ slot [ [ dup emit-slot ] intrinsic ] } @@ -175,24 +154,43 @@ optimizer.allot ; { \ float> [ [ emit-float> ] intrinsic ] } { \ float? [ [ emit-float= ] intrinsic ] } - { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] } - { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] } - { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] } + ! { \ (tuple) [ dup first-input '[ , emit-(tuple) ] intrinsic ] } + ! { \ (array) [ dup first-input '[ , emit-(array) ] intrinsic ] } + ! { \ (byte-array) [ dup first-input '[ , emit-(byte-array) ] intrinsic ] } [ (emit-call) ] } case drop ; M: #call convert emit-call ; -M: #call-label convert - dup param>> loop-nesting get at [ - basic-block get successors>> push - end-basic-block - basic-block off - drop - ] [ - (emit-call) - ] if* ; +: emit-call-loop ( #recursive -- ) + dup label>> loop-nesting get at basic-block get successors>> push + end-basic-block + basic-block off + drop ; + +: emit-call-recursive ( #recursive -- ) + label>> id>> (emit-call) ; + +M: #call-recursive convert + dup label>> loop?>> + [ emit-call-loop ] [ emit-call-recursive ] if ; + +M: #push convert + [ + [ out-d>> first produce-vreg ] + [ node-output-infos first literal>> ] + bi emit-literal + ] + [ store-out-d ] bi ; + +M: #shuffle convert [ load-in-d ] [ store-out-d ] bi ; + +M: #>r convert [ load-in-d ] [ store-out-r ] bi ; + +M: #r> convert [ load-in-r ] [ store-out-d ] bi ; + +M: #terminate convert drop ; : integer-conditional ( in1 in2 cc -- ) [ [ next-vreg dup ] 2dip %icmp emit ] dip %bi emit ; inline @@ -221,50 +219,38 @@ M: #call-label convert [ set-basic-block ] bi ; -: phi-inputs ( #if -- vregs-seq ) - children>> - [ last-node ] map - [ #values? ] filter - [ in-d>> [ value>vreg ] map ] map ; - -: phi-outputs ( #if -- vregs ) - successor>> out-d>> [ produce-vreg ] map ; - -: emit-phi ( #if -- ) - [ phi-outputs ] [ phi-inputs ] bi %phi emit ; - M: #if convert - { - [ load-inputs ] - [ emit-if ] - [ convert-if-children ] - [ emit-phi ] - } cleave ; + [ load-in-d ] [ emit-if ] [ convert-if-children ] tri ; -M: #values convert drop ; +M: #dispatch convert + "Unimplemented" throw ; -M: #merge convert drop ; - -M: #entry convert drop ; +M: #phi convert drop ; M: #declare convert drop ; -M: #terminate convert drop ; +M: #return convert drop %return emit ; -M: #label convert - #! Labels create a new procedure. - [ [ param>> ] [ node-child ] bi (build-cfg) ] [ (emit-call) ] bi ; +: convert-recursive ( #recursive -- ) + [ [ label>> id>> ] [ child>> ] bi (build-cfg) ] + [ (emit-call) ] + bi ; -M: #loop convert - #! Loops become part of the current CFG. - begin-basic-block - [ param>> basic-block get 2array loop-nesting get push ] - [ node-child convert-nodes ] - bi +: begin-loop ( #recursive -- ) + label>> basic-block get 2array loop-nesting get push ; + +: end-loop ( -- ) loop-nesting get pop* ; -M: #return convert - param>> loop-nesting get key? [ - %epilog emit - %return emit - ] unless ; +: convert-loop ( #recursive -- ) + begin-basic-block + [ begin-loop ] + [ child>> convert-nodes ] + [ drop end-loop ] + tri ; + +M: #recursive convert + dup label>> loop?>> + [ convert-loop ] [ convert-recursive ] if ; + +M: #copy convert drop ; diff --git a/unfinished/compiler/machine/debug/debug.factor b/unfinished/compiler/machine/debugger/debugger.factor similarity index 58% rename from unfinished/compiler/machine/debug/debug.factor rename to unfinished/compiler/machine/debugger/debugger.factor index f83dadadec..adc84d771f 100644 --- a/unfinished/compiler/machine/debug/debug.factor +++ b/unfinished/compiler/machine/debugger/debugger.factor @@ -1,12 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces sequences assocs io -prettyprint inference generator optimizer compiler.vops -compiler.cfg.builder compiler.cfg.simplifier -compiler.machine.builder compiler.machine.simplifier ; -IN: compiler.machine.debug +prettyprint inference generator optimizer +compiler.vops +compiler.tree.builder +compiler.tree.optimizer +compiler.cfg.builder +compiler.cfg.simplifier +compiler.machine.builder +compiler.machine.simplifier ; +IN: compiler.machine.debugger -: dataflow>linear ( dataflow word -- linear ) +: tree>linear ( tree word -- linear ) [ init-counter build-cfg @@ -20,15 +25,16 @@ IN: compiler.machine.debug ] assoc-each ; : linearized-quot. ( quot -- ) - dataflow optimize - "Anonymous quotation" dataflow>linear + build-tree optimize-tree + "Anonymous quotation" tree>linear linear. ; : linearized-word. ( word -- ) - dup word-dataflow nip optimize swap dataflow>linear linear. ; + dup build-tree-from-word nip optimize-tree + dup word-dataflow nip optimize swap tree>linear linear. ; : >basic-block ( quot -- basic-block ) - dataflow optimize + build-tree optimize-tree [ init-counter "Anonymous quotation" build-cfg diff --git a/unfinished/compiler/tree/debugger/debugger.factor b/unfinished/compiler/tree/debugger/debugger.factor index 804d6ea240..5e8b8888ee 100644 --- a/unfinished/compiler/tree/debugger/debugger.factor +++ b/unfinished/compiler/tree/debugger/debugger.factor @@ -23,6 +23,7 @@ MATCH-VARS: ?a ?b ?c ; : pretty-shuffle ( in out -- word/f ) 2array { + { { { } { } } [ ] } { { { ?a } { ?a } } [ ] } { { { ?a ?b } { ?a ?b } } [ ] } { { { ?a ?b ?c } { ?a ?b ?c } } [ ] } @@ -34,6 +35,8 @@ MATCH-VARS: ?a ?b ?c ; { { { ?a ?b ?c } { ?a ?b ?c ?a ?b ?c } } [ 3dup ] } { { { ?a ?b } { ?a ?b ?a } } [ over ] } { { { ?b ?a } { ?a ?b } } [ swap ] } + { { { ?b ?a ?c } { ?a ?b ?c } } [ swapd ] } + { { { ?a ?b } { ?a ?a ?b } } [ dupd ] } { { { ?a ?b } { ?b ?a ?b } } [ tuck ] } { { { ?a ?b ?c } { ?a ?b ?c ?a } } [ pick ] } { { { ?a ?b ?c } { ?c ?a ?b } } [ -rot ] } @@ -88,7 +91,7 @@ M: node node>quot drop ; : nodes>quot ( node -- quot ) [ [ node>quot ] each ] [ ] make ; -: optimized-quot. ( quot -- ) +: optimized. ( quot/word -- ) dup word? [ specialized-def ] when build-tree optimize-tree nodes>quot . ; From ed848621a3adc38e77b98ccee43c264a24cb80b8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Aug 2008 02:49:43 -0500 Subject: [PATCH 13/13] Fix --- core/effects/effects.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 022490a907..2e0aa4c279 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -29,6 +29,7 @@ M: integer effect>string number>string ; M: pair effect>string first2 [ effect>string ] bi@ ": " swap 3append ; : stack-picture ( seq -- string ) + dup integer? [ "object" ] when [ [ effect>string % CHAR: \s , ] each ] "" make ; M: effect effect>string ( effect -- string )