Mercurial > urweb

annotate src/reduce.sml @ 1710:540df112ff62

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Remove string-valued style attribute, which may allow injection attacks
author Adam Chlipala <adam@chlipala.net>
date Sun, 15 Apr 2012 12:40:53 -0400
parents 0577be31a435
children 62c18ecbfec4
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
adam@1663 496 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) 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