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 FROM: namespaces => set ;
   8 IN: compiler.cfg.linearization
   9
  10 ! This is RPO except loops are rotated and unlikely blocks go
  11 ! at the end. Based on SBCL's src/compiler/control.lisp
  12
  13 <PRIVATE
  14
  15 SYMBOLS: loop-heads visited ;
  16
  17 : visited? ( bb -- ? ) visited get in? ;
  18
  19 : predecessors-ready? ( bb -- ? )
  20     [ predecessors>> ] keep '[
  21         _ 2dup back-edge?
  22         [ 2drop t ] [ drop visited? ] if
  23     ] all? ;
  24
  25 : (find-alternate-loop-head) ( bb -- bb' )
  26     dup {
  27         [ predecessor visited? not ]
  28         [ predecessors>> length 1 = ]
  29         [ predecessor successors>> length 1 = ]
  30         [ [ number>> ] [ predecessor number>> ] bi > ]
  31     } 1&& [ predecessor (find-alternate-loop-head) ] when ;
  32
  33 : find-back-edge ( bb -- pred )
  34     [ predecessors>> ] keep '[ _ back-edge? ] find nip ;
  35
  36 : find-alternate-loop-head ( bb -- bb' )
  37     dup find-back-edge dup visited? [ drop ] [
  38         nip (find-alternate-loop-head)
  39     ] if ;
  40
  41 : sorted-successors ( bb -- seq )
  42     successors>> <reversed> [ loop-nesting-at ] sort-with ;
  43
  44 : process-block ( bb -- bbs )
  45     dup visited get ?adjoin [ dup , sorted-successors ] [ drop { } ] if
  46     [ predecessors-ready? ] filter
  47     [ dup loop-entry? [ find-alternate-loop-head ] when ] map
  48     [ visited? not ] filter ;
  49
  50 : (linearization-order) ( cfg -- bbs )
  51     HS{ } clone visited set
  52     entry>> <dlist> [ push-back ] keep
  53     [ dup '[ process-block _ push-all-back ] slurp-deque ] { } make ;
  54
  55 PRIVATE>
  56
  57 : linearization-order ( cfg -- bbs )
  58     {
  59         [ needs-post-order ]
  60         [ needs-loops ]
  61         [ needs-predecessors ]
  62         [
  63             dup linear-order>> [ ] [
  64                 dup (linearization-order)
  65                 >>linear-order linear-order>>
  66             ] ?if
  67         ]
  68     } cleave ;
  69
  70 SYMBOL: numbers
  71
  72 : block-number ( bb -- n ) numbers get at ;
  73
  74 : number-blocks ( bbs -- )
  75     H{ } zip-index-as numbers set ;
  76
  77 : cfg>insns ( cfg -- insns )
  78     linearization-order [ instructions>> ] map concat ;