Merge branch 'master' of git://factorcode.org/git/factor
Eduardo Cavazos
commit
17c8c248df
basis/disjoint-sets
extra/irc
unfinished/compiler/tree
copy-equiv
dataflow-analysis
escape-analysis
allocations
branches
recursive
simple
work-list
propagation/branches
|
|
@ -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"
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,13 +2,14 @@
|
|||
! 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
|
||||
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
|
||||
|
||||
|
|
@ -24,14 +25,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 +60,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 ;
|
||||
|
|
@ -92,18 +87,24 @@ 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 ;
|
||||
|
||||
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 ;
|
||||
|
|
@ -124,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+ 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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,28 +1,84 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces sequences kernel math
|
||||
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
|
||||
|
||||
SYMBOL: escaping
|
||||
! 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 in this procedure, can never be unboxed
|
||||
|
||||
! A map from values to sequences of values or 'escaping'
|
||||
SYMBOL: allocations
|
||||
|
||||
: allocation ( value -- allocation )
|
||||
resolve-copy allocations get at ;
|
||||
TUPLE: slot-access slot# value ;
|
||||
|
||||
: record-allocation ( allocation value -- )
|
||||
allocations get set-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 ;
|
||||
|
||||
: record-slot-access ( out slot# in -- )
|
||||
over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ;
|
||||
: unknown-allocations ( values -- )
|
||||
[ unknown-allocation ] each ;
|
||||
|
||||
! A map from values to sequences of values
|
||||
SYMBOL: slot-merging
|
||||
! We track escaping values with a disjoint set.
|
||||
SYMBOL: escaping-values
|
||||
|
||||
SYMBOL: +escaping+
|
||||
|
||||
: <escaping-values> ( -- disjoint-set )
|
||||
<disjoint-set> +escaping+ over add-atom ;
|
||||
|
||||
: init-escaping-values ( -- )
|
||||
copies get assoc>disjoint-set +escaping+ over add-atom
|
||||
escaping-values set ;
|
||||
|
||||
: <slot-value> ( -- value )
|
||||
<value>
|
||||
[ introduce-value ]
|
||||
[ escaping-values get add-atom ]
|
||||
[ ]
|
||||
tri ;
|
||||
|
||||
: record-slot-access ( out slot# in -- )
|
||||
over zero? [ 3drop ] [
|
||||
<slot-access> swap record-allocation
|
||||
] if ;
|
||||
|
||||
: merge-values ( in-values out-value -- )
|
||||
escaping-values get '[ , , equate ] each ;
|
||||
|
||||
: merge-slots ( values -- value )
|
||||
<value> [ introduce-value ] [ slot-merging get set-at ] [ ] tri ;
|
||||
<slot-value> [ merge-values ] keep ;
|
||||
|
||||
: add-escaping-values ( values -- )
|
||||
escaping-values get
|
||||
'[ +escaping+ , equate ] each ;
|
||||
|
||||
: escaping-value? ( value -- ? )
|
||||
+escaping+ escaping-values get equiv? ;
|
||||
|
||||
SYMBOL: escaping-allocations
|
||||
|
||||
: compute-escaping-allocations ( -- )
|
||||
allocations get
|
||||
[ drop escaping-value? ] assoc-filter
|
||||
escaping-allocations set ;
|
||||
|
||||
: escaping-allocation? ( value -- ? )
|
||||
escaping-allocations get key? ;
|
||||
|
|
|
|||
|
|
@ -1,30 +1,34 @@
|
|||
! 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 fry
|
||||
stack-checker.branches
|
||||
compiler.tree
|
||||
compiler.tree.propagation.branches
|
||||
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 ;
|
||||
|
||||
: (merge-allocations) ( values -- allocation )
|
||||
[
|
||||
[ allocation ] map dup [ ] all? [
|
||||
dup [ length ] map all-equal? [
|
||||
flip
|
||||
[ (merge-allocations) ] [ [ merge-slots ] map ] bi
|
||||
[ record-allocations ] keep
|
||||
] [ drop f ] if
|
||||
] [ drop 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 -- )
|
||||
[ (merge-allocations) ] dip record-allocations ;
|
||||
[ [ sift ] map ] dip
|
||||
[ [ merge-values ] 2each ]
|
||||
[ [ (merge-allocations) ] dip record-allocations ]
|
||||
2bi ;
|
||||
|
||||
M: #phi escape-analysis*
|
||||
[ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,189 @@
|
|||
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 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
|
||||
compute-copy-equiv
|
||||
propagate
|
||||
cleanup
|
||||
compute-copy-equiv
|
||||
escape-analysis
|
||||
0 swap [ count-unboxed-allocations* ] 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
|
||||
|
||||
[ 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
|
||||
|
||||
[ 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
|
||||
|
|
@ -1,18 +1,19 @@
|
|||
! 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.copy-equiv
|
||||
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
|
||||
init-escaping-values
|
||||
H{ } clone allocations set
|
||||
<hashed-dlist> work-list set
|
||||
dup (escape-analysis) ;
|
||||
dup (escape-analysis)
|
||||
compute-escaping-allocations ;
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -2,33 +2,57 @@
|
|||
! 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.work-list
|
||||
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.
|
||||
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
|
||||
|
||||
: 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 ;
|
||||
] [ 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*
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue