# HG changeset patch # User Ziv Scully # Date 1442861647 14400 # Node ID d665925acff856342de43ad524c946de5d7309dd # Parent e843a04499d48f4a2300ee98c34c77ef42182631 Factor out [Monoize.Fm] to make it accessible to [Sqlcache]. diff -r e843a04499d4 -r d665925acff8 src/mono_fm.sig --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_fm.sig Mon Sep 21 14:54:07 2015 -0400 @@ -0,0 +1,22 @@ +signature MONO_FM = sig + type t + + type vr = string * int * Mono.typ * Mono.exp * string + + datatype foo_kind = + Attr + | Url + + val empty : int -> t + + val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int + val lookupList : t -> foo_kind -> Mono.typ -> (int -> t -> vr * t) -> t * int + val enter : t -> t + val decls : t -> Mono.decl list + + val freshName : t -> int * t + + (* TODO: don't expose raw references if possible. *) + val nextPvar : int ref + val postMonoize : t ref +end diff -r e843a04499d4 -r d665925acff8 src/mono_fm.sml --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mono_fm.sml Mon Sep 21 14:54:07 2015 -0400 @@ -0,0 +1,115 @@ +(* TODO: better name than "fm"? *) +structure MonoFm : MONO_FM = struct + +open Mono + +type vr = string * int * typ * exp * string + +datatype foo_kind = + Attr + | Url + +structure IM = IntBinaryMap + +structure M = BinaryMapFn(struct + type ord_key = foo_kind + fun compare x = + case x of + (Attr, Attr) => EQUAL + | (Attr, _) => LESS + | (_, Attr) => GREATER + + | (Url, Url) => EQUAL + end) + +structure TM = BinaryMapFn(struct + type ord_key = typ + val compare = MonoUtil.Typ.compare + end) + +type t = { + count : int, + map : int IM.map M.map, + listMap : int TM.map M.map, + decls : vr list +} + +val nextPvar = ref 0 + +fun empty count = { + count = count, + 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} = + let + val (next, count) = chooseNext count + in + (next, {count = count , map = map, listMap = listMap, decls = decls}) + end +fun decls ({decls, ...} : t) = + case decls of + [] => [] + | _ => [(DValRec decls, ErrorMsg.dummySpan)] + +fun lookup (t as {count, map, listMap, decls}) k n thunk = + let + val im = Option.getOpt (M.find (map, k), IM.empty) + in + case IM.find (im, n) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = M.insert (map, k, IM.insert (im, n, n')), + listMap = listMap, + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +fun lookupList (t as {count, map, listMap, decls}) k tp thunk = + let + val tm = Option.getOpt (M.find (listMap, k), TM.empty) + in + case TM.find (tm, tp) of + NONE => + let + val n' = count + val (d, {count, map, listMap, decls}) = + thunk count {count = count + 1, + map = map, + listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), + decls = decls} + in + ({count = count, + map = map, + listMap = listMap, + decls = d :: decls}, n') + end + | SOME n' => (t, n') + end + +val postMonoize : t ref = ref (empty 0) + +end diff -r e843a04499d4 -r d665925acff8 src/monoize.sml --- a/src/monoize.sml Mon Sep 21 10:16:55 2015 -0400 +++ b/src/monoize.sml Mon Sep 21 14:54:07 2015 -0400 @@ -50,7 +50,7 @@ (L'.TRecord r2, E.dummySpan)) end) -val nextPvar = ref 0 +val nextPvar = MonoFm.nextPvar val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list) val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list) @@ -374,131 +374,12 @@ val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) -structure IM = IntBinaryMap - -datatype foo_kind = - Attr - | Url +structure Fm = MonoFm fun fk2s fk = case fk of - Attr => "attr" - | Url => "url" - -type vr = string * int * L'.typ * L'.exp * string - -structure Fm :> sig - type t - - val empty : int -> t - - val lookup : t -> foo_kind -> int -> (int -> t -> vr * t) -> t * int - val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> vr * t) -> t * int - val enter : t -> t - val decls : t -> L'.decl list - - val freshName : t -> int * t -end = struct - -structure M = BinaryMapFn(struct - type ord_key = foo_kind - fun compare x = - case x of - (Attr, Attr) => EQUAL - | (Attr, _) => LESS - | (_, Attr) => GREATER - - | (Url, Url) => EQUAL - end) - -structure TM = BinaryMapFn(struct - type ord_key = L'.typ - val compare = MonoUtil.Typ.compare - end) - -type t = { - count : int, - map : int IM.map M.map, - listMap : int TM.map M.map, - decls : vr list -} - -fun empty count = { - count = count, - 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} = - let - val (next, count) = chooseNext count - in - (next, {count = count , map = map, listMap = listMap, decls = decls}) - end -fun decls ({decls, ...} : t) = - case decls of - [] => [] - | _ => [(L'.DValRec decls, ErrorMsg.dummySpan)] - -fun lookup (t as {count, map, listMap, decls}) k n thunk = - let - val im = Option.getOpt (M.find (map, k), IM.empty) - in - case IM.find (im, n) of - NONE => - let - val n' = count - val (d, {count, map, listMap, decls}) = - thunk count {count = count + 1, - map = M.insert (map, k, IM.insert (im, n, n')), - listMap = listMap, - decls = decls} - in - ({count = count, - map = map, - listMap = listMap, - decls = d :: decls}, n') - end - | SOME n' => (t, n') - end - -fun lookupList (t as {count, map, listMap, decls}) k tp thunk = - let - val tm = Option.getOpt (M.find (listMap, k), TM.empty) - in - case TM.find (tm, tp) of - NONE => - let - val n' = count - val (d, {count, map, listMap, decls}) = - thunk count {count = count + 1, - map = map, - listMap = M.insert (listMap, k, TM.insert (tm, tp, n')), - decls = decls} - in - ({count = count, - map = map, - listMap = listMap, - decls = d :: decls}, n') - end - | SOME n' => (t, n') - end - -end - + Fm.Attr => "attr" + | Fm.Url => "url" fun capitalize s = if s = "" then @@ -677,8 +558,8 @@ fooify end -val attrifyExp = fooifyExp Attr -val urlifyExp = fooifyExp Url +val attrifyExp = fooifyExp Fm.Attr +val urlifyExp = fooifyExp Fm.Url val urlifiedUnit = let @@ -4738,7 +4619,7 @@ val mname = CoreUtil.File.maxName file + 1 val () = nextPvar := mname - val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => + val (_, fm, ds) = List.foldl (fn (d, (env, fm, ds)) => case #1 d of L.DDatabase s => let @@ -4786,6 +4667,7 @@ pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; + Fm.postMonoize := fm; (rev ds, []) end diff -r e843a04499d4 -r d665925acff8 src/sources --- a/src/sources Mon Sep 21 10:16:55 2015 -0400 +++ b/src/sources Mon Sep 21 14:54:07 2015 -0400 @@ -168,6 +168,9 @@ $(SRC)/mono_print.sig $(SRC)/mono_print.sml +$(SRC)/mono_fm.sig +$(SRC)/mono_fm.sml + $(SRC)/sql.sig $(SRC)/sql.sml