Mercurial > urweb

annotate src/reduce.sml @ 2050:04d7d563a36f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
MonoReduce bug involving 'error'
author Adam Chlipala <adam@chlipala.net>
date Wed, 06 Aug 2014 09:50:02 -0400
parents f463c773ed6a
children 18e6fb487880
rev   line source
adam@1848 1 (* Copyright (c) 2008-2011, 2013, 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
adam@1817 235 fun passive (e : exp) =
adam@1817 236 case #1 e of
adam@1817 237 EPrim _ => true
adam@1817 238 | ERel _ => true
adam@1817 239 | ENamed _ => true
adam@1817 240 | ECon (_, _, _, NONE) => true
adam@1817 241 | ECon (_, _, _, SOME e) => passive e
adam@1817 242 | EFfi _ => true
adam@1817 243 | EAbs _ => true
adam@1817 244 | ECAbs _ => true
adam@1817 245 | EKAbs _ => true
adam@1817 246 | ERecord xes => List.all (passive o #2) xes
adam@1817 247 | EField (e, _, _) => passive e
adam@1817 248 | _ => false
adam@1817 249
adam@1824 250 fun notFfi (t : con) =
adam@1824 251 case #1 t of
adam@1824 252 CFfi _ => false
adam@1824 253 | _ => true
adam@1824 254
adamc@626 255 fun kindConAndExp (namedC, namedE) =
adamc@508 256 let
adamc@626 257 fun kind env (all as (k, loc)) =
adamc@626 258 case k of
adamc@626 259 KType => all
adamc@626 260 | KArrow (k1, k2) => (KArrow (kind env k1, kind env k2), loc)
adamc@626 261 | KName => all
adamc@626 262 | KRecord k => (KRecord (kind env k), loc)
adamc@626 263 | KUnit => all
adamc@626 264 | KTuple ks => (KTuple (map (kind env) ks), loc)
adamc@626 265
adamc@626 266 | KRel n =>
adamc@626 267 let
adamc@626 268 fun find (n', env, nudge, lift) =
adamc@626 269 case env of
adamc@626 270 [] => raise Fail "Reduce.kind: KRel"
adamc@626 271 | UnknownC :: rest => find (n', rest, nudge, lift)
adamc@626 272 | KnownC _ :: rest => find (n', rest, nudge, lift)
adamc@626 273 | UnknownE :: rest => find (n', rest, nudge, lift)
adamc@626 274 | KnownE _ :: rest => find (n', rest, nudge, lift)
adamc@626 275 | Lift (lift', _, _) :: rest => find (n', rest, nudge + lift', lift + lift')
adamc@626 276 | UnknownK :: rest =>
adamc@626 277 if n' = 0 then
adamc@626 278 (KRel (n + nudge), loc)
adamc@626 279 else
adamc@626 280 find (n' - 1, rest, nudge, lift + 1)
adamc@626 281 | KnownK k :: rest =>
adamc@626 282 if n' = 0 then
adamc@626 283 kind (Lift (lift, 0, 0) :: rest) k
adamc@626 284 else
adamc@626 285 find (n' - 1, rest, nudge - 1, lift)
adamc@626 286 in
adamc@626 287 find (n, env, 0, 0)
adamc@626 288 end
adamc@626 289 | KFun (x, k) => (KFun (x, kind (UnknownK :: env) k), loc)
adamc@626 290
adamc@508 291 fun con env (all as (c, loc)) =
adamc@510 292 ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*)
adamc@508 293 case c of
adamc@508 294 TFun (c1, c2) => (TFun (con env c1, con env c2), loc)
adamc@626 295 | TCFun (x, k, c2) => (TCFun (x, kind env k, con (UnknownC :: env) c2), loc)
adamc@626 296 | TKFun (x, c2) => (TKFun (x, con (UnknownK :: env) c2), loc)
adamc@508 297 | TRecord c => (TRecord (con env c), loc)
adamc@215 298
adamc@508 299 | CRel n =>
adamc@508 300 let
adamc@626 301 fun find (n', env, nudge, liftK, liftC) =
adamc@510 302 case env of
adamc@510 303 [] => raise Fail "Reduce.con: CRel"
adamc@626 304 | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC)
adamc@626 305 | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC)
adamc@626 306 | UnknownE :: rest => find (n', rest, nudge, liftK, liftC)
adamc@626 307 | KnownE _ :: rest => find (n', rest, nudge, liftK, liftC)
adamc@626 308 | Lift (liftK', liftC', _) :: rest => find (n', rest, nudge + liftC',
adamc@626 309 liftK + liftK', liftC + liftC')
adamc@510 310 | UnknownC :: rest =>
adamc@510 311 if n' = 0 then
adamc@510 312 (CRel (n + nudge), loc)
adamc@510 313 else
adamc@626 314 find (n' - 1, rest, nudge, liftK, liftC + 1)
adamc@510 315 | KnownC c :: rest =>
adamc@510 316 if n' = 0 then
adamc@626 317 con (Lift (liftK, liftC, 0) :: rest) c
adamc@510 318 else
adamc@626 319 find (n' - 1, rest, nudge - 1, liftK, liftC)
adamc@508 320 in
adamc@510 321 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
adamc@626 322 find (n, env, 0, 0, 0)
adamc@508 323 end
adam@1544 324
adamc@508 325 | CNamed n =>
adamc@508 326 (case IM.find (namedC, n) of
adamc@508 327 NONE => all
adamc@508 328 | SOME c => c)
adam@1544 329
adam@1544 330 | CFfi ("Basis", "monad") => (CAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc), monadRecord (CRel 0, loc) loc), loc)
adam@1544 331
adamc@508 332 | CFfi _ => all
adamc@508 333 | CApp (c1, c2) =>
adamc@508 334 let
adamc@508 335 val c1 = con env c1
adamc@508 336 val c2 = con env c2
adamc@508 337 in
adamc@508 338 case #1 c1 of
adamc@508 339 CAbs (_, _, b) =>
adamc@510 340 con (KnownC c2 :: deKnown env) b
adamc@215 341
adamc@621 342 | CApp ((CMap (dom, ran), _), f) =>
adamc@508 343 (case #1 c2 of
adamc@626 344 CRecord (_, []) => (CRecord (kind env ran, []), loc)
adamc@621 345 | CRecord (_, (x, c) :: rest) =>
adamc@510 346 con (deKnown env)
adamc@621 347 (CConcat ((CRecord (ran, [(x, (CApp (f, c), loc))]), loc),
adamc@626 348 (CApp (c1, (CRecord (kind env dom, rest), loc)), loc)), loc)
adamc@508 349 | _ => (CApp (c1, c2), loc))
adamc@20 350
adamc@508 351 | _ => (CApp (c1, c2), loc)
adamc@508 352 end
adamc@626 353 | CAbs (x, k, b) => (CAbs (x, kind env k, con (UnknownC :: env) b), loc)
adamc@626 354
adamc@626 355 | CKApp (c1, k) =>
adamc@626 356 let
adamc@626 357 val c1 = con env c1
adamc@626 358 in
adamc@626 359 case #1 c1 of
adamc@626 360 CKAbs (_, b) =>
adamc@626 361 con (KnownK k :: deKnown env) b
adamc@626 362
adamc@626 363 | _ => (CKApp (c1, kind env k), loc)
adamc@626 364 end
adamc@626 365 | CKAbs (x, b) => (CKAbs (x, con (UnknownK :: env) b), loc)
adamc@20 366
adamc@508 367 | CName _ => all
adamc@21 368
adamc@626 369 | CRecord (k, xcs) => (CRecord (kind env k, map (fn (x, c) => (con env x, con env c)) xcs), loc)
adamc@508 370 | CConcat (c1, c2) =>
adamc@508 371 let
adamc@508 372 val c1 = con env c1
adamc@508 373 val c2 = con env c2
adamc@508 374 in
adamc@508 375 case (#1 c1, #1 c2) of
adamc@508 376 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@626 377 (CRecord (kind env k, xcs1 @ xcs2), loc)
adamc@1122 378 | (CRecord (_, []), _) => c2
adamc@1122 379 | (_, CRecord (_, [])) => c1
adamc@508 380 | _ => (CConcat (c1, c2), loc)
adamc@508 381 end
adamc@626 382 | CMap (dom, ran) => (CMap (kind env dom, kind env ran), loc)
adamc@74 383
adamc@508 384 | CUnit => all
adamc@21 385
adamc@508 386 | CTuple cs => (CTuple (map (con env) cs), loc)
adamc@508 387 | CProj (c, n) =>
adamc@508 388 let
adamc@508 389 val c = con env c
adamc@508 390 in
adamc@508 391 case #1 c of
adamc@508 392 CTuple cs => List.nth (cs, n - 1)
adamc@508 393 | _ => (CProj (c, n), loc)
adamc@510 394 end)
adamc@22 395
adamc@509 396 fun patCon pc =
adamc@509 397 case pc of
adamc@509 398 PConVar _ => pc
adamc@509 399 | PConFfi {mod = m, datatyp, params, con = c, arg, kind} =>
adamc@509 400 PConFfi {mod = m, datatyp = datatyp, params = params, con = c,
adamc@509 401 arg = Option.map (con (map (fn _ => UnknownC) params)) arg,
adamc@509 402 kind = kind}
adamc@509 403
adamc@509 404
adamc@509 405 val k = (KType, ErrorMsg.dummySpan)
adamc@509 406 fun doPart e (this as (x, t), rest) =
adamc@509 407 ((x, (EField (e, x, {field = t, rest = (CRecord (k, rest), #2 t)}), #2 t), t),
adamc@509 408 this :: rest)
adamc@509 409
adamc@509 410 fun exp env (all as (e, loc)) =
adamc@909 411 let
adamc@909 412 (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@909 413 ("env", Print.PD.string (e2s env))]*)
adamc@1176 414 (*val () = if dangling (edepth env) all then
adamc@909 415 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@909 416 ("env", Print.PD.string (e2s env))];
adamc@909 417 raise Fail "!")
adamc@909 418 else
adamc@1176 419 ()*)
adamc@1272 420 (*val () = if cdangling (cdepth env) all then
adamc@1272 421 Print.prefaces "Bad exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@1272 422 ("env", Print.PD.string (e2s env))]
adamc@1272 423 else
adamc@1272 424 ()*)
adamc@509 425
kkallio@1533 426 fun patBinds (p, _) =
kkallio@1533 427 case p of
kkallio@1533 428 PWild => 0
kkallio@1533 429 | PVar _ => 1
kkallio@1533 430 | PPrim _ => 0
kkallio@1533 431 | PCon (_, _, _, NONE) => 0
kkallio@1533 432 | PCon (_, _, _, SOME p) => patBinds p
kkallio@1533 433 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
kkallio@1533 434
adamc@909 435 val r = case e of
adamc@909 436 EPrim _ => all
adamc@909 437 | ERel n =>
adamc@909 438 let
adamc@909 439 fun find (n', env, nudge, liftK, liftC, liftE) =
adamc@909 440 case env of
adamc@909 441 [] => raise Fail ("Reduce.exp: ERel (" ^ ErrorMsg.spanToString loc ^ ")")
adamc@909 442 | UnknownK :: rest => find (n', rest, nudge, liftK + 1, liftC, liftE)
adamc@909 443 | KnownK _ :: rest => find (n', rest, nudge, liftK, liftC, liftE)
adamc@909 444 | UnknownC :: rest => find (n', rest, nudge, liftK, liftC + 1, liftE)
adamc@909 445 | KnownC _ :: rest => find (n', rest, nudge, liftK, liftC, liftE)
adamc@909 446 | Lift (liftK', liftC', liftE') :: rest =>
adamc@909 447 find (n', rest, nudge + liftE',
adamc@909 448 liftK + liftK', liftC + liftC', liftE + liftE')
adamc@909 449 | UnknownE :: rest =>
adamc@909 450 if n' = 0 then
adamc@909 451 (ERel (n + nudge), loc)
adamc@909 452 else
adamc@909 453 find (n' - 1, rest, nudge, liftK, liftC, liftE + 1)
adamc@909 454 | KnownE e :: rest =>
adamc@909 455 if n' = 0 then
adamc@909 456 ((*print "SUBSTITUTING\n";*)
adamc@909 457 exp (Lift (liftK, liftC, liftE) :: rest) e)
adamc@909 458 else
adamc@909 459 find (n' - 1, rest, nudge - 1, liftK, liftC, liftE)
adamc@909 460 in
adamc@909 461 (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*)
adamc@909 462 find (n, env, 0, 0, 0, 0)
adamc@909 463 end
adamc@909 464 | ENamed n =>
adamc@909 465 (case IM.find (namedE, n) of
adamc@909 466 NONE => all
adamc@909 467 | SOME e => e)
adamc@909 468 | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc,
adamc@909 469 map (con env) cs, Option.map (exp env) eo), loc)
adam@1544 470
adam@1544 471 | EFfi ("Basis", "return") =>
adam@1544 472 (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc),
adam@1544 473 (ECAbs ("a", (KType, loc),
adam@1544 474 (EAbs ("m", monadRecord (CRel 1, loc) loc, returnType (CRel 1, loc) loc,
adam@1544 475 (ECApp ((EField ((ERel 0, loc), (CName "Return", loc),
adam@1544 476 {field = returnType (CRel 1, loc) loc,
adam@1544 477 rest = (CRecord ((KType, loc),
adam@1544 478 [((CName "Bind", loc), bindType (CRel 1, loc) loc)]),
adam@1544 479 loc)}), loc), (CRel 0, loc)), loc)), loc)), loc)), loc)
adam@1544 480
adam@1544 481 | EFfi ("Basis", "bind") =>
adam@1544 482 (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc),
adam@1544 483 (ECAbs ("a", (KType, loc),
adam@1544 484 (ECAbs ("b", (KType, loc),
adam@1544 485 (EAbs ("m", monadRecord (CRel 2, loc) loc, bindType (CRel 2, loc) loc,
adam@1544 486 (ECApp ((ECApp ((EField ((ERel 0, loc), (CName "Bind", loc),
adam@1544 487 {field = bindType (CRel 2, loc) loc,
adam@1544 488 rest = (CRecord ((KType, loc),
adam@1544 489 [((CName "Return", loc),
adam@1544 490 returnType (CRel 2, loc) loc)]),
adam@1544 491 loc)}), loc), (CRel 1, loc)), loc),
adam@1544 492 (CRel 0, loc)), loc)), loc)), loc)), loc)), loc)
adam@1544 493
adam@1544 494 | EFfi ("Basis", "mkMonad") =>
adam@1544 495 (ECAbs ("m", (KArrow ((KType, loc), (KType, loc)), loc),
adam@1544 496 (EAbs ("m", monadRecord (CRel 0, loc) loc, monadRecord (CRel 0, loc) loc,
adam@1544 497 (ERel 0, loc)), loc)), loc)
adam@1544 498
adam@1544 499 | EFfi ("Basis", "transaction_monad") =>
adam@1544 500 (ERecord [((CName "Return", loc),
adam@1544 501 (EFfi ("Basis", "transaction_return"), loc),
adam@1544 502 returnType (CFfi ("Basis", "transaction"), loc) loc),
adam@1544 503 ((CName "Bind", loc),
adam@1544 504 (EFfi ("Basis", "transaction_bind"), loc),
adam@1544 505 bindType (CFfi ("Basis", "transaction"), loc) loc)], loc)
adam@1544 506
adam@1544 507 | EFfi ("Basis", "signal_monad") =>
adam@1544 508 (ERecord [((CName "Return", loc),
adam@1544 509 (EFfi ("Basis", "signal_return"), loc),
adam@1544 510 returnType (CFfi ("Basis", "signal"), loc) loc),
adam@1544 511 ((CName "Bind", loc),
adam@1544 512 (EFfi ("Basis", "signal_bind"), loc),
adam@1544 513 bindType (CFfi ("Basis", "signal"), loc) loc)], loc)
adam@1544 514
adamc@909 515 | EFfi _ => all
adam@1663 516 | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc)
adamc@908 517
adamc@909 518 (*| EApp (
adamc@909 519 (EApp
adamc@909 520 ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _),
adamc@909 521 (EFfi ("Basis", "transaction_monad"), _)), _),
adamc@909 522 (ECase (ed, pes, {disc, ...}), _)), _),
adamc@909 523 trans2) =>
adamc@909 524 let
adamc@909 525 val e' = (EFfi ("Basis", "bind"), loc)
adamc@909 526 val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc)
adamc@909 527 val e' = (ECApp (e', t1), loc)
adamc@909 528 val e' = (ECApp (e', t2), loc)
adamc@909 529 val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc)
adamc@908 530
adamc@909 531 val pes = map (fn (p, e) =>
adamc@909 532 let
adamc@909 533 val e' = (EApp (e', e), loc)
adamc@909 534 val e' = (EApp (e',
adamc@909 535 multiLiftExpInExp (E.patBindsN p)
adamc@909 536 trans2), loc)
adamc@909 537 val e' = exp env e'
adamc@909 538 in
adamc@909 539 (p, e')
adamc@909 540 end) pes
adamc@909 541 in
adamc@909 542 (ECase (exp env ed,
adamc@909 543 pes,
adamc@909 544 {disc = con env disc,
adamc@909 545 result = (CApp ((CFfi ("Basis", "transaction"), loc), con env t2), loc)}),
adamc@909 546 loc)
adamc@909 547 end*)
adamc@908 548
adamc@909 549 | EApp (e1, e2) =>
adamc@909 550 let
adamc@910 551 val env' = deKnown env
adamc@910 552
adamc@909 553 val e1 = exp env e1
adamc@909 554 val e2 = exp env e2
adamc@909 555 in
adamc@1179 556 case #1 e1 of
adam@1817 557 ELet (x, t, e1', e2') =>
adam@1817 558 (ELet (x, t, e1', exp (UnknownE :: env') (EApp (e2', E.liftExpInExp 0 e2), loc)), loc)
adam@1817 559
adam@1817 560 | EAbs (x, dom, _, b) =>
adam@1863 561 if count b <= 1 orelse passive e2 orelse ESpecialize.functionInside IS.empty dom then
adam@1817 562 let
adam@1817 563 val r = exp (KnownE e2 :: env') b
adam@1817 564 in
adam@1817 565 (*Print.prefaces "eapp" [("b", CorePrint.p_exp CoreEnv.empty b),
adam@1817 566 ("env", Print.PD.string (e2s env')),
adam@1817 567 ("e2", CorePrint.p_exp CoreEnv.empty e2),
adam@1817 568 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
adam@1817 569 r
adam@1817 570 end
adam@1817 571 else
adam@1817 572 let
adam@1817 573 val dom = con env' dom
adam@1817 574 val r = exp (UnknownE :: env') b
adam@1817 575 in
adam@1817 576 (*Print.prefaces "El skippo" [("x", Print.PD.string x),
adam@1817 577 ("e2", CorePrint.p_exp CoreEnv.empty e2)];*)
adam@1817 578 (ELet (x, dom, e2, r), loc)
adam@1817 579 end
adam@1817 580
kkallio@1533 581 | ECase (e, pes, cc as {disc, result = res as (TFun (_, c2), _)}) =>
kkallio@1533 582 let
kkallio@1533 583 val pes' = map (fn (p, body) =>
kkallio@1533 584 let
adam@1534 585 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env
kkallio@1533 586 val body' = exp env' (EApp (body, multiLiftExpInExp (patBinds p) e2), #2 body)
kkallio@1533 587 in
kkallio@1533 588 (p, body')
kkallio@1533 589 end) pes
kkallio@1533 590
kkallio@1533 591 val cc' = {disc = disc, result = c2}
kkallio@1533 592 in
kkallio@1533 593 (ECase (e, pes', cc'), loc)
kkallio@1533 594 end
adamc@1179 595 | _ => (EApp (e1, e2), loc)
adamc@909 596 end
adamc@509 597
adamc@909 598 | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc)
adamc@509 599
adamc@909 600 | ECApp (e, c) =>
adamc@909 601 let
adamc@909 602 val e = exp env e
adamc@909 603 val c = con env c
adamc@909 604 in
adamc@909 605 case #1 e of
adamc@1181 606 ECAbs (_, _, b) =>
adamc@1181 607 let
adamc@1181 608 val r = exp (KnownC c :: deKnown env) b
adamc@1181 609 in
adamc@1181 610 (*Print.prefaces "csub" [("l", Print.PD.string (ErrorMsg.spanToString loc)),
adamc@1181 611 ("env", Print.PD.string (e2s (deKnown env))),
adamc@1181 612 ("b", CorePrint.p_exp CoreEnv.empty b),
adamc@1181 613 ("c", CorePrint.p_con CoreEnv.empty c),
adamc@1181 614 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
adamc@1181 615 r
adamc@1181 616 end
kkallio@1533 617 | ECase (e, pes, cc as {disc, result = res as (TCFun (_, _, c'), _)}) =>
kkallio@1533 618 let
kkallio@1533 619 val pes' = map (fn (p, body) =>
kkallio@1533 620 let
adam@1534 621 val env' = List.tabulate (patBinds p, fn _ => UnknownE) @ deKnown env
kkallio@1533 622
kkallio@1533 623 val body' = exp env' (ECApp (body, c), #2 body)
kkallio@1533 624 in
kkallio@1533 625 (p, body')
kkallio@1533 626 end) pes
kkallio@1533 627
kkallio@1533 628 val c' = E.subConInCon (0, c) c'
kkallio@1533 629 val cc' = {disc = disc, result = c'}
kkallio@1533 630 in
kkallio@1533 631 (ECase (e, pes', cc'), loc)
kkallio@1533 632 end
adamc@909 633 | _ => (ECApp (e, c), loc)
adamc@909 634 end
adamc@626 635
adamc@909 636 | ECAbs (x, k, e) => (ECAbs (x, kind env k, exp (UnknownC :: env) e), loc)
adamc@626 637
adamc@909 638 | EKApp (e, k) =>
adamc@909 639 let
adamc@909 640 val e = exp env e
adamc@909 641 in
adamc@909 642 case #1 e of
adamc@1181 643 EKAbs (_, b) =>
adamc@1181 644 let
adamc@1181 645 val r = exp (KnownK k :: deKnown env) b
adamc@1181 646 in
adamc@1181 647 (*Print.prefaces "ksub" [("l", Print.PD.string (ErrorMsg.spanToString loc)),
adamc@1181 648 ("b", CorePrint.p_exp CoreEnv.empty b),
adamc@1181 649 ("k", CorePrint.p_kind CoreEnv.empty k),
adamc@1181 650 ("r", CorePrint.p_exp CoreEnv.empty r)];*)
adamc@1181 651 r
adamc@1181 652 end
adamc@909 653 | _ => (EKApp (e, kind env k), loc)
adamc@909 654 end
adamc@509 655
adamc@909 656 | EKAbs (x, e) => (EKAbs (x, exp (UnknownK :: env) e), loc)
adamc@509 657
adamc@909 658 | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc)
adamc@909 659 | EField (e, c, {field, rest}) =>
adamc@909 660 let
adamc@909 661 val e = exp env e
adamc@909 662 val c = con env c
adamc@509 663
adamc@909 664 fun default () = (EField (e, c, {field = con env field, rest = con env rest}), loc)
adamc@909 665 in
adamc@909 666 case (#1 e, #1 c) of
adamc@909 667 (ERecord xcs, CName x) =>
adamc@909 668 (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of
adamc@909 669 NONE => default ()
adamc@909 670 | SOME (_, e, _) => e)
adamc@909 671 | _ => default ()
adamc@909 672 end
adamc@509 673
adamc@909 674 | EConcat (e1, c1, e2, c2) =>
adamc@909 675 let
adamc@909 676 val e1 = exp env e1
adamc@909 677 val e2 = exp env e2
adamc@909 678 in
adamc@909 679 case (#1 e1, #1 e2) of
adamc@909 680 (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc)
adamc@909 681 | _ =>
adamc@909 682 let
adamc@909 683 val c1 = con env c1
adamc@909 684 val c2 = con env c2
adamc@909 685 in
adamc@909 686 case (#1 c1, #1 c2) of
adamc@909 687 (CRecord (k, xcs1), CRecord (_, xcs2)) =>
adamc@909 688 let
adamc@909 689 val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1
adamc@909 690 val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2
adamc@909 691 in
adamc@909 692 exp (deKnown env) (ERecord (xes1 @ xes2), loc)
adamc@909 693 end
adamc@909 694 | _ => (EConcat (e1, c1, e2, c2), loc)
adamc@909 695 end
adamc@909 696 end
adamc@509 697
adamc@909 698 | ECut (e, c, {field, rest}) =>
adamc@909 699 let
adamc@909 700 val e = exp env e
adamc@909 701 val c = con env c
adamc@509 702
adamc@909 703 fun default () =
adamc@909 704 let
adamc@909 705 val rest = con env rest
adamc@909 706 in
adamc@909 707 case #1 rest of
adamc@909 708 CRecord (k, xcs) =>
adamc@909 709 let
adamc@909 710 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@909 711 in
adamc@909 712 exp (deKnown env) (ERecord xes, loc)
adamc@909 713 end
adamc@909 714 | _ => (ECut (e, c, {field = con env field, rest = rest}), loc)
adamc@909 715 end
adamc@909 716 in
adamc@909 717 case (#1 e, #1 c) of
adamc@909 718 (ERecord xes, CName x) =>
adamc@909 719 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then
adamc@909 720 (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x
adamc@909 721 | _ => raise Fail "Reduce: ECut") xes), loc)
adamc@909 722 else
adamc@909 723 default ()
adamc@909 724 | _ => default ()
adamc@909 725 end
adamc@509 726
adamc@909 727 | ECutMulti (e, c, {rest}) =>
adamc@909 728 let
adamc@909 729 val e = exp env e
adamc@909 730 val c = con env c
adamc@509 731
adamc@909 732 fun default () =
adamc@909 733 let
adamc@909 734 val rest = con env rest
adamc@909 735 in
adamc@909 736 case #1 rest of
adamc@909 737 CRecord (k, xcs) =>
adamc@909 738 let
adamc@909 739 val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs
adamc@909 740 in
adamc@909 741 exp (deKnown env) (ERecord xes, loc)
adamc@909 742 end
adamc@909 743 | _ => (ECutMulti (e, c, {rest = rest}), loc)
adamc@909 744 end
adamc@909 745 in
adamc@909 746 case (#1 e, #1 c) of
adamc@909 747 (ERecord xes, CRecord (_, xcs)) =>
adamc@909 748 if List.all (fn ((CName _, _), _, _) => true | _ => false) xes
adamc@909 749 andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then
adamc@909 750 (ERecord (List.filter (fn ((CName x', _), _, _) =>
adamc@909 751 List.all (fn ((CName x, _), _) => x' <> x
adamc@909 752 | _ => raise Fail "Reduce: ECutMulti [1]") xcs
adamc@909 753 | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc)
adamc@909 754 else
adamc@909 755 default ()
adamc@909 756 | _ => default ()
adamc@909 757 end
adamc@823 758
adamc@909 759 | ECase (_, [((PRecord [], _), e)], _) => exp env e
adamc@909 760 | ECase (_, [((PWild, _), e)], _) => exp env e
adamc@509 761
adamc@909 762 | ECase (e, pes, {disc, result}) =>
adamc@909 763 let
adamc@909 764 fun pat (all as (p, loc)) =
adamc@909 765 case p of
adamc@909 766 PWild => all
adamc@909 767 | PVar (x, t) => (PVar (x, con env t), loc)
adamc@909 768 | PPrim _ => all
adamc@909 769 | PCon (dk, pc, cs, po) =>
adamc@909 770 (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc)
adamc@909 771 | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc)
adamc@930 772
adamc@930 773 fun push () =
adamc@930 774 (ECase (exp env e,
adamc@930 775 map (fn (p, e) => (pat p,
adamc@930 776 exp (List.tabulate (patBinds p,
adamc@930 777 fn _ => UnknownE) @ env) e))
adamc@930 778 pes, {disc = con env disc, result = con env result}), loc)
adamc@930 779
adamc@930 780 fun search pes =
adamc@930 781 case pes of
adamc@930 782 [] => push ()
adamc@930 783 | (p, body) :: pes =>
adamc@930 784 case match (env, p, e) of
adamc@930 785 No => search pes
adamc@930 786 | Maybe => push ()
adamc@930 787 | Yes env' => exp env' body
adamc@909 788 in
adamc@930 789 search pes
adamc@909 790 end
adamc@509 791
adamc@909 792 | EWrite e => (EWrite (exp env e), loc)
adamc@909 793 | EClosure (n, es) => (EClosure (n, map (exp env) es), loc)
adamc@607 794
adamc@910 795 | ELet (x, t, e1, e2) =>
adam@1289 796 let
adam@1817 797 val e1' = exp env e1
adam@1817 798
adam@1289 799 val t = con env t
adam@1289 800 in
adam@1863 801 if notFfi t andalso (passive e1' orelse count e2 <= 1 orelse ESpecialize.functionInside IS.empty t) then
adam@1289 802 exp (KnownE e1 :: env) e2
adam@1289 803 else
adam@1817 804 (ELet (x, t, e1', exp (UnknownE :: env) e2), loc)
adam@1289 805 end
adamc@909 806
adam@1848 807 | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc)
adamc@909 808 in
adamc@909 809 (*if dangling (edepth' (deKnown env)) r then
adamc@909 810 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@909 811 ("r", CorePrint.p_exp CoreEnv.empty r)];
adamc@909 812 raise Fail "!!")
adamc@909 813 else
adamc@909 814 ();*)
adamc@1272 815 (*if cdangling (cdepth' (deKnown env)) r then
adamc@1272 816 (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all),
adamc@1272 817 ("r", CorePrint.p_exp CoreEnv.empty r)];
adamc@1272 818 raise Fail "!!")
adamc@1272 819 else
adamc@1272 820 ();*)
adamc@909 821 r
adamc@909 822 end
adamc@417 823 in
adamc@626 824 {kind = kind, con = con, exp = exp}
adamc@417 825 end
adamc@21 826
adamc@626 827 fun kind namedC env k = #kind (kindConAndExp (namedC, IM.empty)) env k
adamc@626 828 fun con namedC env c = #con (kindConAndExp (namedC, IM.empty)) env c
adamc@626 829 fun exp (namedC, namedE) env e = #exp (kindConAndExp (namedC, namedE)) env e
adamc@20 830
adamc@508 831 fun reduce file =
adamc@508 832 let
adamc@1016 833 val uses = CoreUtil.File.fold {kind = fn (_, m) => m,
adamc@1016 834 con = fn (_, m) => m,
adamc@1016 835 exp = fn (e, m) =>
adamc@1016 836 case e of
adamc@1016 837 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
adamc@1016 838 | _ => m,
adamc@1016 839 decl = fn (_, m) => m}
adamc@1016 840 IM.empty file
adamc@1016 841
adamc@1016 842 fun isPoly names = CoreUtil.Con.exists {kind = fn _ => false,
adamc@1016 843 con = fn TCFun _ => true
adamc@1016 844 | TKFun _ => true
adamc@1016 845 | CNamed n => IS.member (names, n)
adamc@1016 846 | _ => false}
adamc@1016 847
adamc@1016 848 val size = CoreUtil.Exp.fold {kind = fn (_, n) => n,
adamc@1016 849 con = fn (_, n) => n,
adamc@1016 850 exp = fn (_, n) => n + 1} 0
adamc@1016 851
adam@1969 852 fun mayInline (polyC, n, t, e, s) =
adamc@1240 853 let
adamc@1240 854 fun isPolicy t =
adamc@1240 855 case #1 t of
adamc@1240 856 CFfi ("Basis", "sql_policy") => true
adamc@1240 857 | TFun (_, t) => isPolicy t
adamc@1240 858 | _ => false
adamc@1240 859 in
adam@1969 860 not (Settings.checkNeverInline s) andalso
adamc@1240 861 case IM.find (uses, n) of
adamc@1240 862 NONE => false
adamc@1240 863 | SOME count => count <= 1
adamc@1240 864 orelse (case #1 e of
adamc@1240 865 ERecord _ => true
adamc@1240 866 | _ => false)
adamc@1240 867 orelse isPolicy t
adamc@1240 868 orelse isPoly polyC t
adamc@1240 869 orelse size e <= Settings.getCoreInline ()
adamc@1240 870 end
adamc@1016 871
adamc@1016 872 fun doDecl (d as (_, loc), st as (polyC, namedC, namedE)) =
adamc@508 873 case #1 d of
adamc@508 874 DCon (x, n, k, c) =>
adamc@508 875 let
adamc@626 876 val k = kind namedC [] k
adamc@509 877 val c = con namedC [] c
adamc@508 878 in
adamc@508 879 ((DCon (x, n, k, c), loc),
adamc@1016 880 (if isPoly polyC c then
adamc@1016 881 IS.add (polyC, n)
adamc@1016 882 else
adamc@1016 883 polyC,
adamc@1016 884 IM.insert (namedC, n, c),
adamc@1016 885 namedE))
adamc@508 886 end
adamc@807 887 | DDatatype dts =>
adamc@807 888 ((DDatatype (map (fn (x, n, ps, cs) =>
adamc@807 889 let
adamc@807 890 val env = map (fn _ => UnknownC) ps
adamc@807 891 in
adamc@807 892 (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs)
adamc@807 893 end) dts), loc),
adamc@1016 894 (if List.exists (fn (_, _, _, cs) => List.exists (fn (_, _, co) => case co of
adamc@1016 895 NONE => false
adamc@1016 896 | SOME c => isPoly polyC c) cs)
adamc@1016 897 dts then
adamc@1016 898 foldl (fn ((_, n, _, _), polyC) => IS.add (polyC, n)) polyC dts
adamc@1016 899 else
adamc@1016 900 polyC,
adamc@1016 901 namedC,
adamc@1016 902 namedE))
adamc@508 903 | DVal (x, n, t, e, s) =>
adamc@508 904 let
adamc@509 905 val t = con namedC [] t
adamc@509 906 val e = exp (namedC, namedE) [] e
adamc@508 907 in
adamc@508 908 ((DVal (x, n, t, e, s), loc),
adamc@1016 909 (polyC,
adamc@1016 910 namedC,
adam@1969 911 if mayInline (polyC, n, t, e, s) then
adamc@1016 912 IM.insert (namedE, n, e)
adamc@1016 913 else
adamc@1016 914 namedE))
adamc@508 915 end
adamc@508 916 | DValRec vis =>
adamc@910 917 ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t,
adamc@910 918 exp (namedC, namedE) [] e, s)) vis), loc),
adamc@508 919 st)
adamc@508 920 | DExport _ => (d, st)
adamc@707 921 | DTable (s, n, c, s', pe, pc, ce, cc) => ((DTable (s, n, con namedC [] c, s',
adamc@707 922 exp (namedC, namedE) [] pe,
adamc@707 923 con namedC [] pc,
adamc@707 924 exp (namedC, namedE) [] ce,
adamc@707 925 con namedC [] cc), loc), st)
adamc@508 926 | DSequence _ => (d, st)
adamc@754 927 | DView (s, n, s', e, c) => ((DView (s, n, s', exp (namedC, namedE) [] e, con namedC [] c), loc), st)
adamc@508 928 | DDatabase _ => (d, st)
adamc@509 929 | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st)
adamc@720 930 | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st)
adamc@1075 931 | DTask (e1, e2) =>
adamc@1073 932 let
adamc@1075 933 val e1 = exp (namedC, namedE) [] e1
adamc@1075 934 val e2 = exp (namedC, namedE) [] e2
adamc@1073 935 in
adamc@1075 936 ((DTask (e1, e2), loc),
adamc@1073 937 (polyC,
adamc@1073 938 namedC,
adamc@1073 939 namedE))
adamc@1073 940 end
adamc@1199 941 | DPolicy e1 =>
adamc@1199 942 let
adamc@1199 943 val e1 = exp (namedC, namedE) [] e1
adamc@1199 944 in
adamc@1199 945 ((DPolicy e1, loc),
adamc@1199 946 (polyC,
adamc@1199 947 namedC,
adamc@1199 948 namedE))
adamc@1199 949 end
adam@1294 950 | DOnError _ => (d, st)
adamc@20 951
adamc@1016 952 val (file, _) = ListUtil.foldlMap doDecl (IS.empty, IM.empty, IM.empty) file
adamc@508 953 in
adamc@508 954 file
adamc@508 955 end
adamc@20 956
adamc@20 957 end