Mercurial > urweb

annotate src/mono_reduce.sml @ 1451:b6ce8ef0ea88

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Before allowing an indirect return, check (dynamically, for now) that we aren't in an RPC handler
author Adam Chlipala <adam@chlipala.net>
date Sun, 17 Apr 2011 13:43:00 -0400
parents 6e6f1643c4e9
children 4437b008e0ab
rev   line source
adamc@133 1 (* Copyright (c) 2008, Adam Chlipala
adamc@133 2 * All rights reserved.
adamc@133 3 *
adamc@133 4 * Redistribution and use in source and binary forms, with or without
adamc@133 5 * modification, are permitted provided that the following conditions are met:
adamc@133 6 *
adamc@133 7 * - Redistributions of source code must retain the above copyright notice,
adamc@133 8 * this list of conditions and the following disclaimer.
adamc@133 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@133 10 * this list of conditions and the following disclaimer in the documentation
adamc@133 11 * and/or other materials provided with the distribution.
adamc@133 12 * - The names of contributors may not be used to endorse or promote products
adamc@133 13 * derived from this software without specific prior written permission.
adamc@133 14 *
adamc@133 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@133 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@133 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@133 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@133 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@133 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@133 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@133 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@133 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@133 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@133 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@133 26 *)
adamc@133 27
adamc@133 28 (* Simplify a Mono program algebraically *)
adamc@133 29
adamc@133 30 structure MonoReduce :> MONO_REDUCE = struct
adamc@133 31
adamc@133 32 open Mono
adamc@133 33
adamc@133 34 structure E = MonoEnv
adamc@133 35 structure U = MonoUtil
adamc@133 36
adamc@470 37 structure IM = IntBinaryMap
adamc@916 38 structure IS = IntBinarySet
adamc@470 39
adamc@133 40
adamc@948 41 fun simpleTypeImpure tsyms =
adamc@919 42 U.Typ.exists (fn TFun _ => true
adamc@948 43 | TDatatype (n, _) => IS.member (tsyms, n)
adamc@919 44 | _ => false)
adamc@919 45
adamc@948 46 fun simpleImpure (tsyms, syms) =
adamc@919 47 U.Exp.existsB {typ = fn _ => false,
adamc@919 48 exp = fn (env, e) =>
adamc@919 49 case e of
adamc@919 50 EWrite _ => true
adamc@919 51 | EQuery _ => true
adamc@919 52 | EDml _ => true
adamc@919 53 | ENextval _ => true
adamc@1073 54 | ESetval _ => true
adamc@1171 55 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
adamc@919 56 | EServerCall _ => true
adamc@919 57 | ERecv _ => true
adamc@919 58 | ESleep _ => true
adamc@919 59 | ENamed n => IS.member (syms, n)
adamc@919 60 | ERel n =>
adamc@919 61 let
adamc@919 62 val (_, t, _) = E.lookupERel env n
adamc@919 63 in
adamc@948 64 simpleTypeImpure tsyms t
adamc@919 65 end
adamc@919 66 | _ => false,
adamc@919 67 bind = fn (env, b) =>
adamc@919 68 case b of
adamc@919 69 U.Exp.RelE (x, t) => E.pushERel env x t NONE
adamc@919 70 | _ => env}
adamc@916 71
adamc@252 72 fun impure (e, _) =
adamc@252 73 case e of
adamc@252 74 EWrite _ => true
adamc@252 75 | EQuery _ => true
adamc@307 76 | EDml _ => true
adamc@338 77 | ENextval _ => true
adamc@1073 78 | ESetval _ => true
adam@1423 79 | EUnurlify (e, _, _) => impure e
adamc@252 80 | EAbs _ => false
adamc@252 81
adamc@252 82 | EPrim _ => false
adamc@252 83 | ERel _ => false
adamc@252 84 | ENamed _ => false
adamc@252 85 | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
adamc@297 86 | ENone _ => false
adamc@290 87 | ESome (_, e) => impure e
adamc@252 88 | EFfi _ => false
adamc@1171 89 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
adamc@252 90 | EApp ((EFfi _, _), _) => false
adamc@252 91 | EApp _ => true
adamc@252 92
adamc@387 93 | EUnop (_, e) => impure e
adam@1360 94 | EBinop (_, _, e1, e2) => impure e1 orelse impure e2
adamc@387 95
adamc@252 96 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes
adamc@252 97 | EField (e, _) => impure e
adamc@252 98
adamc@252 99 | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
adamc@252 100
adamc@1069 101 | EError _ => true
adamc@741 102 | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2
adamc@1065 103 | ERedirect (e, _) => impure e
adamc@283 104
adamc@252 105 | EStrcat (e1, e2) => impure e1 orelse impure e2
adamc@252 106
adamc@252 107 | ESeq (e1, e2) => impure e1 orelse impure e2
adamc@252 108 | ELet (_, _, e1, e2) => impure e1 orelse impure e2
adamc@252 109
adamc@252 110 | EClosure (_, es) => List.exists impure es
adamc@815 111 | EJavaScript (_, e) => impure e
adamc@568 112 | ESignalReturn e => impure e
adamc@572 113 | ESignalBind (e1, e2) => impure e1 orelse impure e2
adamc@574 114 | ESignalSource e => impure e
adamc@608 115 | EServerCall _ => true
adamc@670 116 | ERecv _ => true
adamc@695 117 | ESleep _ => true
adamc@1021 118 | ESpawn _ => true
adamc@252 119
adamc@252 120 val liftExpInExp = Monoize.liftExpInExp
adamc@252 121
adamc@829 122 fun multiLift n e =
adamc@829 123 case n of
adamc@829 124 0 => e
adamc@829 125 | _ => multiLift (n - 1) (liftExpInExp 0 e)
adamc@829 126
adamc@252 127 val subExpInExp' =
adamc@133 128 U.Exp.mapB {typ = fn t => t,
adamc@133 129 exp = fn (xn, rep) => fn e =>
adamc@133 130 case e of
adamc@133 131 ERel xn' =>
adamc@133 132 (case Int.compare (xn', xn) of
adamc@133 133 EQUAL => #1 rep
adamc@133 134 | GREATER=> ERel (xn' - 1)
adamc@133 135 | LESS => e)
adamc@133 136 | _ => e,
adamc@133 137 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
adamc@133 138 | (ctx, _) => ctx}
adamc@133 139
adamc@252 140 fun subExpInExp (n, e1) e2 =
adamc@252 141 let
adamc@252 142 val r = subExpInExp' (n, e1) e2
adamc@252 143 in
adamc@252 144 (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1),
adamc@252 145 ("e2", MonoPrint.p_exp MonoEnv.empty e2),
adamc@252 146 ("r", MonoPrint.p_exp MonoEnv.empty r)];*)
adamc@252 147 r
adamc@252 148 end
adamc@133 149
adamc@133 150 fun typ c = c
adamc@133 151
adamc@316 152 val swapExpVars =
adamc@316 153 U.Exp.mapB {typ = fn t => t,
adamc@316 154 exp = fn lower => fn e =>
adamc@316 155 case e of
adamc@316 156 ERel xn =>
adamc@316 157 if xn = lower then
adamc@316 158 ERel (lower + 1)
adamc@316 159 else if xn = lower + 1 then
adamc@316 160 ERel lower
adamc@316 161 else
adamc@316 162 e
adamc@316 163 | _ => e,
adamc@316 164 bind = fn (lower, U.Exp.RelE _) => lower+1
adamc@316 165 | (lower, _) => lower}
adamc@316 166
adamc@341 167 val swapExpVarsPat =
adamc@341 168 U.Exp.mapB {typ = fn t => t,
adamc@341 169 exp = fn (lower, len) => fn e =>
adamc@341 170 case e of
adamc@341 171 ERel xn =>
adamc@341 172 if xn = lower then
adamc@827 173 ERel (lower + len)
adamc@341 174 else if xn >= lower + 1 andalso xn < lower + 1 + len then
adamc@341 175 ERel (xn - 1)
adamc@341 176 else
adamc@341 177 e
adamc@341 178 | _ => e,
adamc@341 179 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
adamc@341 180 | (st, _) => st}
adamc@341 181
adamc@814 182 datatype result = Yes of exp list | No | Maybe
adamc@258 183
adamc@183 184 fun match (env, p : pat, e : exp) =
adamc@183 185 case (#1 p, #1 e) of
adamc@258 186 (PWild, _) => Yes env
adamc@814 187 | (PVar (x, t), _) => Yes (e :: env)
adamc@183 188
adamc@280 189 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
adamc@280 190 if String.isPrefix s' s then
adamc@280 191 Maybe
adamc@280 192 else
adamc@280 193 No
adamc@280 194
adamc@1207 195 | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) =>
adamc@1207 196 if String.isSuffix s' s then
adamc@1207 197 Maybe
adamc@1207 198 else
adamc@1207 199 No
adamc@1207 200
adamc@183 201 | (PPrim p, EPrim p') =>
adamc@183 202 if Prim.equal (p, p') then
adamc@258 203 Yes env
adamc@183 204 else
adamc@258 205 No
adamc@183 206
adamc@188 207 | (PCon (_, PConVar n1, NONE), ECon (_, PConVar n2, NONE)) =>
adamc@183 208 if n1 = n2 then
adamc@258 209 Yes env
adamc@183 210 else
adamc@258 211 No
adamc@183 212
adamc@188 213 | (PCon (_, PConVar n1, SOME p), ECon (_, PConVar n2, SOME e)) =>
adamc@183 214 if n1 = n2 then
adamc@183 215 match (env, p, e)
adamc@183 216 else
adamc@258 217 No
adamc@183 218
adamc@188 219 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, NONE), ECon (_, PConFfi {mod = m2, con = con2, ...}, NONE)) =>
adamc@185 220 if m1 = m2 andalso con1 = con2 then
adamc@258 221 Yes env
adamc@185 222 else
adamc@258 223 No
adamc@185 224
adamc@188 225 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (_, PConFfi {mod = m2, con = con2, ...}, SOME e)) =>
adamc@185 226 if m1 = m2 andalso con1 = con2 then
adamc@185 227 match (env, p, e)
adamc@185 228 else
adamc@258 229 No
adamc@185 230
adamc@183 231 | (PRecord xps, ERecord xes) =>
adamc@183 232 let
adamc@183 233 fun consider (xps, env) =
adamc@183 234 case xps of
adamc@258 235 [] => Yes env
adamc@183 236 | (x, p, _) :: rest =>
adamc@183 237 case List.find (fn (x', _, _) => x' = x) xes of
adamc@258 238 NONE => No
adamc@183 239 | SOME (_, e, _) =>
adamc@183 240 case match (env, p, e) of
adamc@258 241 No => No
adamc@258 242 | Maybe => Maybe
adamc@258 243 | Yes env => consider (rest, env)
adamc@183 244 in
adamc@183 245 consider (xps, env)
adamc@183 246 end
adamc@183 247
adamc@726 248 | (PNone _, ENone _) => Yes env
adamc@921 249 | (PNone _, ESome _) => No
adamc@726 250 | (PSome (_, p), ESome (_, e)) => match (env, p, e)
adamc@921 251 | (PSome _, ENone _) => No
adamc@726 252
adamc@258 253 | _ => Maybe
adamc@183 254
adamc@318 255 datatype event =
adamc@318 256 WritePage
adamc@318 257 | ReadDb
adamc@318 258 | WriteDb
adamc@1225 259 | ReadCookie
adamc@1225 260 | WriteCookie
adamc@481 261 | UseRel
adamc@318 262 | Unsure
adamc@1225 263 | Abort
adamc@318 264
adamc@318 265 fun p_event e =
adamc@318 266 let
adamc@318 267 open Print.PD
adamc@318 268 in
adamc@318 269 case e of
adamc@318 270 WritePage => string "WritePage"
adamc@318 271 | ReadDb => string "ReadDb"
adamc@318 272 | WriteDb => string "WriteDb"
adamc@1225 273 | ReadCookie => string "ReadCookie"
adamc@1225 274 | WriteCookie => string "WriteCookie"
adamc@481 275 | UseRel => string "UseRel"
adamc@318 276 | Unsure => string "Unsure"
adamc@1225 277 | Abort => string "Abort"
adamc@318 278 end
adamc@318 279
adamc@470 280 val p_events = Print.p_list p_event
adamc@470 281
adamc@318 282 fun patBinds (p, _) =
adamc@318 283 case p of
adamc@318 284 PWild => 0
adamc@318 285 | PVar _ => 1
adamc@318 286 | PPrim _ => 0
adamc@318 287 | PCon (_, _, NONE) => 0
adamc@318 288 | PCon (_, _, SOME p) => patBinds p
adamc@318 289 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
adamc@318 290 | PNone _ => 0
adamc@318 291 | PSome (_, p) => patBinds p
adamc@318 292
adamc@932 293 val countFree = U.Exp.foldB {typ = fn (_, n) => n,
adamc@932 294 exp = fn (x, e, n) =>
adamc@932 295 case e of
adamc@932 296 ERel x' => if x = x' then n + 1 else n
adamc@932 297 | _ => n,
adamc@932 298 bind = fn (n, b) =>
adamc@932 299 case b of
adamc@932 300 U.Exp.RelE _ => n + 1
adamc@975 301 | _ => n}
adamc@975 302
adamc@975 303 val freeInAbs = U.Exp.existsB {typ = fn _ => false,
adamc@975 304 exp = fn (n, e) =>
adamc@975 305 case e of
adamc@975 306 EAbs (_, _, _, b) => countFree n 0 b > 0
adamc@975 307 | EJavaScript (_, b) => countFree n 0 b > 0
adamc@975 308 | _ => false,
adamc@975 309 bind = fn (n, b) =>
adamc@975 310 case b of
adamc@975 311 U.Exp.RelE _ => n + 1
adamc@975 312 | _ => n} 0
adamc@932 313
adamc@470 314 fun reduce file =
adamc@470 315 let
adamc@948 316 val (timpures, impures, absCounts) =
adamc@948 317 foldl (fn ((d, _), (timpures, impures, absCounts)) =>
adamc@916 318 let
adamc@916 319 fun countAbs (e, _) =
adamc@916 320 case e of
adamc@916 321 EAbs (_, _, _, e) => 1 + countAbs e
adamc@916 322 | _ => 0
adamc@916 323 in
adamc@916 324 case d of
adamc@948 325 DDatatype dts =>
adamc@948 326 (if List.exists (fn (_, _, cs) =>
adamc@948 327 List.exists (fn (_, _, NONE) => false
adamc@948 328 | (_, _, SOME t) => simpleTypeImpure timpures t) cs)
adamc@948 329 dts then
adamc@948 330 IS.addList (timpures, map #2 dts)
adamc@948 331 else
adamc@948 332 timpures,
adamc@948 333 impures,
adamc@948 334 absCounts)
adamc@948 335 | DVal (_, n, _, e, _) =>
adamc@948 336 (timpures,
adamc@948 337 if simpleImpure (timpures, impures) E.empty e then
adamc@916 338 IS.add (impures, n)
adamc@916 339 else
adamc@916 340 impures,
adamc@916 341 IM.insert (absCounts, n, countAbs e))
adamc@916 342 | DValRec vis =>
adamc@948 343 (timpures,
adamc@948 344 if List.exists (fn (_, _, _, e, _) => simpleImpure (timpures, impures) E.empty e) vis then
adamc@916 345 foldl (fn ((_, n, _, _, _), impures) =>
adamc@916 346 IS.add (impures, n)) impures vis
adamc@916 347 else
adamc@916 348 impures,
adamc@916 349 foldl (fn ((x, n, _, e, _), absCounts) =>
adamc@916 350 IM.insert (absCounts, n, countAbs e))
adamc@916 351 absCounts vis)
adamc@948 352 | _ => (timpures, impures, absCounts)
adamc@916 353 end)
adamc@948 354 (IS.empty, IS.empty, IM.empty) file
adamc@387 355
adamc@1017 356 val uses = U.File.fold {typ = fn (_, m) => m,
adamc@1017 357 exp = fn (e, m) =>
adamc@1017 358 case e of
adamc@1017 359 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
adamc@1017 360 | _ => m,
adamc@1017 361 decl = fn (_, m) => m}
adamc@1017 362 IM.empty file
adamc@1017 363
adamc@1017 364 val size = U.Exp.fold {typ = fn (_, n) => n,
adamc@1017 365 exp = fn (_, n) => n + 1} 0
adamc@1017 366
adam@1360 367 val functionInside' = U.Typ.exists (fn c => case c of
adam@1360 368 TFun _ => true
adam@1360 369 | _ => false)
adam@1360 370
adam@1360 371 fun functionInside t =
adam@1360 372 case #1 t of
adam@1360 373 TFun (t1, t2) => functionInside' t1 orelse functionInside t2
adam@1360 374 | _ => functionInside' t
adam@1360 375
adam@1393 376 fun mayInline (n, e, t, s) =
adamc@1017 377 case IM.find (uses, n) of
adamc@1017 378 NONE => false
adamc@1017 379 | SOME count => count <= 1
adamc@1017 380 orelse size e <= Settings.getMonoInline ()
adam@1360 381 orelse functionInside t
adam@1393 382 orelse Settings.checkAlwaysInline s
adamc@1017 383
adamc@470 384 fun summarize d (e, _) =
adamc@579 385 let
adamc@579 386 val s =
adamc@579 387 case e of
adamc@579 388 EPrim _ => []
adamc@579 389 | ERel n => if n = d then [UseRel] else []
adamc@579 390 | ENamed _ => []
adamc@579 391 | ECon (_, _, NONE) => []
adamc@579 392 | ECon (_, _, SOME e) => summarize d e
adamc@579 393 | ENone _ => []
adamc@579 394 | ESome (_, e) => summarize d e
adamc@579 395 | EFfi _ => []
adamc@1225 396 | EFfiApp ("Basis", "get_cookie", [e]) =>
adamc@1225 397 summarize d e @ [ReadCookie]
adam@1423 398 | EFfiApp ("Basis", "set_cookie", es) =>
adam@1423 399 List.concat (map (summarize d) es) @ [WriteCookie]
adam@1423 400 | EFfiApp ("Basis", "clear_cookie", es) =>
adam@1423 401 List.concat (map (summarize d) es) @ [WriteCookie]
adamc@765 402 | EFfiApp (m, x, es) =>
adamc@1171 403 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
adam@1394 404 List.concat (map (summarize d) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
adam@1394 405 WritePage
adam@1394 406 else
adam@1394 407 Unsure]
adamc@765 408 else
adamc@765 409 List.concat (map (summarize d) es)
adamc@579 410 | EApp ((EFfi _, _), e) => summarize d e
adamc@579 411 | EApp _ =>
adamc@579 412 let
adamc@694 413 fun unravel (e, passed, ls) =
adamc@579 414 case e of
adamc@579 415 ENamed n =>
adamc@579 416 let
adamc@579 417 val ls = rev ls
adamc@579 418 in
adamc@948 419 if IS.member (impures, n) then
adamc@948 420 case IM.find (absCounts, n) of
adamc@948 421 NONE => [Unsure]
adamc@948 422 | SOME len =>
adamc@948 423 if passed < len then
adamc@948 424 ls
adamc@948 425 else
adamc@948 426 ls @ [Unsure]
adamc@948 427 else
adamc@948 428 ls
adamc@579 429 end
adamc@579 430 | ERel n => List.revAppend (ls,
adamc@579 431 if n = d then
adamc@579 432 [UseRel, Unsure]
adamc@579 433 else
adamc@579 434 [Unsure])
adamc@579 435 | EApp (f, x) =>
adamc@995 436 unravel (#1 f, passed + 1, List.revAppend (summarize d x,
adamc@995 437 ls))
adam@1394 438 | EError _ => [Abort]
adamc@579 439 | _ => [Unsure]
adamc@579 440 in
adamc@694 441 unravel (e, 0, [])
adamc@579 442 end
adamc@252 443
adamc@941 444 | EAbs _ => []
adamc@316 445
adamc@579 446 | EUnop (_, e) => summarize d e
adam@1360 447 | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2
adamc@470 448
adamc@579 449 | ERecord xets => List.concat (map (summarize d o #2) xets)
adamc@579 450 | EField (e, _) => summarize d e
adamc@470 451
adamc@1214 452 | ECase (e, pes, _) =>
adamc@1214 453 let
adamc@579 454 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
adam@1394 455
adam@1394 456 fun splitRel ls acc =
adam@1394 457 case ls of
adam@1394 458 [] => (acc, false, ls)
adam@1394 459 | UseRel :: ls => (acc, true, ls)
adam@1394 460 | v :: ls => splitRel ls (v :: acc)
adam@1394 461
adam@1394 462 val (pre, used, post) = foldl (fn (ls, (pre, used, post)) =>
adam@1394 463 let
adam@1394 464 val (pre', used', post') = splitRel ls []
adam@1394 465 in
adam@1394 466 (pre' @ pre, used' orelse used, post' @ post)
adam@1394 467 end)
adam@1394 468 ([], false, []) lss
adamc@579 469 in
adam@1394 470 summarize d e
adam@1394 471 @ pre
adam@1394 472 @ (if used then [UseRel] else [])
adam@1394 473 @ post
adamc@1214 474 end
adamc@579 475 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
adamc@316 476
adamc@1225 477 | EError (e, _) => summarize d e @ [Abort]
adamc@1225 478 | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
adamc@1225 479 | ERedirect (e, _) => summarize d e @ [Abort]
adamc@318 480
adamc@579 481 | EWrite e => summarize d e @ [WritePage]
adamc@579 482
adamc@579 483 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 484 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
adamc@456 485
adamc@579 486 | EClosure (_, es) => List.concat (map (summarize d) es)
adamc@470 487
adamc@579 488 | EQuery {query, body, initial, ...} =>
adamc@579 489 List.concat [summarize d query,
adamc@579 490 summarize d initial,
adamc@941 491 [ReadDb],
adamc@941 492 summarize (d + 2) body]
adamc@470 493
adam@1293 494 | EDml (e, _) => summarize d e @ [WriteDb]
adamc@579 495 | ENextval e => summarize d e @ [WriteDb]
adamc@1073 496 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
adamc@1112 497 | EUnurlify (e, _, _) => summarize d e
adamc@815 498 | EJavaScript (_, e) => summarize d e
adamc@579 499 | ESignalReturn e => summarize d e
adamc@579 500 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 501 | ESignalSource e => summarize d e
adamc@608 502
adamc@1020 503 | EServerCall (e, _, _) => summarize d e @ [Unsure]
adamc@1021 504 | ERecv (e, _) => summarize d e @ [Unsure]
adamc@1021 505 | ESleep e => summarize d e @ [Unsure]
adamc@1021 506 | ESpawn e => summarize d e @ [Unsure]
adamc@579 507 in
adamc@579 508 (*Print.prefaces "Summarize"
adamc@579 509 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
adamc@579 510 ("d", Print.PD.string (Int.toString d)),
adamc@579 511 ("s", p_events s)];*)
adamc@579 512 s
adamc@579 513 end
adamc@470 514
adamc@919 515 val impure = fn env => fn e =>
adamc@948 516 simpleImpure (timpures, impures) env e andalso impure e
adamc@916 517 andalso not (List.null (summarize ~1 e))
adamc@916 518
adamc@470 519 fun exp env e =
adamc@470 520 let
adamc@470 521 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
adamc@470 522
adamc@1017 523 fun doLet (x, t, e', b) =
adamc@1017 524 let
adamc@1017 525 fun doSub () =
adamc@1017 526 let
adamc@1017 527 val r = subExpInExp (0, e') b
adamc@1017 528 in
adamc@1017 529 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
adam@1423 530 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adam@1423 531 ("r", MonoPrint.p_exp env r)];*)
adamc@1017 532 #1 (reduceExp env r)
adamc@1017 533 end
adamc@1017 534
adamc@1017 535 fun trySub () =
adamc@1017 536 ((*Print.prefaces "trySub"
adamc@1017 537 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
adamc@1017 538 case t of
adamc@1017 539 (TFfi ("Basis", "string"), _) => doSub ()
adamc@1017 540 | (TSignal _, _) => e
adamc@1017 541 | _ =>
adamc@1017 542 case e' of
adamc@1017 543 (ECase _, _) => e
adamc@1017 544 | _ => doSub ())
adamc@1017 545 in
adamc@1017 546 if impure env e' then
adamc@1017 547 let
adamc@1017 548 val effs_e' = summarize 0 e'
adamc@1017 549 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
adamc@1017 550 val effs_b = summarize 0 b
adamc@1017 551
adam@1394 552 (*val () = Print.fprefaces outf "Try"
adam@1394 553 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
adamc@1017 554 ("e'", MonoPrint.p_exp env e'),
adamc@1017 555 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 556 ("e'_eff", p_events effs_e'),
adamc@1017 557 ("b_eff", p_events effs_b)]*)
adamc@1017 558
adamc@1017 559 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
adamc@1017 560 val writesPage = does WritePage
adamc@1017 561 val readsDb = does ReadDb
adamc@1017 562 val writesDb = does WriteDb
adamc@1225 563 val readsCookie = does ReadCookie
adamc@1225 564 val writesCookie = does ReadCookie
adamc@1017 565
adamc@1017 566 fun verifyUnused eff =
adamc@1017 567 case eff of
adamc@1017 568 UseRel => false
adamc@1017 569 | _ => true
adamc@1017 570
adamc@1017 571 fun verifyCompatible effs =
adamc@1017 572 case effs of
adamc@1017 573 [] => false
adamc@1017 574 | eff :: effs =>
adamc@1017 575 case eff of
adamc@1017 576 Unsure => false
adamc@1017 577 | UseRel => List.all verifyUnused effs
adamc@1017 578 | WritePage => not writesPage andalso verifyCompatible effs
adamc@1017 579 | ReadDb => not writesDb andalso verifyCompatible effs
adamc@1017 580 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
adamc@1225 581 | ReadCookie => not writesCookie andalso verifyCompatible effs
adamc@1225 582 | WriteCookie => not writesCookie andalso not readsCookie
adamc@1225 583 andalso verifyCompatible effs
adamc@1225 584 | Abort => true
adamc@1017 585 in
adamc@1017 586 (*Print.prefaces "verifyCompatible"
adamc@1017 587 [("e'", MonoPrint.p_exp env e'),
adamc@1017 588 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 589 ("effs_e'", Print.p_list p_event effs_e'),
adamc@1017 590 ("effs_b", Print.p_list p_event effs_b)];*)
adamc@1017 591 if (List.null effs_e'
adamc@1017 592 orelse (List.all (fn eff => eff <> Unsure) effs_e'
adamc@1017 593 andalso verifyCompatible effs_b)
adamc@1017 594 orelse (case effs_b of
adamc@1017 595 UseRel :: effs => List.all verifyUnused effs
adamc@1017 596 | _ => false))
adamc@1017 597 andalso countFree 0 0 b = 1
adamc@1017 598 andalso not (freeInAbs b) then
adamc@1017 599 trySub ()
adamc@1017 600 else
adamc@1017 601 e
adamc@1017 602 end
adamc@1017 603 else
adamc@1017 604 trySub ()
adamc@1017 605 end
adamc@1017 606
adamc@470 607 val r =
adamc@470 608 case e of
adamc@470 609 ERel n =>
adamc@470 610 (case E.lookupERel env n of
adamc@470 611 (_, _, SOME e') => #1 e'
adamc@470 612 | _ => e)
adamc@470 613 | ENamed n =>
adamc@470 614 (case E.lookupENamed env n of
adamc@470 615 (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
adamc@470 616 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 617 #1 e')
adamc@470 618 | _ => e)
adamc@470 619
adamc@470 620 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
adamc@470 621 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
adamc@694 622 ("e2", MonoPrint.p_exp env e2),
adamc@694 623 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
adamc@975 624 if impure env e2 orelse countFree 0 0 e1 > 1 then
adamc@470 625 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
adamc@470 626 else
adamc@470 627 #1 (reduceExp env (subExpInExp (0, e2) e1)))
adamc@470 628
adamc@470 629 | ECase (e', pes, {disc, result}) =>
adamc@442 630 let
adamc@470 631 fun push () =
adamc@470 632 case result of
adamc@470 633 (TFun (dom, result), loc) =>
adamc@1107 634 let
adamc@1107 635 fun safe (e, _) =
adamc@1107 636 case e of
adamc@1107 637 EAbs _ => true
adam@1445 638 | EError _ => true
adamc@1107 639 | _ => false
adamc@1107 640 in
adamc@1107 641 if List.all (safe o #2) pes then
adamc@1107 642 EAbs ("y", dom, result,
adamc@1107 643 (ECase (liftExpInExp 0 e',
adamc@1107 644 map (fn (p, (EAbs (_, _, _, e), _)) =>
adamc@1107 645 (p, swapExpVarsPat (0, patBinds p) e)
adam@1445 646 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
adam@1445 647 (p, (EError (e, t), loc))
adamc@1107 648 | _ => raise Fail "MonoReduce ECase") pes,
adamc@1107 649 {disc = disc, result = result}), loc))
adamc@1107 650 else
adamc@1107 651 e
adamc@1107 652 end
adamc@470 653 | _ => e
adamc@318 654
adamc@470 655 fun search pes =
adamc@470 656 case pes of
adamc@470 657 [] => push ()
adamc@470 658 | (p, body) :: pes =>
adamc@814 659 case match ([], p, e') of
adamc@470 660 No => search pes
adamc@470 661 | Maybe => push ()
adamc@814 662 | Yes subs =>
adamc@800 663 let
adamc@829 664 val (body, remaining) =
adamc@829 665 foldl (fn (e, (body, remaining)) =>
adamc@829 666 (subExpInExp (0, multiLift remaining e) body, remaining - 1))
adamc@829 667 (body, length subs - 1) subs
adamc@920 668 val r = reduceExp (E.patBinds env p) body
adamc@800 669 in
adamc@829 670 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
adamc@800 671 (*Print.prefaces "ECase"
adamc@829 672 [("old", MonoPrint.p_exp env body),
adamc@829 673 ("body", MonoPrint.p_exp env body),
adamc@800 674 ("r", MonoPrint.p_exp env r)];*)
adamc@800 675 #1 r
adamc@800 676 end
adamc@470 677 in
adamc@941 678 if impure env e' then
adamc@941 679 e
adamc@941 680 else
adamc@941 681 search pes
adamc@470 682 end
adamc@318 683
adamc@470 684 | EField ((ERecord xes, _), x) =>
adamc@470 685 (case List.find (fn (x', _, _) => x' = x) xes of
adamc@470 686 SOME (_, e, _) => #1 e
adamc@470 687 | NONE => e)
adamc@398 688
adamc@470 689 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
adamc@470 690 let
adamc@470 691 val e' = (ELet (x2, t2, e1,
adamc@470 692 (ELet (x1, t1, b1,
adamc@470 693 liftExpInExp 1 b2), loc)), loc)
adamc@442 694 in
adamc@470 695 (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
adamc@470 696 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 697 #1 (reduceExp env e')
adamc@470 698 end
adamc@470 699 | EApp ((ELet (x, t, e, b), loc), e') =>
adamc@470 700 #1 (reduceExp env (ELet (x, t, e,
adamc@470 701 (EApp (b, liftExpInExp 0 e'), loc)), loc))
adamc@470 702
adamc@1017 703 | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
adamc@919 704 if impure env e' then
adamc@1017 705 doLet (x, t, e', b)
adamc@848 706 else
adamc@920 707 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
adamc@920 708 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
adamc@470 709
adamc@1017 710 | ELet (x, t, e', b) => doLet (x, t, e', b)
adamc@252 711
adamc@470 712 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
adamc@470 713 EPrim (Prim.String (s1 ^ s2))
adamc@268 714
adamc@572 715 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 716 #1 (reduceExp env (EApp (e2, e1), loc))
adamc@572 717
adamc@470 718 | _ => e
adamc@470 719 in
adamc@829 720 (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
adamc@829 721 ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
adamc@470 722 r
adamc@470 723 end
adamc@470 724
adamc@470 725 and bind (env, b) =
adamc@470 726 case b of
adamc@470 727 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
adamc@470 728 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
adamc@1017 729 | U.Decl.NamedE (x, n, t, eo, s) =>
adamc@1017 730 let
adamc@1017 731 val eo = case eo of
adamc@1017 732 NONE => NONE
adam@1393 733 | SOME e => if mayInline (n, e, t, s) then
adamc@1017 734 SOME e
adamc@1017 735 else
adamc@1017 736 NONE
adamc@1017 737 in
adamc@1017 738 E.pushENamed env x n t (Option.map (reduceExp env) eo) s
adamc@1017 739 end
adamc@470 740
adamc@470 741 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
adamc@470 742
adamc@801 743 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
adamc@801 744 d)
adamc@398 745 in
adamc@470 746 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
adamc@398 747 end
adamc@133 748
adamc@133 749 end