Mercurial > urweb

annotate src/mono_reduce.sml @ 2082:1b76ae703cbb

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