Mercurial > urweb

comparison src/monoize.sml @ 1713:1b3f82b09bb0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix monoization of recursive variants
author Adam Chlipala <adam@chlipala.net>
date Mon, 16 Apr 2012 09:07:28 -0400
parents 355dc023fbb8
children 95d3b4f26f59
comparison
equal deleted inserted replaced
1712:355dc023fbb8 1713:1b3f82b09bb0
50 (L'.TRecord r2, E.dummySpan)) 50 (L'.TRecord r2, E.dummySpan))
51 end) 51 end)
52 52
53 val nextPvar = ref 0 53 val nextPvar = ref 0
54 val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map) 54 val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map)
55 val pvarDefs = ref ([] : L'.decl list) 55 val pvarDefs = ref ([] : (string * int * (string * int * L'.typ option) list) list)
56 val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list) 56 val pvarOldDefs = ref ([] : (int * (string * int * L.con option) list) list)
57 57
58 fun choosePvar () = 58 fun choosePvar () =
59 let 59 let
60 val n = !nextPvar 60 val n = !nextPvar
72 val (r, fs') = ListPair.foldr (fn ((_, t), (x, n, _), (r, fs')) => 72 val (r, fs') = ListPair.foldr (fn ((_, t), (x, n, _), (r, fs')) =>
73 ((x, n, SOME t) :: r, 73 ((x, n, SOME t) :: r,
74 SM.insert (fs', x, n))) ([], SM.empty) (r, fs) 74 SM.insert (fs', x, n))) ([], SM.empty) (r, fs)
75 in 75 in
76 pvars := RM.insert (!pvars, r', (n, fs)); 76 pvars := RM.insert (!pvars, r', (n, fs));
77 pvarDefs := (L'.DDatatype [("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)], loc) 77 pvarDefs := ("$poly" ^ Int.toString n, n, map (fn (x, n, t) => (x, n, SOME t)) fs)
78 :: !pvarDefs; 78 :: !pvarDefs;
79 pvarOldDefs := (n, r) :: !pvarOldDefs; 79 pvarOldDefs := (n, r) :: !pvarOldDefs;
80 (n, fs) 80 (n, fs)
81 end 81 end
82 | SOME v => v 82 | SOME v => v
530 | L'.TDatatype (i, ref (dk, _)) => 530 | L'.TDatatype (i, ref (dk, _)) =>
531 let 531 let
532 fun makeDecl n fm = 532 fun makeDecl n fm =
533 let 533 let
534 val (x, xncs) = 534 val (x, xncs) =
535 case ListUtil.search (fn (L'.DDatatype [(x, i', xncs)], _) => 535 case ListUtil.search (fn (x, i', xncs) =>
536 if i' = i then 536 if i' = i then
537 SOME (x, xncs) 537 SOME (x, xncs)
538 else 538 else
539 NONE 539 NONE) (!pvarDefs) of
540 | _ => NONE) (!pvarDefs) of
541 NONE => 540 NONE =>
542 let 541 let
543 val (x, _, xncs) = Env.lookupDatatype env i 542 val (x, _, xncs) = Env.lookupDatatype env i
544 in 543 in
545 (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs) 544 (x, map (fn (x, n, c) => (x, n, Option.map (monoType env) c)) xncs)
4359 n, 4358 n,
4360 [], 4359 [],
4361 cs)], loc)) 4360 cs)], loc))
4362 env (!pvarOldDefs), 4361 env (!pvarOldDefs),
4363 Fm.enter fm, 4362 Fm.enter fm,
4364 ds' @ Fm.decls fm @ !pvarDefs @ ds))) 4363 case ds' of
4364 [(L'.DDatatype dts, loc)] =>
4365 (L'.DDatatype (dts @ !pvarDefs), loc) :: Fm.decls fm @ ds
4366 | _ =>
4367 ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds)))
4365 (env, Fm.empty mname, []) file 4368 (env, Fm.empty mname, []) file
4366 in 4369 in
4367 pvars := RM.empty; 4370 pvars := RM.empty;
4368 pvarDefs := []; 4371 pvarDefs := [];
4369 pvarOldDefs := []; 4372 pvarOldDefs := [];