diff --git a/extra/cfdg/models/spirales/spirales.factor b/extra/cfdg/models/spirales/spirales.factor new file mode 100644 index 0000000000..60e4384fe0 --- /dev/null +++ b/extra/cfdg/models/spirales/spirales.factor @@ -0,0 +1,41 @@ + +USING: namespaces sequences math random-weighted cfdg ; + +IN: cfdg.models.spirales + +DEFER: line + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: block ( -- ) + [ + [ circle ] do + [ 0.3 s 60 flip line ] do + ] + recursive ; + +: a1 ( -- ) + [ + [ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do + [ block ] do + ] + recursive ; + +: line ( -- ) + -0.3 a + [ 0 rotate a1 ] do + [ 120 rotate a1 ] do + [ 240 rotate a1 ] do ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: run ( -- ) + [ -1 b ] >background + { -20 40 -20 40 } viewport set + [ line ] >start-shape + 0.03 >threshold + cfdg-window ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: run \ No newline at end of file diff --git a/extra/cfdg/models/spirales/tags.txt b/extra/cfdg/models/spirales/tags.txt new file mode 100644 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/cfdg/models/spirales/tags.txt @@ -0,0 +1 @@ +demos diff --git a/extra/html/streams/streams-tests.factor b/extra/html/streams/streams-tests.factor index 14f1621346..948c998e13 100644 --- a/extra/html/streams/streams-tests.factor +++ b/extra/html/streams/streams-tests.factor @@ -1,6 +1,8 @@ + USING: html.streams html.streams.private -io io.streams.string io.styles kernel -namespaces tools.test xml.writer sbufs sequences inspector ; + io io.streams.string io.styles kernel + namespaces tools.test xml.writer sbufs sequences inspector colors ; + IN: html.streams.tests : make-html-string @@ -52,7 +54,7 @@ M: funky browser-link-href [ [ "car" - H{ { foreground { 1 0 1 1 } } } + H{ { foreground T{ rgba f 1 0 1 1 } } } format ] make-html-string ] unit-test @@ -60,7 +62,7 @@ M: funky browser-link-href [ "
cdr
" ] [ [ - H{ { page-color { 1 0 1 1 } } } + H{ { page-color T{ rgba f 1 0 1 1 } } } [ "cdr" write ] with-nesting ] make-html-string ] unit-test diff --git a/extra/html/streams/streams.factor b/extra/html/streams/streams.factor index eae13f53ad..76719b6ffa 100755 --- a/extra/html/streams/streams.factor +++ b/extra/html/streams/streams.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic assocs help http io io.styles io.files continuations -io.streams.string kernel math math.order math.parser namespaces -quotations assocs sequences strings words html.elements -xml.entities sbufs continuations destructors accessors ; + +USING: combinators generic assocs help http io io.styles io.files + continuations io.streams.string kernel math math.order math.parser + namespaces quotations assocs sequences strings words html.elements + xml.entities sbufs continuations destructors accessors arrays ; + IN: html.streams GENERIC: browser-link-href ( presented -- href ) @@ -47,9 +49,9 @@ TUPLE: html-sub-stream < html-stream style parent ; ] [ call ] if* ] [ call ] if* ; inline -: hex-color, ( triplet -- ) - 3 head-slice - [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; +: hex-color, ( color -- ) + { [ red>> ] [ green>> ] [ blue>> ] } cleave 3array + [ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ; : fg-css, ( color -- ) "color: #" % hex-color, "; " % ; diff --git a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor index bf5b47c9b1..a96fe8eb22 100644 --- a/unfinished/compiler/tree/copy-equiv/copy-equiv.factor +++ b/unfinished/compiler/tree/copy-equiv/copy-equiv.factor @@ -8,7 +8,8 @@ compiler.tree.combinators ; IN: compiler.tree.copy-equiv ! Two values are copy-equivalent if they are always identical -! at run-time ("DS" relation). +! at run-time ("DS" relation). This is just a weak form of +! value numbering. ! Mapping from values to their canonical leader SYMBOL: copies @@ -25,7 +26,8 @@ SYMBOL: copies ] if ] ; -: resolve-copy ( copy -- val ) copies get compress-path ; +: resolve-copy ( copy -- val ) + copies get compress-path [ "Unknown value" throw ] unless* ; : is-copy-of ( val copy -- ) copies get set-at ; @@ -55,7 +57,7 @@ M: #return-recursive compute-copy-equiv* #! An output is a copy of every input if all inputs are #! copies of the same original value. [ - swap [ resolve-copy ] map sift + swap sift [ resolve-copy ] map dup [ all-equal? ] [ empty? not ] bi and [ first swap is-copy-of ] [ 2drop ] if ] 2each ; diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor index 4bd23aa8a7..b4f4a2a5dd 100644 --- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor +++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor @@ -1,26 +1,41 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs namespaces sequences kernel math combinators sets -disjoint-sets fry stack-checker.state compiler.tree.copy-equiv ; +USING: accessors assocs namespaces sequences kernel math +combinators sets disjoint-sets fry stack-checker.state +compiler.tree.copy-equiv ; IN: compiler.tree.escape-analysis.allocations ! A map from values to one of the following: ! - f -- initial status, assigned to values we have not seen yet; ! may potentially become an allocation later ! - a sequence of values -- potentially unboxed tuple allocations -! - t -- not allocated locally, can never be unboxed +! - t -- not allocated in this procedure, can never be unboxed SYMBOL: allocations -: (allocation) resolve-copy allocations get ; inline +TUPLE: slot-access slot# value ; -: allocation ( value -- allocation ) (allocation) at ; +C: slot-access + +: (allocation) ( value -- value' allocations ) + resolve-copy allocations get ; inline + +: allocation ( value -- allocation ) + (allocation) at dup slot-access? [ + [ slot#>> ] [ value>> allocation ] bi nth + allocation + ] when ; : record-allocation ( allocation value -- ) (allocation) set-at ; +: unknown-allocation ( value -- ) t swap record-allocation ; + : record-allocations ( allocations values -- ) [ record-allocation ] 2each ; +: unknown-allocations ( values -- ) + [ unknown-allocation ] each ; + ! We track escaping values with a disjoint set. SYMBOL: escaping-values @@ -40,21 +55,16 @@ SYMBOL: +escaping+ [ ] tri ; -: same-value ( in-value out-value -- ) - over [ - [ is-copy-of ] [ escaping-values get equate ] 2bi - ] [ 2drop ] if ; - : record-slot-access ( out slot# in -- ) - over zero? [ 3drop ] [ allocation ?nth swap same-value ] if ; + over zero? [ 3drop ] [ + swap record-allocation + ] if ; : merge-values ( in-values out-value -- ) escaping-values get '[ , , equate ] each ; : merge-slots ( values -- value ) - dup [ ] contains? [ - [ merge-values ] keep - ] [ drop f ] if ; + [ merge-values ] keep ; : add-escaping-values ( values -- ) escaping-values get diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor index 36d4b1f6a2..391649fcb2 100644 --- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor +++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor @@ -13,16 +13,19 @@ M: #branch escape-analysis* : (merge-allocations) ( values -- allocation ) [ - dup [ allocation ] map dup [ ] all? [ - dup [ length ] map all-equal? [ - nip flip - [ (merge-allocations) ] [ [ merge-slots ] map ] bi - [ record-allocations ] keep - ] [ drop add-escaping-values f ] if - ] [ drop add-escaping-values f ] if + dup [ allocation ] map sift dup empty? [ 2drop f ] [ + dup [ t eq? not ] all? [ + dup [ length ] map all-equal? [ + nip flip + [ (merge-allocations) ] [ [ merge-slots ] map ] bi + [ record-allocations ] keep + ] [ drop add-escaping-values t ] if + ] [ drop add-escaping-values t ] if + ] if ] map ; : merge-allocations ( in-values out-values -- ) + [ [ sift ] 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 6f99868c23..256152a556 100644 --- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -30,6 +30,7 @@ M: node count-unboxed-allocations* drop ; compute-copy-equiv propagate cleanup + compute-copy-equiv escape-analysis 0 swap [ count-unboxed-allocations* ] each-node ; @@ -157,3 +158,32 @@ TUPLE: cons { car read-only } { cdr read-only } ; [ car>> ] [ cdr>> ] bi ] count-unboxed-allocations ] unit-test + +[ 1 ] [ + [ [ 3 cons boa ] [ "A" throw ] if car>> ] + count-unboxed-allocations +] unit-test + +[ 0 ] [ + [ 10 [ drop ] each-integer ] count-unboxed-allocations +] unit-test + +[ 2 ] [ + [ + 1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>> + ] count-unboxed-allocations +] unit-test + +[ 0 ] [ + [ + 1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>> + ] count-unboxed-allocations +] unit-test + +: infinite-cons-loop ( a -- b ) 2 cons boa infinite-cons-loop ; inline recursive + +[ 0 ] [ + [ + 1 2 cons boa infinite-cons-loop + ] count-unboxed-allocations +] unit-test diff --git a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor index f0f49ee083..5bc386690d 100644 --- a/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor +++ b/unfinished/compiler/tree/escape-analysis/recursive/recursive.factor @@ -10,12 +10,16 @@ compiler.tree.escape-analysis.allocations ; IN: compiler.tree.escape-analysis.recursive : congruent? ( alloc1 alloc2 -- ? ) - 2dup [ length ] bi@ = [ - [ [ allocation ] bi@ congruent? ] 2all? - ] [ 2drop f ] if ; + { + { [ 2dup [ f eq? ] either? ] [ eq? ] } + { [ 2dup [ t eq? ] either? ] [ eq? ] } + { [ 2dup [ length ] bi@ = not ] [ 2drop f ] } + [ [ [ allocation ] bi@ congruent? ] 2all? ] + } cond ; : check-fixed-point ( node alloc1 alloc2 -- node ) - congruent? [ dup label>> f >>fixed-point drop ] unless ; inline + [ congruent? ] 2all? + [ dup label>> f >>fixed-point drop ] unless ; inline : node-input-allocations ( node -- allocations ) in-d>> [ allocation ] map ; @@ -27,13 +31,18 @@ IN: compiler.tree.escape-analysis.recursive [ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ; : analyze-recursive-phi ( #enter-recursive -- ) - [ ] [ recursive-stacks flip (merge-allocations) ] [ out-d>> ] tri - [ [ allocation ] map check-fixed-point drop ] 2keep - record-allocations ; + [ ] [ recursive-stacks flip ] [ out-d>> ] tri + [ [ merge-values ] 2each ] + [ + [ (merge-allocations) ] dip + [ [ allocation ] map check-fixed-point drop ] + [ record-allocations ] + 2bi + ] 2bi ; M: #recursive escape-analysis* ( #recursive -- ) [ - copies [ clone ] change + ! copies [ clone ] change child>> [ first analyze-recursive-phi ] diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor index 8828b4c410..51d3b6913a 100644 --- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor +++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor @@ -10,12 +10,21 @@ compiler.tree.escape-analysis.nodes compiler.tree.escape-analysis.allocations ; IN: compiler.tree.escape-analysis.simple +M: #introduce escape-analysis* + value>> unknown-allocation ; + +: record-literal-allocation ( value object -- ) + dup class immutable-tuple-class? [ + tuple-slots rest-slice + [ [ swap record-literal-allocation ] keep ] map + swap record-allocation + ] [ + drop unknown-allocation + ] if ; + M: #push escape-analysis* #! Delegation. - dup literal>> dup class immutable-tuple-class? [ - tuple-slots length 1- [ ] replicate - swap out-d>> first record-allocation - ] [ 2drop ] if ; + [ out-d>> first ] [ literal>> ] bi record-literal-allocation ; : record-tuple-allocation ( #call -- ) #! Delegation. @@ -23,19 +32,27 @@ M: #push escape-analysis* class>> immutable-tuple-class? [ [ in-d>> but-last ] [ out-d>> first ] bi record-allocation - ] [ drop ] if ; + ] [ out-d>> unknown-allocations ] if ; : record-slot-call ( #call -- ) [ out-d>> first ] [ dup in-d>> second node-value-info literal>> ] [ in-d>> first ] tri - over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ; + over fixnum? [ + [ 3 - ] dip record-slot-access + ] [ + 2drop unknown-allocation + ] if ; M: #call escape-analysis* dup word>> { { \ [ record-tuple-allocation ] } { \ slot [ record-slot-call ] } - [ drop in-d>> add-escaping-values ] + [ + drop + [ in-d>> add-escaping-values ] + [ out-d>> unknown-allocations ] bi + ] } case ; M: #return escape-analysis* diff --git a/unfinished/compiler/tree/propagation/branches/branches.factor b/unfinished/compiler/tree/propagation/branches/branches.factor index 535fddb93b..eb6ba3697f 100644 --- a/unfinished/compiler/tree/propagation/branches/branches.factor +++ b/unfinished/compiler/tree/propagation/branches/branches.factor @@ -59,7 +59,7 @@ SYMBOL: infer-children-data : compute-phi-input-infos ( phi-in -- phi-info ) infer-children-data get - '[ , [ [ value-info ] bind ] 2map ] map ; + '[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ; : annotate-phi-inputs ( #phi -- ) dup phi-in-d>> compute-phi-input-infos >>phi-info-d