From 9a84cfe6568f41d03d70d4dbe3eff1f78c1787eb Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Fri, 1 Aug 2008 19:59:18 -0300
Subject: [PATCH 1/8] irc.client: Fix user quit notification
---
extra/irc/client/client-tests.factor | 17 ++++++++++++++++-
extra/irc/client/client.factor | 27 +++++++--------------------
2 files changed, 23 insertions(+), 21 deletions(-)
diff --git a/extra/irc/client/client-tests.factor b/extra/irc/client/client-tests.factor
index e021ff4ff4..1b338df442 100644
--- a/extra/irc/client/client-tests.factor
+++ b/extra/irc/client/client-tests.factor
@@ -160,7 +160,7 @@ IN: irc.client.tests
} cleave
] unit-test
-! Namelist notification
+! Namelist change notification
{ T{ participant-changed f f f } } [
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
@@ -172,4 +172,19 @@ IN: irc.client.tests
[ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
+ ] unit-test
+
+{ T{ participant-changed f "somedude" +part+ } } [
+ { ":somedude!n=user@isp.net QUIT" } make-client
+ { [ "factorbot" set-nick ]
+ [ listeners>>
+ [ "#factortest" [ <irc-channel-listener>
+ H{ { "somedude" +normal+ } } clone >>participants ] keep
+ ] dip set-at ]
+ [ connect-irc ]
+ [ drop 0.1 seconds sleep ]
+ [ listeners>> [ "#factortest" ] dip at
+ [ read-message drop ] [ read-message drop ] [ read-message ] tri ]
+ [ terminate-irc ]
+ } cleave
] unit-test
\ No newline at end of file
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index 813de0f57c..99922b1fb5 100644
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -88,10 +88,11 @@ SYMBOL: current-irc-client
: irc-stream> ( -- stream ) irc> stream>> ;
: irc-write ( s -- ) irc-stream> stream-write ;
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
+: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: listener> ( name -- listener/f ) irc> listeners>> at ;
: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
- [ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline
+ [ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
GENERIC: to-listener ( message obj -- )
@@ -147,24 +148,6 @@ DEFER: me?
"JOIN " irc-write
[ [ " :" ] dip 3append ] when* irc-print ;
-: /PART ( channel text -- )
- [ "PART " irc-write irc-write ] dip
- " :" irc-write irc-print ;
-
-: /KICK ( channel who -- )
- [ "KICK " irc-write irc-write ] dip
- " " irc-write irc-print ;
-
-: /PRIVMSG ( nick line -- )
- [ "PRIVMSG " irc-write irc-write ] dip
- " :" irc-write irc-print ;
-
-: /ACTION ( nick line -- )
- [ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
-
-: /QUIT ( text -- )
- "QUIT :" irc-write irc-print ;
-
: /PONG ( text -- )
"PONG " irc-write irc-print ;
@@ -240,10 +223,14 @@ M: kick handle-incoming-irc ( kick -- )
M: quit handle-incoming-irc ( quit -- )
[ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ]
- [ prefix>> parse-name remove-participant-from-all ]
[ handle-participant-change ]
+ [ prefix>> parse-name remove-participant-from-all ]
tri ;
+! FIXME: implement this
+! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
+! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
+
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;
From 710bc04b6ff9040887f0c5b7ec757da0e29d9cf5 Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Sat, 2 Aug 2008 15:54:02 -0400
Subject: [PATCH 2/8] irc.ui: Fixed color bugs
---
extra/irc/ui/ui.factor | 36 +++++++++++++++---------------------
1 file changed, 15 insertions(+), 21 deletions(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index 662fca6d79..d899b75d8d 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel threads combinators concurrency.mailboxes
- sequences strings hashtables splitting fry assocs hashtables
+ sequences strings hashtables splitting fry assocs hashtables colors
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
@@ -24,14 +24,8 @@ TUPLE: irc-tab < frame listener client userlist ;
: write-color ( str color -- )
foreground associate format ;
-: red { 0.5 0 0 1 } ;
-: green { 0 0.5 0 1 } ;
-: blue { 0 0 1 1 } ;
-: black { 0 0 0 1 } ;
-
-: colors H{ { +operator+ { 0 0.5 0 1 } }
- { +voice+ { 0 0 1 1 } }
- { +normal+ { 0 0 0 1 } } } ;
+: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
+: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;
: dot-or-parens ( string -- string )
dup empty? [ drop "." ]
@@ -65,21 +59,21 @@ M: own-message write-irc
message>> write ;
M: join write-irc
- "* " green write-color
+ "* " dark-green write-color
prefix>> parse-name write
- " has entered the channel." green write-color ;
+ " has entered the channel." dark-green write-color ;
M: part write-irc
- "* " red write-color
+ "* " dark-red write-color
[ prefix>> parse-name write ] keep
- " has left the channel" red write-color
- trailing>> dot-or-parens red write-color ;
+ " has left the channel" dark-red write-color
+ trailing>> dot-or-parens dark-red write-color ;
M: quit write-irc
- "* " red write-color
+ "* " dark-red write-color
[ prefix>> parse-name write ] keep
- " has left IRC" red write-color
- trailing>> dot-or-parens red write-color ;
+ " has left IRC" dark-red write-color
+ trailing>> dot-or-parens dark-red write-color ;
: full-mode ( message -- mode )
parameters>> rest " " sjoin ;
@@ -97,13 +91,13 @@ M: unhandled write-irc
line>> blue write-color ;
M: irc-end write-irc
- drop "* You have left IRC" red write-color ;
+ drop "* You have left IRC" dark-red write-color ;
M: irc-disconnected write-irc
- drop "* Disconnected" red write-color ;
+ drop "* Disconnected" dark-red write-color ;
M: irc-connected write-irc
- drop "* Connected" green write-color ;
+ drop "* Connected" dark-green write-color ;
M: irc-listener-end write-irc
drop ;
@@ -130,7 +124,7 @@ GENERIC: handle-inbox ( tab message -- )
: update-participants ( tab -- )
[ userlist>> [ clear-gadget ] keep ]
[ listener>> participants>> ] bi
- [ +operator+ green filter-participants ]
+ [ +operator+ dark-green filter-participants ]
[ +voice+ blue filter-participants ]
[ +normal+ black filter-participants ] tri drop ;
From d14efabed37ce9c9727924fbf8be34aa72db18db Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 2 Aug 2008 20:21:25 -0500
Subject: [PATCH 3/8] Working on escape analysis
---
.../allocations/allocations.factor | 26 +++-
.../escape-analysis/branches/branches.factor | 10 +-
.../escape-analysis-tests.factor | 130 ++++++++++++++++++
.../escape-analysis/escape-analysis.factor | 1 +
.../tree/escape-analysis/simple/simple.factor | 3 +
5 files changed, 164 insertions(+), 6 deletions(-)
create mode 100644 unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index 7600a3b5a2..59febb3801 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs namespaces sequences kernel math
+USING: assocs namespaces sequences kernel math combinators sets
stack-checker.state compiler.tree.copy-equiv ;
IN: compiler.tree.escape-analysis.allocations
@@ -13,7 +13,11 @@ SYMBOL: allocations
resolve-copy allocations get at ;
: record-allocation ( allocation value -- )
- allocations get set-at ;
+ {
+ { [ dup not ] [ 2drop ] }
+ { [ over not ] [ allocations get delete-at drop ] }
+ [ allocations get set-at ]
+ } cond ;
: record-allocations ( allocations values -- )
[ record-allocation ] 2each ;
@@ -25,4 +29,20 @@ SYMBOL: allocations
SYMBOL: slot-merging
: merge-slots ( values -- value )
- <value> [ introduce-value ] [ slot-merging get set-at ] [ ] tri ;
+ dup [ ] contains? [
+ <value>
+ [ introduce-value ]
+ [ slot-merging get set-at ]
+ [ ] tri
+ ] [ drop f ] if ;
+
+! If an allocation's slot appears in this set, the allocation
+! is disqualified from unboxing.
+SYMBOL: disqualified
+
+: disqualify ( slot-value -- )
+ [ disqualified get conjoin ]
+ [ slot-merging get at [ disqualify ] each ] bi ;
+
+: escaping-allocation? ( value -- ? )
+ allocation [ [ disqualified get key? ] contains? ] [ t ] if* ;
diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
index 23e53fd4fe..1bd6973369 100644
--- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor
+++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences
+USING: accessors kernel namespaces sequences sets
+stack-checker.branches
compiler.tree
compiler.tree.propagation.branches
compiler.tree.escape-analysis.nodes
@@ -12,6 +13,9 @@ SYMBOL: children-escape-data
M: #branch escape-analysis*
live-children sift [ (escape-analysis) ] each ;
+: disqualify-allocations ( allocations -- )
+ [ [ disqualify ] each ] each ;
+
: (merge-allocations) ( values -- allocation )
[
[ allocation ] map dup [ ] all? [
@@ -19,8 +23,8 @@ M: #branch escape-analysis*
flip
[ (merge-allocations) ] [ [ merge-slots ] map ] bi
[ record-allocations ] keep
- ] [ drop f ] if
- ] [ drop f ] if
+ ] [ disqualify-allocations f ] if
+ ] [ disqualify-allocations f ] if
] map ;
: merge-allocations ( in-values out-values -- )
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
new file mode 100644
index 0000000000..34ecc74813
--- /dev/null
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -0,0 +1,130 @@
+IN: compiler.tree.escape-analysis.tests
+USING: compiler.tree.escape-analysis
+compiler.tree.escape-analysis.allocations compiler.tree.builder
+compiler.tree.normalization compiler.tree.copy-equiv
+compiler.tree.propagation compiler.tree.cleanup
+compiler.tree.combinators compiler.tree sequences math
+kernel tools.test accessors slots.private quotations.private
+prettyprint ;
+
+\ escape-analysis must-infer
+
+: count-unboxed-allocations ( quot -- sizes )
+ build-tree
+ normalize
+ compute-copy-equiv
+ propagate
+ cleanup
+ escape-analysis
+ 0 swap [
+ dup #call?
+ [
+ out-d>> dup empty? [ drop ] [
+ first escaping-allocation? [ 1+ ] unless
+ ] if
+ ] [ drop ] if
+ ] each-node ;
+
+[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry drop ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry 3 slot ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry 3 slot drop ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry uncurry ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
+
+[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
+
+[ 0 ] [ [ [ [ + ] curry ] [ drop [ ] ] if ] count-unboxed-allocations ] unit-test
+
+[ 2 ] [
+ [ [ [ + ] curry ] [ [ * ] curry ] if uncurry ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [ [ [ + ] curry ] [ [ * ] curry ] if ] count-unboxed-allocations
+] unit-test
+
+[ 3 ] [
+ [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if uncurry ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+ [ [ [ + ] curry 4 ] [ dup [ [ * ] curry ] [ [ / ] curry ] if uncurry ] if ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if ] count-unboxed-allocations
+] unit-test
+
+TUPLE: cons { car read-only } { cdr read-only } ;
+
+[ 0 ] [
+ [
+ dup 0 = [
+ 2 cons boa
+ ] [
+ dup 1 = [
+ 3 cons boa
+ ] when
+ ] if car>>
+ ] count-unboxed-allocations
+] unit-test
+
+[ 3 ] [
+ [
+ dup 0 = [
+ 2 cons boa
+ ] [
+ dup 1 = [
+ 3 cons boa
+ ] [
+ 4 cons boa
+ ] if
+ ] if car>>
+ ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [
+ dup 0 = [
+ dup 1 = [
+ 3 cons boa
+ ] [
+ 4 cons boa
+ ] if
+ ] unless car>>
+ ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+ [
+ dup 0 = [
+ 2 cons boa
+ ] [
+ dup 1 = [
+ 3 cons boa
+ ] [
+ 4 cons boa
+ ] if car>>
+ ] if
+ ] count-unboxed-allocations
+] unit-test
+
+[ 0 ] [
+ [
+ dup 0 = [
+ 2 cons boa
+ ] [
+ dup 1 = [
+ 3 cons boa dup .
+ ] [
+ 4 cons boa
+ ] if
+ ] if drop
+ ] count-unboxed-allocations
+] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
index 490fff82ec..e8c02046f2 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@@ -14,5 +14,6 @@ IN: compiler.tree.escape-analysis
: escape-analysis ( node -- node )
H{ } clone slot-merging set
H{ } clone allocations set
+ H{ } clone disqualified set
<hashed-dlist> work-list set
dup (escape-analysis) ;
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index cc6ac57a5e..93d0b28be3 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -24,6 +24,9 @@ IN: compiler.tree.escape-analysis.simple
[ in-d>> first ] tri
over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ;
+: add-escaping-values ( values -- )
+ [ allocation [ disqualify ] each ] each ;
+
M: #call escape-analysis*
dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] }
From d41bc716bfb26d79a579dfc669baed7026c06c70 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 3 Aug 2008 05:01:05 -0500
Subject: [PATCH 4/8] More escape analysis work
---
.../dataflow-analysis.factor | 6 +--
.../allocations/allocations.factor | 30 ++++++++++-----
.../escape-analysis-tests.factor | 8 ++--
.../escape-analysis/escape-analysis.factor | 11 +++---
.../escape-analysis/graph/graph-tests.factor | 19 ++++++++++
.../tree/escape-analysis/graph/graph.factor | 38 +++++++++++++++++++
.../tree/escape-analysis/simple/simple.factor | 1 -
.../work-list/work-list.factor | 9 -----
8 files changed, 88 insertions(+), 34 deletions(-)
create mode 100644 unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor
create mode 100644 unfinished/compiler/tree/escape-analysis/graph/graph.factor
delete mode 100644 unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
diff --git a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
index b6772650b6..c7d558f4bf 100644
--- a/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
+++ b/unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
@@ -8,11 +8,9 @@ IN: compiler.tree.dataflow-analysis
! Dataflow analysis
SYMBOL: work-list
-: look-at-value ( values -- )
- work-list get push-front ;
+: look-at-value ( values -- ) work-list get push-front ;
-: look-at-values ( values -- )
- work-list get '[ , push-front ] each ;
+: look-at-values ( values -- ) work-list get push-all-front ;
: look-at-inputs ( node -- ) in-d>> look-at-values ;
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index 59febb3801..09c20a93dc 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel math combinators sets
-stack-checker.state compiler.tree.copy-equiv ;
+fry stack-checker.state compiler.tree.copy-equiv
+compiler.tree.escape-analysis.graph ;
IN: compiler.tree.escape-analysis.allocations
SYMBOL: escaping
@@ -25,24 +26,33 @@ SYMBOL: allocations
: record-slot-access ( out slot# in -- )
over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ;
-! A map from values to sequences of values
-SYMBOL: slot-merging
+! We track available values
+SYMBOL: slot-graph
: merge-slots ( values -- value )
dup [ ] contains? [
<value>
[ introduce-value ]
- [ slot-merging get set-at ]
+ [ slot-graph get add-edges ]
[ ] tri
] [ drop f ] if ;
-! If an allocation's slot appears in this set, the allocation
-! is disqualified from unboxing.
-SYMBOL: disqualified
+! A disqualified slot value is not available for unboxing. A
+! tuple may be unboxed if none of its slots have been
+! disqualified.
: disqualify ( slot-value -- )
- [ disqualified get conjoin ]
- [ slot-merging get at [ disqualify ] each ] bi ;
+ slot-graph get mark-vertex ;
+
+SYMBOL: escaping-allocations
+
+: compute-escaping-allocations ( -- )
+ #! Any allocations involving unavailable slots are
+ #! potentially escaping, and cannot be unboxed.
+ allocations get
+ slot-graph get marked-components
+ '[ [ , key? ] contains? nip ] assoc-filter
+ escaping-allocations set ;
: escaping-allocation? ( value -- ? )
- allocation [ [ disqualified get key? ] contains? ] [ t ] if* ;
+ escaping-allocations get key? ;
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 34ecc74813..83cdfd980b 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -5,7 +5,7 @@ compiler.tree.normalization compiler.tree.copy-equiv
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math
kernel tools.test accessors slots.private quotations.private
-prettyprint ;
+prettyprint classes.tuple.private ;
\ escape-analysis must-infer
@@ -19,9 +19,9 @@ prettyprint ;
0 swap [
dup #call?
[
- out-d>> dup empty? [ drop ] [
- first escaping-allocation? [ 1+ ] unless
- ] if
+ dup word>> \ <tuple-boa> = [
+ out-d>> first escaping-allocation? [ 1+ ] unless
+ ] [ drop ] if
] [ drop ] if
] each-node ;
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
index e8c02046f2..c41627005b 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@@ -3,17 +3,16 @@
USING: kernel namespaces search-dequeues
compiler.tree
compiler.tree.def-use
+compiler.tree.escape-analysis.graph
compiler.tree.escape-analysis.allocations
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.branches
compiler.tree.escape-analysis.nodes
-compiler.tree.escape-analysis.simple
-compiler.tree.escape-analysis.work-list ;
+compiler.tree.escape-analysis.simple ;
IN: compiler.tree.escape-analysis
: escape-analysis ( node -- node )
- H{ } clone slot-merging set
H{ } clone allocations set
- H{ } clone disqualified set
- <hashed-dlist> work-list set
- dup (escape-analysis) ;
+ <graph> slot-graph set
+ dup (escape-analysis)
+ compute-escaping-allocations ;
diff --git a/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor b/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor
new file mode 100644
index 0000000000..3a7dee58a9
--- /dev/null
+++ b/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor
@@ -0,0 +1,19 @@
+IN: compiler.tree.escape-analysis.graph.tests
+USING: compiler.tree.escape-analysis.graph tools.test namespaces
+accessors ;
+
+<graph> "graph" set
+
+[ ] [ { 2 3 4 } 1 "graph" get add-edges ] unit-test
+[ ] [ { 5 6 } 2 "graph" get add-edges ] unit-test
+[ ] [ { 7 8 } 9 "graph" get add-edges ] unit-test
+[ ] [ { 6 10 } 4 "graph" get add-edges ] unit-test
+
+[ ] [ 3 "graph" get mark-vertex ] unit-test
+
+[ H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 5 } { 6 6 } { 10 10 } } ]
+[ "graph" get marked>> ] unit-test
+
+[ ] [ { 1 11 } 12 "graph" get add-edges ] unit-test
+
+[ t ] [ 11 "graph" get marked-vertex? ] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/graph/graph.factor b/unfinished/compiler/tree/escape-analysis/graph/graph.factor
new file mode 100644
index 0000000000..59ba51d99e
--- /dev/null
+++ b/unfinished/compiler/tree/escape-analysis/graph/graph.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors assocs fry sequences sets
+dequeues search-dequeues namespaces ;
+IN: compiler.tree.escape-analysis.graph
+
+TUPLE: graph edges work-list ;
+
+: <graph> ( -- graph )
+ H{ } clone <hashed-dlist> graph boa ;
+
+: mark-vertex ( vertex graph -- ) work-list>> push-front ;
+
+: add-edge ( out in graph -- )
+ [ edges>> push-at ] [ swapd edges>> push-at ] 3bi ;
+
+: add-edges ( out-seq in graph -- )
+ '[ , , add-edge ] each ;
+
+<PRIVATE
+
+SYMBOL: marked
+
+: (mark-vertex) ( vertex graph -- )
+ over marked get key? [ 2drop ] [
+ [ drop marked get conjoin ]
+ [ [ edges>> at ] [ work-list>> ] bi push-all-front ]
+ 2bi
+ ] if ;
+
+PRIVATE>
+
+: marked-components ( graph -- vertices )
+ #! All vertices in connected components of marked vertices.
+ H{ } clone marked [
+ [ work-list>> ] keep
+ '[ , (mark-vertex) ] slurp-dequeue
+ ] with-variable ;
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index 93d0b28be3..8329a04a61 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -6,7 +6,6 @@ combinators dequeues search-dequeues namespaces fry
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes
-compiler.tree.escape-analysis.work-list
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.simple
diff --git a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor b/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
deleted file mode 100644
index 8378ee43ae..0000000000
--- a/unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
+++ /dev/null
@@ -1,9 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: dequeues namespaces sequences fry ;
-IN: compiler.tree.escape-analysis.work-list
-
-SYMBOL: work-list
-
-: add-escaping-values ( values -- )
- work-list get '[ , push-front ] each ;
From 64bed4e44e9f4eb495ed5196b4408bd4ca19714f Mon Sep 17 00:00:00 2001
From: William Schlieper <schlieper@unc.edu>
Date: Sun, 3 Aug 2008 13:21:32 -0400
Subject: [PATCH 5/8] irc.ui: Userlists are now sorted
---
extra/irc/ui/ui.factor | 22 ++++++++++++++++------
1 file changed, 16 insertions(+), 6 deletions(-)
diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor
index d899b75d8d..0c9fdee6e0 100755
--- a/extra/irc/ui/ui.factor
+++ b/extra/irc/ui/ui.factor
@@ -3,12 +3,13 @@
USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables colors
+ sorting qualified unicode.case math.order
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
io io.styles namespaces calendar calendar.format models continuations
irc.client irc.client.private irc.messages irc.messages.private
- irc.ui.commandparser irc.ui.load qualified ;
+ irc.ui.commandparser irc.ui.load ;
RENAME: join sequences => sjoin
@@ -86,6 +87,12 @@ M: mode write-irc
" to " blue write-color
channel>> write ;
+M: nick write-irc
+ "* " blue write-color
+ [ prefix>> parse-name write ] keep
+ " is now known as " blue write-color
+ trailing>> write ;
+
M: unhandled write-irc
"UNHANDLED: " write
line>> blue write-color ;
@@ -118,15 +125,18 @@ M: irc-message write-irc
GENERIC: handle-inbox ( tab message -- )
-: filter-participants ( pack alist val color -- pack )
- '[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;
+: value-labels ( assoc val -- seq )
+ '[ nip , = ] assoc-filter keys [ >lower <=> ] sort [ <label> ] map ;
+
+: add-gadget-color ( pack seq color -- pack )
+ '[ , >>color add-gadget ] each ;
: update-participants ( tab -- )
[ userlist>> [ clear-gadget ] keep ]
[ listener>> participants>> ] bi
- [ +operator+ dark-green filter-participants ]
- [ +voice+ blue filter-participants ]
- [ +normal+ black filter-participants ] tri drop ;
+ [ +operator+ value-labels dark-green add-gadget-color ]
+ [ +voice+ value-labels blue add-gadget-color ]
+ [ +normal+ value-labels black add-gadget-color ] tri drop ;
M: participant-changed handle-inbox
drop update-participants ;
From 0ed0167dd6b5df5f9816cf86a7b43353f5d2fbb1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 3 Aug 2008 21:32:12 -0500
Subject: [PATCH 6/8] More accurate escape analysis
---
.../allocations/allocations.factor | 62 ++++++++++++-------
.../escape-analysis/branches/branches.factor | 17 +++--
.../escape-analysis-tests.factor | 47 +++++++++++---
.../escape-analysis/escape-analysis.factor | 7 ++-
.../escape-analysis/graph/graph-tests.factor | 19 ------
.../tree/escape-analysis/graph/graph.factor | 38 ------------
.../tree/escape-analysis/simple/simple.factor | 15 +++--
7 files changed, 100 insertions(+), 105 deletions(-)
delete mode 100644 unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor
delete mode 100644 unfinished/compiler/tree/escape-analysis/graph/graph.factor
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index 09c20a93dc..19a5e5b12a 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -1,13 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel math combinators sets
-fry stack-checker.state compiler.tree.copy-equiv
-compiler.tree.escape-analysis.graph ;
+disjoint-sets fry stack-checker.state compiler.tree.copy-equiv ;
IN: compiler.tree.escape-analysis.allocations
-SYMBOL: escaping
-
-! A map from values to sequences of values or 'escaping'
+! A map from values to sequences of values
SYMBOL: allocations
: allocation ( value -- allocation )
@@ -23,35 +20,56 @@ SYMBOL: allocations
: record-allocations ( allocations values -- )
[ record-allocation ] 2each ;
-: record-slot-access ( out slot# in -- )
- over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ;
+! We track escaping values with a disjoint set.
+SYMBOL: escaping-values
-! We track available values
-SYMBOL: slot-graph
+SYMBOL: +escaping+
+
+: <escaping-values> ( -- disjoint-set )
+ <disjoint-set> +escaping+ over add-atom ;
+
+: init-escaping-values ( -- )
+ copies get <escaping-values>
+ [ '[ drop , add-atom ] assoc-each ]
+ [ '[ , equate ] assoc-each ]
+ [ nip escaping-values set ]
+ 2tri ;
+
+: <slot-value> ( -- value )
+ <value>
+ [ introduce-value ]
+ [ escaping-values get add-atom ]
+ [ ]
+ 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 ;
+
+: merge-values ( in-values out-value -- )
+ escaping-values get '[ , , equate ] each ;
: merge-slots ( values -- value )
dup [ ] contains? [
- <value>
- [ introduce-value ]
- [ slot-graph get add-edges ]
- [ ] tri
+ <slot-value> [ merge-values ] keep
] [ drop f ] if ;
-! A disqualified slot value is not available for unboxing. A
-! tuple may be unboxed if none of its slots have been
-! disqualified.
+: add-escaping-values ( values -- )
+ escaping-values get
+ '[ +escaping+ , equate ] each ;
-: disqualify ( slot-value -- )
- slot-graph get mark-vertex ;
+: escaping-value? ( value -- ? )
+ +escaping+ escaping-values get equiv? ;
SYMBOL: escaping-allocations
: compute-escaping-allocations ( -- )
- #! Any allocations involving unavailable slots are
- #! potentially escaping, and cannot be unboxed.
allocations get
- slot-graph get marked-components
- '[ [ , key? ] contains? nip ] assoc-filter
+ [ drop escaping-value? ] assoc-filter
escaping-allocations set ;
: escaping-allocation? ( value -- ? )
diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
index 1bd6973369..950e0341f9 100644
--- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor
+++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces sequences sets
+USING: accessors kernel namespaces sequences sets fry
stack-checker.branches
compiler.tree
compiler.tree.propagation.branches
@@ -13,22 +13,21 @@ SYMBOL: children-escape-data
M: #branch escape-analysis*
live-children sift [ (escape-analysis) ] each ;
-: disqualify-allocations ( allocations -- )
- [ [ disqualify ] each ] each ;
-
: (merge-allocations) ( values -- allocation )
[
- [ allocation ] map dup [ ] all? [
+ dup [ allocation ] map dup [ ] all? [
dup [ length ] map all-equal? [
- flip
+ nip flip
[ (merge-allocations) ] [ [ merge-slots ] map ] bi
[ record-allocations ] keep
- ] [ disqualify-allocations f ] if
- ] [ disqualify-allocations f ] if
+ ] [ drop add-escaping-values f ] if
+ ] [ drop add-escaping-values f ] if
] map ;
: merge-allocations ( in-values out-values -- )
- [ (merge-allocations) ] dip record-allocations ;
+ [ [ merge-values ] 2each ]
+ [ [ (merge-allocations) ] dip record-allocations ]
+ 2bi ;
M: #phi escape-analysis*
[ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ]
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 83cdfd980b..6f99868c23 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -5,10 +5,25 @@ compiler.tree.normalization compiler.tree.copy-equiv
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math
kernel tools.test accessors slots.private quotations.private
-prettyprint classes.tuple.private ;
+prettyprint classes.tuple.private classes classes.tuple ;
\ escape-analysis must-infer
+GENERIC: count-unboxed-allocations* ( m node -- n )
+
+: (count-unboxed-allocations) ( m node -- n )
+ out-d>> first escaping-allocation? [ 1+ ] unless ;
+
+M: #call count-unboxed-allocations*
+ dup word>> \ <tuple-boa> =
+ [ (count-unboxed-allocations) ] [ drop ] if ;
+
+M: #push count-unboxed-allocations*
+ dup literal>> class immutable-tuple-class?
+ [ (count-unboxed-allocations) ] [ drop ] if ;
+
+M: node count-unboxed-allocations* drop ;
+
: count-unboxed-allocations ( quot -- sizes )
build-tree
normalize
@@ -16,14 +31,7 @@ prettyprint classes.tuple.private ;
propagate
cleanup
escape-analysis
- 0 swap [
- dup #call?
- [
- dup word>> \ <tuple-boa> = [
- out-d>> first escaping-allocation? [ 1+ ] unless
- ] [ drop ] if
- ] [ drop ] if
- ] each-node ;
+ 0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
@@ -128,3 +136,24 @@ TUPLE: cons { car read-only } { cdr read-only } ;
] if drop
] count-unboxed-allocations
] unit-test
+
+[ 2 ] [
+ [
+ [ dup cons boa ] [ drop 1 2 cons boa ] if car>>
+ ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+ [
+ 3dup
+ [ cons boa ] [ cons boa 3 cons boa ] if
+ [ car>> ] [ cdr>> ] bi
+ ] count-unboxed-allocations
+] unit-test
+
+[ 2 ] [
+ [
+ 3dup [ cons boa ] [ cons boa . 1 2 cons boa ] if
+ [ car>> ] [ cdr>> ] bi
+ ] count-unboxed-allocations
+] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
index c41627005b..0ba44a1dc5 100644
--- a/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
+++ b/unfinished/compiler/tree/escape-analysis/escape-analysis.factor
@@ -1,9 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces search-dequeues
+USING: kernel namespaces search-dequeues assocs fry sequences
+disjoint-sets
compiler.tree
compiler.tree.def-use
-compiler.tree.escape-analysis.graph
+compiler.tree.copy-equiv
compiler.tree.escape-analysis.allocations
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.branches
@@ -12,7 +13,7 @@ compiler.tree.escape-analysis.simple ;
IN: compiler.tree.escape-analysis
: escape-analysis ( node -- node )
+ init-escaping-values
H{ } clone allocations set
- <graph> slot-graph set
dup (escape-analysis)
compute-escaping-allocations ;
diff --git a/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor b/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor
deleted file mode 100644
index 3a7dee58a9..0000000000
--- a/unfinished/compiler/tree/escape-analysis/graph/graph-tests.factor
+++ /dev/null
@@ -1,19 +0,0 @@
-IN: compiler.tree.escape-analysis.graph.tests
-USING: compiler.tree.escape-analysis.graph tools.test namespaces
-accessors ;
-
-<graph> "graph" set
-
-[ ] [ { 2 3 4 } 1 "graph" get add-edges ] unit-test
-[ ] [ { 5 6 } 2 "graph" get add-edges ] unit-test
-[ ] [ { 7 8 } 9 "graph" get add-edges ] unit-test
-[ ] [ { 6 10 } 4 "graph" get add-edges ] unit-test
-
-[ ] [ 3 "graph" get mark-vertex ] unit-test
-
-[ H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 5 } { 6 6 } { 10 10 } } ]
-[ "graph" get marked>> ] unit-test
-
-[ ] [ { 1 11 } 12 "graph" get add-edges ] unit-test
-
-[ t ] [ 11 "graph" get marked-vertex? ] unit-test
diff --git a/unfinished/compiler/tree/escape-analysis/graph/graph.factor b/unfinished/compiler/tree/escape-analysis/graph/graph.factor
deleted file mode 100644
index 59ba51d99e..0000000000
--- a/unfinished/compiler/tree/escape-analysis/graph/graph.factor
+++ /dev/null
@@ -1,38 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors assocs fry sequences sets
-dequeues search-dequeues namespaces ;
-IN: compiler.tree.escape-analysis.graph
-
-TUPLE: graph edges work-list ;
-
-: <graph> ( -- graph )
- H{ } clone <hashed-dlist> graph boa ;
-
-: mark-vertex ( vertex graph -- ) work-list>> push-front ;
-
-: add-edge ( out in graph -- )
- [ edges>> push-at ] [ swapd edges>> push-at ] 3bi ;
-
-: add-edges ( out-seq in graph -- )
- '[ , , add-edge ] each ;
-
-<PRIVATE
-
-SYMBOL: marked
-
-: (mark-vertex) ( vertex graph -- )
- over marked get key? [ 2drop ] [
- [ drop marked get conjoin ]
- [ [ edges>> at ] [ work-list>> ] bi push-all-front ]
- 2bi
- ] if ;
-
-PRIVATE>
-
-: marked-components ( graph -- vertices )
- #! All vertices in connected components of marked vertices.
- H{ } clone marked [
- [ work-list>> ] keep
- '[ , (mark-vertex) ] slurp-dequeue
- ] with-variable ;
diff --git a/unfinished/compiler/tree/escape-analysis/simple/simple.factor b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
index 8329a04a61..8828b4c410 100644
--- a/unfinished/compiler/tree/escape-analysis/simple/simple.factor
+++ b/unfinished/compiler/tree/escape-analysis/simple/simple.factor
@@ -2,17 +2,25 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences classes.tuple
classes.tuple.private math math.private slots.private
-combinators dequeues search-dequeues namespaces fry
+combinators dequeues search-dequeues namespaces fry classes
+stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.simple
+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 ;
+
: record-tuple-allocation ( #call -- )
#! Delegation.
dup dup in-d>> peek node-value-info literal>>
- class>> all-slots rest-slice [ read-only>> ] all? [
+ class>> immutable-tuple-class? [
[ in-d>> but-last ] [ out-d>> first ] bi
record-allocation
] [ drop ] if ;
@@ -23,9 +31,6 @@ IN: compiler.tree.escape-analysis.simple
[ in-d>> first ] tri
over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ;
-: add-escaping-values ( values -- )
- [ allocation [ disqualify ] each ] each ;
-
M: #call escape-analysis*
dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] }
From 04a72f2472c37c892dd80cf9f2231416cefd3908 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 3 Aug 2008 21:55:19 -0500
Subject: [PATCH 7/8] Document disjoint-sets
---
basis/disjoint-sets/disjoint-sets-docs.factor | 58 +++++++++++++++++++
basis/disjoint-sets/disjoint-sets.factor | 13 +++--
.../allocations/allocations.factor | 26 ++++-----
.../escape-analysis/branches/branches.factor | 2 -
4 files changed, 78 insertions(+), 21 deletions(-)
create mode 100644 basis/disjoint-sets/disjoint-sets-docs.factor
diff --git a/basis/disjoint-sets/disjoint-sets-docs.factor b/basis/disjoint-sets/disjoint-sets-docs.factor
new file mode 100644
index 0000000000..b1d7cf685a
--- /dev/null
+++ b/basis/disjoint-sets/disjoint-sets-docs.factor
@@ -0,0 +1,58 @@
+IN: disjoint-sets
+USING: help.markup help.syntax kernel assocs math ;
+
+HELP: <disjoint-set>
+{ $values { "disjoint-set" disjoint-set } }
+{ $description "Creates a new disjoint set data structure with no elements." } ;
+
+HELP: add-atom
+{ $values { "a" object } { "disjoint-set" disjoint-set } }
+{ $description "Adds a new element to the disjoint set, initially only equivalent to itself." } ;
+
+HELP: equiv-set-size
+{ $values { "a" object } { "disjoint-set" disjoint-set } { "n" integer } }
+{ $description "Outputs the number of elements in the equivalence class of " { $snippet "a" } "." } ;
+
+HELP: equiv?
+{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } { "?" "a boolean" } }
+{ $description "Tests if two elements belong to the same equivalence class." } ;
+
+HELP: equate
+{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } }
+{ $description "Merges the equivalence classes of two elements, which must previously have been added with " { $link add-atom } "." } ;
+
+HELP: assoc>disjoint-set
+{ $values { "assoc" assoc } { "disjoint-set" disjoint-set } }
+{ $description "Given an assoc representation of a graph where the keys are vertices and key/value pairs are edges, creates a disjoint set whose elements are the keys of assoc, and two keys are equvalent if they belong to the same connected component of the graph." }
+{ $examples
+ { $example
+ "USING: disjoint-sets kernel prettyprint ;"
+ "H{ { 1 1 } { 2 1 } { 3 4 } { 4 4 } { 5 3 } } assoc>disjoint-set"
+ "1 2 pick equiv? ."
+ "4 5 pick equiv? ."
+ "1 5 pick equiv? ."
+ "drop"
+ "t\nt\nf\n"
+ }
+} ;
+
+ARTICLE: "disjoint-sets" "Disjoint sets"
+"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
+$nl
+"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time."
+$nl
+"The class of disjoint sets:"
+{ $subsection disjoint-set }
+"Creating new disjoint sets:"
+{ $subsection <disjoint-set> }
+{ $subsection assoc>disjoint-set }
+"Queries:"
+{ $subsection equiv? }
+{ $subsection equiv-set-size }
+"Adding elements:"
+{ $subsection add-atom }
+"Equating elements:"
+{ $subsection equate }
+"Additionally, disjoint sets implement the " { $link clone } " generic word." ;
+
+ABOUT: "disjoint-sets"
diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor
index 284d206da4..a885e333c5 100644
--- a/basis/disjoint-sets/disjoint-sets.factor
+++ b/basis/disjoint-sets/disjoint-sets.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hints kernel locals math hashtables
-assocs ;
+assocs fry ;
IN: disjoint-sets
@@ -36,8 +36,6 @@ TUPLE: disjoint-set
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
-PRIVATE>
-
GENERIC: representative ( a disjoint-set -- p )
M: disjoint-set representative
@@ -45,8 +43,6 @@ M: disjoint-set representative
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
-<PRIVATE
-
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline
@@ -90,3 +86,10 @@ M:: disjoint-set equate ( a b disjoint-set -- )
M: disjoint-set clone
[ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
disjoint-set boa ;
+
+: assoc>disjoint-set ( assoc -- disjoint-set )
+ <disjoint-set>
+ [ '[ drop , add-atom ] assoc-each ]
+ [ '[ , equate ] assoc-each ]
+ [ nip ]
+ 2tri ;
diff --git a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
index 19a5e5b12a..4bd23aa8a7 100644
--- a/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -4,18 +4,19 @@ USING: 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 sequences of values
+! 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
+
SYMBOL: allocations
-: allocation ( value -- allocation )
- resolve-copy allocations get at ;
+: (allocation) resolve-copy allocations get ; inline
-: record-allocation ( allocation value -- )
- {
- { [ dup not ] [ 2drop ] }
- { [ over not ] [ allocations get delete-at drop ] }
- [ allocations get set-at ]
- } cond ;
+: allocation ( value -- allocation ) (allocation) at ;
+
+: record-allocation ( allocation value -- ) (allocation) set-at ;
: record-allocations ( allocations values -- )
[ record-allocation ] 2each ;
@@ -29,11 +30,8 @@ SYMBOL: +escaping+
<disjoint-set> +escaping+ over add-atom ;
: init-escaping-values ( -- )
- copies get <escaping-values>
- [ '[ drop , add-atom ] assoc-each ]
- [ '[ , equate ] assoc-each ]
- [ nip escaping-values set ]
- 2tri ;
+ copies get assoc>disjoint-set +escaping+ over add-atom
+ escaping-values set ;
: <slot-value> ( -- value )
<value>
diff --git a/unfinished/compiler/tree/escape-analysis/branches/branches.factor b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
index 950e0341f9..36d4b1f6a2 100644
--- a/unfinished/compiler/tree/escape-analysis/branches/branches.factor
+++ b/unfinished/compiler/tree/escape-analysis/branches/branches.factor
@@ -8,8 +8,6 @@ compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.branches
-SYMBOL: children-escape-data
-
M: #branch escape-analysis*
live-children sift [ (escape-analysis) ] each ;
From 175b6deee58381e802ccfd7fc2caca1a91d31486 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 4 Aug 2008 04:35:31 -0500
Subject: [PATCH 8/8] Working on recursive escape analysis
---
.../tree/copy-equiv/copy-equiv.factor | 8 ++--
.../allocations/allocations.factor | 38 ++++++++++++-------
.../escape-analysis/branches/branches.factor | 17 +++++----
.../escape-analysis-tests.factor | 30 +++++++++++++++
.../recursive/recursive.factor | 25 ++++++++----
.../tree/escape-analysis/simple/simple.factor | 31 +++++++++++----
.../tree/propagation/branches/branches.factor | 2 +-
7 files changed, 111 insertions(+), 40 deletions(-)
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