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

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs classes classes.tuple
   4 classes.tuple.private combinators compiler.tree
   5 compiler.tree.escape-analysis.allocations
   6 compiler.tree.escape-analysis.nodes
   7 compiler.tree.propagation.info kernel math namespaces sequences
   8 slots.private ;
   9 IN: compiler.tree.escape-analysis.simple
  10
  11 M: #declare escape-analysis* drop ;
  12
  13 M: #terminate escape-analysis* drop ;
  14
  15 M: #renaming escape-analysis* inputs/outputs copy-values ;
  16
  17 : declared-class ( value -- class/f )
  18     next-node get dup #declare? [ declaration>> at ] [ 2drop f ] if ;
  19
  20 : record-param-allocation ( value class -- )
  21     dup immutable-tuple-class? [
  22         [ swap set-value-class ] [
  23             all-slots [
  24                 [ <slot-value> dup ] [ class>> ] bi*
  25                 record-param-allocation
  26             ] map swap record-allocation
  27         ] 2bi
  28     ] [ drop unknown-allocation ] if ;
  29
  30 M: #introduce escape-analysis*
  31     out-d>> [ dup declared-class record-param-allocation ] each ;
  32
  33 DEFER: record-literal-allocation
  34
  35 : make-literal-slots ( seq -- values )
  36     [ <slot-value> [ swap record-literal-allocation ] keep ] map ;
  37
  38 : object-slots ( object -- slots/f )
  39     {
  40         { [ dup class-of immutable-tuple-class? ] [ tuple-slots ] }
  41         [ drop f ]
  42     } cond ;
  43
  44 : record-literal-allocation ( value object -- )
  45     object-slots
  46     [ make-literal-slots swap record-allocation ]
  47     [ unknown-allocation ]
  48     if* ;
  49
  50 M: #push escape-analysis*
  51     dup literal>> layout-up-to-date?
  52     [ [ out-d>> first ] [ literal>> ] bi record-literal-allocation ]
  53     [ out-d>> unknown-allocations ]
  54     if ;
  55
  56 : record-unknown-allocation ( #call -- )
  57     [ in-d>> add-escaping-values ]
  58     [ out-d>> unknown-allocations ] bi ;
  59
  60 : record-tuple-allocation ( #call -- )
  61     dup immutable-tuple-boa?
  62     [ [ in-d>> but-last { } like ] [ out-d>> first ] bi record-allocation ]
  63     [ record-unknown-allocation ]
  64     if ;
  65
  66 : slot-offset ( #call -- n/f )
  67     dup in-d>> second node-value-info literal>> dup [ 2 - ] when ;
  68
  69 : valid-slot-offset? ( slot# in -- ? )
  70     over [
  71         allocation dup [
  72             dup array? [ bounds-check? ] [ 2drop f ] if
  73         ] [ 2drop t ] if
  74     ] [ 2drop f ] if ;
  75
  76 : unknown-slot-call ( out slot# in -- )
  77     [ unknown-allocation ] [ drop ] [ add-escaping-value ] tri* ;
  78
  79 : record-slot-call ( #call -- )
  80     [ out-d>> first ] [ slot-offset ] [ in-d>> first ] tri
  81     2dup valid-slot-offset?
  82     [ [ record-slot-access ] [ copy-slot-value ] 3bi ]
  83     [ unknown-slot-call ]
  84     if ;
  85
  86 M: #call escape-analysis*
  87     dup word>> {
  88         { \ <tuple-boa> [ record-tuple-allocation ] }
  89         { \ slot [ record-slot-call ] }
  90         [ drop record-unknown-allocation ]
  91     } case ;
  92
  93 M: #return escape-analysis*
  94     in-d>> add-escaping-values ;
  95
  96 M: #alien-node escape-analysis*
  97     [ in-d>> add-escaping-values ]
  98     [ out-d>> unknown-allocations ]
  99     bi ;
 100
 101 M: #alien-callback escape-analysis*
 102     child>> (escape-analysis) ;