basis/compiler/tree/escape-analysis/allocations/allocations.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators disjoint-sets fry kernel
   4 namespaces sequences stack-checker.values ;
   5 IN: compiler.tree.escape-analysis.allocations
   6
   7 SYMBOL: value-classes
   8
   9 : value-class ( value -- class ) value-classes get at ;
  10
  11 : set-value-class ( class value -- ) value-classes get set-at ;
  12
  13 SYMBOL: allocations
  14
  15 : (allocation) ( -- allocations )
  16     allocations get ; inline
  17
  18 : allocation ( value -- allocation )
  19     (allocation) at ;
  20
  21 : record-allocation ( allocation value -- )
  22     (allocation) set-at ;
  23
  24 : record-allocations ( allocations values -- )
  25     (allocation) '[ _ set-at ] 2each ;
  26
  27 SYMBOL: slot-accesses
  28
  29 TUPLE: slot-access slot# value ;
  30
  31 C: <slot-access> slot-access
  32
  33 : record-slot-access ( out slot# in -- )
  34     <slot-access> swap slot-accesses get set-at ;
  35
  36 SYMBOL: escaping-values
  37
  38 SYMBOL: +escaping+
  39
  40 : <escaping-values> ( -- disjoint-set )
  41     <disjoint-set> +escaping+ over add-atom ;
  42
  43 : init-escaping-values ( -- )
  44     <escaping-values> escaping-values set ;
  45
  46 : (introduce-value) ( values escaping-values -- )
  47     2dup disjoint-set-member?
  48     [ 2drop ] [ add-atom ] if ; inline
  49
  50 : introduce-value ( values -- )
  51     escaping-values get (introduce-value) ;
  52
  53 : introduce-values ( values -- )
  54     escaping-values get '[ _ (introduce-value) ] each ;
  55
  56 : <slot-value> ( -- value )
  57     <value> dup introduce-value ;
  58
  59 : merge-values ( in-values out-value -- )
  60     escaping-values get equate-all-with ;
  61
  62 : merge-slots ( values -- value )
  63     <slot-value> [ merge-values ] keep ;
  64
  65 : equate-values ( value1 value2 -- )
  66     escaping-values get equate ;
  67
  68 : add-escaping-value ( value -- )
  69     [
  70         allocation {
  71             { [ dup not ] [ drop ] }
  72             { [ dup t eq? ] [ drop ] }
  73             [ [ add-escaping-value ] each ]
  74         } cond
  75     ]
  76     [ +escaping+ equate-values ] bi ;
  77
  78 : add-escaping-values ( values -- )
  79     [ add-escaping-value ] each ;
  80
  81 : unknown-allocation ( value -- )
  82     [ add-escaping-value ]
  83     [ t swap record-allocation ]
  84     bi ;
  85
  86 : unknown-allocations ( values -- )
  87     [ unknown-allocation ] each ;
  88
  89 : (escaping-value?) ( value escaping-values -- ? )
  90     +escaping+ swap equiv? ; inline
  91
  92 : escaping-value? ( value -- ? )
  93     escaping-values get (escaping-value?) ;
  94
  95 DEFER: copy-value
  96
  97 : copy-allocation ( allocation -- allocation' )
  98     {
  99         { [ dup not ] [ ] }
 100         { [ dup t eq? ] [ ] }
 101         [ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
 102     } cond ;
 103
 104 : copy-value ( from to -- )
 105     [ equate-values ]
 106     [ [ allocation copy-allocation ] dip record-allocation ]
 107     2bi ;
 108
 109 : copy-values ( from to -- )
 110     [ copy-value ] 2each ;
 111
 112 : copy-slot-value ( out slot# in -- )
 113     allocation {
 114         { [ dup not ] [ 3drop ] }
 115         { [ dup t eq? ] [ 3drop ] }
 116         [ nth swap copy-value ]
 117     } cond ;
 118
 119 SYMBOL: escaping-allocations
 120
 121 : compute-escaping-allocations ( -- )
 122     allocations get escaping-values get
 123     '[ drop _ (escaping-value?) ] assoc-filter
 124     escaping-allocations set ;
 125
 126 : escaping-allocation? ( value -- ? )
 127     escaping-allocations get key? ;
 128
 129 : unboxed-allocation ( value -- allocation/f )
 130     dup escaping-allocation? [ drop f ] [ allocation ] if ;
 131
 132 : unboxed-slot-access? ( value -- ? )
 133     slot-accesses get at*
 134     [ value>> unboxed-allocation >boolean ] when ;