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: 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 get ?adjoin [
  62         [ , ]
  63         [ sorted-successors [ process-successor ] each ]
  64         bi
  65     ] [ drop ] if ;
  66
  67 : (linearization-order) ( cfg -- bbs )
  68     init-linearization-order
  69
  70     [ work-list get [ process-block ] slurp-deque ] { } make
  71     ! [ unlikely?>> not ] partition append
  72     ;
  73
  74 PRIVATE>
  75
  76 : linearization-order ( cfg -- bbs )
  77     {
  78         [ needs-post-order ]
  79         [ needs-loops ]
  80         [ needs-predecessors ]
  81         [
  82             dup linear-order>> [ ] [
  83                 dup (linearization-order)
  84                 >>linear-order linear-order>>
  85             ] ?if
  86         ]
  87     } cleave ;
  88
  89 SYMBOL: numbers
  90
  91 : block-number ( bb -- n ) numbers get at ;
  92
  93 : number-blocks ( bbs -- )
  94     H{ } zip-index-as numbers set ;
  95
  96 : cfg>insns ( cfg -- insns )
  97     linearization-order [ instructions>> ] map concat ;