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