basis/compiler/tree/recursive/recursive.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel assocs arrays namespaces accessors sequences deques
   4 search-deques compiler.tree compiler.tree.combinators ;
   5 IN: compiler.tree.recursive
   6
   7 ! Collect label info
   8 GENERIC: collect-label-info ( node -- )
   9
  10 M: #return-recursive collect-label-info
  11     dup label>> (>>return) ;
  12
  13 M: #call-recursive collect-label-info
  14     dup label>> calls>> push ;
  15
  16 M: #recursive collect-label-info
  17     label>> V{ } clone >>calls drop ;
  18
  19 M: node collect-label-info drop ;
  20
  21 ! A loop is a #recursive which only tail calls itself, and those
  22 ! calls are nested inside other loops only. We optimistically
  23 ! assume all #recursive nodes are loops, disqualifying them as
  24 ! we see evidence to the contrary.
  25 : (tail-calls) ( tail? seq -- seq' )
  26     reverse [ swap [ and ] keep ] map nip reverse ;
  27
  28 : tail-calls ( tail? node -- seq )
  29     [
  30         [ #phi? ]
  31         [ #return? ]
  32         [ #return-recursive? ]
  33         tri or or
  34     ] map (tail-calls) ;
  35
  36 SYMBOL: loop-heights
  37 SYMBOL: loop-calls
  38 SYMBOL: loop-stack
  39 SYMBOL: work-list
  40
  41 GENERIC: collect-loop-info* ( tail? node -- )
  42
  43 : non-tail-label-info ( nodes -- )
  44     [ f swap collect-loop-info* ] each ;
  45
  46 : (collect-loop-info) ( tail? nodes -- )
  47     [ tail-calls ] keep [ collect-loop-info* ] 2each ;
  48
  49 : remember-loop-info ( label -- )
  50     loop-stack get length swap loop-heights get set-at ;
  51
  52 M: #recursive collect-loop-info*
  53     [
  54         [
  55             label>>
  56             [ swap 2array loop-stack [ swap suffix ] change ]
  57             [ remember-loop-info ]
  58             [ t >>loop? drop ]
  59             tri
  60         ]
  61         [ t swap child>> (collect-loop-info) ] bi
  62     ] with-scope ;
  63
  64 : current-loop-nesting ( label -- alist )
  65     loop-stack get swap loop-heights get at tail ;
  66
  67 : disqualify-loop ( label -- )
  68     work-list get push-front ;
  69
  70 M: #call-recursive collect-loop-info*
  71     label>>
  72     swap [ dup disqualify-loop ] unless
  73     dup current-loop-nesting
  74     [ keys [ loop-calls get push-at ] with each ]
  75     [ [ nip not ] assoc-filter keys [ disqualify-loop ] each ]
  76     bi ;
  77
  78 M: #if collect-loop-info*
  79     children>> [ (collect-loop-info) ] with each ;
  80
  81 M: #dispatch collect-loop-info*
  82     children>> [ (collect-loop-info) ] with each ;
  83
  84 M: node collect-loop-info* 2drop ;
  85
  86 : collect-loop-info ( node -- )
  87     { } loop-stack set
  88     H{ } clone loop-calls set
  89     H{ } clone loop-heights set
  90     <hashed-dlist> work-list set
  91     t swap (collect-loop-info) ;
  92
  93 : disqualify-loops ( -- )
  94     work-list get [
  95         dup loop?>> [
  96             [ f >>loop? drop ]
  97             [ loop-calls get at [ disqualify-loop ] each ]
  98             bi
  99         ] [ drop ] if
 100     ] slurp-deque ;
 101
 102 : analyze-recursive ( nodes -- nodes )
 103     dup [ collect-label-info ] each-node
 104     dup collect-loop-info disqualify-loops ;