Mercurial > urweb

annotate src/reduce.sml @ 1642:c3627f317bfd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Refactor HTML contexts to prevent some illegal nestings (that can crash the JavaScript runtime system)
author Adam Chlipala <adam@chlipala.net>
date Tue, 20 Dec 2011 21:06:25 -0500
parents a99b743a3087
children 0577be31a435
rev   line source
adam@1544 1 (* Copyright (c) 2008-2011, Adam Chlipala
adamc@20 2 * All rights reserved.
adamc@20 3 *
adamc@20 4 * Redistribution and use in source and binary forms, with or without
adamc@20 5 * modification, are permitted provided that the following conditions are met:
adamc@20 6 *
adamc@20 7 * - Redistributions of source code must retain the above copyright notice,
adamc@20 8 * this list of conditions and the following disclaimer.
adamc@20 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@20 10 * this list of conditions and the following disclaimer in the documentation
adamc@20 11 * and/or other materials provided with the distribution.
adamc@20 12 * - The names of contributors may not be used to endorse or promote products
adamc@20 13 * derived from this software without specific prior written permission.
adamc@20 14 *
adamc@20 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@20 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@20 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@20 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@20 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@20 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@20 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@20 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@20 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@20 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@20 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@20 26 *)
adamc@20 27
adamc@20 28 (* Simplify a Core program algebraically *)
adamc@20 29
adamc@20 30 structure Reduce :> REDUCE = struct
adamc@20 31
adamc@20 32 open Core
adamc@20 33
adamc@1016 34 structure IS = IntBinarySet
adamc@508 35 structure IM = IntBinaryMap
adamc@20 36
adamc@908 37 structure E = CoreEnv
adamc@908 38
adam@1544 39 fun multiLiftConInCon n c =
adam@1544 40 if n = 0 then
adam@1544 41 c
adam@1544 42 else
adam@1544 43 multiLiftConInCon (n - 1) (E.liftConInCon 0 c)
adam@1544 44
adamc@908 45 fun multiLiftExpInExp n e =
adamc@908 46 if n = 0 then
adamc@908 47 e
adamc@908 48 else
adamc@908 49 multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e)
adamc@908 50
adamc@1179 51 val count = CoreUtil.Exp.foldB {kind = fn (_, _, c) => c,
adamc@1179 52 con = fn (_, _, c) => c,
adamc@1179 53 exp = fn (x, e, c) =>
adamc@1179 54 case e of
adamc@1179 55 ERel x' => if x = x' then c + 1 else c
adamc@1179 56 | _ => c,
adamc@1179 57 bind = fn (x, b) =>
adamc@1179 58 case b of
adamc@1179 59 CoreUtil.Exp.RelE _ => x+1
adamc@1179 60 | _ => x} 0 0
adamc@1179 61
adamc@909 62 val dangling =
adamc@909 63 CoreUtil.Exp.existsB {kind = fn _ => false,
adamc@909 64 con = fn _ => false,
adamc@909 65 exp = fn (n, e) =>
adamc@909 66 case e of
adamc@909 67 ERel n' => n' >= n
adamc@909 68 | _ => false,
adamc@909 69 bind = fn (n, b) =>
adamc@909 70 case b of
adamc@909 71 CoreUtil.Exp.RelE _ => n + 1
adamc@909 72 | _ => n}
adamc@909 73
adamc@1272 74 val cdangling =
adamc@1272 75 CoreUtil.Exp.existsB {kind = fn _ => false,
adamc@1272 76 con = fn (n, c) =>
adamc@1272 77 case c of
adamc@1272 78 CRel n' => n' >= n
adamc@1272 79 | _ => false,
adamc@1272 80 exp = fn _ => false,
adamc@1272 81 bind = fn (n, b) =>
adamc@1272 82 case b of
adamc@1272 83 CoreUtil.Exp.RelC _ => n + 1
adamc@1272 84 | _ => n}
adamc@1272 85
adamc@508 86 datatype env_item =
adamc@626 87 UnknownK
adamc@626 88 | KnownK of kind
adamc@626 89
adamc@626 90 | UnknownC
adamc@508 91 | KnownC of con
adamc@21 92
adamc@508 93 | UnknownE
adamc@508 94 | KnownE of exp
adamc@20 95
adamc@626 96 | Lift of int * int * int
adamc@20 97
adamc@909 98 val edepth = foldl (fn (UnknownE, n) => n + 1
adamc@909 99 | (KnownE _, n) => n + 1
adamc@909 100 | (_, n) => n) 0
adamc@909 101
adamc@909 102 val edepth' = foldl (fn (UnknownE, n) => n + 1
adamc@909 103 | (KnownE _, n) => n + 1
adamc@909 104 | (Lift (_, _, n'), n) => n + n'
adamc@909 105 | (_, n) => n) 0
adamc@909 106
adamc@1272 107 val cdepth = foldl (fn (UnknownC, n) => n + 1
adamc@1272 108 | (KnownC _, n) => n + 1
adamc@1272 109 | (_, n) => n) 0
adamc@1272 110
adamc@1272 111 val cdepth' = foldl (fn (UnknownC, n) => n + 1
adamc@1272 112 | (KnownC _, n) => n + 1
adamc@1272 113 | (Lift (_, n', _), n) => n + n'
adamc@1272 114 | (_, n) => n) 0
adamc@1272 115
adamc@508 116 type env = env_item list
adamc@20 117
adamc@510 118 fun ei2s ei =
adamc@510 119 case ei of
adamc@626 120 UnknownK => "UK"
adamc@626 121 | KnownK _ => "KK"
adamc@626 122 | UnknownC => "UC"
adamc@510 123 | KnownC _ => "KC"
adamc@510 124 | UnknownE => "UE"
adamc@510 125 | KnownE _ => "KE"
adamc@626 126 | Lift (_, n1, n2) => "(" ^ Int.toString n1 ^ ", " ^ Int.toString n2 ^ ")"
adamc@510 127
adamc@510 128 fun e2s env = String.concatWith " " (map ei2s env)
adamc@510 129
adamc@909 130 (*val deKnown = List.filter (fn KnownC _ => false
adamc@510 131 | KnownE _ => false
adamc@626 132 | KnownK _ => false
adamc@909 133 | _ => true)*)
adamc@909 134
adamc@909 135 val deKnown = ListUtil.mapConcat (fn KnownC _ => []
adamc@909 136 | KnownE _ => []
adamc@909 137 | KnownK _ => []
adamc@909 138 | Lift (nk, nc, ne) => List.tabulate (nk, fn _ => UnknownK)
adamc@909 139 @ List.tabulate (nc, fn _ => UnknownC)
adamc@909 140 @ List.tabulate (ne, fn _ => UnknownE)
adamc@909 141 | x => [x])
adamc@510 142
adamc@930 143 datatype result = Yes of env | No | Maybe
adamc@930 144
adamc@930 145 fun match (env, p : pat, e : exp) =
adamc@942 146 let
adamc@942 147 val baseline = length env
adamc@930 148
adamc@942 149 fun match (env, p, e) =
adamc@942 150 case (#1 p, #1 e) of
adamc@942 151 (PWild, _) => Yes env
adamc@942 152 | (PVar (x, t), _) => Yes (KnownE (multiLiftExpInExp (length env - baseline) e) :: env)
adamc@930 153
adamc@942 154 | (PPrim p, EPrim p') =>
adamc@942 155 if Prim.equal (p, p') then
adamc@942 156 Yes env
adamc@942 157 else
adamc@942 158 No
adamc@930 159
adamc@942 160 | (PCon (_, PConVar n1, _, NONE), ECon (_, PConVar n2, _, NONE)) =>
adamc@942 161 if n1 = n2 then
adamc@942 162 Yes env
adamc@942 163 else
adamc@942 164 No
adamc@930 165
adamc@942 166 | (PCon (_, PConVar n1, _, SOME p), ECon (_, PConVar n2, _, SOME e)) =>
adamc@942 167 if n1 = n2 then
adamc@942 168 match (env, p, e)
adamc@942 169 else
adamc@942 170 No
adamc@930 171
adamc@942 172 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, NONE),
adamc@942 173 ECon (_, PConFfi {mod = m2, con = con2, ...}, _, NONE)) =>
adamc@942 174 if m1 = m2 andalso con1 = con2 then
adamc@942 175 Yes env
adamc@942 176 else
adamc@942 177 No
adamc@930 178
adamc@942 179 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, _, SOME ep),
adamc@942 180 ECon (_, PConFfi {mod = m2, con = con2, ...}, _, SOME e)) =>
adamc@942 181 if m1 = m2 andalso con1 = con2 then
adamc@942 182 match (env, p, e)
adamc@942 183 else
adamc@942 184 No
adamc@930 185
adamc@942 186 | (PRecord xps, ERecord xes) =>
adamc@942 187 if List.exists (fn ((CName _, _), _, _) => false
adamc@942 188 | _ => true) xes then
adamc@942 189 Maybe
adamc@942 190 else
adamc@942 191 let
adamc@942 192 fun consider (xps, env) =
adamc@942 193 case xps of
adamc@942 194 [] => Yes env
adamc@942 195 | (x, p, _) :: rest =>
adamc@942 196 case List.find (fn ((CName x', _), _, _) => x' = x
adamc@942 197 | _ => false) xes of
adamc@942 198 NONE => No
adamc@942 199 | SOME (_, e, _) =>
adamc@942 200 case match (env, p, e) of
adamc@942 201 No => No
adamc@942 202 | Maybe => Maybe
adamc@942 203 | Yes env => consider (rest, env)
adamc@942 204 in
adamc@942 205 consider (xps, env)
adamc@942 206 end
adamc@942 207
adamc@942 208 | _ => Maybe
adamc@942 209 in
adamc@942 210 match (env, p, e)
adamc@942 211 end
adamc@930 212
adam@1544 213 fun returnType m loc =
adam@1544 214 (TCFun ("a", (KType, loc),
adam@1544 215 (TFun ((CRel 0, loc),
adam@1544 216 (CApp (multiLiftConInCon 1 m, (CRel 0, loc)), loc)), loc)), loc)
adam@1544 217
adam@1544 218 fun bindType m loc =
adam@1544 219 (TCFun ("a", (KType, loc),
adam@1544 220 (TCFun ("b", (KType, loc),
adam@1544 221 (TFun ((CApp (multiLiftConInCon 2 m, (CRel 1, loc)), loc),
adam@1544 222 (TFun ((TFun ((CRel 1, loc),
adam@1544 223 (CApp (multiLiftConInCon 2 m, (CRel 0, loc)), loc)),
adam@1544 224 loc),
adam@1544 225 (CApp (multiLiftConInCon 2 m, (CRel 0, loc)), loc)), loc)),
adam@1544 226 loc)), loc)), loc)
adam@1544 227
adam@1544 228 fun monadRecord m loc =
adam@1544 229 (TRecord (CRecord ((KType, loc),
adam@1544 230 [((CName "Return", loc),
adam@1544 231 returnType m loc),
adam@1544 232 ((CName "Bind", loc),
adam@1544 233 bindType m loc)]), loc), loc)
adam@1544 234
adamc@626 235 fun kindConAndExp (namedC, namedE) =
adamc@508 236 let
adamc@626 237 fun kind env (all as (k, loc)) =
adamc@626 238 case k of
adamc@626 239 KType => all
adamc@626 240 | KArrow (k1, k2) => (KArrow (kind env k1, kind env k2), loc)
adamc@626 241 | KName => all
adamc@626 242 | KRecord k => (KRecord (kind env k), loc)
adamc@626 243 | KUnit => all
adamc@626 244 | KTuple ks => (KTuple (map (kind env) ks), loc)
adamc@626 245
adamc@626 246 | KRel n =>
adamc@626 247 let
adamc@626 248 fun find (n', env, nudge, lift) =
adamc@626 249 case env of
adamc@626 250 [] => raise Fail "Reduce.kind: KRel"
adamc@626 251 | UnknownC :: rest => find (n', rest, nudge, lift)
adamc@626 252 | KnownC _ :: rest => find (n', rest, nudge, lift)
adamc@626 253 | UnknownE :: rest => find (n', rest, nudge, lift)
adamc@626 254 | KnownE _ :: rest => find (n', rest, nudge, lift)
adamc@626 255 | Lift (lift', _, _) :: rest => find (n', rest, nudge + lift', lift + lift')
adamc@626 256 | UnknownK :: rest =>
adamc@626 257 if n' = 0 then
adamc@626 258 (KRel (n + nudge), loc)
adamc@626 259 else
adamc@626 260 find (n' - 1, rest, nudge, lift + 1)
adamc@626 261 | KnownK k :: rest =>
adamc@626 262 if n' = 0 then
adamc@626 263 kind (Lift (lift, 0, 0) :: rest) k
adamc@626 264 else
adamc@626 265 find (n' - 1, rest, nudge - 1, lift)
adamc@626 266 in
adamc@626 267 find (n, env, 0, 0)
adamc@626 268 end
adamc@626 269 | KFun (x, k) => (KFun (x, kind (UnknownK :: env) k), loc)
adamc@626 270
adamc@508 271 fun con env (all as (c, loc)) =
adamc@510 272 ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*)
adamc@508 273 case c of
adamc@508 274 TFun (c1, c2) => (TFun (con env c1, con env c2), loc)
adamc@626 275 | TCFun (x, k, c2) => (TCFun (x, kind env k, con (UnknownC :: env) c2), loc)
adamc@626 276 | TKFun (x, c2) => (TKFun (x, con (UnknownK :: env) c2), loc)
adamc@508 277 | TRecord c => (TRecord (con env c), loc)
adamc@215 278
adamc@508 279 | CRel n =>
adamc@508 280 let
adamc@626 281 fun find (n', env, nudge, liftK, liftC) =
adamc@510 282 case env of
adamc@510 283 [] => raise Fail "Reduce.con: CRel"
adamc@626 284 | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC)
adamc@626 285 | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC)
adamc@626 286 | UnknownE :: rest => find (n', rest, nudge, liftK, liftC)
adamc@626 287 | KnownE _ :: rest => find (n', rest, nudge, liftK, liftC)
adamc@626 288 | Lift (liftK', liftC', _) :: rest => find (n', rest, nudge + liftC',
adamc@626 289 liftK + liftK', liftC + liftC')
adamc@510 290 | UnknownC :: rest =>
adamc@510 291 if n' = 0 then
adamc@510 292 (CRel (n + nudge), loc)
adamc@510 293 else
adamc@626 294 find (n' - 1, rest, nudge, liftK, liftC + 1)
adamc@510 295 | KnownC c :: rest =>
adamc@510 296 if n' = 0 then
adamc@626 297 con (Lift (liftK, liftC, 0) :: rest) c
adamc@510 298 else
adamc@626 299 find (n' - 1, rest, nudge - 1, liftK, liftC)
adamc@508 300 in
adamc@510 301 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
adamc@626 302 find (n, env, 0, 0, 0)
adamc@508 303 end
adam@1544 304
adamc@508 305 | CNamed n =>
adamc@508 306 (case IM.find (namedC, n) of
adamc@508 307 NONE => all
adamc@508 308 | SOME c => c)
adam@1544 309
adam@1544 310 | CFfi ("Basis", "monad") => (CAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc), monadRecord (CRel 0, loc) loc), loc)
adam@1544 311
adamc@508 312 | CFfi _ => all
adamc@508 313 | CApp (c1, c2) =>
adamc@508 314 let
adamc@508 315 val c1 = con env c1
adamc@508 316 val c2 = con env c2
adamc@508 317 in
adamc@508 318 case #1 c1 of
adamc@508 319 CAbs (_, _, b) =>
adamc@510 320 con (KnownC c2 :: deKnown env) b
adamc@215 321
adamc@621 322 | CApp ((CMap (dom, ran), _), f) =>
adamc@508 323 (case #1 c2 of
adamc@626 324 CRecord (_, []) => (CRecord (kind env ran, []), loc)
adamc@621 325 | CRecord (_, (x, c) :: rest) =>
adamc@510 326 con (deKnown env)
adamc@621 327 (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc),
adamc@626 328 (CApp (c1, (CRecord (kind env dom, rest), loc)), loc)), loc)
adamc@508 329 | _ => (CApp (c1, c2), loc))
adamc@20 330
adamc@508 331 | _ => (CApp (c1, c2), loc)
adamc@508 332 end
adamc@626 333 | CAbs (x, k, b) => (CAbs (x, kind env k, con (UnknownC :: env) b), loc)
adamc@626 334
adamc@626 335 | CKApp (c1, k) =>
adamc@626 336 let
adamc@626 337 val c1 = con env c1
adamc@626 338 in
adamc@626 339 case #1 c1 of
adamc@626 340 CKAbs (_, b) =>
adamc@626 341 con (KnownK k :: deKnown env) b
adamc@626 342
adamc@626 343 | _ => (CKApp (c1, kind env k), loc)
adamc@626 344 end
adamc@626 345 | CKAbs (x, b) => (CKAbs (x, con (UnknownK :: env) b), loc)
adamc@20 346
adamc@508 347 | CName _ => all
adamc@21 348
adamc@626 349 | CRecord (k, xcs) => (CRecord (kind env k, map (fn (x, c) => (con env x, con env c)) xcs), loc)
adamc@508 350 | CConcat (c1, c2) =>
adamc@508 351 let
adamc@508 352 val c1 = con env c1
adamc@508 353 val c2 = con env c2
adamc@508 354 in
adamc@508 355 case (#1 c1, #1 c2) of
adamc@508 356 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@626 357 (CRecord (kind env k, xcs1 @ xcs2), loc)
adamc@1122 358 | (CRecord (_, []), _) => c2
adamc@1122 359 | (_, CRecord (_, [])) => c1
adamc@508 360 | _ => (CConcat (c1, c2), loc)
adamc@508 361 end
adamc@626 362 | CMap (dom, ran) => (CMap (kind env dom, kind env ran), loc)
adamc@74 363
adamc@508 364 | CUnit => all
adamc@21 365
adamc@508 366 | CTuple cs => (CTuple (map (con env) cs), loc)
adamc@508 367 | CProj (c, n) =>
adamc@508 368 let
adamc@508 369 val c = con env c
adamc@508 370 in
adamc@508 371 case #1 c of
adamc@508 372 CTuple cs => List.nth (cs, n - 1)
adamc@508 373 | _ => (CProj (c, n), loc)
adamc@510 374 end)
adamc@22 375
adamc@509 376 fun patCon pc =
adamc@509 377 case pc of
adamc@509 378 PConVar _ => pc
adamc@509 379 | PConFfi {mod = m, datatyp, params, con = c, arg, kind} =>
adamc@509 380 PConFfi {mod = m, datatyp = datatyp, params = params, con = c,
adamc@509 381 arg = Option.map (con (map (fn _ => UnknownC) params)) arg,
adamc@509 382 kind = kind}
adamc@509 383
adamc@509 384
adamc@509 385 val k = (KType, ErrorMsg.dummySpan)
adamc@509 386 fun doPart e (this as (x, t), rest) =
adamc@509 387 ((x, (EField (e, x, {field = t, rest = (CRecord (k, rest), #2 t)}), #2 t), t),
adamc@509 388 this :: rest)
adamc@509 389
adamc@509 390 fun exp env (all as (e, loc)) =
adamc@909 391 let
adamc@909 392 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@909 393 ("env", Print.PD.string (e2s env))]*)
adamc@1176 394 (*val () = if dangling (edepth env) all then
adamc@909 395 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@909 396 ("env", Print.PD.string (e2s env))];
adamc@909 397 raise Fail "!")
adamc@909 398 else
adamc@1176 399 ()*)
adamc@1272 400 (*val () = if cdangling (cdepth env) all then
adamc@1272 401 Print.prefaces "Bad exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@1272 402 ("env", Print.PD.string (e2s env))]
adamc@1272 403 else
adamc@1272 404 ()*)
adamc@509 405
kkallio@1533 406 fun patBinds (p, _) =
kkallio@1533 407 case p of
kkallio@1533 408 PWild => 0
kkallio@1533 409 | PVar _ => 1
kkallio@1533 410 | PPrim _ => 0
kkallio@1533 411 | PCon (_, _, _, NONE) => 0
kkallio@1533 412 | PCon (_, _, _, SOME p) => patBinds p
kkallio@1533 413 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
kkallio@1533 414
adamc@909 415 val r = case e of
adamc@909 416 EPrim _ => all
adamc@909 417 | ERel n =>
adamc@909 418 let
adamc@909 419 fun find (n', env, nudge, liftK, liftC, liftE) =
adamc@909 420 case env of
adamc@909 421 [] => raise Fail ("Reduce.exp: ERel (" ^ ErrorMsg.spanToString loc ^ ")")
adamc@909 422 | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC, liftE)
adamc@909 423 | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC, liftE)
adamc@909 424 | UnknownC :: rest => find (n', rest, nudge, liftK, liftC + 1, liftE)
adamc@909 425 | KnownC _ :: rest => find (n', rest, nudge, liftK, liftC, liftE)
adamc@909 426 | Lift (liftK', liftC', liftE') :: rest =>
adamc@909 427 find (n', rest, nudge + liftE',
adamc@909 428 liftK + liftK', liftC + liftC', liftE + liftE')
adamc@909 429 | UnknownE :: rest =>
adamc@909 430 if n' = 0 then
adamc@909 431 (ERel (n + nudge), loc)
adamc@909 432 else
adamc@909 433 find (n' - 1, rest, nudge, liftK, liftC, liftE + 1)
adamc@909 434 | KnownE e :: rest =>
adamc@909 435 if n' = 0 then
adamc@909 436 ((*print "SUBSTITUTING\n";*)
adamc@909 437 exp (Lift (liftK, liftC, liftE) :: rest) e)
adamc@909 438 else
adamc@909 439 find (n' - 1, rest, nudge - 1, liftK, liftC, liftE)
adamc@909 440 in
adamc@909 441 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
adamc@909 442 find (n, env, 0, 0, 0, 0)
adamc@909 443 end
adamc@909 444 | ENamed n =>
adamc@909 445 (case IM.find (namedE, n) of
adamc@909 446 NONE => all
adamc@909 447 | SOME e => e)
adamc@909 448 | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc,
adamc@909 449 map (con env) cs, Option.map (exp env) eo), loc)
adam@1544 450
adam@1544 451 | EFfi ("Basis", "return") =>
adam@1544 452 (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc),
adam@1544 453 (ECAbs ("a", (KType, loc),
adam@1544 454 (EAbs ("m", monadRecord (CRel 1, loc) loc, returnType (CRel 1, loc) loc,
adam@1544 455 (ECApp ((EField ((ERel 0, loc), (CName "Return", loc),
adam@1544 456 {field = returnType (CRel 1, loc) loc,
adam@1544 457 rest = (CRecord ((KType, loc),
adam@1544 458 [((CName "Bind", loc), bindType (CRel 1, loc) loc)]),
adam@1544 459 loc)}), loc), (CRel 0, loc)), loc)), loc)), loc)), loc)
adam@1544 460
adam@1544 461 | EFfi ("Basis", "bind") =>
adam@1544 462 (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc),
adam@1544 463 (ECAbs ("a", (KType, loc),
adam@1544 464 (ECAbs ("b", (KType, loc),
adam@1544 465 (EAbs ("m", monadRecord (CRel 2, loc) loc, bindType (CRel 2, loc) loc,
adam@1544 466 (ECApp ((ECApp ((EField ((ERel 0, loc), (CName "Bind", loc),
adam@1544 467 {field = bindType (CRel 2, loc) loc,
adam@1544 468 rest = (CRecord ((KType, loc),
adam@1544 469 [((CName "Return", loc),
adam@1544 470 returnType (CRel 2, loc) loc)]),
adam@1544 471 loc)}), loc), (CRel 1, loc)), loc),
adam@1544 472 (CRel 0, loc)), loc)), loc)), loc)), loc)), loc)
adam@1544 473
adam@1544 474 | EFfi ("Basis", "mkMonad") =>
adam@1544 475 (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc),
adam@1544 476 (EAbs ("m", monadRecord (CRel 0, loc) loc, monadRecord (CRel 0, loc) loc,
adam@1544 477 (ERel 0, loc)), loc)), loc)
adam@1544 478
adam@1544 479 | EFfi ("Basis", "transaction_monad") =>
adam@1544 480 (ERecord [((CName "Return", loc),
adam@1544 481 (EFfi ("Basis", "transaction_return"), loc),
adam@1544 482 returnType (CFfi ("Basis", "transaction"), loc) loc),
adam@1544 483 ((CName "Bind", loc),
adam@1544 484 (EFfi ("Basis", "transaction_bind"), loc),
adam@1544 485 bindType (CFfi ("Basis", "transaction"), loc) loc)], loc)
adam@1544 486
adam@1544 487 | EFfi ("Basis", "signal_monad") =>
adam@1544 488 (ERecord [((CName "Return", loc),
adam@1544 489 (EFfi ("Basis", "signal_return"), loc),
adam@1544 490 returnType (CFfi ("Basis", "signal"), loc) loc),
adam@1544 491 ((CName "Bind", loc),
adam@1544 492 (EFfi ("Basis", "signal_bind"), loc),
adam@1544 493 bindType (CFfi ("Basis", "signal"), loc) loc)], loc)
adam@1544 494
adamc@909 495 | EFfi _ => all
adamc@909 496 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
adamc@908 497
adamc@909 498 (*| EApp (
adamc@909 499 (EApp
adamc@909 500 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
adamc@909 501 (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@909 502 (ECase (ed, pes, {disc, ...}), _)), _),
adamc@909 503 trans2) =>
adamc@909 504 let
adamc@909 505 val e' = (EFfi ("Basis", "bind"), loc)
adamc@909 506 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@909 507 val e' = (ECApp (e', t1), loc)
adamc@909 508 val e' = (ECApp (e', t2), loc)
adamc@909 509 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@908 510
adamc@909 511 val pes = map (fn (p, e) =>
adamc@909 512 let
adamc@909 513 val e' = (EApp (e', e), loc)
adamc@909 514 val e' = (EApp (e',
adamc@909 515 multiLiftExpInExp (E.patBindsN p)
adamc@909 516 trans2), loc)
adamc@909 517 val e' = exp env e'
adamc@909 518 in
adamc@909 519 (p, e')
adamc@909 520 end) pes
adamc@909 521 in
adamc@909 522 (ECase (exp env ed,
adamc@909 523 pes,
adamc@909 524 {disc = con env disc,
adamc@909 525 result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}),
adamc@909 526 loc)
adamc@909 527 end*)
adamc@908 528
adamc@909 529 | EApp (e1, e2) =>
adamc@909 530 let
adamc@910 531 val env' = deKnown env
adamc@910 532
adamc@909 533 val e1 = exp env e1
adamc@909 534 val e2 = exp env e2
adamc@909 535 in
adamc@1179 536 case #1 e1 of
adamc@1179 537 EAbs (_, _, _, b) =>
adamc@1181 538 let
adamc@1181 539 val r = exp (KnownE e2 :: env') b
adamc@1181 540 in
adamc@1181 541 (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b),
adamc@1181 542 ("env", Print.PD.string (e2s env')),
adamc@1181 543 ("e2", CorePrint.p_exp CoreEnv.empty e2),
adamc@1181 544 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
adamc@1181 545 r
adamc@1181 546 end
kkallio@1533 547 | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) =>
kkallio@1533 548 let
kkallio@1533 549 val pes' = map (fn (p, body) =>
kkallio@1533 550 let
adam@1534 551 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env
kkallio@1533 552 val body' = exp env' (EApp (body, multiLiftExpInExp (patBinds p) e2), #2 body)
kkallio@1533 553 in
kkallio@1533 554 (p, body')
kkallio@1533 555 end) pes
kkallio@1533 556
kkallio@1533 557 val cc' = {disc = disc, result = c2}
kkallio@1533 558 in
kkallio@1533 559 (ECase (e, pes', cc'), loc)
kkallio@1533 560 end
adamc@1179 561 | _ => (EApp (e1, e2), loc)
adamc@909 562 end
adamc@509 563
adamc@909 564 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc)
adamc@509 565
adamc@909 566 | ECApp (e, c) =>
adamc@909 567 let
adamc@909 568 val e = exp env e
adamc@909 569 val c = con env c
adamc@909 570 in
adamc@909 571 case #1 e of
adamc@1181 572 ECAbs (_, _, b) =>
adamc@1181 573 let
adamc@1181 574 val r = exp (KnownC c :: deKnown env) b
adamc@1181 575 in
adamc@1181 576 (*Print.prefaces "csub" [("l", Print.PD.string (ErrorMsg.spanToString loc)),
adamc@1181 577 ("env", Print.PD.string (e2s (deKnown env))),
adamc@1181 578 ("b", CorePrint.p_exp CoreEnv.empty b),
adamc@1181 579 ("c", CorePrint.p_con CoreEnv.empty c),
adamc@1181 580 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
adamc@1181 581 r
adamc@1181 582 end
kkallio@1533 583 | ECase (e, pes, cc as {disc, result = res as (TCFun (_, _, c'), _)}) =>
kkallio@1533 584 let
kkallio@1533 585 val pes' = map (fn (p, body) =>
kkallio@1533 586 let
adam@1534 587 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env
kkallio@1533 588
kkallio@1533 589 val body' = exp env' (ECApp (body, c), #2 body)
kkallio@1533 590 in
kkallio@1533 591 (p, body')
kkallio@1533 592 end) pes
kkallio@1533 593
kkallio@1533 594 val c' = E.subConInCon (0, c) c'
kkallio@1533 595 val cc' = {disc = disc, result = c'}
kkallio@1533 596 in
kkallio@1533 597 (ECase (e, pes', cc'), loc)
kkallio@1533 598 end
adamc@909 599 | _ => (ECApp (e, c), loc)
adamc@909 600 end
adamc@626 601
adamc@909 602 | ECAbs (x, k, e) => (ECAbs (x, kind env k, exp (UnknownC :: env) e), loc)
adamc@626 603
adamc@909 604 | EKApp (e, k) =>
adamc@909 605 let
adamc@909 606 val e = exp env e
adamc@909 607 in
adamc@909 608 case #1 e of
adamc@1181 609 EKAbs (_, b) =>
adamc@1181 610 let
adamc@1181 611 val r = exp (KnownK k :: deKnown env) b
adamc@1181 612 in
adamc@1181 613 (*Print.prefaces "ksub" [("l", Print.PD.string (ErrorMsg.spanToString loc)),
adamc@1181 614 ("b", CorePrint.p_exp CoreEnv.empty b),
adamc@1181 615 ("k", CorePrint.p_kind CoreEnv.empty k),
adamc@1181 616 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
adamc@1181 617 r
adamc@1181 618 end
adamc@909 619 | _ => (EKApp (e, kind env k), loc)
adamc@909 620 end
adamc@509 621
adamc@909 622 | EKAbs (x, e) => (EKAbs (x, exp (UnknownK :: env) e), loc)
adamc@509 623
adamc@909 624 | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc)
adamc@909 625 | EField (e, c, {field, rest}) =>
adamc@909 626 let
adamc@909 627 val e = exp env e
adamc@909 628 val c = con env c
adamc@509 629
adamc@909 630 fun default () = (EField (e, c, {field = con env field, rest = con env rest}), loc)
adamc@909 631 in
adamc@909 632 case (#1 e, #1 c) of
adamc@909 633 (ERecord xcs, CName x) =>
adamc@909 634 (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
adamc@909 635 NONE => default ()
adamc@909 636 | SOME (_, e, _) => e)
adamc@909 637 | _ => default ()
adamc@909 638 end
adamc@509 639
adamc@909 640 | EConcat (e1, c1, e2, c2) =>
adamc@909 641 let
adamc@909 642 val e1 = exp env e1
adamc@909 643 val e2 = exp env e2
adamc@909 644 in
adamc@909 645 case (#1 e1, #1 e2) of
adamc@909 646 (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc)
adamc@909 647 | _ =>
adamc@909 648 let
adamc@909 649 val c1 = con env c1
adamc@909 650 val c2 = con env c2
adamc@909 651 in
adamc@909 652 case (#1 c1, #1 c2) of
adamc@909 653 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@909 654 let
adamc@909 655 val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1
adamc@909 656 val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2
adamc@909 657 in
adamc@909 658 exp (deKnown env) (ERecord (xes1 @ xes2), loc)
adamc@909 659 end
adamc@909 660 | _ => (EConcat (e1, c1, e2, c2), loc)
adamc@909 661 end
adamc@909 662 end
adamc@509 663
adamc@909 664 | ECut (e, c, {field, rest}) =>
adamc@909 665 let
adamc@909 666 val e = exp env e
adamc@909 667 val c = con env c
adamc@509 668
adamc@909 669 fun default () =
adamc@909 670 let
adamc@909 671 val rest = con env rest
adamc@909 672 in
adamc@909 673 case #1 rest of
adamc@909 674 CRecord (k, xcs) =>
adamc@909 675 let
adamc@909 676 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@909 677 in
adamc@909 678 exp (deKnown env) (ERecord xes, loc)
adamc@909 679 end
adamc@909 680 | _ => (ECut (e, c, {field = con env field, rest = rest}), loc)
adamc@909 681 end
adamc@909 682 in
adamc@909 683 case (#1 e, #1 c) of
adamc@909 684 (ERecord xes, CName x) =>
adamc@909 685 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then
adamc@909 686 (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x
adamc@909 687 | _ => raise Fail "Reduce: ECut") xes), loc)
adamc@909 688 else
adamc@909 689 default ()
adamc@909 690 | _ => default ()
adamc@909 691 end
adamc@509 692
adamc@909 693 | ECutMulti (e, c, {rest}) =>
adamc@909 694 let
adamc@909 695 val e = exp env e
adamc@909 696 val c = con env c
adamc@509 697
adamc@909 698 fun default () =
adamc@909 699 let
adamc@909 700 val rest = con env rest
adamc@909 701 in
adamc@909 702 case #1 rest of
adamc@909 703 CRecord (k, xcs) =>
adamc@909 704 let
adamc@909 705 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@909 706 in
adamc@909 707 exp (deKnown env) (ERecord xes, loc)
adamc@909 708 end
adamc@909 709 | _ => (ECutMulti (e, c, {rest = rest}), loc)
adamc@909 710 end
adamc@909 711 in
adamc@909 712 case (#1 e, #1 c) of
adamc@909 713 (ERecord xes, CRecord (_, xcs)) =>
adamc@909 714 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes
adamc@909 715 andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then
adamc@909 716 (ERecord (List.filter (fn ((CName x', _), _, _) =>
adamc@909 717 List.all (fn ((CName x, _), _) => x' <> x
adamc@909 718 | _ => raise Fail "Reduce: ECutMulti [1]") xcs
adamc@909 719 | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc)
adamc@909 720 else
adamc@909 721 default ()
adamc@909 722 | _ => default ()
adamc@909 723 end
adamc@823 724
adamc@909 725 | ECase (_, [((PRecord [], _), e)], _) => exp env e
adamc@909 726 | ECase (_, [((PWild, _), e)], _) => exp env e
adamc@509 727
adamc@909 728 | ECase (e, pes, {disc, result}) =>
adamc@909 729 let
adamc@909 730 fun pat (all as (p, loc)) =
adamc@909 731 case p of
adamc@909 732 PWild => all
adamc@909 733 | PVar (x, t) => (PVar (x, con env t), loc)
adamc@909 734 | PPrim _ => all
adamc@909 735 | PCon (dk, pc, cs, po) =>
adamc@909 736 (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
adamc@909 737 | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
adamc@930 738
adamc@930 739 fun push () =
adamc@930 740 (ECase (exp env e,
adamc@930 741 map (fn (p, e) => (pat p,
adamc@930 742 exp (List.tabulate (patBinds p,
adamc@930 743 fn _ => UnknownE) @ env) e))
adamc@930 744 pes, {disc = con env disc, result = con env result}), loc)
adamc@930 745
adamc@930 746 fun search pes =
adamc@930 747 case pes of
adamc@930 748 [] => push ()
adamc@930 749 | (p, body) :: pes =>
adamc@930 750 case match (env, p, e) of
adamc@930 751 No => search pes
adamc@930 752 | Maybe => push ()
adamc@930 753 | Yes env' => exp env' body
adamc@909 754 in
adamc@930 755 search pes
adamc@909 756 end
adamc@509 757
adamc@909 758 | EWrite e => (EWrite (exp env e), loc)
adamc@909 759 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
adamc@607 760
adamc@910 761 | ELet (x, t, e1, e2) =>
adam@1289 762 let
adam@1289 763 val t = con env t
adam@1289 764 in
adam@1289 765 if ESpecialize.functionInside t then
adam@1289 766 exp (KnownE e1 :: env) e2
adam@1289 767 else
adam@1314 768 (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc)
adam@1289 769 end
adamc@909 770
adamc@1020 771 | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc)
adamc@909 772 in
adamc@909 773 (*if dangling (edepth' (deKnown env)) r then
adamc@909 774 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@909 775 ("r", CorePrint.p_exp CoreEnv.empty r)];
adamc@909 776 raise Fail "!!")
adamc@909 777 else
adamc@909 778 ();*)
adamc@1272 779 (*if cdangling (cdepth' (deKnown env)) r then
adamc@1272 780 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@1272 781 ("r", CorePrint.p_exp CoreEnv.empty r)];
adamc@1272 782 raise Fail "!!")
adamc@1272 783 else
adamc@1272 784 ();*)
adamc@909 785 r
adamc@909 786 end
adamc@417 787 in
adamc@626 788 {kind = kind, con = con, exp = exp}
adamc@417 789 end
adamc@21 790
adamc@626 791 fun kind namedC env k = #kind (kindConAndExp (namedC, IM.empty)) env k
adamc@626 792 fun con namedC env c = #con (kindConAndExp (namedC, IM.empty)) env c
adamc@626 793 fun exp (namedC, namedE) env e = #exp (kindConAndExp (namedC, namedE)) env e
adamc@20 794
adamc@508 795 fun reduce file =
adamc@508 796 let
adamc@1016 797 val uses = CoreUtil.File.fold {kind = fn (_, m) => m,
adamc@1016 798 con = fn (_, m) => m,
adamc@1016 799 exp = fn (e, m) =>
adamc@1016 800 case e of
adamc@1016 801 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
adamc@1016 802 | _ => m,
adamc@1016 803 decl = fn (_, m) => m}
adamc@1016 804 IM.empty file
adamc@1016 805
adamc@1016 806 fun isPoly names = CoreUtil.Con.exists {kind = fn _ => false,
adamc@1016 807 con = fn TCFun _ => true
adamc@1016 808 | TKFun _ => true
adamc@1016 809 | CNamed n => IS.member (names, n)
adamc@1016 810 | _ => false}
adamc@1016 811
adamc@1016 812 val size = CoreUtil.Exp.fold {kind = fn (_, n) => n,
adamc@1016 813 con = fn (_, n) => n,
adamc@1016 814 exp = fn (_, n) => n + 1} 0
adamc@1016 815
adamc@1016 816 fun mayInline (polyC, n, t, e) =
adamc@1240 817 let
adamc@1240 818 fun isPolicy t =
adamc@1240 819 case #1 t of
adamc@1240 820 CFfi ("Basis", "sql_policy") => true
adamc@1240 821 | TFun (_, t) => isPolicy t
adamc@1240 822 | _ => false
adamc@1240 823 in
adamc@1240 824 case IM.find (uses, n) of
adamc@1240 825 NONE => false
adamc@1240 826 | SOME count => count <= 1
adamc@1240 827 orelse (case #1 e of
adamc@1240 828 ERecord _ => true
adamc@1240 829 | _ => false)
adamc@1240 830 orelse isPolicy t
adamc@1240 831 orelse isPoly polyC t
adamc@1240 832 orelse size e <= Settings.getCoreInline ()
adamc@1240 833 end
adamc@1016 834
adamc@1016 835 fun doDecl (d as (_, loc), st as (polyC, namedC, namedE)) =
adamc@508 836 case #1 d of
adamc@508 837 DCon (x, n, k, c) =>
adamc@508 838 let
adamc@626 839 val k = kind namedC [] k
adamc@509 840 val c = con namedC [] c
adamc@508 841 in
adamc@508 842 ((DCon (x, n, k, c), loc),
adamc@1016 843 (if isPoly polyC c then
adamc@1016 844 IS.add (polyC, n)
adamc@1016 845 else
adamc@1016 846 polyC,
adamc@1016 847 IM.insert (namedC, n, c),
adamc@1016 848 namedE))
adamc@508 849 end
adamc@807 850 | DDatatype dts =>
adamc@807 851 ((DDatatype (map (fn (x, n, ps, cs) =>
adamc@807 852 let
adamc@807 853 val env = map (fn _ => UnknownC) ps
adamc@807 854 in
adamc@807 855 (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs)
adamc@807 856 end) dts), loc),
adamc@1016 857 (if List.exists (fn (_, _, _, cs) => List.exists (fn (_, _, co) => case co of
adamc@1016 858 NONE => false
adamc@1016 859 | SOME c => isPoly polyC c) cs)
adamc@1016 860 dts then
adamc@1016 861 foldl (fn ((_, n, _, _), polyC) => IS.add (polyC, n)) polyC dts
adamc@1016 862 else
adamc@1016 863 polyC,
adamc@1016 864 namedC,
adamc@1016 865 namedE))
adamc@508 866 | DVal (x, n, t, e, s) =>
adamc@508 867 let
adamc@509 868 val t = con namedC [] t
adamc@509 869 val e = exp (namedC, namedE) [] e
adamc@508 870 in
adamc@508 871 ((DVal (x, n, t, e, s), loc),
adamc@1016 872 (polyC,
adamc@1016 873 namedC,
adamc@1016 874 if mayInline (polyC, n, t, e) then
adamc@1016 875 IM.insert (namedE, n, e)
adamc@1016 876 else
adamc@1016 877 namedE))
adamc@508 878 end
adamc@508 879 | DValRec vis =>
adamc@910 880 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t,
adamc@910 881 exp (namedC, namedE) [] e, s)) vis), loc),
adamc@508 882 st)
adamc@508 883 | DExport _ => (d, st)
adamc@707 884 | DTable (s, n, c, s', pe, pc, ce, cc) => ((DTable (s, n, con namedC [] c, s',
adamc@707 885 exp (namedC, namedE) [] pe,
adamc@707 886 con namedC [] pc,
adamc@707 887 exp (namedC, namedE) [] ce,
adamc@707 888 con namedC [] cc), loc), st)
adamc@508 889 | DSequence _ => (d, st)
adamc@754 890 | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st)
adamc@508 891 | DDatabase _ => (d, st)
adamc@509 892 | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
adamc@720 893 | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
adamc@1075 894 | DTask (e1, e2) =>
adamc@1073 895 let
adamc@1075 896 val e1 = exp (namedC, namedE) [] e1
adamc@1075 897 val e2 = exp (namedC, namedE) [] e2
adamc@1073 898 in
adamc@1075 899 ((DTask (e1, e2), loc),
adamc@1073 900 (polyC,
adamc@1073 901 namedC,
adamc@1073 902 namedE))
adamc@1073 903 end
adamc@1199 904 | DPolicy e1 =>
adamc@1199 905 let
adamc@1199 906 val e1 = exp (namedC, namedE) [] e1
adamc@1199 907 in
adamc@1199 908 ((DPolicy e1, loc),
adamc@1199 909 (polyC,
adamc@1199 910 namedC,
adamc@1199 911 namedE))
adamc@1199 912 end
adam@1294 913 | DOnError _ => (d, st)
adamc@20 914
adamc@1016 915 val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
adamc@508 916 in
adamc@508 917 file
adamc@508 918 end
adamc@20 919
adamc@20 920 end