basis/compiler/tree/recursive/recursive.factor

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