mlton/ssa/analyze.fun

   1 (* Copyright (C) 2011,2017 Matthew Fluet.
   2  * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor Analyze (S: ANALYZE_STRUCTS): ANALYZE =
  11 struct
  12
  13 open S
  14 datatype z = datatype Exp.t
  15 datatype z = datatype Transfer.t
  16
  17 fun 'a analyze
  18    {coerce, conApp, const, filter, filterWord, fromType, layout, primApp,
  19     program = Program.T {main, globals, functions, ...},
  20     select, tuple, useFromTypeOnBinds} =
  21    let
  22       val unit = fromType Type.unit
  23       fun coerces (msg, from, to) =
  24          if Vector.length from = Vector.length to
  25             then Vector.foreach2 (from, to, fn (from, to) =>
  26                                   coerce {from = from, to = to})
  27          else Error.bug (concat ["Analyze.coerces (length mismatch: ", msg, ")"])
  28       val {get = value: Var.t -> 'a, set = setValue, ...} =
  29          Property.getSetOnce
  30          (Var.plist,
  31           Property.initRaise ("Analyze.value", Var.layout))
  32       val value = Trace.trace ("Analyze.value", Var.layout, layout) value
  33       fun values xs = Vector.map (xs, value)
  34       val {get = funcInfo, set = setFuncInfo, ...} =
  35          Property.getSetOnce
  36          (Func.plist, Property.initRaise ("Analyze.funcInfo", Func.layout))
  37       val {get = labelInfo, set = setLabelInfo, ...} =
  38          Property.getSetOnce
  39          (Label.plist, Property.initRaise ("Analyze.labelInfo", Label.layout))
  40       val labelArgs = #args o labelInfo
  41       val labelValues = #values o labelInfo
  42       fun loopArgs args =
  43          Vector.map (args, fn (x, t) =>
  44                      let val v = fromType t
  45                      in setValue (x, v)
  46                         ; v
  47                      end)
  48       val _ =
  49          List.foreach
  50          (functions, fn f =>
  51           let
  52              val {args, name, raises, returns, ...} = Function.dest f
  53           in
  54              setFuncInfo (name, {args = loopArgs args,
  55                                  raises = Option.map (raises, fn ts =>
  56                                                       Vector.map (ts, fromType)),
  57                                  returns = Option.map (returns, fn ts =>
  58                                                        Vector.map (ts, fromType))})
  59           end)
  60       fun loopTransfer (t: Transfer.t,
  61                         shouldReturns: 'a vector option,
  62                         shouldRaises: 'a vector option): unit =
  63         (case t of
  64             Arith {prim, args, overflow, success, ty} =>
  65                (coerces ("arith overflow", Vector.new0 (), labelValues overflow)
  66                 ; coerce {from = primApp {prim = prim,
  67                                           targs = Vector.new0 (),
  68                                           args = values args,
  69                                           resultType = ty,
  70                                           resultVar = NONE},
  71                           to = Vector.sub (labelValues success, 0)})
  72           | Bug => ()
  73           | Call {func, args, return, ...} =>
  74                let
  75                   val {args = formals, raises, returns} = funcInfo func
  76                   val _ = coerces ("call args/formals", values args, formals)
  77                   fun noHandler () =
  78                      case (raises, shouldRaises) of
  79                         (NONE, NONE) => ()
  80                       | (NONE, SOME _) => ()
  81                       | (SOME _, NONE) =>
  82                            Error.bug "Analyze.loopTransfer (raise mismatch)"
  83                       | (SOME vs, SOME vs') => coerces ("call caller/raises", vs, vs')
  84                   datatype z = datatype Return.t
  85                in
  86                   case return of
  87                      Dead =>
  88                         if isSome returns orelse isSome raises
  89                            then Error.bug "Analyze.loopTransfer (return mismatch at Dead)"
  90                         else ()
  91                    | NonTail {cont, handler} =>
  92                         (Option.app (returns, fn vs =>
  93                                      coerces ("call non-tail/returns", vs, labelValues cont))
  94                          ; (case handler of
  95                                Handler.Caller => noHandler ()
  96                              | Handler.Dead =>
  97                                   if isSome raises
  98                                      then Error.bug "Analyze.loopTransfer (raise mismatch at NonTail/Dead)"
  99                                   else ()
 100                              | Handler.Handle h =>
 101                                   let
 102                                      val _ =
 103                                         case raises of
 104                                            NONE => ()
 105                                          | SOME vs =>
 106                                               coerces ("call handle/raises", vs, labelValues h)
 107                                   in
 108                                      ()
 109                                   end))
 110                    | Tail =>
 111                         let
 112                            val _ = noHandler ()
 113                            val _ =
 114                               case (returns, shouldReturns) of
 115                                  (NONE, NONE) => ()
 116                                | (NONE, SOME _) => ()
 117                                | (SOME _, NONE) =>
 118                                     Error.bug "Analyze.loopTransfer (return mismatch at Tail)"
 119                                | (SOME vs, SOME vs') =>
 120                                     coerces ("call tail/returns", vs, vs')
 121                         in
 122                            ()
 123                         end
 124
 125                end
 126           | Case {test, cases, default, ...} =>
 127                let
 128                   val test = value test
 129                   fun ensureNullary j =
 130                      if Vector.isEmpty (labelValues j)
 131                         then ()
 132                      else Error.bug (concat ["Analyze.loopTransfer (case ",
 133                                              Label.toString j,
 134                                              " must be nullary)"])
 135                   fun ensureSize (w, s) =
 136                      if WordSize.equals (s, WordX.size w)
 137                         then ()
 138                      else Error.bug (concat ["Analyze.loopTransfer (case ",
 139                                              WordX.toString w,
 140                                              " must be size ",
 141                                              WordSize.toString s,
 142                                              ")"])
 143                   fun doitWord (s, cs) =
 144                      (ignore (filterWord (test, s))
 145                       ; Vector.foreach (cs, fn (w, j) =>
 146                                         (ensureSize (w, s)
 147                                          ; ensureNullary j)))
 148                   fun doitCon cs =
 149                      Vector.foreach (cs, fn (c, j) =>
 150                                      filter (test, c, labelValues j))
 151                   datatype z = datatype Cases.t
 152                   val _ =
 153                      case cases of
 154                         Con cs => doitCon cs
 155                       | Word (s, cs) => doitWord (s, cs)
 156                   val _ = Option.app (default, ensureNullary)
 157                in ()
 158                end
 159           | Goto {dst, args} => coerces ("goto", values args, labelValues dst)
 160           | Raise xs =>
 161                (case shouldRaises of
 162                    NONE => Error.bug "Analyze.loopTransfer (raise mismatch at Raise)"
 163                  | SOME vs => coerces ("raise", values xs, vs))
 164           | Return xs =>
 165                (case shouldReturns of
 166                    NONE => Error.bug "Analyze.loopTransfer (return mismatch at Return)"
 167                  | SOME vs => coerces ("return", values xs, vs))
 168           | Runtime {prim, args, return} =>
 169                let
 170                   val xts = labelArgs return
 171                   val (resultVar, resultType) =
 172                      if Vector.isEmpty xts
 173                         then (NONE, Type.unit)
 174                      else
 175                         let
 176                            val (x, t) = Vector.first xts
 177                         in
 178                            (SOME x, t)
 179                         end
 180                   val _ =
 181                      primApp {prim = prim,
 182                               targs = Vector.new0 (),
 183                               args = values args,
 184                               resultType = resultType,
 185                               resultVar = resultVar}
 186                in
 187                   ()
 188                end)
 189         handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Transfer.layout t)])
 190       val loopTransfer =
 191          Trace.trace3
 192          ("Analyze.loopTransfer",
 193           Transfer.layout,
 194           Option.layout (Vector.layout layout),
 195           Option.layout (Vector.layout layout),
 196           Layout.ignore)
 197          loopTransfer
 198       fun loopStatement (s as Statement.T {var, exp, ty}): unit =
 199          let
 200             val v =
 201                case exp of
 202                   ConApp {con, args} => conApp {con = con, args = values args}
 203                 | Const c => const c
 204                 | PrimApp {prim, targs, args, ...} =>
 205                      primApp {prim = prim,
 206                               targs = targs,
 207                               args = values args,
 208                               resultType = ty,
 209                               resultVar = var}
 210                 | Profile _ => unit
 211                 | Select {tuple, offset} =>
 212                      select {tuple = value tuple,
 213                              offset = offset,
 214                              resultType = ty}
 215                 | Tuple xs =>
 216                      if 1 = Vector.length xs
 217                         then Error.bug "Analyze.loopStatement (unary tuple)"
 218                      else tuple (values xs)
 219                 | Var x => value x
 220          in
 221             Option.app
 222             (var, fn var =>
 223              if useFromTypeOnBinds
 224                 then let
 225                         val v' = fromType ty
 226                         val _ = coerce {from = v, to = v'}
 227                         val _ = setValue (var, v')
 228                      in
 229                         ()
 230                      end
 231              else setValue (var, v))
 232          end
 233          handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Statement.layout s)])
 234       val loopStatement =
 235          Trace.trace ("Analyze.loopStatement", Statement.layout, Unit.layout)
 236          loopStatement
 237       val _ = coerces ("main", Vector.new0 (), #args (funcInfo main))
 238       val _ = Vector.foreach (globals, loopStatement)
 239               handle exn => Error.reraiseSuffix (exn, concat [" in Globals"])
 240       val _ =
 241          List.foreach
 242          (functions, fn f =>
 243           let
 244              val {blocks, name, start, ...} = Function.dest f
 245              val _ =
 246                 Vector.foreach
 247                 (blocks, fn b as Block.T {label, args, ...} =>
 248                  setLabelInfo (label, {args = args,
 249                                        block = b,
 250                                        values = loopArgs args,
 251                                        visited = ref false}))
 252              val {returns, raises, ...} = funcInfo name
 253              fun visit (l: Label.t) =
 254                 let
 255                    val {block, visited, ...} = labelInfo l
 256                 in
 257                    if !visited
 258                       then ()
 259                    else
 260                       let
 261                          val _ = visited := true
 262                          val Block.T {statements, transfer, ...} = block
 263                          val _ = (Vector.foreach (statements, loopStatement)
 264                                   ; loopTransfer (transfer, returns, raises))
 265                                  handle exn => Error.reraiseSuffix (exn, concat [" in ", Label.toString l])
 266                       in
 267                          Transfer.foreachLabel (transfer, visit)
 268                       end
 269                 end
 270
 271              val _ = visit start
 272           in
 273              ()
 274           end
 275           handle exn => Error.reraiseSuffix (exn, concat [" in ", Func.toString (Function.name f)]))
 276    in
 277       {func = funcInfo,
 278        label = labelValues,
 279        value = value}
 280    end
 281
 282 end