Mercurial > urweb

annotate src/mono_reduce.sml @ 2084:0d48cfb59b29

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
More aggressive inlining of 'let' with record literals, plus some changes to Monoization of queries, to make inlining more common
author Adam Chlipala <adam@chlipala.net>
date Thu, 04 Dec 2014 02:47:24 -0500
parents 1b76ae703cbb
children 9e9c915f554c
rev   line source
adam@2040 1 (* Copyright (c) 2008, 2013-2014, 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
adam@2084 42 structure SS = BinarySetFn(struct
adam@2084 43 type ord_key = string
adam@2084 44 val compare = String.compare
adam@2084 45 end)
adamc@133 46
adamc@948 47 fun simpleTypeImpure tsyms =
adamc@919 48 U.Typ.exists (fn TFun _ => true
adamc@948 49 | TDatatype (n, _) => IS.member (tsyms, n)
adamc@919 50 | _ => false)
adamc@919 51
adam@1963 52 fun simpleImpure isGlobal (tsyms, syms) =
adamc@919 53 U.Exp.existsB {typ = fn _ => false,
adamc@919 54 exp = fn (env, e) =>
adamc@919 55 case e of
adamc@919 56 EWrite _ => true
adamc@919 57 | EQuery _ => true
adamc@919 58 | EDml _ => true
adamc@919 59 | ENextval _ => true
adamc@1073 60 | ESetval _ => true
adamc@1171 61 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
adamc@919 62 | EServerCall _ => true
adamc@919 63 | ERecv _ => true
adamc@919 64 | ESleep _ => true
adamc@919 65 | ENamed n => IS.member (syms, n)
adamc@919 66 | ERel n =>
adamc@919 67 let
adamc@919 68 val (_, t, _) = E.lookupERel env n
adamc@919 69 in
adamc@948 70 simpleTypeImpure tsyms t
adamc@919 71 end
adam@1963 72 | EApp _ => not isGlobal
adamc@919 73 | _ => false,
adamc@919 74 bind = fn (env, b) =>
adamc@919 75 case b of
adamc@919 76 U.Exp.RelE (x, t) => E.pushERel env x t NONE
adamc@919 77 | _ => env}
adamc@916 78
adamc@252 79 fun impure (e, _) =
adamc@252 80 case e of
adamc@252 81 EWrite _ => true
adamc@252 82 | EQuery _ => true
adamc@307 83 | EDml _ => true
adamc@338 84 | ENextval _ => true
adamc@1073 85 | ESetval _ => true
adam@1423 86 | EUnurlify (e, _, _) => impure e
adamc@252 87 | EAbs _ => false
adamc@252 88
adamc@252 89 | EPrim _ => false
adamc@252 90 | ERel _ => false
adamc@252 91 | ENamed _ => false
adamc@252 92 | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
adamc@297 93 | ENone _ => false
adamc@290 94 | ESome (_, e) => impure e
adamc@252 95 | EFfi _ => false
adamc@1171 96 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
adamc@252 97 | EApp ((EFfi _, _), _) => false
adamc@252 98 | EApp _ => true
adamc@252 99
adamc@387 100 | EUnop (_, e) => impure e
adam@1360 101 | EBinop (_, _, e1, e2) => impure e1 orelse impure e2
adamc@387 102
adamc@252 103 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes
adamc@252 104 | EField (e, _) => impure e
adamc@252 105
adamc@252 106 | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
adamc@252 107
adamc@1069 108 | EError _ => true
adam@1932 109 | EReturnBlob {blob = NONE, mimeType = e2, ...} => impure e2
adam@1932 110 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => impure e1 orelse impure e2
adamc@1065 111 | ERedirect (e, _) => impure e
adamc@283 112
adamc@252 113 | EStrcat (e1, e2) => impure e1 orelse impure e2
adamc@252 114
adamc@252 115 | ESeq (e1, e2) => impure e1 orelse impure e2
adamc@252 116 | ELet (_, _, e1, e2) => impure e1 orelse impure e2
adamc@252 117
adamc@252 118 | EClosure (_, es) => List.exists impure es
adamc@815 119 | EJavaScript (_, e) => impure e
adamc@568 120 | ESignalReturn e => impure e
adamc@572 121 | ESignalBind (e1, e2) => impure e1 orelse impure e2
adamc@574 122 | ESignalSource e => impure e
adamc@608 123 | EServerCall _ => true
adamc@670 124 | ERecv _ => true
adamc@695 125 | ESleep _ => true
adamc@1021 126 | ESpawn _ => true
adamc@252 127
adamc@252 128 val liftExpInExp = Monoize.liftExpInExp
adamc@252 129
adamc@829 130 fun multiLift n e =
adamc@829 131 case n of
adamc@829 132 0 => e
adamc@829 133 | _ => multiLift (n - 1) (liftExpInExp 0 e)
adamc@829 134
adamc@252 135 val subExpInExp' =
adamc@133 136 U.Exp.mapB {typ = fn t => t,
adamc@133 137 exp = fn (xn, rep) => fn e =>
adamc@133 138 case e of
adamc@133 139 ERel xn' =>
adamc@133 140 (case Int.compare (xn', xn) of
adamc@133 141 EQUAL => #1 rep
adamc@133 142 | GREATER=> ERel (xn' - 1)
adamc@133 143 | LESS => e)
adamc@133 144 | _ => e,
adamc@133 145 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
adamc@133 146 | (ctx, _) => ctx}
adamc@133 147
adamc@252 148 fun subExpInExp (n, e1) e2 =
adamc@252 149 let
adamc@252 150 val r = subExpInExp' (n, e1) e2
adamc@252 151 in
adamc@252 152 (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1),
adamc@252 153 ("e2", MonoPrint.p_exp MonoEnv.empty e2),
adamc@252 154 ("r", MonoPrint.p_exp MonoEnv.empty r)];*)
adamc@252 155 r
adamc@252 156 end
adamc@133 157
adamc@133 158 fun typ c = c
adamc@133 159
adamc@316 160 val swapExpVars =
adamc@316 161 U.Exp.mapB {typ = fn t => t,
adamc@316 162 exp = fn lower => fn e =>
adamc@316 163 case e of
adamc@316 164 ERel xn =>
adamc@316 165 if xn = lower then
adamc@316 166 ERel (lower + 1)
adamc@316 167 else if xn = lower + 1 then
adamc@316 168 ERel lower
adamc@316 169 else
adamc@316 170 e
adamc@316 171 | _ => e,
adamc@316 172 bind = fn (lower, U.Exp.RelE _) => lower+1
adamc@316 173 | (lower, _) => lower}
adamc@316 174
adamc@341 175 val swapExpVarsPat =
adamc@341 176 U.Exp.mapB {typ = fn t => t,
adamc@341 177 exp = fn (lower, len) => fn e =>
adamc@341 178 case e of
adamc@341 179 ERel xn =>
adamc@341 180 if xn = lower then
adamc@827 181 ERel (lower + len)
adamc@341 182 else if xn >= lower + 1 andalso xn < lower + 1 + len then
adamc@341 183 ERel (xn - 1)
adamc@341 184 else
adamc@341 185 e
adamc@341 186 | _ => e,
adamc@341 187 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
adamc@341 188 | (st, _) => st}
adamc@341 189
adam@1817 190 datatype result = Yes of (string * typ * exp) list | No | Maybe
adamc@258 191
adamc@183 192 fun match (env, p : pat, e : exp) =
adamc@183 193 case (#1 p, #1 e) of
adamc@258 194 (PWild, _) => Yes env
adam@1817 195 | (PVar (x, t), _) => Yes ((x, t, e) :: env)
adamc@183 196
adam@2048 197 | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) =>
adamc@280 198 if String.isPrefix s' s then
adamc@280 199 Maybe
adamc@280 200 else
adamc@280 201 No
adamc@280 202
adam@2048 203 | (PPrim (Prim.String (_, s)), EStrcat (_, (EPrim (Prim.String (_, s')), _))) =>
adamc@1207 204 if String.isSuffix s' s then
adamc@1207 205 Maybe
adamc@1207 206 else
adamc@1207 207 No
adamc@1207 208
adamc@183 209 | (PPrim p, EPrim p') =>
adamc@183 210 if Prim.equal (p, p') then
adamc@258 211 Yes env
adamc@183 212 else
adamc@258 213 No
adamc@183 214
adam@2082 215 | (PPrim (Prim.String (_, s)), _) =>
adam@2082 216 let
adam@2082 217 fun lengthLb (e : exp) =
adam@2082 218 case #1 e of
adam@2082 219 EStrcat (e1, e2) => lengthLb e1 + lengthLb e2
adam@2082 220 | EPrim (Prim.String (_, s)) => size s
adam@2082 221 | _ => 0
adam@2082 222 in
adam@2082 223 if lengthLb e > size s then
adam@2082 224 No
adam@2082 225 else
adam@2082 226 Maybe
adam@2082 227 end
adam@2082 228
kkallio@1489 229 | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) =>
adamc@183 230 if n1 = n2 then
kkallio@1489 231 case (po, eo) of
kkallio@1489 232 (NONE, NONE) => Yes env
kkallio@1489 233 | (SOME p, SOME e) => match (env, p, e)
kkallio@1489 234 | _ => Maybe
adamc@183 235 else
adamc@258 236 No
adamc@183 237
adamc@188 238 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, NONE), ECon (_, PConFfi {mod = m2, con = con2, ...}, NONE)) =>
adamc@185 239 if m1 = m2 andalso con1 = con2 then
adamc@258 240 Yes env
adamc@185 241 else
adamc@258 242 No
adamc@185 243
adamc@188 244 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (_, PConFfi {mod = m2, con = con2, ...}, SOME e)) =>
adamc@185 245 if m1 = m2 andalso con1 = con2 then
adamc@185 246 match (env, p, e)
adamc@185 247 else
adamc@258 248 No
adamc@185 249
adamc@183 250 | (PRecord xps, ERecord xes) =>
adamc@183 251 let
adamc@183 252 fun consider (xps, env) =
adamc@183 253 case xps of
adamc@258 254 [] => Yes env
adamc@183 255 | (x, p, _) :: rest =>
adamc@183 256 case List.find (fn (x', _, _) => x' = x) xes of
adamc@258 257 NONE => No
adamc@183 258 | SOME (_, e, _) =>
adamc@183 259 case match (env, p, e) of
adamc@258 260 No => No
adamc@258 261 | Maybe => Maybe
adamc@258 262 | Yes env => consider (rest, env)
adamc@183 263 in
adamc@183 264 consider (xps, env)
adamc@183 265 end
adamc@183 266
adamc@726 267 | (PNone _, ENone _) => Yes env
adamc@921 268 | (PNone _, ESome _) => No
adamc@726 269 | (PSome (_, p), ESome (_, e)) => match (env, p, e)
adamc@921 270 | (PSome _, ENone _) => No
adamc@726 271
adamc@258 272 | _ => Maybe
adamc@183 273
adamc@318 274 datatype event =
adamc@318 275 WritePage
adamc@318 276 | ReadDb
adamc@318 277 | WriteDb
adamc@1225 278 | ReadCookie
adamc@1225 279 | WriteCookie
adamc@481 280 | UseRel
adamc@318 281 | Unsure
adamc@1225 282 | Abort
adamc@318 283
adamc@318 284 fun p_event e =
adamc@318 285 let
adamc@318 286 open Print.PD
adamc@318 287 in
adamc@318 288 case e of
adamc@318 289 WritePage => string "WritePage"
adamc@318 290 | ReadDb => string "ReadDb"
adamc@318 291 | WriteDb => string "WriteDb"
adamc@1225 292 | ReadCookie => string "ReadCookie"
adamc@1225 293 | WriteCookie => string "WriteCookie"
adamc@481 294 | UseRel => string "UseRel"
adamc@318 295 | Unsure => string "Unsure"
adamc@1225 296 | Abort => string "Abort"
adamc@318 297 end
adamc@318 298
adamc@470 299 val p_events = Print.p_list p_event
adamc@470 300
adamc@318 301 fun patBinds (p, _) =
adamc@318 302 case p of
adamc@318 303 PWild => 0
adamc@318 304 | PVar _ => 1
adamc@318 305 | PPrim _ => 0
adamc@318 306 | PCon (_, _, NONE) => 0
adamc@318 307 | PCon (_, _, SOME p) => patBinds p
adamc@318 308 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
adamc@318 309 | PNone _ => 0
adamc@318 310 | PSome (_, p) => patBinds p
adamc@318 311
adamc@932 312 val countFree = U.Exp.foldB {typ = fn (_, n) => n,
adamc@932 313 exp = fn (x, e, n) =>
adamc@932 314 case e of
adamc@932 315 ERel x' => if x = x' then n + 1 else n
adamc@932 316 | _ => n,
adamc@932 317 bind = fn (n, b) =>
adamc@932 318 case b of
adamc@932 319 U.Exp.RelE _ => n + 1
adamc@975 320 | _ => n}
adamc@975 321
adamc@975 322 val freeInAbs = U.Exp.existsB {typ = fn _ => false,
adamc@975 323 exp = fn (n, e) =>
adamc@975 324 case e of
adamc@975 325 EAbs (_, _, _, b) => countFree n 0 b > 0
adamc@975 326 | EJavaScript (_, b) => countFree n 0 b > 0
adamc@975 327 | _ => false,
adamc@975 328 bind = fn (n, b) =>
adamc@975 329 case b of
adamc@975 330 U.Exp.RelE _ => n + 1
adamc@975 331 | _ => n} 0
adamc@932 332
adam@1845 333 fun reduce (file : file) =
adamc@470 334 let
adamc@948 335 val (timpures, impures, absCounts) =
adamc@948 336 foldl (fn ((d, _), (timpures, impures, absCounts)) =>
adamc@916 337 let
adam@1820 338 fun countAbs env e =
adam@1820 339 case #1 e of
adam@1820 340 EAbs (x, t, _, e) => 1 + countAbs (E.pushERel env x t NONE) e
adam@1820 341 | _ =>
adam@1820 342 let
adam@1820 343 fun remaining e =
adam@1820 344 case #1 e of
adam@1820 345 ENamed n => IM.find (absCounts, n)
adam@1820 346 | EApp (e, arg) =>
adam@1963 347 if simpleImpure true (timpures, impures) env arg then
adam@1820 348 NONE
adam@1820 349 else
adam@1820 350 (case remaining e of
adam@1820 351 NONE => NONE
adam@1820 352 | SOME n => if n > 0 then
adam@1820 353 SOME (n - 1)
adam@1820 354 else
adam@1820 355 NONE)
adam@1820 356 | _ => NONE
adam@1820 357 in
adam@1820 358 getOpt (remaining e, 0)
adam@1820 359 end
adamc@916 360 in
adamc@916 361 case d of
adamc@948 362 DDatatype dts =>
adamc@948 363 (if List.exists (fn (_, _, cs) =>
adamc@948 364 List.exists (fn (_, _, NONE) => false
adamc@948 365 | (_, _, SOME t) => simpleTypeImpure timpures t) cs)
adamc@948 366 dts then
adamc@948 367 IS.addList (timpures, map #2 dts)
adamc@948 368 else
adamc@948 369 timpures,
adamc@948 370 impures,
adamc@948 371 absCounts)
adamc@948 372 | DVal (_, n, _, e, _) =>
adamc@948 373 (timpures,
adam@1963 374 if simpleImpure true (timpures, impures) E.empty e then
adamc@916 375 IS.add (impures, n)
adamc@916 376 else
adamc@916 377 impures,
adam@1820 378 IM.insert (absCounts, n, countAbs E.empty e))
adamc@916 379 | DValRec vis =>
adamc@948 380 (timpures,
adam@1963 381 if List.exists (fn (_, _, _, e, _) => simpleImpure true (timpures, impures) E.empty e) vis then
adamc@916 382 foldl (fn ((_, n, _, _, _), impures) =>
adamc@916 383 IS.add (impures, n)) impures vis
adamc@916 384 else
adamc@916 385 impures,
adamc@916 386 foldl (fn ((x, n, _, e, _), absCounts) =>
adam@1820 387 IM.insert (absCounts, n, countAbs E.empty e))
adamc@916 388 absCounts vis)
adamc@948 389 | _ => (timpures, impures, absCounts)
adamc@916 390 end)
adam@1845 391 (IS.empty, IS.empty, IM.empty) (#1 file)
adamc@387 392
adamc@1017 393 val uses = U.File.fold {typ = fn (_, m) => m,
adamc@1017 394 exp = fn (e, m) =>
adamc@1017 395 case e of
adamc@1017 396 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
adamc@1017 397 | _ => m,
adamc@1017 398 decl = fn (_, m) => m}
adamc@1017 399 IM.empty file
adamc@1017 400
adamc@1017 401 val size = U.Exp.fold {typ = fn (_, n) => n,
adamc@1017 402 exp = fn (_, n) => n + 1} 0
adamc@1017 403
adam@1360 404 val functionInside' = U.Typ.exists (fn c => case c of
adam@1360 405 TFun _ => true
adam@1360 406 | _ => false)
adam@1360 407
adam@1360 408 fun functionInside t =
adam@1360 409 case #1 t of
adam@1360 410 TFun (t1, t2) => functionInside' t1 orelse functionInside t2
adam@1360 411 | _ => functionInside' t
adam@1360 412
adam@1393 413 fun mayInline (n, e, t, s) =
adamc@1017 414 case IM.find (uses, n) of
adamc@1017 415 NONE => false
adam@1966 416 | SOME count => not (Settings.checkNeverInline s)
adam@1966 417 andalso (count <= 1
adam@1966 418 orelse size e <= Settings.getMonoInline ()
adam@1966 419 orelse functionInside t
adam@1966 420 orelse Settings.checkAlwaysInline s)
adamc@1017 421
adamc@470 422 fun summarize d (e, _) =
adamc@579 423 let
adamc@579 424 val s =
adamc@579 425 case e of
adamc@579 426 EPrim _ => []
adamc@579 427 | ERel n => if n = d then [UseRel] else []
adamc@579 428 | ENamed _ => []
adamc@579 429 | ECon (_, _, NONE) => []
adamc@579 430 | ECon (_, _, SOME e) => summarize d e
adamc@579 431 | ENone _ => []
adamc@579 432 | ESome (_, e) => summarize d e
adamc@579 433 | EFfi _ => []
adam@1663 434 | EFfiApp ("Basis", "get_cookie", [(e, _)]) =>
adamc@1225 435 summarize d e @ [ReadCookie]
adam@1423 436 | EFfiApp ("Basis", "set_cookie", es) =>
adam@1663 437 List.concat (map (summarize d o #1) es) @ [WriteCookie]
adam@1423 438 | EFfiApp ("Basis", "clear_cookie", es) =>
adam@1663 439 List.concat (map (summarize d o #1) es) @ [WriteCookie]
adamc@765 440 | EFfiApp (m, x, es) =>
adamc@1171 441 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
adam@1663 442 List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
adam@1663 443 WritePage
adam@1663 444 else
adam@1663 445 Unsure]
adamc@765 446 else
adam@1663 447 List.concat (map (summarize d o #1) es)
adamc@579 448 | EApp ((EFfi _, _), e) => summarize d e
adamc@579 449 | EApp _ =>
adamc@579 450 let
adamc@694 451 fun unravel (e, passed, ls) =
adamc@579 452 case e of
adamc@579 453 ENamed n =>
adamc@579 454 let
adamc@579 455 val ls = rev ls
adamc@579 456 in
adamc@948 457 if IS.member (impures, n) then
adamc@948 458 case IM.find (absCounts, n) of
adamc@948 459 NONE => [Unsure]
adamc@948 460 | SOME len =>
adamc@948 461 if passed < len then
adamc@948 462 ls
adamc@948 463 else
adamc@948 464 ls @ [Unsure]
adamc@948 465 else
adamc@948 466 ls
adamc@579 467 end
adamc@579 468 | ERel n => List.revAppend (ls,
adamc@579 469 if n = d then
adamc@579 470 [UseRel, Unsure]
adamc@579 471 else
adamc@579 472 [Unsure])
adamc@579 473 | EApp (f, x) =>
adamc@995 474 unravel (#1 f, passed + 1, List.revAppend (summarize d x,
adamc@995 475 ls))
adam@1394 476 | EError _ => [Abort]
adamc@579 477 | _ => [Unsure]
adamc@579 478 in
adamc@694 479 unravel (e, 0, [])
adamc@579 480 end
adamc@252 481
adamc@941 482 | EAbs _ => []
adamc@316 483
adamc@579 484 | EUnop (_, e) => summarize d e
adam@1360 485 | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2
adamc@470 486
adamc@579 487 | ERecord xets => List.concat (map (summarize d o #2) xets)
adamc@579 488 | EField (e, _) => summarize d e
adamc@470 489
adamc@1214 490 | ECase (e, pes, _) =>
adamc@1214 491 let
adam@2040 492 val lss = map (fn (p, e) => summarize (if d = ~1 then ~1 else d + patBinds p) e) pes
adam@1394 493
adam@1394 494 fun splitRel ls acc =
adam@1394 495 case ls of
adam@1394 496 [] => (acc, false, ls)
adam@1394 497 | UseRel :: ls => (acc, true, ls)
adam@1394 498 | v :: ls => splitRel ls (v :: acc)
adam@1394 499
adam@1394 500 val (pre, used, post) = foldl (fn (ls, (pre, used, post)) =>
adam@1394 501 let
adam@1394 502 val (pre', used', post') = splitRel ls []
adam@1394 503 in
adam@1394 504 (pre' @ pre, used' orelse used, post' @ post)
adam@1394 505 end)
adam@1394 506 ([], false, []) lss
adamc@579 507 in
adam@1394 508 summarize d e
adam@1394 509 @ pre
adam@1394 510 @ (if used then [UseRel] else [])
adam@1394 511 @ post
adamc@1214 512 end
adamc@579 513 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
adamc@316 514
adamc@1225 515 | EError (e, _) => summarize d e @ [Abort]
adam@1932 516 | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort]
adam@1932 517 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
adamc@1225 518 | ERedirect (e, _) => summarize d e @ [Abort]
adamc@318 519
adamc@579 520 | EWrite e => summarize d e @ [WritePage]
adamc@579 521
adamc@579 522 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
adam@2041 523 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (if d = ~1 then ~1 else d + 1) e2
adamc@456 524
adamc@579 525 | EClosure (_, es) => List.concat (map (summarize d) es)
adamc@470 526
adamc@579 527 | EQuery {query, body, initial, ...} =>
adamc@579 528 List.concat [summarize d query,
adamc@579 529 summarize d initial,
adamc@941 530 [ReadDb],
adam@2040 531 summarize (if d = ~1 then ~1 else d + 2) body]
adamc@470 532
adam@1293 533 | EDml (e, _) => summarize d e @ [WriteDb]
adamc@579 534 | ENextval e => summarize d e @ [WriteDb]
adamc@1073 535 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
adamc@1112 536 | EUnurlify (e, _, _) => summarize d e
adamc@815 537 | EJavaScript (_, e) => summarize d e
adamc@579 538 | ESignalReturn e => summarize d e
adamc@579 539 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 540 | ESignalSource e => summarize d e
adamc@608 541
adam@1848 542 | EServerCall (e, _, _, _) => summarize d e @ [Unsure]
adamc@1021 543 | ERecv (e, _) => summarize d e @ [Unsure]
adamc@1021 544 | ESleep e => summarize d e @ [Unsure]
adamc@1021 545 | ESpawn e => summarize d e @ [Unsure]
adamc@579 546 in
adamc@579 547 (*Print.prefaces "Summarize"
adamc@579 548 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
adamc@579 549 ("d", Print.PD.string (Int.toString d)),
adamc@579 550 ("s", p_events s)];*)
adamc@579 551 s
adamc@579 552 end
adamc@470 553
adamc@919 554 val impure = fn env => fn e =>
adam@1963 555 simpleImpure false (timpures, impures) env e andalso impure e
adamc@916 556 andalso not (List.null (summarize ~1 e))
adamc@916 557
adam@1852 558 fun passive (e : exp) =
adam@1852 559 case #1 e of
adam@1852 560 EPrim _ => true
adam@1852 561 | ERel _ => true
adam@1852 562 | ENamed _ => true
adam@1852 563 | ECon (_, _, NONE) => true
adam@1852 564 | ECon (_, _, SOME e) => passive e
adam@1852 565 | ENone _ => true
adam@1852 566 | ESome (_, e) => passive e
adam@1852 567 | EFfi _ => true
adam@1852 568 | EAbs _ => true
adam@1852 569 | ERecord xets => List.all (passive o #2) xets
adam@1852 570 | EField (e, _) => passive e
adam@1852 571 | _ => false
adam@1852 572
adamc@470 573 fun exp env e =
adamc@470 574 let
adamc@470 575 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
adamc@470 576
adamc@1017 577 fun doLet (x, t, e', b) =
adamc@1017 578 let
adamc@1017 579 fun doSub () =
adamc@1017 580 let
adamc@1017 581 val r = subExpInExp (0, e') b
adamc@1017 582 in
adamc@1017 583 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
adam@1423 584 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adam@1423 585 ("r", MonoPrint.p_exp env r)];*)
adamc@1017 586 #1 (reduceExp env r)
adamc@1017 587 end
adamc@1017 588
adam@1855 589 fun trySub () =
adamc@1017 590 ((*Print.prefaces "trySub"
adamc@1017 591 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
adamc@1017 592 case t of
adamc@1017 593 (TFfi ("Basis", "string"), _) => doSub ()
adamc@1017 594 | (TSignal _, _) => e
adamc@1017 595 | _ =>
adam@1855 596 case e' of
adam@1855 597 (ECase _, _) => e
adam@1855 598 | _ => doSub ())
adam@2084 599
adam@2084 600 fun isRecord () =
adam@2084 601 case #1 e' of
adam@2084 602 ERecord _ => true
adam@2084 603 | _ => false
adam@2084 604
adam@2084 605 fun whichProj i (e : exp) =
adam@2084 606 case #1 e of
adam@2084 607 EPrim _ => SOME SS.empty
adam@2084 608 | ERel i' => if i' = i then NONE else SOME SS.empty
adam@2084 609 | ENamed _ => SOME SS.empty
adam@2084 610 | ECon (_, _, NONE) => SOME SS.empty
adam@2084 611 | ECon (_, _, SOME e') => whichProj i e'
adam@2084 612 | ENone _ => SOME SS.empty
adam@2084 613 | ESome (_, e') => whichProj i e'
adam@2084 614 | EFfi _ => SOME SS.empty
adam@2084 615 | EFfiApp (_, _, es) => whichProjs i (map #1 es)
adam@2084 616 | EApp (e1, e2) => whichProjs i [e1, e2]
adam@2084 617 | EAbs (_, _, _, e) => whichProj (i + 1) e
adam@2084 618 | EUnop (_, e1) => whichProj i e1
adam@2084 619 | EBinop (_, _, e1, e2) => whichProjs i [e1, e2]
adam@2084 620 | ERecord xets => whichProjs i (map #2 xets)
adam@2084 621 | EField ((ERel i', _), s) =>
adam@2084 622 if i' = i then
adam@2084 623 SOME (SS.singleton s)
adam@2084 624 else
adam@2084 625 SOME SS.empty
adam@2084 626 | EField (e1, _) => whichProj i e1
adam@2084 627 | ECase (e1, pes, _) =>
adam@2084 628 whichProjs' i ((0, e1)
adam@2084 629 :: map (fn (p, e) => (patBinds p, e)) pes)
adam@2084 630 | EStrcat (e1, e2) => whichProjs i [e1, e2]
adam@2084 631 | EError (e1, _) => whichProj i e1
adam@2084 632 | EReturnBlob {blob = NONE, mimeType = e2, ...} => whichProj i e2
adam@2084 633 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => whichProjs i [e1, e2]
adam@2084 634 | ERedirect (e1, _) => whichProj i e1
adam@2084 635 | EWrite e1 => whichProj i e1
adam@2084 636 | ESeq (e1, e2) => whichProjs i [e1, e2]
adam@2084 637 | ELet (_, _, e1, e2) => whichProjs' i [(0, e1), (1, e2)]
adam@2084 638 | EClosure (_, es) => whichProjs i es
adam@2084 639 | EQuery {query = e1, body = e2, initial = e3, ...} =>
adam@2084 640 whichProjs' i [(0, e1), (2, e2), (0, e3)]
adam@2084 641 | EDml (e1, _) => whichProj i e1
adam@2084 642 | ENextval e1 => whichProj i e1
adam@2084 643 | ESetval (e1, e2) => whichProjs i [e1, e2]
adam@2084 644 | EUnurlify (e1, _, _) => whichProj i e1
adam@2084 645 | EJavaScript (_, e1) => whichProj i e1
adam@2084 646 | ESignalReturn e1 => whichProj i e1
adam@2084 647 | ESignalBind (e1, e2) => whichProjs i [e1, e2]
adam@2084 648 | ESignalSource e1 => whichProj i e1
adam@2084 649 | EServerCall (e1, _, _, _) => whichProj i e1
adam@2084 650 | ERecv (e1, _) => whichProj i e1
adam@2084 651 | ESleep e1 => whichProj i e1
adam@2084 652 | ESpawn e1 => whichProj i e1
adam@2084 653
adam@2084 654 and whichProjs i es =
adam@2084 655 whichProjs' i (map (fn e => (0, e)) es)
adam@2084 656
adam@2084 657 and whichProjs' i es =
adam@2084 658 case es of
adam@2084 659 [] => SOME SS.empty
adam@2084 660 | (n, e) :: es' =>
adam@2084 661 case (whichProj (i + n) e, whichProjs' i es') of
adam@2084 662 (SOME m1, SOME m2) =>
adam@2084 663 if SS.isEmpty (SS.intersection (m1, m2)) then
adam@2084 664 SOME (SS.union (m1, m2))
adam@2084 665 else
adam@2084 666 NONE
adam@2084 667 | _ => NONE
adamc@1017 668 in
adamc@1017 669 if impure env e' then
adamc@1017 670 let
adamc@1017 671 val effs_e' = summarize 0 e'
adamc@1017 672 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
adamc@1017 673 val effs_b = summarize 0 b
adamc@1017 674
adam@2040 675 (*val () = Print.prefaces "Try"
adam@1394 676 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
adamc@1017 677 ("e'", MonoPrint.p_exp env e'),
adamc@1017 678 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 679 ("e'_eff", p_events effs_e'),
adamc@1017 680 ("b_eff", p_events effs_b)]*)
adamc@1017 681
adamc@1017 682 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
adamc@1017 683 val writesPage = does WritePage
adamc@1017 684 val readsDb = does ReadDb
adamc@1017 685 val writesDb = does WriteDb
adamc@1225 686 val readsCookie = does ReadCookie
adamc@1225 687 val writesCookie = does ReadCookie
adamc@1017 688
adamc@1017 689 fun verifyUnused eff =
adamc@1017 690 case eff of
adamc@1017 691 UseRel => false
adamc@1017 692 | _ => true
adamc@1017 693
adamc@1017 694 fun verifyCompatible effs =
adamc@1017 695 case effs of
adamc@1017 696 [] => false
adamc@1017 697 | eff :: effs =>
adamc@1017 698 case eff of
adamc@1017 699 Unsure => false
adamc@1017 700 | UseRel => List.all verifyUnused effs
adamc@1017 701 | WritePage => not writesPage andalso verifyCompatible effs
adamc@1017 702 | ReadDb => not writesDb andalso verifyCompatible effs
adamc@1017 703 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
adamc@1225 704 | ReadCookie => not writesCookie andalso verifyCompatible effs
adamc@1225 705 | WriteCookie => not writesCookie andalso not readsCookie
adamc@1225 706 andalso verifyCompatible effs
adamc@1225 707 | Abort => true
adamc@1017 708 in
adamc@1017 709 (*Print.prefaces "verifyCompatible"
adamc@1017 710 [("e'", MonoPrint.p_exp env e'),
adamc@1017 711 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 712 ("effs_e'", Print.p_list p_event effs_e'),
adamc@1017 713 ("effs_b", Print.p_list p_event effs_b)];*)
adamc@1017 714 if (List.null effs_e'
adamc@1017 715 orelse (List.all (fn eff => eff <> Unsure) effs_e'
adamc@1017 716 andalso verifyCompatible effs_b)
adamc@1017 717 orelse (case effs_b of
adamc@1017 718 UseRel :: effs => List.all verifyUnused effs
adamc@1017 719 | _ => false))
adamc@1017 720 andalso countFree 0 0 b = 1
adamc@1017 721 andalso not (freeInAbs b) then
adam@1855 722 trySub ()
adamc@1017 723 else
adamc@1017 724 e
adamc@1017 725 end
adam@2084 726 else if countFree 0 0 b > 1
adam@2084 727 andalso not (!fullMode)
adam@2084 728 andalso not (passive e')
adam@2084 729 andalso not (isRecord () andalso Option.isSome (whichProj 0 b)) then
adam@1817 730 e
adamc@1017 731 else
adam@1855 732 trySub ()
adamc@1017 733 end
adamc@1017 734
adamc@470 735 val r =
adamc@470 736 case e of
adamc@470 737 ERel n =>
adamc@470 738 (case E.lookupERel env n of
adamc@470 739 (_, _, SOME e') => #1 e'
adamc@470 740 | _ => e)
adamc@470 741 | ENamed n =>
adamc@470 742 (case E.lookupENamed env n of
adamc@470 743 (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
adamc@470 744 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 745 #1 e')
adamc@470 746 | _ => e)
adamc@470 747
adamc@470 748 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
adamc@470 749 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
adamc@694 750 ("e2", MonoPrint.p_exp env e2),
adamc@694 751 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
adam@1852 752 if impure env e2 orelse (not (!fullMode) andalso countFree 0 0 e1 > 1) then
adamc@470 753 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
adamc@470 754 else
adamc@470 755 #1 (reduceExp env (subExpInExp (0, e2) e1)))
adamc@470 756
adamc@470 757 | ECase (e', pes, {disc, result}) =>
adamc@442 758 let
adamc@470 759 fun push () =
adamc@470 760 case result of
adamc@470 761 (TFun (dom, result), loc) =>
adamc@1107 762 let
adam@1855 763 fun safe e =
adam@1855 764 List.all (fn UseRel => true
adam@1855 765 | Abort => true
adam@1855 766 | _ => false) (summarize 0 e)
adam@1855 767
adam@1855 768 fun p_events' es = Print.box [Print.PD.string "{",
adam@1855 769 p_events es,
adam@1855 770 Print.PD.string "}"]
adamc@1107 771 in
adamc@1107 772 if List.all (safe o #2) pes then
adamc@1107 773 EAbs ("y", dom, result,
adamc@1107 774 (ECase (liftExpInExp 0 e',
adamc@1107 775 map (fn (p, (EAbs (_, _, _, e), _)) =>
adamc@1107 776 (p, swapExpVarsPat (0, patBinds p) e)
adam@1445 777 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
adam@2050 778 (p, (EError (liftExpInExp (patBinds p) e, t), loc))
adam@1855 779 | (p, e) =>
adam@1855 780 (p, (EApp (liftExpInExp (patBinds p) e,
adam@1855 781 (ERel (patBinds p), loc)), loc)))
adam@1855 782 pes,
adamc@1107 783 {disc = disc, result = result}), loc))
adamc@1107 784 else
adamc@1107 785 e
adamc@1107 786 end
adamc@470 787 | _ => e
adamc@318 788
adamc@470 789 fun search pes =
adamc@470 790 case pes of
adamc@470 791 [] => push ()
adamc@470 792 | (p, body) :: pes =>
adamc@814 793 case match ([], p, e') of
adamc@470 794 No => search pes
adamc@470 795 | Maybe => push ()
adamc@814 796 | Yes subs =>
adamc@800 797 let
adamc@829 798 val (body, remaining) =
adam@1817 799 foldl (fn ((x, t, e), (body, remaining)) =>
adam@1817 800 (if countFree 0 0 body > 1 then
adam@1817 801 (ELet (x, t, multiLift remaining e, body), #2 e')
adam@1817 802 else
adam@1817 803 subExpInExp (0, multiLift remaining e) body, remaining - 1))
adamc@829 804 (body, length subs - 1) subs
adamc@920 805 val r = reduceExp (E.patBinds env p) body
adamc@800 806 in
adamc@829 807 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
adamc@800 808 (*Print.prefaces "ECase"
adamc@829 809 [("old", MonoPrint.p_exp env body),
adamc@829 810 ("body", MonoPrint.p_exp env body),
adamc@800 811 ("r", MonoPrint.p_exp env r)];*)
adamc@800 812 #1 r
adamc@800 813 end
adamc@470 814 in
adamc@941 815 if impure env e' then
adamc@941 816 e
adamc@941 817 else
adamc@941 818 search pes
adamc@470 819 end
adamc@318 820
adamc@470 821 | EField ((ERecord xes, _), x) =>
adamc@470 822 (case List.find (fn (x', _, _) => x' = x) xes of
adamc@470 823 SOME (_, e, _) => #1 e
adamc@470 824 | NONE => e)
adamc@398 825
adamc@470 826 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
adamc@470 827 let
adamc@470 828 val e' = (ELet (x2, t2, e1,
adamc@470 829 (ELet (x1, t1, b1,
adamc@470 830 liftExpInExp 1 b2), loc)), loc)
adamc@442 831 in
adamc@470 832 (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
adamc@470 833 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 834 #1 (reduceExp env e')
adamc@470 835 end
adamc@470 836 | EApp ((ELet (x, t, e, b), loc), e') =>
adamc@470 837 #1 (reduceExp env (ELet (x, t, e,
adamc@470 838 (EApp (b, liftExpInExp 0 e'), loc)), loc))
adamc@470 839
adamc@1017 840 | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
adamc@919 841 if impure env e' then
adamc@1017 842 doLet (x, t, e', b)
adamc@848 843 else
adamc@920 844 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
adamc@920 845 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
adamc@470 846
adamc@1017 847 | ELet (x, t, e', b) => doLet (x, t, e', b)
adamc@252 848
adam@2048 849 | EStrcat ((EPrim (Prim.String (k1, s1)), _), (EPrim (Prim.String (k2, s2)), _)) =>
adam@2048 850 EPrim (Prim.String ((case (k1, k2) of
adam@2048 851 (Prim.Html, Prim.Html) => Prim.Html
adam@2048 852 | _ => Prim.Normal), s1 ^ s2))
adamc@268 853
adamc@572 854 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 855 #1 (reduceExp env (EApp (e2, e1), loc))
adamc@572 856
adamc@470 857 | _ => e
adamc@470 858 in
adamc@829 859 (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
adamc@829 860 ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
adamc@470 861 r
adamc@470 862 end
adamc@470 863
adamc@470 864 and bind (env, b) =
adamc@470 865 case b of
adamc@470 866 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
adamc@470 867 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
adamc@1017 868 | U.Decl.NamedE (x, n, t, eo, s) =>
adamc@1017 869 let
adamc@1017 870 val eo = case eo of
adamc@1017 871 NONE => NONE
adam@1393 872 | SOME e => if mayInline (n, e, t, s) then
adamc@1017 873 SOME e
adamc@1017 874 else
adamc@1017 875 NONE
adamc@1017 876 in
adamc@1017 877 E.pushENamed env x n t (Option.map (reduceExp env) eo) s
adamc@1017 878 end
adamc@470 879
adamc@470 880 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
adamc@470 881
adamc@801 882 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
adamc@801 883 d)
adamc@398 884 in
adamc@470 885 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
adamc@398 886 end
adamc@133 887
adamc@133 888 end