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 namespaces sequences kernel math
   4 combinators sets disjoint-sets fry stack-checker.values ;
   5 FROM: namespaces => set ;
   6 IN: compiler.tree.escape-analysis.allocations
   7
   8 ! A map from values to classes. Only for #introduce outputs
   9 SYMBOL: value-classes
  10
  11 : value-class ( value -- class ) value-classes get at ;
  12
  13 : set-value-class ( class value -- ) value-classes get set-at ;
  14
  15 ! A map from values to one of the following:
  16 ! - f -- initial status, assigned to values we have not seen yet;
  17 !        may potentially become an allocation later
  18 ! - a sequence of values -- potentially unboxed tuple allocations
  19 ! - t -- not allocated in this procedure, can never be unboxed
  20 SYMBOL: allocations
  21
  22 : (allocation) ( value -- value' allocations )
  23     allocations get ; inline
  24
  25 : allocation ( value -- allocation )
  26     (allocation) at ;
  27
  28 : record-allocation ( allocation value -- )
  29     (allocation) set-at ;
  30
  31 : record-allocations ( allocations values -- )
  32     [ record-allocation ] 2each ;
  33
  34 ! We track slot access to connect constructor inputs with
  35 ! accessor outputs.
  36 SYMBOL: slot-accesses
  37
  38 TUPLE: slot-access slot# value ;
  39
  40 C: <slot-access> slot-access
  41
  42 : record-slot-access ( out slot# in -- )
  43     <slot-access> swap slot-accesses get set-at ;
  44
  45 ! We track escaping values with a disjoint set.
  46 SYMBOL: escaping-values
  47
  48 SYMBOL: +escaping+
  49
  50 : <escaping-values> ( -- disjoint-set )
  51     <disjoint-set> +escaping+ over add-atom ;
  52
  53 : init-escaping-values ( -- )
  54     <escaping-values> escaping-values set ;
  55
  56 : introduce-value ( values -- )
  57     escaping-values get
  58     2dup disjoint-set-member?
  59     [ 2drop ] [ add-atom ] if ;
  60
  61 : introduce-values ( values -- )
  62     [ introduce-value ] each ;
  63
  64 : <slot-value> ( -- value )
  65     <value> dup introduce-value ;
  66
  67 : merge-values ( in-values out-value -- )
  68     escaping-values get equate-all-with ;
  69
  70 : merge-slots ( values -- value )
  71     <slot-value> [ merge-values ] keep ;
  72
  73 : equate-values ( value1 value2 -- )
  74     escaping-values get equate ;
  75
  76 : add-escaping-value ( value -- )
  77     [
  78         allocation {
  79             { [ dup not ] [ drop ] }
  80             { [ dup t eq? ] [ drop ] }
  81             [ [ add-escaping-value ] each ]
  82         } cond
  83     ]
  84     [ +escaping+ equate-values ] bi ;
  85
  86 : add-escaping-values ( values -- )
  87     [ add-escaping-value ] each ;
  88
  89 : unknown-allocation ( value -- )
  90     [ add-escaping-value ]
  91     [ t swap record-allocation ]
  92     bi ;
  93
  94 : unknown-allocations ( values -- )
  95     [ unknown-allocation ] each ;
  96
  97 : escaping-value? ( value -- ? )
  98     +escaping+ escaping-values get equiv? ;
  99
 100 DEFER: copy-value
 101
 102 : copy-allocation ( allocation -- allocation' )
 103     {
 104         { [ dup not ] [ ] }
 105         { [ dup t eq? ] [ ] }
 106         [ [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map ]
 107     } cond ;
 108
 109 : copy-value ( from to -- )
 110     [ equate-values ]
 111     [ [ allocation copy-allocation ] dip record-allocation ]
 112     2bi ;
 113
 114 : copy-values ( from to -- )
 115     [ copy-value ] 2each ;
 116
 117 : copy-slot-value ( out slot# in -- )
 118     allocation {
 119         { [ dup not ] [ 3drop ] }
 120         { [ dup t eq? ] [ 3drop ] }
 121         [ nth swap copy-value ]
 122     } cond ;
 123
 124 ! Compute which tuples escape
 125 SYMBOL: escaping-allocations
 126
 127 : compute-escaping-allocations ( -- )
 128     allocations get
 129     [ drop escaping-value? ] assoc-filter
 130     escaping-allocations set ;
 131
 132 : escaping-allocation? ( value -- ? )
 133     escaping-allocations get key? ;
 134
 135 : unboxed-allocation ( value -- allocation/f )
 136     dup escaping-allocation? [ drop f ] [ allocation ] if ;
 137
 138 : unboxed-slot-access? ( value -- ? )
 139     slot-accesses get at*
 140     [ value>> unboxed-allocation >boolean ] when ;