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 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     nip
  54     [
  55         [
  56             label>>
  57             [ loop-stack [ swap suffix ] change ]
  58             [ remember-loop-info ]
  59             [ t >>loop? drop ]
  60             tri
  61         ]
  62         [ t swap child>> (collect-loop-info) ] bi
  63     ] with-scope ;
  64
  65 : current-loop-nesting ( label -- labels )
  66     loop-stack get swap loop-heights get at tail ;
  67
  68 : disqualify-loop ( label -- )
  69     work-list get push-front ;
  70
  71 M: #call-recursive collect-loop-info*
  72     label>>
  73     swap [ dup disqualify-loop ] unless
  74     dup current-loop-nesting [ loop-calls get push-at ] with each ;
  75
  76 M: #if collect-loop-info*
  77     children>> [ (collect-loop-info) ] with each ;
  78
  79 M: #dispatch collect-loop-info*
  80     children>> [ (collect-loop-info) ] with each ;
  81
  82 M: node collect-loop-info* 2drop ;
  83
  84 : collect-loop-info ( node -- )
  85     { } loop-stack set
  86     H{ } clone loop-calls set
  87     H{ } clone loop-heights set
  88     <hashed-dlist> work-list set
  89     t swap (collect-loop-info) ;
  90
  91 : disqualify-loops ( -- )
  92     work-list get [
  93         dup loop?>> [
  94             [ f >>loop? drop ]
  95             [ loop-calls get at [ disqualify-loop ] each ]
  96             bi
  97         ] [ drop ] if
  98     ] slurp-deque ;
  99
 100 : analyze-recursive ( nodes -- nodes )
 101     dup [ collect-label-info ] each-node
 102     dup collect-loop-info disqualify-loops ;