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

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See https://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 ( value -- allocation )
  16     allocations get at ;
  17
  18 : record-allocation ( allocation value -- )
  19     allocations get set-at ;
  20
  21 : record-allocations ( allocations values -- )
  22     allocations get '[ _ set-at ] 2each ;
  23
  24 SYMBOL: slot-accesses
  25
  26 TUPLE: slot-access slot# value ;
  27
  28 C: <slot-access> slot-access
  29
  30 : record-slot-access ( out slot# in -- )
  31     <slot-access> swap slot-accesses get set-at ;
  32
  33 SYMBOL: escaping-values
  34
  35 SYMBOL: +escaping+
  36
  37 : <escaping-values> ( -- disjoint-set )
  38     <disjoint-set> +escaping+ over add-atom ;
  39
  40 : init-escaping-values ( -- )
  41     <escaping-values> escaping-values set ;
  42
  43 : (introduce-value) ( values escaping-values -- )
  44     2dup disjoint-set-member?
  45     [ 2drop ] [ add-atom ] if ; inline
  46
  47 : introduce-value ( values -- )
  48     escaping-values get (introduce-value) ;
  49
  50 : introduce-values ( values -- )
  51     escaping-values get '[ _ (introduce-value) ] each ;
  52
  53 : <slot-value> ( -- value )
  54     <value> dup introduce-value ;
  55
  56 : merge-values ( in-values out-value -- )
  57     escaping-values get equate-all-with ;
  58
  59 : merge-slots ( values -- value )
  60     <slot-value> [ merge-values ] keep ;
  61
  62 : equate-values ( value1 value2 -- )
  63     escaping-values get equate ;
  64
  65 DEFER: add-escaping-values
  66
  67 : add-escaping-value ( value -- )
  68     [ allocation dup boolean? [ drop ] [ add-escaping-values ] if ]
  69     [ +escaping+ equate-values ] bi ;
  70
  71 : add-escaping-values ( values -- )
  72     [ add-escaping-value ] each ;
  73
  74 : unknown-allocation ( value -- )
  75     [ add-escaping-value ]
  76     [ t swap record-allocation ]
  77     bi ;
  78
  79 : unknown-allocations ( values -- )
  80     [ unknown-allocation ] each ;
  81
  82 : (escaping-value?) ( value escaping-values -- ? )
  83     +escaping+ swap equiv? ; inline
  84
  85 : escaping-value? ( value -- ? )
  86     escaping-values get (escaping-value?) ;
  87
  88 DEFER: copy-value
  89
  90 : copy-allocation ( allocation -- allocation' )
  91     dup boolean? [
  92         [ <value> [ introduce-value ] [ copy-value ] [ ] tri ] map
  93     ] unless ;
  94
  95 :: (copy-value) ( from to allocations -- )
  96     from to equate-values
  97     from allocations at copy-allocation to allocations set-at ;
  98
  99 : copy-value ( from to -- )
 100     allocations get (copy-value) ;
 101
 102 : copy-values ( from to -- )
 103     allocations get '[ _ (copy-value) ] 2each ;
 104
 105 : copy-slot-value ( out slot# in -- )
 106     allocation dup boolean?
 107     [ 3drop ] [ nth swap copy-value ] if ;
 108
 109 SYMBOL: escaping-allocations
 110
 111 : compute-escaping-allocations ( -- )
 112     allocations get escaping-values get
 113     '[ _ (escaping-value?) ] filter-keys
 114     escaping-allocations set ;
 115
 116 : escaping-allocation? ( value -- ? )
 117     escaping-allocations get key? ;
 118
 119 : unboxed-allocation ( value -- allocation/f )
 120     dup escaping-allocation? [ drop f ] [ allocation ] if ;
 121
 122 : unboxed-slot-access? ( value -- ? )
 123     slot-accesses get at*
 124     [ value>> unboxed-allocation >boolean ] when ;