Mercurial > urweb

annotate src/mono_reduce.sml @ 2134:752e5efe9da9

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Use hyperref in manual This allows the table of contents to show up properly in PDF readers.
author Julian Squires <julian@cipht.net>
date Fri, 24 Apr 2015 07:43:22 -0400
parents ec1614fb97bb
children 25874084bf1f
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@2126 333 val yankedCase = ref false
adam@2126 334
adam@2126 335 fun reduce' (file : file) =
adamc@470 336 let
adamc@948 337 val (timpures, impures, absCounts) =
adamc@948 338 foldl (fn ((d, _), (timpures, impures, absCounts)) =>
adamc@916 339 let
adam@1820 340 fun countAbs env e =
adam@1820 341 case #1 e of
adam@1820 342 EAbs (x, t, _, e) => 1 + countAbs (E.pushERel env x t NONE) e
adam@1820 343 | _ =>
adam@1820 344 let
adam@1820 345 fun remaining e =
adam@1820 346 case #1 e of
adam@1820 347 ENamed n => IM.find (absCounts, n)
adam@1820 348 | EApp (e, arg) =>
adam@1963 349 if simpleImpure true (timpures, impures) env arg then
adam@1820 350 NONE
adam@1820 351 else
adam@1820 352 (case remaining e of
adam@1820 353 NONE => NONE
adam@1820 354 | SOME n => if n > 0 then
adam@1820 355 SOME (n - 1)
adam@1820 356 else
adam@1820 357 NONE)
adam@1820 358 | _ => NONE
adam@1820 359 in
adam@1820 360 getOpt (remaining e, 0)
adam@1820 361 end
adamc@916 362 in
adamc@916 363 case d of
adamc@948 364 DDatatype dts =>
adamc@948 365 (if List.exists (fn (_, _, cs) =>
adamc@948 366 List.exists (fn (_, _, NONE) => false
adamc@948 367 | (_, _, SOME t) => simpleTypeImpure timpures t) cs)
adamc@948 368 dts then
adamc@948 369 IS.addList (timpures, map #2 dts)
adamc@948 370 else
adamc@948 371 timpures,
adamc@948 372 impures,
adamc@948 373 absCounts)
adamc@948 374 | DVal (_, n, _, e, _) =>
adamc@948 375 (timpures,
adam@1963 376 if simpleImpure true (timpures, impures) E.empty e then
adamc@916 377 IS.add (impures, n)
adamc@916 378 else
adamc@916 379 impures,
adam@1820 380 IM.insert (absCounts, n, countAbs E.empty e))
adamc@916 381 | DValRec vis =>
adamc@948 382 (timpures,
adam@1963 383 if List.exists (fn (_, _, _, e, _) => simpleImpure true (timpures, impures) E.empty e) vis then
adamc@916 384 foldl (fn ((_, n, _, _, _), impures) =>
adamc@916 385 IS.add (impures, n)) impures vis
adamc@916 386 else
adamc@916 387 impures,
adamc@916 388 foldl (fn ((x, n, _, e, _), absCounts) =>
adam@1820 389 IM.insert (absCounts, n, countAbs E.empty e))
adamc@916 390 absCounts vis)
adamc@948 391 | _ => (timpures, impures, absCounts)
adamc@916 392 end)
adam@1845 393 (IS.empty, IS.empty, IM.empty) (#1 file)
adamc@387 394
adamc@1017 395 val uses = U.File.fold {typ = fn (_, m) => m,
adamc@1017 396 exp = fn (e, m) =>
adamc@1017 397 case e of
adamc@1017 398 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
adamc@1017 399 | _ => m,
adamc@1017 400 decl = fn (_, m) => m}
adamc@1017 401 IM.empty file
adamc@1017 402
adamc@1017 403 val size = U.Exp.fold {typ = fn (_, n) => n,
adamc@1017 404 exp = fn (_, n) => n + 1} 0
adamc@1017 405
adam@1360 406 val functionInside' = U.Typ.exists (fn c => case c of
adam@1360 407 TFun _ => true
adam@1360 408 | _ => false)
adam@1360 409
adam@1360 410 fun functionInside t =
adam@1360 411 case #1 t of
adam@1360 412 TFun (t1, t2) => functionInside' t1 orelse functionInside t2
adam@1360 413 | _ => functionInside' t
adam@1360 414
adam@1393 415 fun mayInline (n, e, t, s) =
adamc@1017 416 case IM.find (uses, n) of
adamc@1017 417 NONE => false
adam@1966 418 | SOME count => not (Settings.checkNeverInline s)
adam@1966 419 andalso (count <= 1
adam@1966 420 orelse size e <= Settings.getMonoInline ()
adam@1966 421 orelse functionInside t
adam@1966 422 orelse Settings.checkAlwaysInline s)
adamc@1017 423
adamc@470 424 fun summarize d (e, _) =
adamc@579 425 let
adamc@579 426 val s =
adamc@579 427 case e of
adamc@579 428 EPrim _ => []
adamc@579 429 | ERel n => if n = d then [UseRel] else []
adamc@579 430 | ENamed _ => []
adamc@579 431 | ECon (_, _, NONE) => []
adamc@579 432 | ECon (_, _, SOME e) => summarize d e
adamc@579 433 | ENone _ => []
adamc@579 434 | ESome (_, e) => summarize d e
adamc@579 435 | EFfi _ => []
adam@1663 436 | EFfiApp ("Basis", "get_cookie", [(e, _)]) =>
adamc@1225 437 summarize d e @ [ReadCookie]
adam@1423 438 | EFfiApp ("Basis", "set_cookie", es) =>
adam@1663 439 List.concat (map (summarize d o #1) es) @ [WriteCookie]
adam@1423 440 | EFfiApp ("Basis", "clear_cookie", es) =>
adam@1663 441 List.concat (map (summarize d o #1) es) @ [WriteCookie]
adamc@765 442 | EFfiApp (m, x, es) =>
adamc@1171 443 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
adam@1663 444 List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
adam@1663 445 WritePage
adam@1663 446 else
adam@1663 447 Unsure]
adamc@765 448 else
adam@1663 449 List.concat (map (summarize d o #1) es)
adamc@579 450 | EApp ((EFfi _, _), e) => summarize d e
adamc@579 451 | EApp _ =>
adamc@579 452 let
adamc@694 453 fun unravel (e, passed, ls) =
adamc@579 454 case e of
adamc@579 455 ENamed n =>
adamc@579 456 let
adamc@579 457 val ls = rev ls
adamc@579 458 in
adamc@948 459 if IS.member (impures, n) then
adamc@948 460 case IM.find (absCounts, n) of
adamc@948 461 NONE => [Unsure]
adamc@948 462 | SOME len =>
adamc@948 463 if passed < len then
adamc@948 464 ls
adamc@948 465 else
adamc@948 466 ls @ [Unsure]
adamc@948 467 else
adamc@948 468 ls
adamc@579 469 end
adamc@579 470 | ERel n => List.revAppend (ls,
adamc@579 471 if n = d then
adamc@579 472 [UseRel, Unsure]
adamc@579 473 else
adamc@579 474 [Unsure])
adamc@579 475 | EApp (f, x) =>
adamc@995 476 unravel (#1 f, passed + 1, List.revAppend (summarize d x,
adamc@995 477 ls))
adam@1394 478 | EError _ => [Abort]
adamc@579 479 | _ => [Unsure]
adamc@579 480 in
adamc@694 481 unravel (e, 0, [])
adamc@579 482 end
adamc@252 483
adamc@941 484 | EAbs _ => []
adamc@316 485
adamc@579 486 | EUnop (_, e) => summarize d e
adam@1360 487 | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2
adamc@470 488
adamc@579 489 | ERecord xets => List.concat (map (summarize d o #2) xets)
adamc@579 490 | EField (e, _) => summarize d e
adamc@470 491
adamc@1214 492 | ECase (e, pes, _) =>
adamc@1214 493 let
adam@2040 494 val lss = map (fn (p, e) => summarize (if d = ~1 then ~1 else d + patBinds p) e) pes
adam@1394 495
adam@1394 496 fun splitRel ls acc =
adam@1394 497 case ls of
adam@1394 498 [] => (acc, false, ls)
adam@1394 499 | UseRel :: ls => (acc, true, ls)
adam@1394 500 | v :: ls => splitRel ls (v :: acc)
adam@1394 501
adam@1394 502 val (pre, used, post) = foldl (fn (ls, (pre, used, post)) =>
adam@1394 503 let
adam@1394 504 val (pre', used', post') = splitRel ls []
adam@1394 505 in
adam@1394 506 (pre' @ pre, used' orelse used, post' @ post)
adam@1394 507 end)
adam@1394 508 ([], false, []) lss
adamc@579 509 in
adam@1394 510 summarize d e
adam@1394 511 @ pre
adam@1394 512 @ (if used then [UseRel] else [])
adam@1394 513 @ post
adamc@1214 514 end
adamc@579 515 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
adamc@316 516
adamc@1225 517 | EError (e, _) => summarize d e @ [Abort]
adam@1932 518 | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort]
adam@1932 519 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
adamc@1225 520 | ERedirect (e, _) => summarize d e @ [Abort]
adamc@318 521
adamc@579 522 | EWrite e => summarize d e @ [WritePage]
adamc@579 523
adamc@579 524 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
adam@2041 525 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (if d = ~1 then ~1 else d + 1) e2
adamc@456 526
adamc@579 527 | EClosure (_, es) => List.concat (map (summarize d) es)
adamc@470 528
adamc@579 529 | EQuery {query, body, initial, ...} =>
adamc@579 530 List.concat [summarize d query,
adamc@579 531 summarize d initial,
adamc@941 532 [ReadDb],
adam@2040 533 summarize (if d = ~1 then ~1 else d + 2) body]
adamc@470 534
adam@1293 535 | EDml (e, _) => summarize d e @ [WriteDb]
adamc@579 536 | ENextval e => summarize d e @ [WriteDb]
adamc@1073 537 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
adamc@1112 538 | EUnurlify (e, _, _) => summarize d e
adamc@815 539 | EJavaScript (_, e) => summarize d e
adamc@579 540 | ESignalReturn e => summarize d e
adamc@579 541 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 542 | ESignalSource e => summarize d e
adamc@608 543
adam@1848 544 | EServerCall (e, _, _, _) => summarize d e @ [Unsure]
adamc@1021 545 | ERecv (e, _) => summarize d e @ [Unsure]
adamc@1021 546 | ESleep e => summarize d e @ [Unsure]
adamc@1021 547 | ESpawn e => summarize d e @ [Unsure]
adamc@579 548 in
adamc@579 549 (*Print.prefaces "Summarize"
adamc@579 550 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
adamc@579 551 ("d", Print.PD.string (Int.toString d)),
adamc@579 552 ("s", p_events s)];*)
adamc@579 553 s
adamc@579 554 end
adamc@470 555
adamc@919 556 val impure = fn env => fn e =>
adam@1963 557 simpleImpure false (timpures, impures) env e andalso impure e
adamc@916 558 andalso not (List.null (summarize ~1 e))
adamc@916 559
adam@1852 560 fun passive (e : exp) =
adam@1852 561 case #1 e of
adam@1852 562 EPrim _ => true
adam@1852 563 | ERel _ => true
adam@1852 564 | ENamed _ => true
adam@1852 565 | ECon (_, _, NONE) => true
adam@1852 566 | ECon (_, _, SOME e) => passive e
adam@1852 567 | ENone _ => true
adam@1852 568 | ESome (_, e) => passive e
adam@1852 569 | EFfi _ => true
adam@1852 570 | EAbs _ => true
adam@1852 571 | ERecord xets => List.all (passive o #2) xets
adam@1852 572 | EField (e, _) => passive e
adam@1852 573 | _ => false
adam@1852 574
adamc@470 575 fun exp env e =
adamc@470 576 let
adamc@470 577 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
adamc@470 578
adamc@1017 579 fun doLet (x, t, e', b) =
adamc@1017 580 let
adamc@1017 581 fun doSub () =
adamc@1017 582 let
adamc@1017 583 val r = subExpInExp (0, e') b
adamc@1017 584 in
adamc@1017 585 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
adam@1423 586 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adam@1423 587 ("r", MonoPrint.p_exp env r)];*)
adamc@1017 588 #1 (reduceExp env r)
adamc@1017 589 end
adamc@1017 590
adam@1855 591 fun trySub () =
adamc@1017 592 ((*Print.prefaces "trySub"
adamc@1017 593 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
adamc@1017 594 case t of
adamc@1017 595 (TFfi ("Basis", "string"), _) => doSub ()
adamc@1017 596 | (TSignal _, _) => e
adamc@1017 597 | _ =>
adam@1855 598 case e' of
adam@1855 599 (ECase _, _) => e
adam@1855 600 | _ => doSub ())
adam@2084 601
adam@2084 602 fun isRecord () =
adam@2084 603 case #1 e' of
adam@2084 604 ERecord _ => true
adam@2084 605 | _ => false
adam@2084 606
adam@2084 607 fun whichProj i (e : exp) =
adam@2084 608 case #1 e of
adam@2084 609 EPrim _ => SOME SS.empty
adam@2084 610 | ERel i' => if i' = i then NONE else SOME SS.empty
adam@2084 611 | ENamed _ => SOME SS.empty
adam@2084 612 | ECon (_, _, NONE) => SOME SS.empty
adam@2084 613 | ECon (_, _, SOME e') => whichProj i e'
adam@2084 614 | ENone _ => SOME SS.empty
adam@2084 615 | ESome (_, e') => whichProj i e'
adam@2084 616 | EFfi _ => SOME SS.empty
adam@2084 617 | EFfiApp (_, _, es) => whichProjs i (map #1 es)
adam@2084 618 | EApp (e1, e2) => whichProjs i [e1, e2]
adam@2084 619 | EAbs (_, _, _, e) => whichProj (i + 1) e
adam@2084 620 | EUnop (_, e1) => whichProj i e1
adam@2084 621 | EBinop (_, _, e1, e2) => whichProjs i [e1, e2]
adam@2084 622 | ERecord xets => whichProjs i (map #2 xets)
adam@2084 623 | EField ((ERel i', _), s) =>
adam@2084 624 if i' = i then
adam@2084 625 SOME (SS.singleton s)
adam@2084 626 else
adam@2084 627 SOME SS.empty
adam@2084 628 | EField (e1, _) => whichProj i e1
adam@2084 629 | ECase (e1, pes, _) =>
adam@2084 630 whichProjs' i ((0, e1)
adam@2084 631 :: map (fn (p, e) => (patBinds p, e)) pes)
adam@2084 632 | EStrcat (e1, e2) => whichProjs i [e1, e2]
adam@2084 633 | EError (e1, _) => whichProj i e1
adam@2084 634 | EReturnBlob {blob = NONE, mimeType = e2, ...} => whichProj i e2
adam@2084 635 | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => whichProjs i [e1, e2]
adam@2084 636 | ERedirect (e1, _) => whichProj i e1
adam@2084 637 | EWrite e1 => whichProj i e1
adam@2084 638 | ESeq (e1, e2) => whichProjs i [e1, e2]
adam@2084 639 | ELet (_, _, e1, e2) => whichProjs' i [(0, e1), (1, e2)]
adam@2084 640 | EClosure (_, es) => whichProjs i es
adam@2084 641 | EQuery {query = e1, body = e2, initial = e3, ...} =>
adam@2084 642 whichProjs' i [(0, e1), (2, e2), (0, e3)]
adam@2084 643 | EDml (e1, _) => whichProj i e1
adam@2084 644 | ENextval e1 => whichProj i e1
adam@2084 645 | ESetval (e1, e2) => whichProjs i [e1, e2]
adam@2084 646 | EUnurlify (e1, _, _) => whichProj i e1
adam@2084 647 | EJavaScript (_, e1) => whichProj i e1
adam@2084 648 | ESignalReturn e1 => whichProj i e1
adam@2084 649 | ESignalBind (e1, e2) => whichProjs i [e1, e2]
adam@2084 650 | ESignalSource e1 => whichProj i e1
adam@2084 651 | EServerCall (e1, _, _, _) => whichProj i e1
adam@2084 652 | ERecv (e1, _) => whichProj i e1
adam@2084 653 | ESleep e1 => whichProj i e1
adam@2084 654 | ESpawn e1 => whichProj i e1
adam@2084 655
adam@2084 656 and whichProjs i es =
adam@2084 657 whichProjs' i (map (fn e => (0, e)) es)
adam@2084 658
adam@2084 659 and whichProjs' i es =
adam@2084 660 case es of
adam@2084 661 [] => SOME SS.empty
adam@2084 662 | (n, e) :: es' =>
adam@2084 663 case (whichProj (i + n) e, whichProjs' i es') of
adam@2084 664 (SOME m1, SOME m2) =>
adam@2084 665 if SS.isEmpty (SS.intersection (m1, m2)) then
adam@2084 666 SOME (SS.union (m1, m2))
adam@2084 667 else
adam@2084 668 NONE
adam@2084 669 | _ => NONE
adamc@1017 670 in
adamc@1017 671 if impure env e' then
adamc@1017 672 let
adamc@1017 673 val effs_e' = summarize 0 e'
adamc@1017 674 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
adamc@1017 675 val effs_b = summarize 0 b
adamc@1017 676
adam@2040 677 (*val () = Print.prefaces "Try"
adam@1394 678 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
adamc@1017 679 ("e'", MonoPrint.p_exp env e'),
adamc@1017 680 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 681 ("e'_eff", p_events effs_e'),
adamc@1017 682 ("b_eff", p_events effs_b)]*)
adamc@1017 683
adamc@1017 684 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
adamc@1017 685 val writesPage = does WritePage
adamc@1017 686 val readsDb = does ReadDb
adamc@1017 687 val writesDb = does WriteDb
adamc@1225 688 val readsCookie = does ReadCookie
adamc@1225 689 val writesCookie = does ReadCookie
adamc@1017 690
adamc@1017 691 fun verifyUnused eff =
adamc@1017 692 case eff of
adamc@1017 693 UseRel => false
adamc@1017 694 | _ => true
adamc@1017 695
adamc@1017 696 fun verifyCompatible effs =
adamc@1017 697 case effs of
adamc@1017 698 [] => false
adamc@1017 699 | eff :: effs =>
adamc@1017 700 case eff of
adamc@1017 701 Unsure => false
adamc@1017 702 | UseRel => List.all verifyUnused effs
adamc@1017 703 | WritePage => not writesPage andalso verifyCompatible effs
adamc@1017 704 | ReadDb => not writesDb andalso verifyCompatible effs
adamc@1017 705 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
adamc@1225 706 | ReadCookie => not writesCookie andalso verifyCompatible effs
adamc@1225 707 | WriteCookie => not writesCookie andalso not readsCookie
adamc@1225 708 andalso verifyCompatible effs
adamc@1225 709 | Abort => true
adamc@1017 710 in
adamc@1017 711 (*Print.prefaces "verifyCompatible"
adamc@1017 712 [("e'", MonoPrint.p_exp env e'),
adamc@1017 713 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 714 ("effs_e'", Print.p_list p_event effs_e'),
adamc@1017 715 ("effs_b", Print.p_list p_event effs_b)];*)
adamc@1017 716 if (List.null effs_e'
adamc@1017 717 orelse (List.all (fn eff => eff <> Unsure) effs_e'
adamc@1017 718 andalso verifyCompatible effs_b)
adamc@1017 719 orelse (case effs_b of
adamc@1017 720 UseRel :: effs => List.all verifyUnused effs
adamc@1017 721 | _ => false))
adamc@1017 722 andalso countFree 0 0 b = 1
adamc@1017 723 andalso not (freeInAbs b) then
adam@1855 724 trySub ()
adamc@1017 725 else
adamc@1017 726 e
adamc@1017 727 end
adam@2084 728 else if countFree 0 0 b > 1
adam@2084 729 andalso not (!fullMode)
adam@2084 730 andalso not (passive e')
adam@2084 731 andalso not (isRecord () andalso Option.isSome (whichProj 0 b)) then
adam@1817 732 e
adamc@1017 733 else
adam@1855 734 trySub ()
adamc@1017 735 end
adamc@1017 736
adamc@470 737 val r =
adamc@470 738 case e of
adamc@470 739 ERel n =>
adamc@470 740 (case E.lookupERel env n of
adamc@470 741 (_, _, SOME e') => #1 e'
adamc@470 742 | _ => e)
adamc@470 743 | ENamed n =>
adamc@470 744 (case E.lookupENamed env n of
adamc@470 745 (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
adamc@470 746 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 747 #1 e')
adamc@470 748 | _ => e)
adamc@470 749
adamc@470 750 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
adamc@470 751 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
adamc@694 752 ("e2", MonoPrint.p_exp env e2),
adamc@694 753 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
adam@1852 754 if impure env e2 orelse (not (!fullMode) andalso countFree 0 0 e1 > 1) then
adamc@470 755 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
adamc@470 756 else
adamc@470 757 #1 (reduceExp env (subExpInExp (0, e2) e1)))
adamc@470 758
adamc@470 759 | ECase (e', pes, {disc, result}) =>
adamc@442 760 let
adamc@470 761 fun push () =
adamc@470 762 case result of
adamc@470 763 (TFun (dom, result), loc) =>
adamc@1107 764 let
adam@1855 765 fun safe e =
adam@1855 766 List.all (fn UseRel => true
adam@1855 767 | Abort => true
adam@1855 768 | _ => false) (summarize 0 e)
adam@1855 769
adam@1855 770 fun p_events' es = Print.box [Print.PD.string "{",
adam@1855 771 p_events es,
adam@1855 772 Print.PD.string "}"]
adamc@1107 773 in
adamc@1107 774 if List.all (safe o #2) pes then
adam@2126 775 (yankedCase := true;
adam@2126 776 EAbs ("y", dom, result,
adam@2126 777 (ECase (liftExpInExp 0 e',
adam@2126 778 map (fn (p, (EAbs (_, _, _, e), _)) =>
adam@2126 779 (p, swapExpVarsPat (0, patBinds p) e)
adam@2126 780 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
adam@2126 781 (p, (EError (liftExpInExp (patBinds p) e, t), loc))
adam@2126 782 | (p, e) =>
adam@2126 783 (p, (EApp (liftExpInExp (patBinds p) e,
adam@2126 784 (ERel (patBinds p), loc)), loc)))
adam@2126 785 pes,
adam@2126 786 {disc = disc, result = result}), loc)))
adamc@1107 787 else
adamc@1107 788 e
adamc@1107 789 end
adamc@470 790 | _ => e
adamc@318 791
adamc@470 792 fun search pes =
adamc@470 793 case pes of
adamc@470 794 [] => push ()
adamc@470 795 | (p, body) :: pes =>
adamc@814 796 case match ([], p, e') of
adamc@470 797 No => search pes
adamc@470 798 | Maybe => push ()
adamc@814 799 | Yes subs =>
adamc@800 800 let
adamc@829 801 val (body, remaining) =
adam@1817 802 foldl (fn ((x, t, e), (body, remaining)) =>
adam@1817 803 (if countFree 0 0 body > 1 then
adam@1817 804 (ELet (x, t, multiLift remaining e, body), #2 e')
adam@1817 805 else
adam@1817 806 subExpInExp (0, multiLift remaining e) body, remaining - 1))
adamc@829 807 (body, length subs - 1) subs
adamc@920 808 val r = reduceExp (E.patBinds env p) body
adamc@800 809 in
adamc@829 810 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
adamc@800 811 (*Print.prefaces "ECase"
adamc@829 812 [("old", MonoPrint.p_exp env body),
adamc@829 813 ("body", MonoPrint.p_exp env body),
adamc@800 814 ("r", MonoPrint.p_exp env r)];*)
adamc@800 815 #1 r
adamc@800 816 end
adamc@470 817 in
adamc@941 818 if impure env e' then
adamc@941 819 e
adamc@941 820 else
adamc@941 821 search pes
adamc@470 822 end
adamc@318 823
adam@2110 824 | EField (e1, x) =>
adam@2110 825 let
adam@2110 826 fun yankLets (e : exp) =
adam@2110 827 case #1 e of
adam@2110 828 ELet (x, t, e1, e2) => (ELet (x, t, e1, yankLets e2), #2 e)
adam@2110 829 | ERecord xes =>
adam@2110 830 (case List.find (fn (x', _, _) => x' = x) xes of
adam@2110 831 SOME (_, e, _) => e
adam@2110 832 | NONE => (EField (e, x), #2 e))
adam@2110 833 | _ => (EField (e, x), #2 e)
adam@2110 834 in
adam@2110 835 #1 (yankLets e1)
adam@2110 836 end
adamc@398 837
adamc@470 838 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
adamc@470 839 let
adamc@470 840 val e' = (ELet (x2, t2, e1,
adamc@470 841 (ELet (x1, t1, b1,
adamc@470 842 liftExpInExp 1 b2), loc)), loc)
adamc@442 843 in
adamc@470 844 (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
adamc@470 845 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 846 #1 (reduceExp env e')
adamc@470 847 end
adamc@470 848 | EApp ((ELet (x, t, e, b), loc), e') =>
adamc@470 849 #1 (reduceExp env (ELet (x, t, e,
adamc@470 850 (EApp (b, liftExpInExp 0 e'), loc)), loc))
adamc@470 851
adamc@1017 852 | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
adamc@919 853 if impure env e' then
adamc@1017 854 doLet (x, t, e', b)
adamc@848 855 else
adamc@920 856 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
adamc@920 857 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
adamc@470 858
adamc@1017 859 | ELet (x, t, e', b) => doLet (x, t, e', b)
adamc@252 860
adam@2048 861 | EStrcat ((EPrim (Prim.String (k1, s1)), _), (EPrim (Prim.String (k2, s2)), _)) =>
adam@2048 862 EPrim (Prim.String ((case (k1, k2) of
adam@2048 863 (Prim.Html, Prim.Html) => Prim.Html
adam@2048 864 | _ => Prim.Normal), s1 ^ s2))
adamc@268 865
adamc@572 866 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 867 #1 (reduceExp env (EApp (e2, e1), loc))
adamc@572 868
adamc@470 869 | _ => e
adamc@470 870 in
adamc@829 871 (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
adamc@829 872 ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
adamc@470 873 r
adamc@470 874 end
adamc@470 875
adamc@470 876 and bind (env, b) =
adamc@470 877 case b of
adamc@470 878 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
adamc@470 879 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
adamc@1017 880 | U.Decl.NamedE (x, n, t, eo, s) =>
adamc@1017 881 let
adamc@1017 882 val eo = case eo of
adamc@1017 883 NONE => NONE
adam@1393 884 | SOME e => if mayInline (n, e, t, s) then
adamc@1017 885 SOME e
adamc@1017 886 else
adamc@1017 887 NONE
adamc@1017 888 in
adamc@1017 889 E.pushENamed env x n t (Option.map (reduceExp env) eo) s
adamc@1017 890 end
adamc@470 891
adamc@470 892 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
adamc@470 893
adamc@801 894 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
adamc@801 895 d)
adamc@398 896 in
adamc@470 897 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
adamc@398 898 end
adamc@133 899
adam@2126 900 fun reduce file =
adam@2126 901 let
adam@2126 902 val () = yankedCase := false
adam@2126 903 val file' = reduce' file
adam@2126 904 in
adam@2126 905 if !yankedCase then
adam@2126 906 reduce file'
adam@2126 907 else
adam@2126 908 file'
adam@2126 909 end
adam@2126 910
adam@2126 911
adamc@133 912 end