basis/compiler/cfg/loop-detection/loop-detection.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators deques dlists fry kernel
   4 namespaces sequences sets compiler.cfg compiler.cfg.predecessors ;
   5 IN: compiler.cfg.loop-detection
   6
   7 TUPLE: natural-loop header index ends blocks ;
   8
   9 SYMBOL: loops
  10
  11 <PRIVATE
  12
  13 : <natural-loop> ( header index -- loop )
  14     H{ } clone H{ } clone natural-loop boa ;
  15
  16 : lookup-header ( header -- loop )
  17     loops get [
  18         loops get assoc-size <natural-loop>
  19     ] cache ;
  20
  21 SYMBOLS: visited active ;
  22
  23 : record-back-edge ( from to -- )
  24     lookup-header ends>> conjoin ;
  25
  26 DEFER: find-loop-headers
  27
  28 : visit-edge ( from to -- )
  29     dup active get key?
  30     [ record-back-edge ]
  31     [ nip find-loop-headers ]
  32     if ;
  33
  34 : find-loop-headers ( bb -- )
  35     dup visited get key? [ drop ] [
  36         {
  37             [ visited get conjoin ]
  38             [ active get conjoin ]
  39             [ dup successors>> [ visit-edge ] with each ]
  40             [ active get delete-at ]
  41         } cleave
  42     ] if ;
  43
  44 SYMBOL: work-list
  45
  46 : process-loop-block ( bb loop -- )
  47     2dup blocks>> key? [ 2drop ] [
  48         [ blocks>> conjoin ] [
  49             2dup header>> eq? [ 2drop ] [
  50                 drop predecessors>> work-list get push-all-front
  51             ] if
  52         ] 2bi
  53     ] if ;
  54
  55 : process-loop-ends ( loop -- )
  56     [ ends>> keys <dlist> [ push-all-front ] [ work-list set ] [ ] tri ] keep
  57     '[ _ process-loop-block ] slurp-deque ;
  58
  59 : process-loop-headers ( -- )
  60     loops get values [ process-loop-ends ] each ;
  61
  62 SYMBOL: loop-nesting
  63
  64 : compute-loop-nesting ( -- )
  65     loops get H{ } clone [
  66         [ values ] dip '[ blocks>> values [ _ inc-at ] each ] each
  67     ] keep loop-nesting set ;
  68
  69 : detect-loops ( cfg -- cfg' )
  70     needs-predecessors
  71     H{ } clone loops set
  72     H{ } clone visited set
  73     H{ } clone active set
  74     H{ } clone loop-nesting set
  75     dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ;
  76
  77 PRIVATE>
  78
  79 : loop-nesting-at ( bb -- n ) loop-nesting get at 0 or ;
  80
  81 : needs-loops ( cfg -- cfg' )
  82     needs-predecessors
  83     dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;