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

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel sequences math combinators accessors namespaces
   4 fry disjoint-sets
   5 compiler.tree
   6 compiler.tree.combinators
   7 compiler.tree.escape-analysis.nodes
   8 compiler.tree.escape-analysis.branches
   9 compiler.tree.escape-analysis.allocations ;
  10 IN: compiler.tree.escape-analysis.recursive
  11
  12 : congruent? ( alloc1 alloc2 -- ? )
  13     {
  14         { [ 2dup [ f eq? ] either? ] [ eq? ] }
  15         { [ 2dup [ t eq? ] either? ] [ eq? ] }
  16         { [ 2dup [ length ] bi@ = not ] [ 2drop f ] }
  17         [ [ [ allocation ] bi@ congruent? ] 2all? ]
  18     } cond ;
  19
  20 : check-fixed-point ( node alloc1 alloc2 -- )
  21     [ congruent? ] 2all? [ drop ] [ label>> f >>fixed-point drop ] if ;
  22
  23 : node-input-allocations ( node -- allocations )
  24     in-d>> [ allocation ] map ;
  25
  26 : node-output-allocations ( node -- allocations )
  27     out-d>> [ allocation ] map ;
  28
  29 : recursive-stacks ( #enter-recursive -- stacks )
  30     recursive-phi-in
  31     escaping-values get '[ [ _ disjoint-set-member? ] all? ] filter
  32     flip ;
  33
  34 : analyze-recursive-phi ( #enter-recursive -- )
  35     [ ] [ recursive-stacks ] [ out-d>> ] tri
  36     [ [ merge-values ] 2each ]
  37     [
  38         [ (merge-allocations) ] dip
  39         [ [ allocation ] map check-fixed-point ]
  40         [ record-allocations ]
  41         2bi
  42     ] 2bi ;
  43
  44 M: #recursive escape-analysis* ( #recursive -- )
  45     [ label>> return>> in-d>> introduce-values ]
  46     [
  47         [
  48             child>>
  49             [ first out-d>> introduce-values ]
  50             [ first analyze-recursive-phi ]
  51             [ (escape-analysis) ]
  52             tri
  53         ] until-fixed-point
  54     ] bi ;
  55
  56 M: #enter-recursive escape-analysis* ( #enter-recursive -- )
  57     #! Handled by #recursive
  58     drop ;
  59
  60 M: #call-recursive escape-analysis* ( #call-label -- )
  61     [ ] [ label>> return>> ] [ node-output-allocations ] tri
  62     [ [ node-input-allocations ] dip check-fixed-point ]
  63     [ drop swap [ in-d>> ] [ out-d>> ] bi* copy-values ]
  64     3bi ;
  65
  66 M: #return-recursive escape-analysis* ( #return-recursive -- )
  67     [ call-next-method ]
  68     [
  69         [ in-d>> ] [ label>> calls>> ] bi
  70         [ out-d>> escaping-values get '[ _ equate ] 2each ] with each
  71     ] bi ;