basis/compiler/cfg/linearization/linearization.factor

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