2008-08-02 00:31:43 -04:00
|
|
|
! Copyright (C) 2008 Slava Pestov.
|
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-08-02 21:21:25 -04:00
|
|
|
USING: assocs namespaces sequences kernel math combinators sets
|
2008-08-02 00:31:43 -04:00
|
|
|
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'
|
|
|
|
SYMBOL: allocations
|
|
|
|
|
|
|
|
: allocation ( value -- allocation )
|
|
|
|
resolve-copy allocations get at ;
|
|
|
|
|
|
|
|
: record-allocation ( allocation value -- )
|
2008-08-02 21:21:25 -04:00
|
|
|
{
|
|
|
|
{ [ dup not ] [ 2drop ] }
|
|
|
|
{ [ over not ] [ allocations get delete-at drop ] }
|
|
|
|
[ allocations get set-at ]
|
|
|
|
} cond ;
|
2008-08-02 00:31:43 -04:00
|
|
|
|
|
|
|
: record-allocations ( allocations values -- )
|
|
|
|
[ record-allocation ] 2each ;
|
|
|
|
|
|
|
|
: 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
|
|
|
|
|
|
|
|
: merge-slots ( values -- value )
|
2008-08-02 21:21:25 -04:00
|
|
|
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* ;
|