basis/compiler/tree/recursive/recursive.factor

   1 ! Copyright (C) 2008, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators.short-circuit compiler.tree fry
   4 kernel namespaces sequences sets ;
   5 FROM: namespaces => set ;
   6 IN: compiler.tree.recursive
   7
   8 TUPLE: call-site tail? node label ;
   9
  10 : recursive-phi-in ( #enter-recursive -- seq )
  11     [ label>> calls>> [ node>> in-d>> ] map ] [ in-d>> ] bi suffix ;
  12
  13 <PRIVATE
  14
  15 TUPLE: call-graph-node tail? label children calls ;
  16
  17 : (tail-calls) ( tail? seq -- seq' )
  18     reverse [ swap [ and ] keep ] map nip reverse ;
  19
  20 : tail-calls ( tail? node -- seq )
  21     [
  22         {
  23             [ #phi? ]
  24             [ #return? ]
  25             [ #return-recursive? ]
  26         } 1||
  27     ] map (tail-calls) ;
  28
  29 SYMBOLS: children calls ;
  30
  31 GENERIC: node-call-graph ( tail? node -- )
  32
  33 : (build-call-graph) ( tail? nodes -- )
  34     [ tail-calls ] keep
  35     [ node-call-graph ] 2each ;
  36
  37 : build-call-graph ( nodes -- labels calls )
  38     [
  39         V{ } clone children set
  40         V{ } clone calls set
  41         [ t ] dip (build-call-graph)
  42         children get
  43         calls get
  44     ] with-scope ;
  45
  46 M: #return-recursive node-call-graph
  47     nip dup label>> return<< ;
  48
  49 M: #call-recursive node-call-graph
  50     [ dup label>> call-site boa ] keep
  51     [ drop calls get push ]
  52     [ label>> calls>> push ] 2bi ;
  53
  54 M: #recursive node-call-graph
  55     [ label>> V{ } clone >>calls drop ]
  56     [
  57         [ label>> ] [ child>> build-call-graph ] bi
  58         call-graph-node boa children get push
  59     ] bi ;
  60
  61 M: #branch node-call-graph
  62     children>> [ (build-call-graph) ] with each ;
  63
  64 M: #alien-callback node-call-graph
  65     child>> (build-call-graph) ;
  66
  67 M: node node-call-graph 2drop ;
  68
  69 SYMBOLS: not-loops recursive-nesting ;
  70
  71 : not-a-loop ( label -- ) not-loops get adjoin ;
  72
  73 : not-a-loop? ( label -- ? ) not-loops get in? ;
  74
  75 : non-tail-calls ( call-graph-node -- seq )
  76     calls>> [ tail?>> not ] filter ;
  77
  78 : visit-back-edges ( call-graph -- )
  79     [
  80         [ non-tail-calls [ label>> not-a-loop ] each ]
  81         [ children>> visit-back-edges ]
  82         bi
  83     ] each ;
  84
  85 SYMBOL: changed?
  86
  87 : check-cross-frame-call ( call-site -- )
  88     label>> dup not-a-loop? [ drop ] [
  89         recursive-nesting get <reversed> [
  90             2dup label>> eq? [ 2drop f ] [
  91                 [ label>> not-a-loop? ] [ tail?>> not ] bi or
  92                 [ not-a-loop changed? on ] [ drop ] if t
  93             ] if
  94         ] with all? drop
  95     ] if ;
  96
  97 : detect-cross-frame-calls ( call-graph -- )
  98     ! Suppose we have a nesting of recursives A --> B --> C
  99     ! B tail-calls A, and C non-tail-calls B. Then A cannot be
 100     ! a loop, it needs its own procedure, since the call from
 101     ! C to A crosses a call-frame boundary.
 102     [
 103         [ recursive-nesting get push ]
 104         [ calls>> [ check-cross-frame-call ] each ]
 105         [ children>> detect-cross-frame-calls ] tri
 106         recursive-nesting get pop*
 107     ] each ;
 108
 109 : while-changing ( ... quot: ( ... -- ... ) -- ... )
 110     changed? off
 111     [ call ] [ changed? get [ while-changing ] [ drop ] if ] bi ;
 112     inline recursive
 113
 114 : detect-loops ( call-graph -- )
 115     HS{ } clone not-loops set
 116     V{ } clone recursive-nesting set
 117     [ visit-back-edges ]
 118     [ '[ _ detect-cross-frame-calls ] while-changing ]
 119     bi ;
 120
 121 : mark-loops ( call-graph -- )
 122     [
 123         [ label>> dup not-a-loop? [ t >>loop? ] unless drop ]
 124         [ children>> mark-loops ]
 125         bi
 126     ] each ;
 127
 128 PRIVATE>
 129
 130 SYMBOL: call-graph
 131
 132 : analyze-recursive ( nodes -- nodes )
 133     dup build-call-graph drop
 134     [ call-graph set ]
 135     [ detect-loops ]
 136     [ mark-loops ]
 137     tri ;