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
[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
[
[
- 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> 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 ] [
+ <slot-access> swap record-allocation
+ ] if ;
: merge-values ( in-values out-value -- )
escaping-values get '[ , , equate ] each ;
: merge-slots ( values -- value )
- dup [ ] contains? [
- <slot-value> [ merge-values ] keep
- ] [ drop f ] if ;
+ <slot-value> [ 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
+ [ <slot-value> [ 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- [ <slot-value> ] 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>> {
{ \ <tuple-boa> [ 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