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

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