mlton/ssa/ssa-to-ssa2.fun

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 2004-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  *
   5  * MLton is released under a BSD-style license.
   6  * See the file MLton-LICENSE for details.
   7  *)
   8
   9 functor SsaToSsa2 (S: SSA_TO_SSA2_STRUCTS): SSA_TO_SSA2 =
  10 struct
  11
  12 open S
  13
  14 structure S = Ssa
  15 structure S2 = Ssa2
  16
  17 local
  18    open S
  19 in
  20    structure Con = Con
  21    structure Label = Label
  22    structure Prim = Prim
  23    structure Var = Var
  24 end
  25
  26 local
  27    open S2
  28 in
  29    structure Base = Base
  30    structure Prod = Prod
  31 end
  32
  33 fun convert (S.Program.T {datatypes, functions, globals, main}) =
  34    let
  35       val {get = convertType: S.Type.t -> S2.Type.t, ...} =
  36          Property.get
  37          (S.Type.plist,
  38           Property.initRec
  39           (fn (t, convertType)  =>
  40            case S.Type.dest t of
  41               S.Type.Array t => S2.Type.array1 (convertType t)
  42             | S.Type.CPointer => S2.Type.cpointer
  43             | S.Type.Datatype tycon => S2.Type.datatypee tycon
  44             | S.Type.IntInf => S2.Type.intInf
  45             | S.Type.Real s => S2.Type.real s
  46             | S.Type.Ref t => S2.Type.reff1 (convertType t)
  47             | S.Type.Thread => S2.Type.thread
  48             | S.Type.Tuple ts =>
  49                  S2.Type.tuple (Prod.make
  50                                 (Vector.map (ts, fn t =>
  51                                              {elt = convertType t,
  52                                               isMutable = false})))
  53             | S.Type.Vector t => S2.Type.vector1 (convertType t)
  54             | S.Type.Weak t => S2.Type.weak (convertType t)
  55             | S.Type.Word s => S2.Type.word s))
  56       fun convertTypes ts = Vector.map (ts, convertType)
  57       val {get = conType: Con.t -> S2.Type.t, set = setConType, ...} =
  58          Property.getSetOnce (Con.plist,
  59                               Property.initRaise ("type", Con.layout))
  60       val datatypes =
  61          Vector.map
  62          (datatypes, fn S.Datatype.T {cons, tycon} =>
  63           S2.Datatype.T
  64           {cons = Vector.map (cons, fn {args, con} =>
  65                               let
  66                                  val args =
  67                                     Prod.make
  68                                     (Vector.map (args, fn t =>
  69                                                  {elt = convertType t,
  70                                                   isMutable = false}))
  71                                  val () =
  72                                     setConType (con, S2.Type.conApp (con, args))
  73                               in
  74                                  {args = args,
  75                                   con = con}
  76                               end),
  77            tycon = tycon})
  78       fun convertPrim p = S.Prim.map (p, convertType)
  79       fun convertStatement (S.Statement.T {exp, ty, var})
  80          : S2.Statement.t vector =
  81          let
  82             val ty = convertType ty
  83             fun simple (exp: S2.Exp.t): S2.Statement.t vector =
  84                Vector.new1 (S2.Statement.Bind {exp = exp, ty = ty, var = var})
  85             fun maybeBindUnit (stmt: S2.Statement.t): S2.Statement.t vector =
  86                case var of
  87                   NONE => Vector.new1 stmt
  88                 | SOME _ =>
  89                      Vector.new2
  90                      (S2.Statement.Bind {var = var,
  91                                          ty = ty,
  92                                          exp = S2.Exp.unit},
  93                       stmt)
  94          in
  95             case exp of
  96                S.Exp.ConApp {args, con} =>
  97                   let
  98                      val sum =
  99                         case S2.Type.dest ty of
 100                            S2.Type.Datatype tycon => tycon
 101                          | _ => Error.bug "SsaToSsa2.convertStatement: strange ConApp"
 102                      val variant = Var.newNoname ()
 103                   in
 104                      Vector.new2
 105                      (S2.Statement.Bind {exp = S2.Exp.Object {args = args,
 106                                                               con = SOME con},
 107                                          ty = conType con,
 108                                          var = SOME variant},
 109                       S2.Statement.Bind {exp = S2.Exp.Inject {variant = variant,
 110                                                               sum = sum},
 111                                          ty = ty,
 112                                          var = var})
 113                   end
 114              | S.Exp.Const c => simple (S2.Exp.Const c)
 115              | S.Exp.PrimApp {args, prim, ...} =>
 116                   let
 117                      fun arg i = Vector.sub (args, i)
 118                      fun sub () =
 119                         simple
 120                         (S2.Exp.Select {base = Base.VectorSub {index = arg 1,
 121                                                                vector = arg 0},
 122                                         offset = 0})
 123                      datatype z = datatype Prim.Name.t
 124                    in
 125                       case Prim.name prim of
 126                          Array_sub => sub ()
 127                        | Array_update =>
 128                             maybeBindUnit
 129                             (S2.Statement.Update
 130                              {base = Base.VectorSub {index = arg 1,
 131                                                      vector = arg 0},
 132                               offset = 0,
 133                               value = arg 2})
 134                        | Ref_assign =>
 135                             maybeBindUnit
 136                             (S2.Statement.Update
 137                              {base = Base.Object (arg 0),
 138                               offset = 0,
 139                               value = arg 1})
 140                        | Ref_deref =>
 141                             simple (S2.Exp.Select {base = Base.Object (arg 0),
 142                                                    offset = 0})
 143                        | Ref_ref =>
 144                             simple (S2.Exp.Object {args = Vector.new1 (arg 0),
 145                                                    con = NONE})
 146                        | Vector_length =>
 147                             simple (S2.Exp.PrimApp {args = args,
 148                                                     prim = Prim.arrayLength})
 149                        | Vector_sub => sub ()
 150                        | Vector_vector =>
 151                             let
 152                                val siws = S2.WordSize.seqIndex ()
 153                                fun mkIStmt (iVar, i) =
 154                                   S2.Statement.Bind
 155                                   {exp = (S2.Exp.Const o S2.Const.word o S2.WordX.fromIntInf)
 156                                          (IntInf.fromInt i, siws),
 157                                    ty = S2.Type.word siws,
 158                                    var = SOME iVar}
 159                                val nVar = Var.newString "n"
 160                                val aVar = Var.newString "a"
 161                                val vStmt =
 162                                   S2.Statement.Bind
 163                                   {exp = S2.Exp.PrimApp {args = Vector.new1 aVar,
 164                                                          prim = Prim.arrayToVector},
 165                                    ty = ty,
 166                                    var = var}
 167                                val stmts =
 168                                   Vector.foldri
 169                                   (args, [vStmt], fn (i, arg, stmts) =>
 170                                    let
 171                                       val iVar = Var.newString "i"
 172                                       val iStmt = mkIStmt (iVar, i)
 173                                       val uStmt =
 174                                          S2.Statement.Update
 175                                          {base = Base.VectorSub {index = iVar,
 176                                                                  vector = aVar},
 177                                           offset = 0,
 178                                           value = arg}
 179                                    in
 180                                       iStmt::uStmt::stmts
 181                                    end)
 182                                val nStmt = mkIStmt (nVar, Vector.length args)
 183                                val aStmt =
 184                                   S2.Statement.Bind
 185                                   {exp = S2.Exp.PrimApp {args = Vector.new1 nVar,
 186                                                          prim = Prim.arrayAlloc
 187                                                                 {raw = false}},
 188                                    ty = S2.Type.array1 (S2.Type.deVector1 ty),
 189                                    var = SOME aVar}
 190                                val stmts = nStmt::aStmt::stmts
 191                             in
 192                                Vector.fromList stmts
 193                             end
 194                        | _ =>
 195                             simple (S2.Exp.PrimApp {args = args,
 196                                                     prim = convertPrim prim})
 197                    end
 198              | S.Exp.Profile e => maybeBindUnit (S2.Statement.Profile e)
 199              | S.Exp.Select {offset, tuple} =>
 200                   simple (S2.Exp.Select {base = Base.Object tuple,
 201                                          offset = offset})
 202              | S.Exp.Tuple v => simple (S2.Exp.Object {args = v, con = NONE})
 203              | S.Exp.Var x => simple (S2.Exp.Var x)
 204          end
 205       val convertStatement =
 206          Trace.trace ("SsaToSsa2.convertStatement",
 207                       S.Statement.layout,
 208                       Vector.layout S2.Statement.layout)
 209             convertStatement
 210       fun convertHandler (h: S.Handler.t): S2.Handler.t =
 211          case h of
 212             S.Handler.Caller => S2.Handler.Caller
 213           | S.Handler.Dead => S2.Handler.Dead
 214           | S.Handler.Handle l => S2.Handler.Handle l
 215       fun convertReturn (r: S.Return.t): S2.Return.t =
 216          case r of
 217             S.Return.Dead => S2.Return.Dead
 218           | S.Return.NonTail {cont, handler} =>
 219                S2.Return.NonTail {cont = cont,
 220                                   handler = convertHandler handler}
 221           | S.Return.Tail => S2.Return.Tail
 222       val extraBlocks: S2.Block.t list ref = ref []
 223       fun convertCases (cs: S.Cases.t): S2.Cases.t =
 224          case cs of
 225             S.Cases.Con v =>
 226                S2.Cases.Con
 227                (Vector.map
 228                 (v, fn (c, l) =>
 229                  let
 230                     val objectTy = conType c
 231                  in
 232                     case S2.Type.dest objectTy of
 233                        S2.Type.Object {args, ...} =>
 234                           if Prod.isEmpty args
 235                              then (c, l)
 236                           else
 237                              let
 238                                 val l' = Label.newNoname ()
 239                                 val object = Var.newNoname ()
 240                                 val (xs, statements) =
 241                                    Vector.unzip
 242                                    (Vector.mapi
 243                                     (Prod.dest args, fn (i, {elt = ty, ...}) =>
 244                                      let
 245                                         val x = Var.newNoname ()
 246                                         val exp =
 247                                            S2.Exp.Select
 248                                            {base = Base.Object object,
 249                                             offset = i}
 250                                      in
 251                                         (x,
 252                                          S2.Statement.Bind {exp = exp,
 253                                                             ty = ty,
 254                                                             var = SOME x})
 255                                      end))
 256                                 val transfer =
 257                                    S2.Transfer.Goto {args = xs, dst = l}
 258                                 val args = Vector.new1 (object, objectTy)
 259                                 val () =
 260                                    List.push
 261                                    (extraBlocks,
 262                                     S2.Block.T {args = args,
 263                                                 label = l',
 264                                                 statements = statements,
 265                                                 transfer = transfer})
 266                              in
 267                                 (c, l')
 268                              end
 269                      | _ => Error.bug "SsaToSsa2.convertCases: strange object type"
 270                  end))
 271           | S.Cases.Word v => S2.Cases.Word v
 272       fun convertTransfer (t: S.Transfer.t): S2.Transfer.t =
 273          case t of
 274             S.Transfer.Arith {args, overflow, prim, success, ty} =>
 275                S2.Transfer.Arith {args = args,
 276                                   overflow = overflow,
 277                                   prim = convertPrim prim,
 278                                   success = success,
 279                                   ty = convertType ty}
 280           | S.Transfer.Bug => S2.Transfer.Bug
 281           | S.Transfer.Call {args, func, return} =>
 282                S2.Transfer.Call {args = args,
 283                                  func = func,
 284                                  return = convertReturn return}
 285           | S.Transfer.Case {cases, default, test} =>
 286                S2.Transfer.Case {cases = convertCases cases,
 287                                  default = default,
 288                                  test = test}
 289           | S.Transfer.Goto r => S2.Transfer.Goto r
 290           | S.Transfer.Raise v => S2.Transfer.Raise v
 291           | S.Transfer.Return v => S2.Transfer.Return v
 292           | S.Transfer.Runtime {args, prim, return} =>
 293                S2.Transfer.Runtime {args = args,
 294                                     prim = convertPrim prim,
 295                                     return = return}
 296       fun convertStatements ss =
 297          Vector.concatV (Vector.map (ss, convertStatement))
 298       fun convertFormals xts = Vector.map (xts, fn (x, t) => (x, convertType t))
 299       fun convertBlock (S.Block.T {args, label, statements, transfer}) =
 300          S2.Block.T {args = convertFormals args,
 301                      label = label,
 302                      statements = convertStatements statements,
 303                      transfer = convertTransfer transfer}
 304       val functions =
 305          List.map
 306          (functions, fn f =>
 307           let
 308              val {args, blocks, mayInline, name, raises, returns, start} =
 309                 S.Function.dest f
 310              fun rr tvo = Option.map (tvo, convertTypes)
 311              val blocks = Vector.map (blocks, convertBlock)
 312              val blocks = Vector.concat [blocks, Vector.fromList (!extraBlocks)]
 313              val () = extraBlocks := []
 314           in
 315              S2.Function.new {args = convertFormals args,
 316                               blocks = blocks,
 317                               mayInline = mayInline,
 318                               name = name,
 319                               raises = rr raises,
 320                               returns = rr returns,
 321                               start = start}
 322           end)
 323       val globals = convertStatements globals
 324       val program =
 325          S2.Program.T {datatypes = datatypes,
 326                        functions = functions,
 327                        globals = globals,
 328                        main = main}
 329    in
 330       S2.shrink program
 331    end
 332
 333 end