mlton/ssa/global.fun

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 1999-2005, 2008 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 Global (S: GLOBAL_STRUCTS): GLOBAL =
  11 struct
  12
  13 open S
  14 open Exp
  15
  16 fun equalss (xs, xs') = Vector.equals (xs, xs', Var.equals)
  17
  18 val expEquals =
  19    fn (ConApp {con = c, args}, ConApp {con = c', args = args'}) =>
  20          Con.equals (c, c') andalso equalss (args, args')
  21     | (Const c, Const c') => Const.equals (c, c')
  22     | (PrimApp {prim = p, targs = ts, args = xs},
  23        PrimApp {prim = p', targs = ts', args = xs'}) =>
  24          let
  25             datatype z = datatype Prim.Name.t
  26             val n = Prim.name p
  27             val n' = Prim.name p'
  28          in
  29             case (n, n') of
  30                (Vector_vector, Vector_vector) =>
  31                   Vector.equals (ts, ts', Type.equals)
  32                   andalso equalss (xs, xs')
  33              | _ => false
  34          end
  35     | (Tuple xs, Tuple xs') => equalss (xs, xs')
  36     | _ => false
  37
  38 fun make () =
  39    let
  40       type bind = {var: Var.t, ty: Type.t, exp: Exp.t}
  41       val binds: bind list ref = ref []
  42       fun all () = Vector.fromList
  43                    (List.revMap
  44                     (!binds, fn {var, ty, exp} =>
  45                      Statement.T {var = SOME var, ty = ty, exp = exp}))
  46                    before binds := []
  47       val set: (word * bind) HashSet.t = HashSet.new {hash = #1}
  48       fun new (ty: Type.t, exp: Exp.t): Var.t =
  49          let
  50             val hash = hash exp
  51          in
  52             #var
  53             (#2
  54              (HashSet.lookupOrInsert
  55               (set, hash,
  56                fn (_, {exp = exp', ...}) => expEquals (exp, exp'),
  57                fn () =>
  58                let
  59                   val x = Var.newString "global"
  60                   val bind = {var = x, ty = ty, exp = exp}
  61                in List.push (binds, bind)
  62                   ; (hash, bind)
  63                end)))
  64          end
  65    in {new = new, all = all}
  66    end
  67 end