Mercurial > urweb

annotate src/mono_reduce.sml @ 2057:f4a6ccb7937f

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