Mercurial > urweb

annotate src/reduce.sml @ 1804:62c18ecbfec4

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