Mercurial > urweb

annotate src/mono_reduce.sml @ 1415:e65082d76d26

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Only announce URI serving in standalone HTTP server (grandfathered into release!)
author Adam Chlipala <adam@chlipala.net>
date Sun, 23 Jan 2011 15:34:06 -0500
parents d328983dc5a6
children bd6c90f5a428
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
adamc@1225 79 | EUnurlify _ => false
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]
adamc@765 398 | EFfiApp (m, x, es) =>
adamc@1171 399 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
adam@1394 400 List.concat (map (summarize d) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
adam@1394 401 WritePage
adam@1394 402 else
adam@1394 403 Unsure]
adamc@765 404 else
adamc@765 405 List.concat (map (summarize d) es)
adamc@579 406 | EApp ((EFfi _, _), e) => summarize d e
adamc@579 407 | EApp _ =>
adamc@579 408 let
adamc@694 409 fun unravel (e, passed, ls) =
adamc@579 410 case e of
adamc@579 411 ENamed n =>
adamc@579 412 let
adamc@579 413 val ls = rev ls
adamc@579 414 in
adamc@948 415 if IS.member (impures, n) then
adamc@948 416 case IM.find (absCounts, n) of
adamc@948 417 NONE => [Unsure]
adamc@948 418 | SOME len =>
adamc@948 419 if passed < len then
adamc@948 420 ls
adamc@948 421 else
adamc@948 422 ls @ [Unsure]
adamc@948 423 else
adamc@948 424 ls
adamc@579 425 end
adamc@579 426 | ERel n => List.revAppend (ls,
adamc@579 427 if n = d then
adamc@579 428 [UseRel, Unsure]
adamc@579 429 else
adamc@579 430 [Unsure])
adamc@579 431 | EApp (f, x) =>
adamc@995 432 unravel (#1 f, passed + 1, List.revAppend (summarize d x,
adamc@995 433 ls))
adam@1394 434 | EError _ => [Abort]
adamc@579 435 | _ => [Unsure]
adamc@579 436 in
adamc@694 437 unravel (e, 0, [])
adamc@579 438 end
adamc@252 439
adamc@941 440 | EAbs _ => []
adamc@316 441
adamc@579 442 | EUnop (_, e) => summarize d e
adam@1360 443 | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2
adamc@470 444
adamc@579 445 | ERecord xets => List.concat (map (summarize d o #2) xets)
adamc@579 446 | EField (e, _) => summarize d e
adamc@470 447
adamc@1214 448 | ECase (e, pes, _) =>
adamc@1214 449 let
adamc@579 450 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
adam@1394 451
adam@1394 452 fun splitRel ls acc =
adam@1394 453 case ls of
adam@1394 454 [] => (acc, false, ls)
adam@1394 455 | UseRel :: ls => (acc, true, ls)
adam@1394 456 | v :: ls => splitRel ls (v :: acc)
adam@1394 457
adam@1394 458 val (pre, used, post) = foldl (fn (ls, (pre, used, post)) =>
adam@1394 459 let
adam@1394 460 val (pre', used', post') = splitRel ls []
adam@1394 461 in
adam@1394 462 (pre' @ pre, used' orelse used, post' @ post)
adam@1394 463 end)
adam@1394 464 ([], false, []) lss
adamc@579 465 in
adam@1394 466 summarize d e
adam@1394 467 @ pre
adam@1394 468 @ (if used then [UseRel] else [])
adam@1394 469 @ post
adamc@1214 470 end
adamc@579 471 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
adamc@316 472
adamc@1225 473 | EError (e, _) => summarize d e @ [Abort]
adamc@1225 474 | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
adamc@1225 475 | ERedirect (e, _) => summarize d e @ [Abort]
adamc@318 476
adamc@579 477 | EWrite e => summarize d e @ [WritePage]
adamc@579 478
adamc@579 479 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 480 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
adamc@456 481
adamc@579 482 | EClosure (_, es) => List.concat (map (summarize d) es)
adamc@470 483
adamc@579 484 | EQuery {query, body, initial, ...} =>
adamc@579 485 List.concat [summarize d query,
adamc@579 486 summarize d initial,
adamc@941 487 [ReadDb],
adamc@941 488 summarize (d + 2) body]
adamc@470 489
adam@1293 490 | EDml (e, _) => summarize d e @ [WriteDb]
adamc@579 491 | ENextval e => summarize d e @ [WriteDb]
adamc@1073 492 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
adamc@1112 493 | EUnurlify (e, _, _) => summarize d e
adamc@815 494 | EJavaScript (_, e) => summarize d e
adamc@579 495 | ESignalReturn e => summarize d e
adamc@579 496 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 497 | ESignalSource e => summarize d e
adamc@608 498
adamc@1020 499 | EServerCall (e, _, _) => summarize d e @ [Unsure]
adamc@1021 500 | ERecv (e, _) => summarize d e @ [Unsure]
adamc@1021 501 | ESleep e => summarize d e @ [Unsure]
adamc@1021 502 | ESpawn e => summarize d e @ [Unsure]
adamc@579 503 in
adamc@579 504 (*Print.prefaces "Summarize"
adamc@579 505 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
adamc@579 506 ("d", Print.PD.string (Int.toString d)),
adamc@579 507 ("s", p_events s)];*)
adamc@579 508 s
adamc@579 509 end
adamc@470 510
adamc@919 511 val impure = fn env => fn e =>
adamc@948 512 simpleImpure (timpures, impures) env e andalso impure e
adamc@916 513 andalso not (List.null (summarize ~1 e))
adamc@916 514
adamc@470 515 fun exp env e =
adamc@470 516 let
adamc@470 517 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
adamc@470 518
adamc@1017 519 fun doLet (x, t, e', b) =
adamc@1017 520 let
adamc@1017 521 fun doSub () =
adamc@1017 522 let
adamc@1017 523 val r = subExpInExp (0, e') b
adamc@1017 524 in
adamc@1017 525 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
adamc@1017 526 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 527 ("r", MonoPrint.p_exp env r)];*)
adamc@1017 528 #1 (reduceExp env r)
adamc@1017 529 end
adamc@1017 530
adamc@1017 531 fun trySub () =
adamc@1017 532 ((*Print.prefaces "trySub"
adamc@1017 533 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
adamc@1017 534 case t of
adamc@1017 535 (TFfi ("Basis", "string"), _) => doSub ()
adamc@1017 536 | (TSignal _, _) => e
adamc@1017 537 | _ =>
adamc@1017 538 case e' of
adamc@1017 539 (ECase _, _) => e
adamc@1017 540 | _ => doSub ())
adamc@1017 541 in
adamc@1017 542 if impure env e' then
adamc@1017 543 let
adamc@1017 544 val effs_e' = summarize 0 e'
adamc@1017 545 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
adamc@1017 546 val effs_b = summarize 0 b
adamc@1017 547
adam@1394 548 (*val () = Print.fprefaces outf "Try"
adam@1394 549 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
adamc@1017 550 ("e'", MonoPrint.p_exp env e'),
adamc@1017 551 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 552 ("e'_eff", p_events effs_e'),
adamc@1017 553 ("b_eff", p_events effs_b)]*)
adamc@1017 554
adamc@1017 555 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
adamc@1017 556 val writesPage = does WritePage
adamc@1017 557 val readsDb = does ReadDb
adamc@1017 558 val writesDb = does WriteDb
adamc@1225 559 val readsCookie = does ReadCookie
adamc@1225 560 val writesCookie = does ReadCookie
adamc@1017 561
adamc@1017 562 fun verifyUnused eff =
adamc@1017 563 case eff of
adamc@1017 564 UseRel => false
adamc@1017 565 | _ => true
adamc@1017 566
adamc@1017 567 fun verifyCompatible effs =
adamc@1017 568 case effs of
adamc@1017 569 [] => false
adamc@1017 570 | eff :: effs =>
adamc@1017 571 case eff of
adamc@1017 572 Unsure => false
adamc@1017 573 | UseRel => List.all verifyUnused effs
adamc@1017 574 | WritePage => not writesPage andalso verifyCompatible effs
adamc@1017 575 | ReadDb => not writesDb andalso verifyCompatible effs
adamc@1017 576 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
adamc@1225 577 | ReadCookie => not writesCookie andalso verifyCompatible effs
adamc@1225 578 | WriteCookie => not writesCookie andalso not readsCookie
adamc@1225 579 andalso verifyCompatible effs
adamc@1225 580 | Abort => true
adamc@1017 581 in
adamc@1017 582 (*Print.prefaces "verifyCompatible"
adamc@1017 583 [("e'", MonoPrint.p_exp env e'),
adamc@1017 584 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 585 ("effs_e'", Print.p_list p_event effs_e'),
adamc@1017 586 ("effs_b", Print.p_list p_event effs_b)];*)
adamc@1017 587 if (List.null effs_e'
adamc@1017 588 orelse (List.all (fn eff => eff <> Unsure) effs_e'
adamc@1017 589 andalso verifyCompatible effs_b)
adamc@1017 590 orelse (case effs_b of
adamc@1017 591 UseRel :: effs => List.all verifyUnused effs
adamc@1017 592 | _ => false))
adamc@1017 593 andalso countFree 0 0 b = 1
adamc@1017 594 andalso not (freeInAbs b) then
adamc@1017 595 trySub ()
adamc@1017 596 else
adamc@1017 597 e
adamc@1017 598 end
adamc@1017 599 else
adamc@1017 600 trySub ()
adamc@1017 601 end
adamc@1017 602
adamc@470 603 val r =
adamc@470 604 case e of
adamc@470 605 ERel n =>
adamc@470 606 (case E.lookupERel env n of
adamc@470 607 (_, _, SOME e') => #1 e'
adamc@470 608 | _ => e)
adamc@470 609 | ENamed n =>
adamc@470 610 (case E.lookupENamed env n of
adamc@470 611 (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
adamc@470 612 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 613 #1 e')
adamc@470 614 | _ => e)
adamc@470 615
adamc@470 616 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
adamc@470 617 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
adamc@694 618 ("e2", MonoPrint.p_exp env e2),
adamc@694 619 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
adamc@975 620 if impure env e2 orelse countFree 0 0 e1 > 1 then
adamc@470 621 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
adamc@470 622 else
adamc@470 623 #1 (reduceExp env (subExpInExp (0, e2) e1)))
adamc@470 624
adamc@470 625 | ECase (e', pes, {disc, result}) =>
adamc@442 626 let
adamc@470 627 fun push () =
adamc@470 628 case result of
adamc@470 629 (TFun (dom, result), loc) =>
adamc@1107 630 let
adamc@1107 631 fun safe (e, _) =
adamc@1107 632 case e of
adamc@1107 633 EAbs _ => true
adamc@1107 634 | _ => false
adamc@1107 635 in
adamc@1107 636 if List.all (safe o #2) pes then
adamc@1107 637 EAbs ("y", dom, result,
adamc@1107 638 (ECase (liftExpInExp 0 e',
adamc@1107 639 map (fn (p, (EAbs (_, _, _, e), _)) =>
adamc@1107 640 (p, swapExpVarsPat (0, patBinds p) e)
adamc@1107 641 | _ => raise Fail "MonoReduce ECase") pes,
adamc@1107 642 {disc = disc, result = result}), loc))
adamc@1107 643 else
adamc@1107 644 e
adamc@1107 645 end
adamc@470 646 | _ => e
adamc@318 647
adamc@470 648 fun search pes =
adamc@470 649 case pes of
adamc@470 650 [] => push ()
adamc@470 651 | (p, body) :: pes =>
adamc@814 652 case match ([], p, e') of
adamc@470 653 No => search pes
adamc@470 654 | Maybe => push ()
adamc@814 655 | Yes subs =>
adamc@800 656 let
adamc@829 657 val (body, remaining) =
adamc@829 658 foldl (fn (e, (body, remaining)) =>
adamc@829 659 (subExpInExp (0, multiLift remaining e) body, remaining - 1))
adamc@829 660 (body, length subs - 1) subs
adamc@920 661 val r = reduceExp (E.patBinds env p) body
adamc@800 662 in
adamc@829 663 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
adamc@800 664 (*Print.prefaces "ECase"
adamc@829 665 [("old", MonoPrint.p_exp env body),
adamc@829 666 ("body", MonoPrint.p_exp env body),
adamc@800 667 ("r", MonoPrint.p_exp env r)];*)
adamc@800 668 #1 r
adamc@800 669 end
adamc@470 670 in
adamc@941 671 if impure env e' then
adamc@941 672 e
adamc@941 673 else
adamc@941 674 search pes
adamc@470 675 end
adamc@318 676
adamc@470 677 | EField ((ERecord xes, _), x) =>
adamc@470 678 (case List.find (fn (x', _, _) => x' = x) xes of
adamc@470 679 SOME (_, e, _) => #1 e
adamc@470 680 | NONE => e)
adamc@398 681
adamc@470 682 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
adamc@470 683 let
adamc@470 684 val e' = (ELet (x2, t2, e1,
adamc@470 685 (ELet (x1, t1, b1,
adamc@470 686 liftExpInExp 1 b2), loc)), loc)
adamc@442 687 in
adamc@470 688 (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
adamc@470 689 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 690 #1 (reduceExp env e')
adamc@470 691 end
adamc@470 692 | EApp ((ELet (x, t, e, b), loc), e') =>
adamc@470 693 #1 (reduceExp env (ELet (x, t, e,
adamc@470 694 (EApp (b, liftExpInExp 0 e'), loc)), loc))
adamc@470 695
adamc@1017 696 | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
adamc@919 697 if impure env e' then
adamc@1017 698 doLet (x, t, e', b)
adamc@848 699 else
adamc@920 700 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
adamc@920 701 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
adamc@470 702
adamc@1017 703 | ELet (x, t, e', b) => doLet (x, t, e', b)
adamc@252 704
adamc@470 705 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
adamc@470 706 EPrim (Prim.String (s1 ^ s2))
adamc@268 707
adamc@572 708 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 709 #1 (reduceExp env (EApp (e2, e1), loc))
adamc@572 710
adamc@470 711 | _ => e
adamc@470 712 in
adamc@829 713 (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
adamc@829 714 ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
adamc@470 715 r
adamc@470 716 end
adamc@470 717
adamc@470 718 and bind (env, b) =
adamc@470 719 case b of
adamc@470 720 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
adamc@470 721 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
adamc@1017 722 | U.Decl.NamedE (x, n, t, eo, s) =>
adamc@1017 723 let
adamc@1017 724 val eo = case eo of
adamc@1017 725 NONE => NONE
adam@1393 726 | SOME e => if mayInline (n, e, t, s) then
adamc@1017 727 SOME e
adamc@1017 728 else
adamc@1017 729 NONE
adamc@1017 730 in
adamc@1017 731 E.pushENamed env x n t (Option.map (reduceExp env) eo) s
adamc@1017 732 end
adamc@470 733
adamc@470 734 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
adamc@470 735
adamc@801 736 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
adamc@801 737 d)
adamc@398 738 in
adamc@470 739 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
adamc@398 740 end
adamc@133 741
adamc@133 742 end