135 lines
3.3 KiB
Factor
135 lines
3.3 KiB
Factor
! Copyright (C) 2008, 2009 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors assocs combinators disjoint-sets fry kernel
|
|
namespaces sequences stack-checker.values ;
|
|
IN: compiler.tree.escape-analysis.allocations
|
|
|
|
SYMBOL: value-classes
|
|
|
|
: value-class ( value -- class ) value-classes get at ;
|
|
|
|
: set-value-class ( class value -- ) value-classes get set-at ;
|
|
|
|
SYMBOL: allocations
|
|
|
|
: (allocation) ( -- allocations )
|
|
allocations get ; inline
|
|
|
|
: allocation ( value -- allocation )
|
|
(allocation) at ;
|
|
|
|
: record-allocation ( allocation value -- )
|
|
(allocation) set-at ;
|
|
|
|
: record-allocations ( allocations values -- )
|
|
(allocation) '[ _ set-at ] 2each ;
|
|
|
|
SYMBOL: slot-accesses
|
|
|
|
TUPLE: slot-access slot# value ;
|
|
|
|
C: <slot-access> slot-access
|
|
|
|
: record-slot-access ( out slot# in -- )
|
|
<slot-access> swap slot-accesses get set-at ;
|
|
|
|
SYMBOL: escaping-values
|
|
|
|
SYMBOL: +escaping+
|
|
|
|
: <escaping-values> ( -- disjoint-set )
|
|
<disjoint-set> +escaping+ over add-atom ;
|
|
|
|
: init-escaping-values ( -- )
|
|
<escaping-values> escaping-values set ;
|
|
|
|
: (introduce-value) ( values escaping-values -- )
|
|
2dup disjoint-set-member?
|
|
[ 2drop ] [ add-atom ] if ; inline
|
|
|
|
: introduce-value ( values -- )
|
|
escaping-values get (introduce-value) ;
|
|
|
|
: introduce-values ( values -- )
|
|
escaping-values get '[ _ (introduce-value) ] each ;
|
|
|
|
: <slot-value> ( -- value )
|
|
<value> dup introduce-value ;
|
|
|
|
: merge-values ( in-values out-value -- )
|
|
escaping-values get equate-all-with ;
|
|
|
|
: merge-slots ( values -- value )
|
|
<slot-value> [ merge-values ] keep ;
|
|
|
|
: equate-values ( value1 value2 -- )
|
|
escaping-values get equate ;
|
|
|
|
: add-escaping-value ( value -- )
|
|
[
|
|
allocation {
|
|
{ [ dup not ] [ drop ] }
|
|
{ [ dup t eq? ] [ drop ] }
|
|
[ [ add-escaping-value ] each ]
|
|
} cond
|
|
]
|
|
[ +escaping+ equate-values ] bi ;
|
|
|
|
: add-escaping-values ( values -- )
|
|
[ add-escaping-value ] each ;
|
|
|
|
: unknown-allocation ( value -- )
|
|
[ add-escaping-value ]
|
|
[ t swap record-allocation ]
|
|
bi ;
|
|
|
|
: unknown-allocations ( values -- )
|
|
[ unknown-allocation ] each ;
|
|
|
|
: (escaping-value?) ( value escaping-values -- ? )
|
|
+escaping+ swap equiv? ; inline
|
|
|
|
: escaping-value? ( value -- ? )
|
|
escaping-values get (escaping-value?) ;
|
|
|
|
DEFER: copy-value
|
|
|
|
: copy-allocation ( allocation -- allocation' )
|
|
{
|
|
{ [ dup not ] [ ] }
|
|
{ [ dup t eq? ] [ ] }
|
|
[ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
|
|
} cond ;
|
|
|
|
: copy-value ( from to -- )
|
|
[ equate-values ]
|
|
[ [ allocation copy-allocation ] dip record-allocation ]
|
|
2bi ;
|
|
|
|
: copy-values ( from to -- )
|
|
[ copy-value ] 2each ;
|
|
|
|
: copy-slot-value ( out slot# in -- )
|
|
allocation {
|
|
{ [ dup not ] [ 3drop ] }
|
|
{ [ dup t eq? ] [ 3drop ] }
|
|
[ nth swap copy-value ]
|
|
} cond ;
|
|
|
|
SYMBOL: escaping-allocations
|
|
|
|
: compute-escaping-allocations ( -- )
|
|
allocations get escaping-values get
|
|
'[ drop _ (escaping-value?) ] assoc-filter
|
|
escaping-allocations set ;
|
|
|
|
: escaping-allocation? ( value -- ? )
|
|
escaping-allocations get key? ;
|
|
|
|
: unboxed-allocation ( value -- allocation/f )
|
|
dup escaping-allocation? [ drop f ] [ allocation ] if ;
|
|
|
|
: unboxed-slot-access? ( value -- ? )
|
|
slot-accesses get at*
|
|
[ value>> unboxed-allocation >boolean ] when ;
|