Ur/Web: src/monoize.sml comparison

comparison src/monoize.sml @ 1287:5137b0537c92

Polymorphic variants

author	Adam Chlipala <adam@chlipala.net>
date	Thu, 19 Aug 2010 17:28:52 -0400
parents	a9a500d22ebc
children	fc7ecf8883b1

comparison

equal deleted inserted replaced

-:829da30fb808
+:5137b0537c92
 structure L' = Mono
 structure IM = IntBinaryMap
 structure IS = IntBinarySet
-structure SS = BinarySetFn(struct
+structure SK = struct
 type ord_key = string
 val compare = String.compare
+end
+structure SS = BinarySetFn(SK)
+structure SM = BinaryMapFn(SK)
+structure RM = BinaryMapFn(struct
+type ord_key = (string * L'.typ) list
+fun compare (r1, r2) = MonoUtil.Typ.compare ((L'.TRecord r1, E.dummySpan),
+(L'.TRecord r2, E.dummySpan))
 end)
+val nextPvar = ref 0
+val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map)
+val pvarDefs = ref ([] : L'.decl list)
+fun choosePvar () =
+let
+val n = !nextPvar
+in
+nextPvar := n + 1;
+n
+end
+fun pvar (r, loc) =
+case RM.find (!pvars, r) of
+NONE =>
+let
+val n = choosePvar ()
+val fs = map (fn (x, t) => (x, choosePvar (), t)) r
+val fs' = foldl (fn ((x, n, _), fs') => SM.insert (fs', x, n)) SM.empty fs
+in
+pvars := RM.insert (!pvars, r, (n, fs));
+pvarDefs := (L'.DDatatype [("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)], loc)
+:: !pvarDefs;
+(n, fs)
+end
+| SOME v => v
 val singletons = SS.addList (SS.empty,
 ["link",
 "br",
 "p",
 | L.CApp ((L.CFfi ("Basis", "option"), _), t) =>
 (L'.TOption (mt env dtmap t), loc)
 | L.CApp ((L.CFfi ("Basis", "list"), _), t) =>
 (L'.TList (mt env dtmap t), loc)
+| L.CApp ((L.CFfi ("Basis", "variant"), _), (L.CRecord ((L.KType, _), xts), _)) =>
+let
+val xts = map (fn (x, t) => (monoName env x, mt env dtmap t)) xts
+val xts = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts
+val (n, cs) = pvar (xts, loc)
+val cs = map (fn (x, n, t) => (x, n, SOME t)) cs
+in
+(L'.TDatatype (n, ref (ElabUtil.classifyDatatype cs, cs)), loc)
+end
 | L.CApp ((L.CFfi ("Basis", "monad"), _), _) =>
 (L'.TRecord [], loc)
 | L.CApp ((L.CFfi ("Basis", "eq"), _), t) =>
 map = M.empty,
 listMap = M.empty,
 decls = []
 }
+fun chooseNext count =
+let
+val n = !nextPvar
+in
+if count < n then
+(count, count+1)
+else
+(nextPvar := n + 1;
+(n, n+1))
+end
 fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
-fun freshName {count, map, listMap, decls} = (count, {count = count + 1, map = map, listMap = listMap, decls = decls})
+fun freshName {count, map, listMap, decls} =
+let
+val (next, count) = chooseNext count
+in
+(next, {count = count , map = map, listMap = listMap, decls = decls})
+end
 fun decls ({decls, ...} : t) = decls
 fun lookup (t as {count, map, listMap, decls}) k n thunk =
 let
 val im = Option.getOpt (M.find (map, k), IM.empty)
 val (e, fm) = monoExp (env, st, fm) e
 in
 ((L'.ESome (monoType env t, e), loc), fm)
 end
 | L.ECon _ => poly ()
+| L.ECApp (
+(L.ECApp (
+(L.ECApp ((L.EFfi ("Basis", "make"), _), (L.CName nm, _)), _),
+t), _),
+(L.CRecord (_, xts), _)) =>
+let
+val t = monoType env t
+val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
+val xts = (nm, t) :: xts
+val xts = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts
+val (n, cs) = pvar (xts, loc)
+val cs' = map (fn (x, n, t) => (x, n, SOME t)) cs
+val cl = ElabUtil.classifyDatatype cs'
+in
+case List.find (fn (nm', _, _) => nm' = nm) cs of
+NONE => raise Fail "Monoize: Polymorphic variant tag mismatch for 'make'"
+| SOME (_, n', _) => ((L'.EAbs ("x", t, (L'.TDatatype (n, ref (cl, cs')), loc),
+(L'.ECon (cl, L'.PConVar n', SOME (L'.ERel 0, loc)), loc)), loc),
+fm)
+end
+| L.ECApp (
+(L.ECApp ((L.EFfi ("Basis", "match"), _), (L.CRecord (_, xts), _)), _),
+t) =>
+let
+val t = monoType env t
+val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
+val xts = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts
+val (n, cs) = pvar (xts, loc)
+val cs' = map (fn (x, n, t) => (x, n, SOME t)) cs
+val cl = ElabUtil.classifyDatatype cs'
+val fs = (L'.TRecord (map (fn (x, t') => (x, (L'.TFun (t', t), loc))) xts), loc)
+val dt = (L'.TDatatype (n, ref (cl, cs')), loc)
+in
+((L'.EAbs ("v",
+dt,
+(L'.TFun (fs, t), loc),
+(L'.EAbs ("fs", fs, t,
+(L'.ECase ((L'.ERel 1, loc),
+map (fn (x, n', t') =>
+((L'.PCon (cl, L'.PConVar n', SOME (L'.PVar ("x", t'), loc)), loc),
+(L'.EApp ((L'.EField ((L'.ERel 1, loc), x), loc),
+(L'.ERel 0, loc)), loc))) cs,
+{disc = dt, result = t}), loc)), loc)), loc),
+fm)
+end
 | L.ECApp ((L.EFfi ("Basis", "eq"), _), t) =>
 let
 val t = monoType env t
 val b = (L'.TFfi ("Basis", "bool"), loc)
 datatype expungable = Client | Channel
 fun monoize env file =
 let
+val () = pvars := RM.empty
 (* Calculate which exported functions need cookie signature protection *)
 val rcook = foldl (fn ((d, _), rcook) =>
 case d of
 L.DExport (L.Action L.ReadCookieWrite, n, _) => IS.add (rcook, n)
 | L.DExport (L.Rpc L.ReadCookieWrite, n, _) => IS.add (rcook, n)
 foldl (fn ((d, _), e) =>
 case d of
 L.DTable (_, _, xts, tab, _, _, _, _) => doTable (tab, #1 xts, e)
 | _ => e) e file
 end
+val mname = CoreUtil.File.maxName file + 1
+val () = nextPvar := mname
 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
 case #1 d of
 L.DDatabase s =>
 let
 :: (dExp, loc)
 :: (dIni, loc)
 :: ds)
 end
 | _ =>
-case monoDecl (env, fm) d of
+(pvarDefs := [];
-NONE => (env, fm, ds)
+case monoDecl (env, fm) d of
-| SOME (env, fm, ds') =>
+NONE => (env, fm, ds)
-(env,
+| SOME (env, fm, ds') =>
-Fm.enter fm,
+(env,
-ds' @ Fm.decls fm @ ds))
+Fm.enter fm,
-(env, Fm.empty (CoreUtil.File.maxName file + 1), []) file
+ds' @ Fm.decls fm @ !pvarDefs @ ds)))
+(env, Fm.empty mname, []) file
 in
+pvars := RM.empty;
+pvarDefs := [];
 rev ds
 end
 end

Mercurial > urweb

comparison src/monoize.sml @ 1287:5137b0537c92