mlton/xml/monomorphise.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 Monomorphise (S: MONOMORPHISE_STRUCTS): MONOMORPHISE =
  10 struct
  11
  12 open S
  13 open Xml.Atoms
  14 local
  15    open Xml
  16 in
  17    structure Xcases = Cases
  18    structure Xpat = Pat
  19    structure Xdec = Dec
  20    structure Xexp = Exp
  21    structure Xlambda = Lambda
  22    structure XprimExp = PrimExp
  23    structure Xprogram = Program
  24    structure Xtype = Type
  25    structure XvarExp = VarExp
  26 end
  27 local
  28    open Sxml
  29 in
  30    structure Scases = Cases
  31    structure Spat = Pat
  32    structure Sdec = Dec
  33    structure Sexp = Exp
  34    structure Slambda = Lambda
  35    structure SprimExp = PrimExp
  36    structure Sprogram = Program
  37    structure Stype = Type
  38    structure SvarExp = VarExp
  39 end
  40
  41 structure Cache:
  42    sig
  43       type 'a t
  44       val new: unit -> 'a t
  45       val getOrAdd: 'a t * Stype.t vector * (unit -> 'a) -> 'a
  46       val toList: 'a t -> (Stype.t vector * 'a) list
  47    end =
  48    struct
  49       type 'a t = (Stype.t vector * Word.t * 'a) HashSet.t
  50
  51       local
  52          val generator: Word.t = 0wx5555
  53          val base = Random.word ()
  54       in
  55          fun hash ts =
  56             Vector.fold (ts, base, fn (t, w) =>
  57                          Word.xorb (w * generator, Stype.hash t))
  58          fun equal (ts, ts') =
  59             Vector.equals (ts, ts', Stype.equals)
  60       end
  61
  62       fun new () : 'a t = HashSet.new {hash = #2}
  63
  64       fun getOrAdd (c, ts, th) =
  65          let
  66             val hash = hash ts
  67          in
  68             (#3 o HashSet.lookupOrInsert)
  69             (c, hash, fn (ts', _, _) => equal (ts, ts'),
  70              fn () => (ts, hash, th ()))
  71          end
  72
  73       fun toList c = HashSet.fold (c, [], fn ((ts, _, v), l) => (ts, v) :: l)
  74    end
  75
  76 fun monomorphise (Xprogram.T {datatypes, body, ...}): Sprogram.t =
  77    let
  78       val {get = getVar: Var.t -> (Stype.t vector -> SvarExp.t),
  79            set = setVar, ...} =
  80          Property.getSet (Var.plist, Property.initRaise ("var", Var.layout))
  81       val setVar =
  82          Trace.trace2
  83          ("Monomorphise.setVar", Var.layout, Layout.ignore, Unit.layout)
  84          setVar
  85       val getVar =
  86          Trace.trace
  87          ("Monomorphise.getVar", Var.layout, Layout.ignore)
  88          getVar
  89       val {get = getCon: Con.t -> (Stype.t vector -> Con.t),
  90            set = setCon, destroy = destroyCon} =
  91          Property.destGetSet (Con.plist, Property.initRaise ("mono", Con.layout))
  92       val {get = getTycon: Tycon.t -> Stype.t vector -> Stype.t,
  93            set = setTycon, destroy = destroyTycon} =
  94          Property.destGetSet (Tycon.plist,
  95                               Property.initRaise ("mono", Tycon.layout))
  96       val _ =
  97          List.foreach (Tycon.prims, fn {tycon = t, ...} =>
  98                        setTycon (t, fn ts => Stype.con (t, ts)))
  99       val {set = setTyvar, get = getTyvar: Tyvar.t -> Stype.t, ...} =
 100          Property.getSet (Tyvar.plist,
 101                           Property.initRaise ("tyvar", Tyvar.layout))
 102       val getTyvar =
 103          Trace.trace
 104          ("Monomorphise.getTyvar", Tyvar.layout, Stype.layout)
 105          getTyvar
 106       val setTyvar =
 107          Trace.trace2
 108          ("Monomorphise.setTyvar", Tyvar.layout, Stype.layout, Unit.layout)
 109          setTyvar
 110       fun setTyvars (tyvs, tys) = Vector.foreach2 (tyvs, tys, setTyvar)
 111       val setTyvars =
 112          Trace.trace2
 113          ("Monomorphise.setTyvars", Vector.layout Tyvar.layout, Vector.layout Stype.layout, Unit.layout)
 114          setTyvars
 115       fun monoType (t: Xtype.t): Stype.t =
 116          Xtype.hom {ty = t,
 117                     var = getTyvar,
 118                     con = fn (c, ts) => getTycon c ts}
 119       val monoType =
 120          Trace.trace
 121          ("Monomorphise.monoType", Xtype.layout, Stype.layout)
 122          monoType
 123       fun monoTypeOpt (to: Xtype.t option): Stype.t option =
 124          case to of
 125             NONE => NONE
 126           | SOME t => SOME (monoType t)
 127       fun monoTypes ts = Vector.map (ts, monoType)
 128       fun monoVar (x: Var.t, ts: Xtype.t vector): SvarExp.t = getVar x (monoTypes ts)
 129       val monoVar =
 130          Trace.trace2
 131          ("Monomorphise.monoVar",
 132           Var.layout, Vector.layout Xtype.layout, SvarExp.layout)
 133          monoVar
 134       fun monoCon (c: Con.t, ts: Xtype.t vector): Con.t = getCon c (monoTypes ts)
 135       val monoCon =
 136          Trace.trace2
 137          ("Monomorphise.monoCon",
 138           Con.layout, Vector.layout Xtype.layout, Con.layout)
 139          monoCon
 140       (* It is necessary to create new variables for monomorphic variables
 141        * because they still may have type variables in their type.
 142        *)
 143       fun renameMono (x, t) =
 144          let
 145             val x' = Var.new x
 146             val ve = SvarExp.mono x'
 147             fun inst ts =
 148                if Vector.isEmpty ts
 149                   then ve
 150                else Error.bug "Monomorphise.renameMono: expected monomorphic instance"
 151             val _ = setVar (x, inst)
 152          in
 153             (x', monoType t)
 154          end
 155       val renameMono =
 156          Trace.trace2
 157          ("Monomorphise.renameMono",
 158           Var.layout, Xtype.layout, Layout.tuple2 (Var.layout, Stype.layout))
 159          renameMono
 160       fun monoPat (Xpat.T {con, targs, arg}): Spat.t =
 161          let
 162             val con = monoCon (con, targs)
 163          in
 164             Spat.T {con = con, targs = Vector.new0 (),
 165                     arg = (case arg of
 166                               NONE => NONE
 167                             | SOME x => SOME (renameMono x))}
 168          end
 169       val monoPat =
 170          Trace.trace
 171          ("Monomorphise.monoPat", Xpat.layout, Spat.layout)
 172          monoPat
 173       val traceMonoExp =
 174          Trace.trace
 175          ("Monomorphise.monoExp", Xexp.layout, Sexp.layout)
 176       val traceMonoDec =
 177          Trace.trace
 178          ("Monomorphise.monoDec",
 179           Xdec.layout, fn (_: unit -> Sdec.t list) => Layout.empty)
 180       (*------------------------------------*)
 181       (*             datatypes              *)
 182       (*------------------------------------*)
 183       val newDbs: {tyvars: Tyvar.t vector,
 184                    types: Stype.t vector,
 185                    tycon: Tycon.t,
 186                    ty: Stype.t,
 187                    cons: {con: Con.t,
 188                           typ: Xtype.t option,
 189                           used: bool} ref vector} list ref = ref []
 190       val _ =
 191          Vector.foreach
 192          (datatypes, fn {tyvars, tycon, cons} =>
 193           let
 194              val cache = Cache.new ()
 195              fun instantiate ts =
 196                 Cache.getOrAdd
 197                 (cache, ts, fn () =>
 198                  let
 199                     val (tycon, cons) =
 200                        if Tycon.equals (tycon, Tycon.bool)
 201                           then (tycon,
 202                                 Vector.map (cons, fn {con, ...} =>
 203                                             ref {con = con, typ = NONE,
 204                                                  used = true}))
 205                        else
 206                           (Tycon.new tycon,
 207                            Vector.map (cons, fn {con, arg} =>
 208                                        ref {con = con, typ = arg,
 209                                             used = false}))
 210                     val db =
 211                        {tyvars = tyvars,
 212                         types = ts,
 213                         tycon = tycon,
 214                         ty = Stype.con (tycon, Vector.new0 ()),
 215                         cons = cons}
 216                     val _ = List.push (newDbs, db)
 217                  in
 218                     db
 219                  end)
 220              val _ = setTycon (tycon, #ty o instantiate)
 221              val _ =
 222                 Vector.foreachi
 223                 (cons, fn (n, {con, ...}) =>
 224                  setCon (con, fn ts =>
 225                          let
 226                             val r as ref {con, typ, used} =
 227                                Vector.sub (#cons (instantiate ts), n)
 228                          in if used then con
 229                             else let val con = Con.new con
 230                                  in r := {con = con, typ = typ,
 231                                           used = true}
 232                                     ; con
 233                                  end
 234                          end))
 235           in ()
 236           end)
 237       val _ = monoCon (Con.truee, Vector.new0 ())
 238       val _ = monoCon (Con.falsee, Vector.new0 ())
 239       fun finishDbs ac =
 240          let
 241             val dbs = !newDbs
 242             val _ = newDbs := []
 243          in case dbs of
 244             [] => ac
 245           | _ =>
 246                finishDbs
 247                (List.fold
 248                 (dbs, ac,
 249                  fn ({tyvars, types, tycon, cons, ...}, ac) =>
 250                  let
 251                     val cons =
 252                        Vector.keepAllMap
 253                        (cons, fn ref {con, typ, used} =>
 254                         if used
 255                            then (setTyvars (tyvars, types)
 256                                  ; SOME {con = con,
 257                                          arg = monoTypeOpt typ})
 258                         else NONE)
 259                     val cons =
 260                        if Vector.isEmpty cons
 261                           then Vector.new1 {con = Con.newNoname (), arg = NONE}
 262                        else cons
 263                  in {tycon = tycon, tyvars = Vector.new0 (), cons = cons}
 264                     :: ac
 265                  end))
 266          end
 267       (*------------------------------------*)
 268       (*              monoExp               *)
 269       (*------------------------------------*)
 270       fun monoVarExp (XvarExp.T {var, targs}) =
 271          monoVar (var, targs)
 272       val monoVarExp =
 273          Trace.trace
 274          ("Monomorphise.monoVarExp", XvarExp.layout, SvarExp.layout)
 275          monoVarExp
 276       fun monoVarExps xs = Vector.map (xs, monoVarExp)
 277       fun monoExp (arg: Xexp.t): Sexp.t =
 278          traceMonoExp
 279          (fn (e: Xexp.t) =>
 280           let
 281              val {decs, result} = Xexp.dest e
 282              val thunks =
 283                 List.fold (decs, [], fn (dec, thunks) => monoDec dec :: thunks)
 284              val result = monoVarExp result
 285              val decs =
 286                 List.fold (thunks, [], fn (thunk, decs) => thunk () @ decs)
 287           in
 288              Sexp.make {decs = decs,
 289                         result = result}
 290           end) arg
 291       and monoPrimExp (e: XprimExp.t): SprimExp.t =
 292          case e of
 293             XprimExp.App {func, arg} =>
 294                SprimExp.App {func = monoVarExp func, arg = monoVarExp arg}
 295           | XprimExp.Case {test, cases, default} =>
 296                let
 297                   val cases =
 298                      case cases of
 299                         Xcases.Con cases =>
 300                            Scases.Con (Vector.map (cases, fn (pat, exp) =>
 301                                                    (monoPat pat, monoExp exp)))
 302                       | Xcases.Word (s, v) =>
 303                            Scases.Word
 304                            (s, Vector.map (v, fn (c, e) => (c, monoExp e)))
 305
 306                in
 307                   SprimExp.Case
 308                   {test = monoVarExp test,
 309                    cases = cases,
 310                    default = Option.map (default, fn (e, r) =>
 311                                          (monoExp e, r))}
 312                end
 313           | XprimExp.ConApp {con, targs, arg} =>
 314                let val con = monoCon (con, targs)
 315                in SprimExp.ConApp {con = con, targs = Vector.new0 (),
 316                                    arg = Option.map (arg, monoVarExp)}
 317                end
 318           | XprimExp.Const c => SprimExp.Const c
 319           | XprimExp.Handle {try, catch, handler} =>
 320                SprimExp.Handle {try = monoExp try,
 321                                 catch = renameMono catch,
 322                                 handler = monoExp handler}
 323           | XprimExp.Lambda l => SprimExp.Lambda (monoLambda l)
 324           | XprimExp.PrimApp {prim, targs, args} =>
 325                SprimExp.PrimApp {args = monoVarExps args,
 326                                  prim = Prim.map (prim, monoType),
 327                                  targs = monoTypes targs}
 328           | XprimExp.Profile e => SprimExp.Profile  e
 329           | XprimExp.Raise {exn, extend} =>
 330                SprimExp.Raise {exn = monoVarExp exn, extend = extend}
 331           | XprimExp.Select {tuple, offset} =>
 332                SprimExp.Select {tuple = monoVarExp tuple, offset = offset}
 333           | XprimExp.Tuple xs => SprimExp.Tuple (monoVarExps xs)
 334           | XprimExp.Var x => SprimExp.Var (monoVarExp x)
 335       and monoLambda l: Slambda.t =
 336          let
 337             val {arg, argType, body, mayInline} = Xlambda.dest l
 338             val (arg, argType) = renameMono (arg, argType)
 339          in
 340             Slambda.make {arg = arg,
 341                           argType = argType,
 342                           body = monoExp body,
 343                           mayInline = mayInline}
 344          end
 345       (*------------------------------------*)
 346       (*              monoDec               *)
 347       (*------------------------------------*)
 348       and monoDec arg: unit -> Sdec.t list =
 349          traceMonoDec
 350          (fn (d: Xdec.t) =>
 351           case d of
 352              Xdec.MonoVal {var, ty, exp} =>
 353                 let
 354                    val (var, ty) = renameMono (var, ty)
 355                 in
 356                    fn () =>
 357                    [Sdec.MonoVal {var = var,
 358                                   ty = ty,
 359                                   exp = monoPrimExp exp}]
 360                 end
 361            | Xdec.PolyVal {var, tyvars, ty, exp} =>
 362                 let
 363                    val cache = Cache.new ()
 364                    val _ =
 365                       setVar
 366                       (var, fn ts =>
 367                        (setTyvars (tyvars, ts)
 368                         ; Cache.getOrAdd (cache, ts, fn () =>
 369                                           SvarExp.mono (Var.new var))))
 370                 in
 371                    fn () =>
 372                    List.fold
 373                    (Cache.toList cache, [], fn ((ts, ve), decs) =>
 374                     (setVar (var, fn _ => ve)
 375                      ; let
 376                           val _ = setTyvars (tyvars, ts)
 377                           val ty = monoType ty
 378                           val {decs = decs', result} = Sexp.dest (monoExp exp)
 379                        in
 380                           decs'
 381                           @ (Sdec.MonoVal {var = SvarExp.var ve,
 382                                            ty = ty,
 383                                            exp = SprimExp.Var result} :: decs)
 384                        end))
 385                 end
 386            | Xdec.Fun {tyvars, decs} =>
 387                 let
 388                    val cache = Cache.new ()
 389                    val _ =
 390                       Vector.foreachi
 391                       (decs, fn (n, {var, ...}) =>
 392                        setVar
 393                        (var, fn ts =>
 394                         (setTyvars (tyvars, ts)
 395                          ; Vector.sub (Cache.getOrAdd
 396                                        (cache, ts, fn () =>
 397                                         Vector.map (decs, SvarExp.mono o Var.new o #var)),
 398                                        n))))
 399                 in
 400                    fn () =>
 401                    List.revMap
 402                    (Cache.toList cache, fn (ts, xs) =>
 403                     (Vector.foreach2 (decs, xs, fn ({var, ...}, ve) =>
 404                                       setVar (var, fn _ => ve))
 405                      ; (Sdec.Fun
 406                         {tyvars = Vector.new0 (),
 407                          decs = (Vector.map2
 408                                  (decs, xs, fn ({ty, lambda, ...}, ve) =>
 409                                   let
 410                                      val _ = setTyvars (tyvars, ts)
 411                                      val ty = monoType ty
 412                                      val lambda = monoLambda lambda
 413                                   in
 414                                      {var = SvarExp.var ve,
 415                                       ty = ty,
 416                                       lambda = lambda}
 417                                   end))})))
 418                 end
 419            | Xdec.Exception {con, arg} =>
 420                 let
 421                    val con' =
 422                       if Con.equals (con, Con.overflow)
 423                          then
 424                             (* We avoid renaming Overflow because the closure
 425                              * converter needs to recognize it.  This is not
 426                              * safe in general, but is OK in this case because
 427                              * we know there is only one Overflow excon.
 428                              *)
 429                             con
 430                       else Con.new con
 431                    val _ = setCon (con, fn _ => con')
 432                 in
 433                    fn () =>
 434                    [Sdec.Exception {con = con',
 435                                     arg = monoTypeOpt arg}]
 436                 end) arg
 437       (*------------------------------------*)
 438       (*     main code for monomorphise     *)
 439       (*------------------------------------*)
 440       val body = monoExp body
 441       val datatypes = finishDbs []
 442       val program =
 443          Sprogram.T {datatypes = Vector.fromList datatypes,
 444                      body = body,
 445                      overflow = NONE}
 446       val _ = Sprogram.clear program
 447       val _ = destroyCon ()
 448       val _ = destroyTycon ()
 449    in
 450       program
 451    end
 452
 453 end