Mercurial > urweb

comparison src/monoize.sml @ 188:8e9f97508f0d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Datatype representation optimization
author Adam Chlipala <adamc@hcoop.net>
date Sun, 03 Aug 2008 19:49:21 -0400
parents 88d46972de53
children 3eb53c957d10
comparison
equal deleted inserted replaced
187:fb6ed259f5bd 188:8e9f97508f0d
31 structure Env = CoreEnv 31 structure Env = CoreEnv
32 32
33 structure L = Core 33 structure L = Core
34 structure L' = Mono 34 structure L' = Mono
35 35
36 val dummyTyp = (L'.TDatatype (0, []), E.dummySpan) 36 val dummyTyp = (L'.TDatatype (L'.Enum, 0, []), E.dummySpan)
37 37
38 fun monoName env (all as (c, loc)) = 38 fun monoName env (all as (c, loc)) =
39 let 39 let
40 fun poly () = 40 fun poly () =
41 (E.errorAt loc "Unsupported name constructor"; 41 (E.errorAt loc "Unsupported name constructor";
71 let 71 let
72 val (_, xncs) = Env.lookupDatatype env n 72 val (_, xncs) = Env.lookupDatatype env n
73 73
74 val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs 74 val xncs = map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs
75 in 75 in
76 (L'.TDatatype (n, xncs), loc) 76 (L'.TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc)
77 end 77 end
78 | L.CFfi mx => (L'.TFfi mx, loc) 78 | L.CFfi mx => (L'.TFfi mx, loc)
79 | L.CApp _ => poly () 79 | L.CApp _ => poly ()
80 | L.CAbs _ => poly () 80 | L.CAbs _ => poly ()
81 81
200 | _ => 200 | _ =>
201 case t of 201 case t of
202 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm) 202 L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
203 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) 203 | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
204 204
205 | L'.TDatatype (i, _) => 205 | L'.TDatatype (dk, i, _) =>
206 let 206 let
207 fun makeDecl n fm = 207 fun makeDecl n fm =
208 let 208 let
209 val (x, xncs) = Env.lookupDatatype env i 209 val (x, xncs) = Env.lookupDatatype env i
210 210
211 val (branches, fm) = 211 val (branches, fm) =
212 ListUtil.foldlMap 212 ListUtil.foldlMap
213 (fn ((x, n, to), fm) => 213 (fn ((x, n, to), fm) =>
214 case to of 214 case to of
215 NONE => 215 NONE =>
216 (((L'.PCon (L'.PConVar n, NONE), loc), 216 (((L'.PCon (dk, L'.PConVar n, NONE), loc),
217 (L'.EPrim (Prim.String x), loc)), 217 (L'.EPrim (Prim.String x), loc)),
218 fm) 218 fm)
219 | SOME t => 219 | SOME t =>
220 let 220 let
221 val t = monoType env t 221 val t = monoType env t
222 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t) 222 val (arg, fm) = fooify fm ((L'.ERel 0, loc), t)
223 in 223 in
224 (((L'.PCon (L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc), 224 (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc),
225 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc), 225 (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc),
226 arg), loc)), 226 arg), loc)),
227 fm) 227 fm)
228 end) 228 end)
229 fm xncs 229 fm xncs
287 end 287 end
288 288
289 fun monoPatCon env pc = 289 fun monoPatCon env pc =
290 case pc of 290 case pc of
291 L.PConVar n => L'.PConVar n 291 L.PConVar n => L'.PConVar n
292 | L.PConFfi {mod = m, datatyp, con, arg} => L'.PConFfi {mod = m, datatyp = datatyp, con = con, 292 | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
293 arg = Option.map (monoType env) arg} 293 arg = Option.map (monoType env) arg}
294 294
295 fun monoPat env (p, loc) = 295 fun monoPat env (p, loc) =
296 case p of 296 case p of
297 L.PWild => (L'.PWild, loc) 297 L.PWild => (L'.PWild, loc)
298 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) 298 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
299 | L.PPrim p => (L'.PPrim p, loc) 299 | L.PPrim p => (L'.PPrim p, loc)
300 | L.PCon (pc, po) => (L'.PCon (monoPatCon env pc, Option.map (monoPat env) po), loc) 300 | L.PCon (dk, pc, po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
301 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc) 301 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
302 302
303 fun monoExp (env, st, fm) (all as (e, loc)) = 303 fun monoExp (env, st, fm) (all as (e, loc)) =
304 let 304 let
305 fun poly () = 305 fun poly () =
309 in 309 in
310 case e of 310 case e of
311 L.EPrim p => ((L'.EPrim p, loc), fm) 311 L.EPrim p => ((L'.EPrim p, loc), fm)
312 | L.ERel n => ((L'.ERel n, loc), fm) 312 | L.ERel n => ((L'.ERel n, loc), fm)
313 | L.ENamed n => ((L'.ENamed n, loc), fm) 313 | L.ENamed n => ((L'.ENamed n, loc), fm)
314 | L.ECon (pc, eo) => 314 | L.ECon (dk, pc, eo) =>
315 let 315 let
316 val (eo, fm) = 316 val (eo, fm) =
317 case eo of 317 case eo of
318 NONE => (NONE, fm) 318 NONE => (NONE, fm)
319 | SOME e => 319 | SOME e =>
321 val (e, fm) = monoExp (env, st, fm) e 321 val (e, fm) = monoExp (env, st, fm) e
322 in 322 in
323 (SOME e, fm) 323 (SOME e, fm)
324 end 324 end
325 in 325 in
326 ((L'.ECon (monoPatCon env pc, eo), loc), fm) 326 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
327 end 327 end
328 | L.EFfi mx => ((L'.EFfi mx, loc), fm) 328 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
329 | L.EFfiApp (m, x, es) => 329 | L.EFfiApp (m, x, es) =>
330 let 330 let
331 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es 331 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es