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