basis/compiler/cfg/linearization/order/order.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs deques dlists kernel make sorting
   4 namespaces sequences combinators combinators.short-circuit
   5 fry math compiler.cfg.rpo compiler.cfg.utilities
   6 compiler.cfg.loop-detection compiler.cfg.predecessors
   7 new-sets hash-sets ;
   8 FROM: namespaces => set ;
   9 IN: compiler.cfg.linearization.order
  10
  11 ! This is RPO except loops are rotated. Based on SBCL's src/compiler/control.lisp
  12
  13 <PRIVATE
  14
  15 SYMBOLS: work-list loop-heads visited ;
  16
  17 : visited? ( bb -- ? ) visited get in? ;
  18
  19 : add-to-work-list ( bb -- )
  20     dup visited? [ drop ] [
  21         work-list get push-back
  22     ] if ;
  23
  24 : init-linearization-order ( cfg -- )
  25     <dlist> work-list set
  26     HS{ } clone visited set
  27     entry>> add-to-work-list ;
  28
  29 : (find-alternate-loop-head) ( bb -- bb' )
  30     dup {
  31         [ predecessor visited? not ]
  32         [ predecessors>> length 1 = ]
  33         [ predecessor successors>> length 1 = ]
  34         [ [ number>> ] [ predecessor number>> ] bi > ]
  35     } 1&& [ predecessor (find-alternate-loop-head) ] when ;
  36
  37 : find-back-edge ( bb -- pred )
  38     [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
  39
  40 : find-alternate-loop-head ( bb -- bb' )
  41     dup find-back-edge dup visited? [ drop ] [
  42         nip (find-alternate-loop-head)
  43     ] if ;
  44
  45 : predecessors-ready? ( bb -- ? )
  46     [ predecessors>> ] keep '[
  47         _ 2dup back-edge?
  48         [ 2drop t ] [ drop visited? ] if
  49     ] all? ;
  50
  51 : process-successor ( bb -- )
  52     dup predecessors-ready? [
  53         dup loop-entry? [ find-alternate-loop-head ] when
  54         add-to-work-list
  55     ] [ drop ] if ;
  56
  57 : sorted-successors ( bb -- seq )
  58     successors>> <reversed> [ loop-nesting-at ] sort-with ;
  59
  60 : process-block ( bb -- )
  61     dup visited? [ drop ] [
  62         [ , ]
  63         [ visited get adjoin ]
  64         [ sorted-successors [ process-successor ] each ]
  65         tri
  66     ] if ;
  67
  68 : (linearization-order) ( cfg -- bbs )
  69     init-linearization-order
  70
  71     [ work-list get [ process-block ] slurp-deque ] { } make ;
  72
  73 PRIVATE>
  74
  75 : linearization-order ( cfg -- bbs )
  76     needs-post-order needs-loops needs-predecessors
  77
  78     dup linear-order>> [ ] [
  79         dup (linearization-order)
  80         >>linear-order linear-order>>
  81     ] ?if ;