Mercurial > urweb

comparison src/monoize.sml @ 193:8a70e2919e86

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Specialization of single-parameter datatypes
author Adam Chlipala <adamc@hcoop.net>
date Fri, 08 Aug 2008 17:55:51 -0400
parents 9bbf4d383381
children 890a61991263
comparison
equal deleted inserted replaced
192:9bbf4d383381 193:8a70e2919e86
65 (L'.TFfi ("Basis", "string"), loc) 65 (L'.TFfi ("Basis", "string"), loc)
66 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => 66 | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) =>
67 (L'.TFfi ("Basis", "string"), loc) 67 (L'.TFfi ("Basis", "string"), loc)
68 68
69 | L.CRel _ => poly () 69 | L.CRel _ => poly ()
70 | L.CNamed n => raise Fail "Monoize CNamed" 70 | L.CNamed n =>
71 (*let 71 let
72 val (_, xncs) = Env.lookupDatatype env n 72 val (_, xs, 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 (MonoUtil.classifyDatatype xncs, n, xncs), loc) 76 case xs of
77 end*) 77 [] => (L'.TDatatype (MonoUtil.classifyDatatype xncs, n, xncs), loc)
78 | _ => poly ()
79 end
78 | L.CFfi mx => (L'.TFfi mx, loc) 80 | L.CFfi mx => (L'.TFfi mx, loc)
79 | L.CApp _ => poly () 81 | L.CApp _ => poly ()
80 | L.CAbs _ => poly () 82 | L.CAbs _ => poly ()
81 83
82 | L.CName _ => poly () 84 | L.CName _ => poly ()
204 206
205 | L'.TDatatype (dk, i, _) => 207 | L'.TDatatype (dk, i, _) =>
206 let 208 let
207 fun makeDecl n fm = 209 fun makeDecl n fm =
208 let 210 let
209 val (x, xncs) = raise Fail "Monoize TDataype" (*Env.lookupDatatype env i*) 211 val (x, _, xncs) = Env.lookupDatatype env i
210 212
211 val (branches, fm) = 213 val (branches, fm) =
212 ListUtil.foldlMap 214 ListUtil.foldlMap
213 (fn ((x, n, to), fm) => 215 (fn ((x, n, to), fm) =>
214 case to of 216 case to of
290 case pc of 292 case pc of
291 L.PConVar n => L'.PConVar n 293 L.PConVar n => L'.PConVar n
292 | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con, 294 | L.PConFfi {mod = m, datatyp, con, arg, ...} => L'.PConFfi {mod = m, datatyp = datatyp, con = con,
293 arg = Option.map (monoType env) arg} 295 arg = Option.map (monoType env) arg}
294 296
295 fun monoPat env (p, loc) = 297 val dummyPat = (L'.PPrim (Prim.Int 0), ErrorMsg.dummySpan)
296 case p of 298
297 L.PWild => (L'.PWild, loc) 299 fun monoPat env (all as (p, loc)) =
298 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc) 300 let
299 | L.PPrim p => (L'.PPrim p, loc) 301 fun poly () =
300 | L.PCon (dk, pc, _, po) => raise Fail "Monoize PCon" (*(L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)*) 302 (E.errorAt loc "Unsupported pattern";
301 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc) 303 Print.eprefaces' [("Pattern", CorePrint.p_pat env all)];
304 dummyPat)
305 in
306 case p of
307 L.PWild => (L'.PWild, loc)
308 | L.PVar (x, t) => (L'.PVar (x, monoType env t), loc)
309 | L.PPrim p => (L'.PPrim p, loc)
310 | L.PCon (dk, pc, [], po) => (L'.PCon (dk, monoPatCon env pc, Option.map (monoPat env) po), loc)
311 | L.PCon _ => poly ()
312 | L.PRecord xps => (L'.PRecord (map (fn (x, p, t) => (x, monoPat env p, monoType env t)) xps), loc)
313 end
302 314
303 fun monoExp (env, st, fm) (all as (e, loc)) = 315 fun monoExp (env, st, fm) (all as (e, loc)) =
304 let 316 let
305 fun poly () = 317 fun poly () =
306 (E.errorAt loc "Unsupported expression"; 318 (E.errorAt loc "Unsupported expression";
309 in 321 in
310 case e of 322 case e of
311 L.EPrim p => ((L'.EPrim p, loc), fm) 323 L.EPrim p => ((L'.EPrim p, loc), fm)
312 | L.ERel n => ((L'.ERel n, loc), fm) 324 | L.ERel n => ((L'.ERel n, loc), fm)
313 | L.ENamed n => ((L'.ENamed n, loc), fm) 325 | L.ENamed n => ((L'.ENamed n, loc), fm)
314 | L.ECon (dk, pc, _, eo) => raise Fail "Monoize ECon" 326 | L.ECon (dk, pc, [], eo) =>
315 (*let 327 let
316 val (eo, fm) = 328 val (eo, fm) =
317 case eo of 329 case eo of
318 NONE => (NONE, fm) 330 NONE => (NONE, fm)
319 | SOME e => 331 | SOME e =>
320 let 332 let
322 in 334 in
323 (SOME e, fm) 335 (SOME e, fm)
324 end 336 end
325 in 337 in
326 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm) 338 ((L'.ECon (dk, monoPatCon env pc, eo), loc), fm)
327 end*) 339 end
340 | L.ECon _ => poly ()
328 | L.EFfi mx => ((L'.EFfi mx, loc), fm) 341 | L.EFfi mx => ((L'.EFfi mx, loc), fm)
329 | L.EFfiApp (m, x, es) => 342 | L.EFfiApp (m, x, es) =>
330 let 343 let
331 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es 344 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
332 in 345 in
716 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)]; 729 Print.eprefaces' [("Declaration", CorePrint.p_decl env all)];
717 NONE) 730 NONE)
718 in 731 in
719 case d of 732 case d of
720 L.DCon _ => NONE 733 L.DCon _ => NONE
721 | L.DDatatype (x, n, _, xncs) => raise Fail "Monoize DDatatype" 734 | L.DDatatype (x, n, [], xncs) =>
722 (*let 735 let
723 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc) 736 val d = (L'.DDatatype (x, n, map (fn (x, n, to) => (x, n, Option.map (monoType env) to)) xncs), loc)
724 in 737 in
725 SOME (Env.declBinds env all, fm, d) 738 SOME (Env.declBinds env all, fm, d)
726 end*) 739 end
740 | L.DDatatype _ => poly ()
727 | L.DVal (x, n, t, e, s) => 741 | L.DVal (x, n, t, e, s) =>
728 let 742 let
729 val (e, fm) = monoExp (env, St.empty, fm) e 743 val (e, fm) = monoExp (env, St.empty, fm) e
730 in 744 in
731 SOME (Env.pushENamed env x n t NONE s, 745 SOME (Env.pushENamed env x n t NONE s,