mlton/codegen/amd64-codegen/amd64-loop-info.fun

   1 (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  * Copyright (C) 1997-2000 NEC Research Institute.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor amd64LoopInfo(S: AMD64_LOOP_INFO_STRUCTS) : AMD64_LOOP_INFO =
  10 struct
  11   open S
  12   open amd64
  13
  14   structure Graph = DirectedGraph
  15   structure Node = Graph.Node
  16   structure LoopForest = Graph.LoopForest
  17
  18   val tracer = amd64.tracer
  19
  20   datatype t = T of {getLoopInfo : Label.t ->
  21                                    {loopHeader: bool,
  22                                     loopLabels: Label.t list,
  23                                     loopPath: int list}}
  24
  25   fun createLoopInfo {chunk = Chunk.T {blocks, ...}, farLoops}
  26     = let
  27         val G = Graph.new ()
  28
  29         val {get = getNodeInfo : unit Node.t -> Label.t,
  30              set = setNodeInfo, ...}
  31           = Property.getSetOnce
  32             (Node.plist,
  33              Property.initRaise ("amd64LoopInfo:getNodeInfo", Node.layout))
  34
  35         val {get = getInfo : Label.t -> unit Node.t,
  36              destroy = destInfo}
  37           = Property.destGet
  38             (Label.plist,
  39              Property.initFun (fn l => let
  40                                          val n = Graph.newNode G
  41                                          val _ = setNodeInfo(n, l)
  42                                        in
  43                                          n
  44                                        end))
  45
  46         val {get = getLoopInfo :
  47                    Label.t ->
  48                    {loopHeader: bool,
  49                     loopLabels: Label.t list,
  50                     loopPath: int list},
  51              set = setLoopInfo, ...}
  52           = Property.getSetOnce
  53             (Label.plist,
  54              Property.initRaise ("amd64LoopInfo:getLoopInfo", Label.layout))
  55
  56         val rootLabel = Label.newString "root"
  57         val root = getInfo rootLabel
  58
  59         fun addEdge edge
  60           = ignore (Graph.addEdge (G, edge))
  61
  62         val _
  63           = List.foreach
  64             (blocks,
  65              fn Block.T {entry, transfer, ...}
  66               => let
  67                    val label = Entry.label entry
  68                    val node = getInfo label
  69
  70                    fun doit' target
  71                      = let
  72                          val node' = getInfo target
  73                        in
  74                          addEdge {from = node, to = node'}
  75                        end
  76                    fun doit'' target
  77                      = let
  78                          val node' = getInfo target
  79                        in
  80                          if farLoops
  81                            then addEdge {from = node, to = node'}
  82                            else addEdge {from = root, to = node'}
  83                        end
  84
  85                    datatype z = datatype Transfer.t
  86                  in
  87                    if Entry.isFunc entry
  88                      then addEdge {from = root, to = node}
  89                      else () ;
  90                    case transfer
  91                      of Goto {target, ...}
  92                       => doit' target
  93                       | Iff {truee, falsee, ...}
  94                       => (doit' truee;
  95                           doit' falsee)
  96                       | Switch {cases, default, ...}
  97                       => (doit' default;
  98                           Transfer.Cases.foreach(cases, doit' o #2))
  99                       | Tail {...}
 100                       => ()
 101                       | NonTail {return, handler, ...}
 102                       => (doit'' return;
 103                           case handler
 104                             of SOME handler => doit'' handler
 105                              | NONE => ())
 106                       | Return {...}
 107                       => ()
 108                       | Raise {...}
 109                       => ()
 110                       | CCall {return, func, ...}
 111                       => Option.app (return, if CFunction.mayGC func
 112                                                then doit''
 113                                                else doit')
 114                  end)
 115         val _ = destInfo ()
 116
 117         val lf = Graph.loopForestSteensgaard (G, {root = root})
 118
 119         fun doit (f: unit LoopForest.t,
 120                   headers,
 121                   path)
 122           = let
 123               val {loops, notInLoop} = LoopForest.dest f
 124               val notInLoop = Vector.toListMap (notInLoop, getNodeInfo)
 125               val path' = List.rev path
 126             in
 127               List.foreach
 128               (notInLoop, fn l =>
 129                setLoopInfo
 130                (l, {loopHeader = Vector.contains (headers, l, Label.equals),
 131                     loopLabels = notInLoop,
 132                     loopPath = path'})) ;
 133               Vector.foreachi
 134               (loops, fn (i,{headers, child}) =>
 135                doit (child,
 136                      Vector.map (headers, getNodeInfo),
 137                      i::path))
 138             end
 139         val _ = doit (lf, Vector.new0 (), [])
 140       in
 141         T {getLoopInfo = getLoopInfo}
 142       end
 143
 144   val (createLoopInfo, createLoopInfo_msg)
 145     = tracer
 146       "createLoopInfo"
 147       createLoopInfo
 148
 149   fun getLoopDistance (T {getLoopInfo, ...}, from, to)
 150     = (case (#loopPath (getLoopInfo from), #loopPath (getLoopInfo to))
 151          of ([], _) => NONE
 152           | (_, []) => NONE
 153           | (pfrom, pto)
 154           => let
 155                val rec check
 156                  = fn ([], pto) => SOME (List.length pto)
 157                     | (pfrom, []) => SOME (~(List.length pfrom))
 158                     | (f::pfrom,t::pto)
 159                     => if f = t
 160                          then check (pfrom, pto)
 161                          else NONE
 162              in
 163                check (pfrom, pto)
 164              end)
 165   fun getLoopLabels (T {getLoopInfo, ...}, label) = #loopLabels (getLoopInfo label)
 166   fun isLoopHeader (T {getLoopInfo, ...}, l) = #loopHeader (getLoopInfo l)
 167 end