Mercurial > urweb

annotate src/mono_reduce.sml @ 1932:98895243b5b6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change handling of returned text blobs, to activate the normal EWrite optimizations
author Adam Chlipala <adam@chlipala.net>
date Wed, 11 Dec 2013 18:22:10 -0500
parents 0480b8f29a47
children 16c219c74426
rev   line source
adam@1848 1 (* Copyright (c) 2008, 2013, 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
adam@1852 34 val fullMode = ref false
adam@1852 35
adamc@133 36 structure E = MonoEnv
adamc@133 37 structure U = MonoUtil
adamc@133 38
adamc@470 39 structure IM = IntBinaryMap
adamc@916 40 structure IS = IntBinarySet
adamc@470 41
adamc@133 42
adamc@948 43 fun simpleTypeImpure tsyms =
adamc@919 44 U.Typ.exists (fn TFun _ => true
adamc@948 45 | TDatatype (n, _) => IS.member (tsyms, n)
adamc@919 46 | _ => false)
adamc@919 47
adamc@948 48 fun simpleImpure (tsyms, syms) =
adamc@919 49 U.Exp.existsB {typ = fn _ => false,
adamc@919 50 exp = fn (env, e) =>
adamc@919 51 case e of
adamc@919 52 EWrite _ => true
adamc@919 53 | EQuery _ => true
adamc@919 54 | EDml _ => true
adamc@919 55 | ENextval _ => true
adamc@1073 56 | ESetval _ => true
adamc@1171 57 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
adamc@919 58 | EServerCall _ => true
adamc@919 59 | ERecv _ => true
adamc@919 60 | ESleep _ => true
adamc@919 61 | ENamed n => IS.member (syms, n)
adamc@919 62 | ERel n =>
adamc@919 63 let
adamc@919 64 val (_, t, _) = E.lookupERel env n
adamc@919 65 in
adamc@948 66 simpleTypeImpure tsyms t
adamc@919 67 end
adamc@919 68 | _ => false,
adamc@919 69 bind = fn (env, b) =>
adamc@919 70 case b of
adamc@919 71 U.Exp.RelE (x, t) => E.pushERel env x t NONE
adamc@919 72 | _ => env}
adamc@916 73
adamc@252 74 fun impure (e, _) =
adamc@252 75 case e of
adamc@252 76 EWrite _ => true
adamc@252 77 | EQuery _ => true
adamc@307 78 | EDml _ => true
adamc@338 79 | ENextval _ => true
adamc@1073 80 | ESetval _ => true
adam@1423 81 | EUnurlify (e, _, _) => impure e
adamc@252 82 | EAbs _ => false
adamc@252 83
adamc@252 84 | EPrim _ => false
adamc@252 85 | ERel _ => false
adamc@252 86 | ENamed _ => false
adamc@252 87 | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
adamc@297 88 | ENone _ => false
adamc@290 89 | ESome (_, e) => impure e
adamc@252 90 | EFfi _ => false
adamc@1171 91 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
adamc@252 92 | EApp ((EFfi _, _), _) => false
adamc@252 93 | EApp _ => true
adamc@252 94
adamc@387 95 | EUnop (_, e) => impure e
adam@1360 96 | EBinop (_, _, e1, e2) => impure e1 orelse impure e2
adamc@387 97
adamc@252 98 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes
adamc@252 99 | EField (e, _) => impure e
adamc@252 100
adamc@252 101 | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
adamc@252 102
adamc@1069 103 | EError _ => true
adam@1932 104 | EReturnBlob {blob = NONE, mimeType = e2, ...} => impure e2
adam@1932 105 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => impure e1 orelse impure e2
adamc@1065 106 | ERedirect (e, _) => impure e
adamc@283 107
adamc@252 108 | EStrcat (e1, e2) => impure e1 orelse impure e2
adamc@252 109
adamc@252 110 | ESeq (e1, e2) => impure e1 orelse impure e2
adamc@252 111 | ELet (_, _, e1, e2) => impure e1 orelse impure e2
adamc@252 112
adamc@252 113 | EClosure (_, es) => List.exists impure es
adamc@815 114 | EJavaScript (_, e) => impure e
adamc@568 115 | ESignalReturn e => impure e
adamc@572 116 | ESignalBind (e1, e2) => impure e1 orelse impure e2
adamc@574 117 | ESignalSource e => impure e
adamc@608 118 | EServerCall _ => true
adamc@670 119 | ERecv _ => true
adamc@695 120 | ESleep _ => true
adamc@1021 121 | ESpawn _ => true
adamc@252 122
adamc@252 123 val liftExpInExp = Monoize.liftExpInExp
adamc@252 124
adamc@829 125 fun multiLift n e =
adamc@829 126 case n of
adamc@829 127 0 => e
adamc@829 128 | _ => multiLift (n - 1) (liftExpInExp 0 e)
adamc@829 129
adamc@252 130 val subExpInExp' =
adamc@133 131 U.Exp.mapB {typ = fn t => t,
adamc@133 132 exp = fn (xn, rep) => fn e =>
adamc@133 133 case e of
adamc@133 134 ERel xn' =>
adamc@133 135 (case Int.compare (xn', xn) of
adamc@133 136 EQUAL => #1 rep
adamc@133 137 | GREATER=> ERel (xn' - 1)
adamc@133 138 | LESS => e)
adamc@133 139 | _ => e,
adamc@133 140 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
adamc@133 141 | (ctx, _) => ctx}
adamc@133 142
adamc@252 143 fun subExpInExp (n, e1) e2 =
adamc@252 144 let
adamc@252 145 val r = subExpInExp' (n, e1) e2
adamc@252 146 in
adamc@252 147 (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1),
adamc@252 148 ("e2", MonoPrint.p_exp MonoEnv.empty e2),
adamc@252 149 ("r", MonoPrint.p_exp MonoEnv.empty r)];*)
adamc@252 150 r
adamc@252 151 end
adamc@133 152
adamc@133 153 fun typ c = c
adamc@133 154
adamc@316 155 val swapExpVars =
adamc@316 156 U.Exp.mapB {typ = fn t => t,
adamc@316 157 exp = fn lower => fn e =>
adamc@316 158 case e of
adamc@316 159 ERel xn =>
adamc@316 160 if xn = lower then
adamc@316 161 ERel (lower + 1)
adamc@316 162 else if xn = lower + 1 then
adamc@316 163 ERel lower
adamc@316 164 else
adamc@316 165 e
adamc@316 166 | _ => e,
adamc@316 167 bind = fn (lower, U.Exp.RelE _) => lower+1
adamc@316 168 | (lower, _) => lower}
adamc@316 169
adamc@341 170 val swapExpVarsPat =
adamc@341 171 U.Exp.mapB {typ = fn t => t,
adamc@341 172 exp = fn (lower, len) => fn e =>
adamc@341 173 case e of
adamc@341 174 ERel xn =>
adamc@341 175 if xn = lower then
adamc@827 176 ERel (lower + len)
adamc@341 177 else if xn >= lower + 1 andalso xn < lower + 1 + len then
adamc@341 178 ERel (xn - 1)
adamc@341 179 else
adamc@341 180 e
adamc@341 181 | _ => e,
adamc@341 182 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
adamc@341 183 | (st, _) => st}
adamc@341 184
adam@1817 185 datatype result = Yes of (string * typ * exp) list | No | Maybe
adamc@258 186
adamc@183 187 fun match (env, p : pat, e : exp) =
adamc@183 188 case (#1 p, #1 e) of
adamc@258 189 (PWild, _) => Yes env
adam@1817 190 | (PVar (x, t), _) => Yes ((x, t, e) :: env)
adamc@183 191
adamc@280 192 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
adamc@280 193 if String.isPrefix s' s then
adamc@280 194 Maybe
adamc@280 195 else
adamc@280 196 No
adamc@280 197
adamc@1207 198 | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) =>
adamc@1207 199 if String.isSuffix s' s then
adamc@1207 200 Maybe
adamc@1207 201 else
adamc@1207 202 No
adamc@1207 203
adamc@183 204 | (PPrim p, EPrim p') =>
adamc@183 205 if Prim.equal (p, p') then
adamc@258 206 Yes env
adamc@183 207 else
adamc@258 208 No
adamc@183 209
kkallio@1489 210 | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) =>
adamc@183 211 if n1 = n2 then
kkallio@1489 212 case (po, eo) of
kkallio@1489 213 (NONE, NONE) => Yes env
kkallio@1489 214 | (SOME p, SOME e) => match (env, p, e)
kkallio@1489 215 | _ => Maybe
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
adam@1845 314 fun reduce (file : 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
adam@1820 319 fun countAbs env e =
adam@1820 320 case #1 e of
adam@1820 321 EAbs (x, t, _, e) => 1 + countAbs (E.pushERel env x t NONE) e
adam@1820 322 | _ =>
adam@1820 323 let
adam@1820 324 fun remaining e =
adam@1820 325 case #1 e of
adam@1820 326 ENamed n => IM.find (absCounts, n)
adam@1820 327 | EApp (e, arg) =>
adam@1820 328 if simpleImpure (timpures, impures) env arg then
adam@1820 329 NONE
adam@1820 330 else
adam@1820 331 (case remaining e of
adam@1820 332 NONE => NONE
adam@1820 333 | SOME n => if n > 0 then
adam@1820 334 SOME (n - 1)
adam@1820 335 else
adam@1820 336 NONE)
adam@1820 337 | _ => NONE
adam@1820 338 in
adam@1820 339 getOpt (remaining e, 0)
adam@1820 340 end
adamc@916 341 in
adamc@916 342 case d of
adamc@948 343 DDatatype dts =>
adamc@948 344 (if List.exists (fn (_, _, cs) =>
adamc@948 345 List.exists (fn (_, _, NONE) => false
adamc@948 346 | (_, _, SOME t) => simpleTypeImpure timpures t) cs)
adamc@948 347 dts then
adamc@948 348 IS.addList (timpures, map #2 dts)
adamc@948 349 else
adamc@948 350 timpures,
adamc@948 351 impures,
adamc@948 352 absCounts)
adamc@948 353 | DVal (_, n, _, e, _) =>
adamc@948 354 (timpures,
adamc@948 355 if simpleImpure (timpures, impures) E.empty e then
adamc@916 356 IS.add (impures, n)
adamc@916 357 else
adamc@916 358 impures,
adam@1820 359 IM.insert (absCounts, n, countAbs E.empty e))
adamc@916 360 | DValRec vis =>
adamc@948 361 (timpures,
adamc@948 362 if List.exists (fn (_, _, _, e, _) => simpleImpure (timpures, impures) E.empty e) vis then
adamc@916 363 foldl (fn ((_, n, _, _, _), impures) =>
adamc@916 364 IS.add (impures, n)) impures vis
adamc@916 365 else
adamc@916 366 impures,
adamc@916 367 foldl (fn ((x, n, _, e, _), absCounts) =>
adam@1820 368 IM.insert (absCounts, n, countAbs E.empty e))
adamc@916 369 absCounts vis)
adamc@948 370 | _ => (timpures, impures, absCounts)
adamc@916 371 end)
adam@1845 372 (IS.empty, IS.empty, IM.empty) (#1 file)
adamc@387 373
adamc@1017 374 val uses = U.File.fold {typ = fn (_, m) => m,
adamc@1017 375 exp = fn (e, m) =>
adamc@1017 376 case e of
adamc@1017 377 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
adamc@1017 378 | _ => m,
adamc@1017 379 decl = fn (_, m) => m}
adamc@1017 380 IM.empty file
adamc@1017 381
adamc@1017 382 val size = U.Exp.fold {typ = fn (_, n) => n,
adamc@1017 383 exp = fn (_, n) => n + 1} 0
adamc@1017 384
adam@1360 385 val functionInside' = U.Typ.exists (fn c => case c of
adam@1360 386 TFun _ => true
adam@1360 387 | _ => false)
adam@1360 388
adam@1360 389 fun functionInside t =
adam@1360 390 case #1 t of
adam@1360 391 TFun (t1, t2) => functionInside' t1 orelse functionInside t2
adam@1360 392 | _ => functionInside' t
adam@1360 393
adam@1393 394 fun mayInline (n, e, t, s) =
adamc@1017 395 case IM.find (uses, n) of
adamc@1017 396 NONE => false
adamc@1017 397 | SOME count => count <= 1
adamc@1017 398 orelse size e <= Settings.getMonoInline ()
adam@1360 399 orelse functionInside t
adam@1393 400 orelse Settings.checkAlwaysInline s
adamc@1017 401
adamc@470 402 fun summarize d (e, _) =
adamc@579 403 let
adamc@579 404 val s =
adamc@579 405 case e of
adamc@579 406 EPrim _ => []
adamc@579 407 | ERel n => if n = d then [UseRel] else []
adamc@579 408 | ENamed _ => []
adamc@579 409 | ECon (_, _, NONE) => []
adamc@579 410 | ECon (_, _, SOME e) => summarize d e
adamc@579 411 | ENone _ => []
adamc@579 412 | ESome (_, e) => summarize d e
adamc@579 413 | EFfi _ => []
adam@1663 414 | EFfiApp ("Basis", "get_cookie", [(e, _)]) =>
adamc@1225 415 summarize d e @ [ReadCookie]
adam@1423 416 | EFfiApp ("Basis", "set_cookie", es) =>
adam@1663 417 List.concat (map (summarize d o #1) es) @ [WriteCookie]
adam@1423 418 | EFfiApp ("Basis", "clear_cookie", es) =>
adam@1663 419 List.concat (map (summarize d o #1) es) @ [WriteCookie]
adamc@765 420 | EFfiApp (m, x, es) =>
adamc@1171 421 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
adam@1663 422 List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
adam@1663 423 WritePage
adam@1663 424 else
adam@1663 425 Unsure]
adamc@765 426 else
adam@1663 427 List.concat (map (summarize d o #1) es)
adamc@579 428 | EApp ((EFfi _, _), e) => summarize d e
adamc@579 429 | EApp _ =>
adamc@579 430 let
adamc@694 431 fun unravel (e, passed, ls) =
adamc@579 432 case e of
adamc@579 433 ENamed n =>
adamc@579 434 let
adamc@579 435 val ls = rev ls
adamc@579 436 in
adamc@948 437 if IS.member (impures, n) then
adamc@948 438 case IM.find (absCounts, n) of
adamc@948 439 NONE => [Unsure]
adamc@948 440 | SOME len =>
adamc@948 441 if passed < len then
adamc@948 442 ls
adamc@948 443 else
adamc@948 444 ls @ [Unsure]
adamc@948 445 else
adamc@948 446 ls
adamc@579 447 end
adamc@579 448 | ERel n => List.revAppend (ls,
adamc@579 449 if n = d then
adamc@579 450 [UseRel, Unsure]
adamc@579 451 else
adamc@579 452 [Unsure])
adamc@579 453 | EApp (f, x) =>
adamc@995 454 unravel (#1 f, passed + 1, List.revAppend (summarize d x,
adamc@995 455 ls))
adam@1394 456 | EError _ => [Abort]
adamc@579 457 | _ => [Unsure]
adamc@579 458 in
adamc@694 459 unravel (e, 0, [])
adamc@579 460 end
adamc@252 461
adamc@941 462 | EAbs _ => []
adamc@316 463
adamc@579 464 | EUnop (_, e) => summarize d e
adam@1360 465 | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2
adamc@470 466
adamc@579 467 | ERecord xets => List.concat (map (summarize d o #2) xets)
adamc@579 468 | EField (e, _) => summarize d e
adamc@470 469
adamc@1214 470 | ECase (e, pes, _) =>
adamc@1214 471 let
adamc@579 472 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
adam@1394 473
adam@1394 474 fun splitRel ls acc =
adam@1394 475 case ls of
adam@1394 476 [] => (acc, false, ls)
adam@1394 477 | UseRel :: ls => (acc, true, ls)
adam@1394 478 | v :: ls => splitRel ls (v :: acc)
adam@1394 479
adam@1394 480 val (pre, used, post) = foldl (fn (ls, (pre, used, post)) =>
adam@1394 481 let
adam@1394 482 val (pre', used', post') = splitRel ls []
adam@1394 483 in
adam@1394 484 (pre' @ pre, used' orelse used, post' @ post)
adam@1394 485 end)
adam@1394 486 ([], false, []) lss
adamc@579 487 in
adam@1394 488 summarize d e
adam@1394 489 @ pre
adam@1394 490 @ (if used then [UseRel] else [])
adam@1394 491 @ post
adamc@1214 492 end
adamc@579 493 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
adamc@316 494
adamc@1225 495 | EError (e, _) => summarize d e @ [Abort]
adam@1932 496 | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort]
adam@1932 497 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
adamc@1225 498 | ERedirect (e, _) => summarize d e @ [Abort]
adamc@318 499
adamc@579 500 | EWrite e => summarize d e @ [WritePage]
adamc@579 501
adamc@579 502 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 503 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
adamc@456 504
adamc@579 505 | EClosure (_, es) => List.concat (map (summarize d) es)
adamc@470 506
adamc@579 507 | EQuery {query, body, initial, ...} =>
adamc@579 508 List.concat [summarize d query,
adamc@579 509 summarize d initial,
adamc@941 510 [ReadDb],
adamc@941 511 summarize (d + 2) body]
adamc@470 512
adam@1293 513 | EDml (e, _) => summarize d e @ [WriteDb]
adamc@579 514 | ENextval e => summarize d e @ [WriteDb]
adamc@1073 515 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
adamc@1112 516 | EUnurlify (e, _, _) => summarize d e
adamc@815 517 | EJavaScript (_, e) => summarize d e
adamc@579 518 | ESignalReturn e => summarize d e
adamc@579 519 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 520 | ESignalSource e => summarize d e
adamc@608 521
adam@1848 522 | EServerCall (e, _, _, _) => summarize d e @ [Unsure]
adamc@1021 523 | ERecv (e, _) => summarize d e @ [Unsure]
adamc@1021 524 | ESleep e => summarize d e @ [Unsure]
adamc@1021 525 | ESpawn e => summarize d e @ [Unsure]
adamc@579 526 in
adamc@579 527 (*Print.prefaces "Summarize"
adamc@579 528 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
adamc@579 529 ("d", Print.PD.string (Int.toString d)),
adamc@579 530 ("s", p_events s)];*)
adamc@579 531 s
adamc@579 532 end
adamc@470 533
adamc@919 534 val impure = fn env => fn e =>
adamc@948 535 simpleImpure (timpures, impures) env e andalso impure e
adamc@916 536 andalso not (List.null (summarize ~1 e))
adamc@916 537
adam@1852 538 fun passive (e : exp) =
adam@1852 539 case #1 e of
adam@1852 540 EPrim _ => true
adam@1852 541 | ERel _ => true
adam@1852 542 | ENamed _ => true
adam@1852 543 | ECon (_, _, NONE) => true
adam@1852 544 | ECon (_, _, SOME e) => passive e
adam@1852 545 | ENone _ => true
adam@1852 546 | ESome (_, e) => passive e
adam@1852 547 | EFfi _ => true
adam@1852 548 | EAbs _ => true
adam@1852 549 | ERecord xets => List.all (passive o #2) xets
adam@1852 550 | EField (e, _) => passive e
adam@1852 551 | _ => false
adam@1852 552
adamc@470 553 fun exp env e =
adamc@470 554 let
adamc@470 555 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
adamc@470 556
adamc@1017 557 fun doLet (x, t, e', b) =
adamc@1017 558 let
adamc@1017 559 fun doSub () =
adamc@1017 560 let
adamc@1017 561 val r = subExpInExp (0, e') b
adamc@1017 562 in
adamc@1017 563 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
adam@1423 564 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adam@1423 565 ("r", MonoPrint.p_exp env r)];*)
adamc@1017 566 #1 (reduceExp env r)
adamc@1017 567 end
adamc@1017 568
adam@1855 569 fun trySub () =
adamc@1017 570 ((*Print.prefaces "trySub"
adamc@1017 571 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
adamc@1017 572 case t of
adamc@1017 573 (TFfi ("Basis", "string"), _) => doSub ()
adamc@1017 574 | (TSignal _, _) => e
adamc@1017 575 | _ =>
adam@1855 576 case e' of
adam@1855 577 (ECase _, _) => e
adam@1855 578 | _ => doSub ())
adamc@1017 579 in
adamc@1017 580 if impure env e' then
adamc@1017 581 let
adamc@1017 582 val effs_e' = summarize 0 e'
adamc@1017 583 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
adamc@1017 584 val effs_b = summarize 0 b
adamc@1017 585
adam@1394 586 (*val () = Print.fprefaces outf "Try"
adam@1394 587 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
adamc@1017 588 ("e'", MonoPrint.p_exp env e'),
adamc@1017 589 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 590 ("e'_eff", p_events effs_e'),
adamc@1017 591 ("b_eff", p_events effs_b)]*)
adamc@1017 592
adamc@1017 593 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
adamc@1017 594 val writesPage = does WritePage
adamc@1017 595 val readsDb = does ReadDb
adamc@1017 596 val writesDb = does WriteDb
adamc@1225 597 val readsCookie = does ReadCookie
adamc@1225 598 val writesCookie = does ReadCookie
adamc@1017 599
adamc@1017 600 fun verifyUnused eff =
adamc@1017 601 case eff of
adamc@1017 602 UseRel => false
adamc@1017 603 | _ => true
adamc@1017 604
adamc@1017 605 fun verifyCompatible effs =
adamc@1017 606 case effs of
adamc@1017 607 [] => false
adamc@1017 608 | eff :: effs =>
adamc@1017 609 case eff of
adamc@1017 610 Unsure => false
adamc@1017 611 | UseRel => List.all verifyUnused effs
adamc@1017 612 | WritePage => not writesPage andalso verifyCompatible effs
adamc@1017 613 | ReadDb => not writesDb andalso verifyCompatible effs
adamc@1017 614 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
adamc@1225 615 | ReadCookie => not writesCookie andalso verifyCompatible effs
adamc@1225 616 | WriteCookie => not writesCookie andalso not readsCookie
adamc@1225 617 andalso verifyCompatible effs
adamc@1225 618 | Abort => true
adamc@1017 619 in
adamc@1017 620 (*Print.prefaces "verifyCompatible"
adamc@1017 621 [("e'", MonoPrint.p_exp env e'),
adamc@1017 622 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 623 ("effs_e'", Print.p_list p_event effs_e'),
adamc@1017 624 ("effs_b", Print.p_list p_event effs_b)];*)
adamc@1017 625 if (List.null effs_e'
adamc@1017 626 orelse (List.all (fn eff => eff <> Unsure) effs_e'
adamc@1017 627 andalso verifyCompatible effs_b)
adamc@1017 628 orelse (case effs_b of
adamc@1017 629 UseRel :: effs => List.all verifyUnused effs
adamc@1017 630 | _ => false))
adamc@1017 631 andalso countFree 0 0 b = 1
adamc@1017 632 andalso not (freeInAbs b) then
adam@1855 633 trySub ()
adamc@1017 634 else
adamc@1017 635 e
adamc@1017 636 end
adam@1852 637 else if countFree 0 0 b > 1 andalso not (!fullMode) andalso not (passive e') then
adam@1817 638 e
adamc@1017 639 else
adam@1855 640 trySub ()
adamc@1017 641 end
adamc@1017 642
adamc@470 643 val r =
adamc@470 644 case e of
adamc@470 645 ERel n =>
adamc@470 646 (case E.lookupERel env n of
adamc@470 647 (_, _, SOME e') => #1 e'
adamc@470 648 | _ => e)
adamc@470 649 | ENamed n =>
adamc@470 650 (case E.lookupENamed env n of
adamc@470 651 (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
adamc@470 652 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 653 #1 e')
adamc@470 654 | _ => e)
adamc@470 655
adamc@470 656 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
adamc@470 657 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
adamc@694 658 ("e2", MonoPrint.p_exp env e2),
adamc@694 659 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
adam@1852 660 if impure env e2 orelse (not (!fullMode) andalso countFree 0 0 e1 > 1) then
adamc@470 661 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
adamc@470 662 else
adamc@470 663 #1 (reduceExp env (subExpInExp (0, e2) e1)))
adamc@470 664
adamc@470 665 | ECase (e', pes, {disc, result}) =>
adamc@442 666 let
adamc@470 667 fun push () =
adamc@470 668 case result of
adamc@470 669 (TFun (dom, result), loc) =>
adamc@1107 670 let
adam@1855 671 fun safe e =
adam@1855 672 List.all (fn UseRel => true
adam@1855 673 | Abort => true
adam@1855 674 | _ => false) (summarize 0 e)
adam@1855 675
adam@1855 676 fun p_events' es = Print.box [Print.PD.string "{",
adam@1855 677 p_events es,
adam@1855 678 Print.PD.string "}"]
adamc@1107 679 in
adamc@1107 680 if List.all (safe o #2) pes then
adamc@1107 681 EAbs ("y", dom, result,
adamc@1107 682 (ECase (liftExpInExp 0 e',
adamc@1107 683 map (fn (p, (EAbs (_, _, _, e), _)) =>
adamc@1107 684 (p, swapExpVarsPat (0, patBinds p) e)
adam@1445 685 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
adam@1445 686 (p, (EError (e, t), loc))
adam@1855 687 | (p, e) =>
adam@1855 688 (p, (EApp (liftExpInExp (patBinds p) e,
adam@1855 689 (ERel (patBinds p), loc)), loc)))
adam@1855 690 pes,
adamc@1107 691 {disc = disc, result = result}), loc))
adamc@1107 692 else
adamc@1107 693 e
adamc@1107 694 end
adamc@470 695 | _ => e
adamc@318 696
adamc@470 697 fun search pes =
adamc@470 698 case pes of
adamc@470 699 [] => push ()
adamc@470 700 | (p, body) :: pes =>
adamc@814 701 case match ([], p, e') of
adamc@470 702 No => search pes
adamc@470 703 | Maybe => push ()
adamc@814 704 | Yes subs =>
adamc@800 705 let
adamc@829 706 val (body, remaining) =
adam@1817 707 foldl (fn ((x, t, e), (body, remaining)) =>
adam@1817 708 (if countFree 0 0 body > 1 then
adam@1817 709 (ELet (x, t, multiLift remaining e, body), #2 e')
adam@1817 710 else
adam@1817 711 subExpInExp (0, multiLift remaining e) body, remaining - 1))
adamc@829 712 (body, length subs - 1) subs
adamc@920 713 val r = reduceExp (E.patBinds env p) body
adamc@800 714 in
adamc@829 715 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
adamc@800 716 (*Print.prefaces "ECase"
adamc@829 717 [("old", MonoPrint.p_exp env body),
adamc@829 718 ("body", MonoPrint.p_exp env body),
adamc@800 719 ("r", MonoPrint.p_exp env r)];*)
adamc@800 720 #1 r
adamc@800 721 end
adamc@470 722 in
adamc@941 723 if impure env e' then
adamc@941 724 e
adamc@941 725 else
adamc@941 726 search pes
adamc@470 727 end
adamc@318 728
adamc@470 729 | EField ((ERecord xes, _), x) =>
adamc@470 730 (case List.find (fn (x', _, _) => x' = x) xes of
adamc@470 731 SOME (_, e, _) => #1 e
adamc@470 732 | NONE => e)
adamc@398 733
adamc@470 734 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
adamc@470 735 let
adamc@470 736 val e' = (ELet (x2, t2, e1,
adamc@470 737 (ELet (x1, t1, b1,
adamc@470 738 liftExpInExp 1 b2), loc)), loc)
adamc@442 739 in
adamc@470 740 (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
adamc@470 741 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 742 #1 (reduceExp env e')
adamc@470 743 end
adamc@470 744 | EApp ((ELet (x, t, e, b), loc), e') =>
adamc@470 745 #1 (reduceExp env (ELet (x, t, e,
adamc@470 746 (EApp (b, liftExpInExp 0 e'), loc)), loc))
adamc@470 747
adamc@1017 748 | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
adamc@919 749 if impure env e' then
adamc@1017 750 doLet (x, t, e', b)
adamc@848 751 else
adamc@920 752 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
adamc@920 753 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
adamc@470 754
adamc@1017 755 | ELet (x, t, e', b) => doLet (x, t, e', b)
adamc@252 756
adamc@470 757 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
adamc@470 758 EPrim (Prim.String (s1 ^ s2))
adamc@268 759
adamc@572 760 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 761 #1 (reduceExp env (EApp (e2, e1), loc))
adamc@572 762
adamc@470 763 | _ => e
adamc@470 764 in
adamc@829 765 (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
adamc@829 766 ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
adamc@470 767 r
adamc@470 768 end
adamc@470 769
adamc@470 770 and bind (env, b) =
adamc@470 771 case b of
adamc@470 772 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
adamc@470 773 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
adamc@1017 774 | U.Decl.NamedE (x, n, t, eo, s) =>
adamc@1017 775 let
adamc@1017 776 val eo = case eo of
adamc@1017 777 NONE => NONE
adam@1393 778 | SOME e => if mayInline (n, e, t, s) then
adamc@1017 779 SOME e
adamc@1017 780 else
adamc@1017 781 NONE
adamc@1017 782 in
adamc@1017 783 E.pushENamed env x n t (Option.map (reduceExp env) eo) s
adamc@1017 784 end
adamc@470 785
adamc@470 786 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
adamc@470 787
adamc@801 788 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
adamc@801 789 d)
adamc@398 790 in
adamc@470 791 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
adamc@398 792 end
adamc@133 793
adamc@133 794 end