Mercurial > urweb

annotate src/mono_reduce.sml @ 1739:c414850f206f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Add support for -boot flag, which allows in-tree execution of Ur/Web The boot flag rewrites most hardcoded paths to point to the build directory, and also forces static compilation. This is convenient for developing Ur/Web, or if you cannot 'sudo make install' Ur/Web. The following changes were made: * Header files were moved to include/urweb instead of include; this lets FFI users point their C_INCLUDE_PATH at this directory at write <urweb/urweb.h>. For internal Ur/Web executables, we simply pass -I$PATH/include/urweb as normal. * Differentiate between LIB and SRCLIB; SRCLIB is Ur and JavaScript source files, while LIB is compiled products from libtool. For in-tree compilation these live in different places. * No longer reference Config for paths; instead use Settings; these settings can be changed dynamically by Compiler.enableBoot () (TODO: add a disableBoot function.) * config.h is now generated directly in include/urweb/config.h, for consistency's sake (especially since it gets installed along with the rest of the headers!) * All of the autotools build products got updated. * The linkStatic field in protocols now only contains the name of the build product, and not the absolute path. Future users have to be careful not to reference the Settings files to early, lest they get an old version (this was the source of two bugs during development of this patch.)
author Edward Z. Yang <ezyang@mit.edu>
date Wed, 02 May 2012 17:17:57 -0400
parents 0577be31a435
children 62c18ecbfec4
rev   line source
adamc@133 1 (* Copyright (c) 2008, 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
adamc@133 34 structure E = MonoEnv
adamc@133 35 structure U = MonoUtil
adamc@133 36
adamc@470 37 structure IM = IntBinaryMap
adamc@916 38 structure IS = IntBinarySet
adamc@470 39
adamc@133 40
adamc@948 41 fun simpleTypeImpure tsyms =
adamc@919 42 U.Typ.exists (fn TFun _ => true
adamc@948 43 | TDatatype (n, _) => IS.member (tsyms, n)
adamc@919 44 | _ => false)
adamc@919 45
adamc@948 46 fun simpleImpure (tsyms, syms) =
adamc@919 47 U.Exp.existsB {typ = fn _ => false,
adamc@919 48 exp = fn (env, e) =>
adamc@919 49 case e of
adamc@919 50 EWrite _ => true
adamc@919 51 | EQuery _ => true
adamc@919 52 | EDml _ => true
adamc@919 53 | ENextval _ => true
adamc@1073 54 | ESetval _ => true
adamc@1171 55 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
adamc@919 56 | EServerCall _ => true
adamc@919 57 | ERecv _ => true
adamc@919 58 | ESleep _ => true
adamc@919 59 | ENamed n => IS.member (syms, n)
adamc@919 60 | ERel n =>
adamc@919 61 let
adamc@919 62 val (_, t, _) = E.lookupERel env n
adamc@919 63 in
adamc@948 64 simpleTypeImpure tsyms t
adamc@919 65 end
adamc@919 66 | _ => false,
adamc@919 67 bind = fn (env, b) =>
adamc@919 68 case b of
adamc@919 69 U.Exp.RelE (x, t) => E.pushERel env x t NONE
adamc@919 70 | _ => env}
adamc@916 71
adamc@252 72 fun impure (e, _) =
adamc@252 73 case e of
adamc@252 74 EWrite _ => true
adamc@252 75 | EQuery _ => true
adamc@307 76 | EDml _ => true
adamc@338 77 | ENextval _ => true
adamc@1073 78 | ESetval _ => true
adam@1423 79 | EUnurlify (e, _, _) => impure e
adamc@252 80 | EAbs _ => false
adamc@252 81
adamc@252 82 | EPrim _ => false
adamc@252 83 | ERel _ => false
adamc@252 84 | ENamed _ => false
adamc@252 85 | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
adamc@297 86 | ENone _ => false
adamc@290 87 | ESome (_, e) => impure e
adamc@252 88 | EFfi _ => false
adamc@1171 89 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
adamc@252 90 | EApp ((EFfi _, _), _) => false
adamc@252 91 | EApp _ => true
adamc@252 92
adamc@387 93 | EUnop (_, e) => impure e
adam@1360 94 | EBinop (_, _, e1, e2) => impure e1 orelse impure e2
adamc@387 95
adamc@252 96 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes
adamc@252 97 | EField (e, _) => impure e
adamc@252 98
adamc@252 99 | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
adamc@252 100
adamc@1069 101 | EError _ => true
adamc@741 102 | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2
adamc@1065 103 | ERedirect (e, _) => impure e
adamc@283 104
adamc@252 105 | EStrcat (e1, e2) => impure e1 orelse impure e2
adamc@252 106
adamc@252 107 | ESeq (e1, e2) => impure e1 orelse impure e2
adamc@252 108 | ELet (_, _, e1, e2) => impure e1 orelse impure e2
adamc@252 109
adamc@252 110 | EClosure (_, es) => List.exists impure es
adamc@815 111 | EJavaScript (_, e) => impure e
adamc@568 112 | ESignalReturn e => impure e
adamc@572 113 | ESignalBind (e1, e2) => impure e1 orelse impure e2
adamc@574 114 | ESignalSource e => impure e
adamc@608 115 | EServerCall _ => true
adamc@670 116 | ERecv _ => true
adamc@695 117 | ESleep _ => true
adamc@1021 118 | ESpawn _ => true
adamc@252 119
adamc@252 120 val liftExpInExp = Monoize.liftExpInExp
adamc@252 121
adamc@829 122 fun multiLift n e =
adamc@829 123 case n of
adamc@829 124 0 => e
adamc@829 125 | _ => multiLift (n - 1) (liftExpInExp 0 e)
adamc@829 126
adamc@252 127 val subExpInExp' =
adamc@133 128 U.Exp.mapB {typ = fn t => t,
adamc@133 129 exp = fn (xn, rep) => fn e =>
adamc@133 130 case e of
adamc@133 131 ERel xn' =>
adamc@133 132 (case Int.compare (xn', xn) of
adamc@133 133 EQUAL => #1 rep
adamc@133 134 | GREATER=> ERel (xn' - 1)
adamc@133 135 | LESS => e)
adamc@133 136 | _ => e,
adamc@133 137 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
adamc@133 138 | (ctx, _) => ctx}
adamc@133 139
adamc@252 140 fun subExpInExp (n, e1) e2 =
adamc@252 141 let
adamc@252 142 val r = subExpInExp' (n, e1) e2
adamc@252 143 in
adamc@252 144 (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1),
adamc@252 145 ("e2", MonoPrint.p_exp MonoEnv.empty e2),
adamc@252 146 ("r", MonoPrint.p_exp MonoEnv.empty r)];*)
adamc@252 147 r
adamc@252 148 end
adamc@133 149
adamc@133 150 fun typ c = c
adamc@133 151
adamc@316 152 val swapExpVars =
adamc@316 153 U.Exp.mapB {typ = fn t => t,
adamc@316 154 exp = fn lower => fn e =>
adamc@316 155 case e of
adamc@316 156 ERel xn =>
adamc@316 157 if xn = lower then
adamc@316 158 ERel (lower + 1)
adamc@316 159 else if xn = lower + 1 then
adamc@316 160 ERel lower
adamc@316 161 else
adamc@316 162 e
adamc@316 163 | _ => e,
adamc@316 164 bind = fn (lower, U.Exp.RelE _) => lower+1
adamc@316 165 | (lower, _) => lower}
adamc@316 166
adamc@341 167 val swapExpVarsPat =
adamc@341 168 U.Exp.mapB {typ = fn t => t,
adamc@341 169 exp = fn (lower, len) => fn e =>
adamc@341 170 case e of
adamc@341 171 ERel xn =>
adamc@341 172 if xn = lower then
adamc@827 173 ERel (lower + len)
adamc@341 174 else if xn >= lower + 1 andalso xn < lower + 1 + len then
adamc@341 175 ERel (xn - 1)
adamc@341 176 else
adamc@341 177 e
adamc@341 178 | _ => e,
adamc@341 179 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
adamc@341 180 | (st, _) => st}
adamc@341 181
adamc@814 182 datatype result = Yes of exp list | No | Maybe
adamc@258 183
adamc@183 184 fun match (env, p : pat, e : exp) =
adamc@183 185 case (#1 p, #1 e) of
adamc@258 186 (PWild, _) => Yes env
adamc@814 187 | (PVar (x, t), _) => Yes (e :: env)
adamc@183 188
adamc@280 189 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
adamc@280 190 if String.isPrefix s' s then
adamc@280 191 Maybe
adamc@280 192 else
adamc@280 193 No
adamc@280 194
adamc@1207 195 | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) =>
adamc@1207 196 if String.isSuffix s' s then
adamc@1207 197 Maybe
adamc@1207 198 else
adamc@1207 199 No
adamc@1207 200
adamc@183 201 | (PPrim p, EPrim p') =>
adamc@183 202 if Prim.equal (p, p') then
adamc@258 203 Yes env
adamc@183 204 else
adamc@258 205 No
adamc@183 206
kkallio@1489 207 | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) =>
adamc@183 208 if n1 = n2 then
kkallio@1489 209 case (po, eo) of
kkallio@1489 210 (NONE, NONE) => Yes env
kkallio@1489 211 | (SOME p, SOME e) => match (env, p, e)
kkallio@1489 212 | _ => Maybe
adamc@183 213 else
adamc@258 214 No
adamc@183 215
adamc@188 216 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, NONE), ECon (_, PConFfi {mod = m2, con = con2, ...}, NONE)) =>
adamc@185 217 if m1 = m2 andalso con1 = con2 then
adamc@258 218 Yes env
adamc@185 219 else
adamc@258 220 No
adamc@185 221
adamc@188 222 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (_, PConFfi {mod = m2, con = con2, ...}, SOME e)) =>
adamc@185 223 if m1 = m2 andalso con1 = con2 then
adamc@185 224 match (env, p, e)
adamc@185 225 else
adamc@258 226 No
adamc@185 227
adamc@183 228 | (PRecord xps, ERecord xes) =>
adamc@183 229 let
adamc@183 230 fun consider (xps, env) =
adamc@183 231 case xps of
adamc@258 232 [] => Yes env
adamc@183 233 | (x, p, _) :: rest =>
adamc@183 234 case List.find (fn (x', _, _) => x' = x) xes of
adamc@258 235 NONE => No
adamc@183 236 | SOME (_, e, _) =>
adamc@183 237 case match (env, p, e) of
adamc@258 238 No => No
adamc@258 239 | Maybe => Maybe
adamc@258 240 | Yes env => consider (rest, env)
adamc@183 241 in
adamc@183 242 consider (xps, env)
adamc@183 243 end
adamc@183 244
adamc@726 245 | (PNone _, ENone _) => Yes env
adamc@921 246 | (PNone _, ESome _) => No
adamc@726 247 | (PSome (_, p), ESome (_, e)) => match (env, p, e)
adamc@921 248 | (PSome _, ENone _) => No
adamc@726 249
adamc@258 250 | _ => Maybe
adamc@183 251
adamc@318 252 datatype event =
adamc@318 253 WritePage
adamc@318 254 | ReadDb
adamc@318 255 | WriteDb
adamc@1225 256 | ReadCookie
adamc@1225 257 | WriteCookie
adamc@481 258 | UseRel
adamc@318 259 | Unsure
adamc@1225 260 | Abort
adamc@318 261
adamc@318 262 fun p_event e =
adamc@318 263 let
adamc@318 264 open Print.PD
adamc@318 265 in
adamc@318 266 case e of
adamc@318 267 WritePage => string "WritePage"
adamc@318 268 | ReadDb => string "ReadDb"
adamc@318 269 | WriteDb => string "WriteDb"
adamc@1225 270 | ReadCookie => string "ReadCookie"
adamc@1225 271 | WriteCookie => string "WriteCookie"
adamc@481 272 | UseRel => string "UseRel"
adamc@318 273 | Unsure => string "Unsure"
adamc@1225 274 | Abort => string "Abort"
adamc@318 275 end
adamc@318 276
adamc@470 277 val p_events = Print.p_list p_event
adamc@470 278
adamc@318 279 fun patBinds (p, _) =
adamc@318 280 case p of
adamc@318 281 PWild => 0
adamc@318 282 | PVar _ => 1
adamc@318 283 | PPrim _ => 0
adamc@318 284 | PCon (_, _, NONE) => 0
adamc@318 285 | PCon (_, _, SOME p) => patBinds p
adamc@318 286 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
adamc@318 287 | PNone _ => 0
adamc@318 288 | PSome (_, p) => patBinds p
adamc@318 289
adamc@932 290 val countFree = U.Exp.foldB {typ = fn (_, n) => n,
adamc@932 291 exp = fn (x, e, n) =>
adamc@932 292 case e of
adamc@932 293 ERel x' => if x = x' then n + 1 else n
adamc@932 294 | _ => n,
adamc@932 295 bind = fn (n, b) =>
adamc@932 296 case b of
adamc@932 297 U.Exp.RelE _ => n + 1
adamc@975 298 | _ => n}
adamc@975 299
adamc@975 300 val freeInAbs = U.Exp.existsB {typ = fn _ => false,
adamc@975 301 exp = fn (n, e) =>
adamc@975 302 case e of
adamc@975 303 EAbs (_, _, _, b) => countFree n 0 b > 0
adamc@975 304 | EJavaScript (_, b) => countFree n 0 b > 0
adamc@975 305 | _ => false,
adamc@975 306 bind = fn (n, b) =>
adamc@975 307 case b of
adamc@975 308 U.Exp.RelE _ => n + 1
adamc@975 309 | _ => n} 0
adamc@932 310
adamc@470 311 fun reduce file =
adamc@470 312 let
adamc@948 313 val (timpures, impures, absCounts) =
adamc@948 314 foldl (fn ((d, _), (timpures, impures, absCounts)) =>
adamc@916 315 let
adamc@916 316 fun countAbs (e, _) =
adamc@916 317 case e of
adamc@916 318 EAbs (_, _, _, e) => 1 + countAbs e
adamc@916 319 | _ => 0
adamc@916 320 in
adamc@916 321 case d of
adamc@948 322 DDatatype dts =>
adamc@948 323 (if List.exists (fn (_, _, cs) =>
adamc@948 324 List.exists (fn (_, _, NONE) => false
adamc@948 325 | (_, _, SOME t) => simpleTypeImpure timpures t) cs)
adamc@948 326 dts then
adamc@948 327 IS.addList (timpures, map #2 dts)
adamc@948 328 else
adamc@948 329 timpures,
adamc@948 330 impures,
adamc@948 331 absCounts)
adamc@948 332 | DVal (_, n, _, e, _) =>
adamc@948 333 (timpures,
adamc@948 334 if simpleImpure (timpures, impures) E.empty e then
adamc@916 335 IS.add (impures, n)
adamc@916 336 else
adamc@916 337 impures,
adamc@916 338 IM.insert (absCounts, n, countAbs e))
adamc@916 339 | DValRec vis =>
adamc@948 340 (timpures,
adamc@948 341 if List.exists (fn (_, _, _, e, _) => simpleImpure (timpures, impures) E.empty e) vis then
adamc@916 342 foldl (fn ((_, n, _, _, _), impures) =>
adamc@916 343 IS.add (impures, n)) impures vis
adamc@916 344 else
adamc@916 345 impures,
adamc@916 346 foldl (fn ((x, n, _, e, _), absCounts) =>
adamc@916 347 IM.insert (absCounts, n, countAbs e))
adamc@916 348 absCounts vis)
adamc@948 349 | _ => (timpures, impures, absCounts)
adamc@916 350 end)
adamc@948 351 (IS.empty, IS.empty, IM.empty) file
adamc@387 352
adamc@1017 353 val uses = U.File.fold {typ = fn (_, m) => m,
adamc@1017 354 exp = fn (e, m) =>
adamc@1017 355 case e of
adamc@1017 356 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
adamc@1017 357 | _ => m,
adamc@1017 358 decl = fn (_, m) => m}
adamc@1017 359 IM.empty file
adamc@1017 360
adamc@1017 361 val size = U.Exp.fold {typ = fn (_, n) => n,
adamc@1017 362 exp = fn (_, n) => n + 1} 0
adamc@1017 363
adam@1360 364 val functionInside' = U.Typ.exists (fn c => case c of
adam@1360 365 TFun _ => true
adam@1360 366 | _ => false)
adam@1360 367
adam@1360 368 fun functionInside t =
adam@1360 369 case #1 t of
adam@1360 370 TFun (t1, t2) => functionInside' t1 orelse functionInside t2
adam@1360 371 | _ => functionInside' t
adam@1360 372
adam@1393 373 fun mayInline (n, e, t, s) =
adamc@1017 374 case IM.find (uses, n) of
adamc@1017 375 NONE => false
adamc@1017 376 | SOME count => count <= 1
adamc@1017 377 orelse size e <= Settings.getMonoInline ()
adam@1360 378 orelse functionInside t
adam@1393 379 orelse Settings.checkAlwaysInline s
adamc@1017 380
adamc@470 381 fun summarize d (e, _) =
adamc@579 382 let
adamc@579 383 val s =
adamc@579 384 case e of
adamc@579 385 EPrim _ => []
adamc@579 386 | ERel n => if n = d then [UseRel] else []
adamc@579 387 | ENamed _ => []
adamc@579 388 | ECon (_, _, NONE) => []
adamc@579 389 | ECon (_, _, SOME e) => summarize d e
adamc@579 390 | ENone _ => []
adamc@579 391 | ESome (_, e) => summarize d e
adamc@579 392 | EFfi _ => []
adam@1663 393 | EFfiApp ("Basis", "get_cookie", [(e, _)]) =>
adamc@1225 394 summarize d e @ [ReadCookie]
adam@1423 395 | EFfiApp ("Basis", "set_cookie", es) =>
adam@1663 396 List.concat (map (summarize d o #1) es) @ [WriteCookie]
adam@1423 397 | EFfiApp ("Basis", "clear_cookie", es) =>
adam@1663 398 List.concat (map (summarize d o #1) es) @ [WriteCookie]
adamc@765 399 | EFfiApp (m, x, es) =>
adamc@1171 400 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
adam@1663 401 List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
adam@1663 402 WritePage
adam@1663 403 else
adam@1663 404 Unsure]
adamc@765 405 else
adam@1663 406 List.concat (map (summarize d o #1) es)
adamc@579 407 | EApp ((EFfi _, _), e) => summarize d e
adamc@579 408 | EApp _ =>
adamc@579 409 let
adamc@694 410 fun unravel (e, passed, ls) =
adamc@579 411 case e of
adamc@579 412 ENamed n =>
adamc@579 413 let
adamc@579 414 val ls = rev ls
adamc@579 415 in
adamc@948 416 if IS.member (impures, n) then
adamc@948 417 case IM.find (absCounts, n) of
adamc@948 418 NONE => [Unsure]
adamc@948 419 | SOME len =>
adamc@948 420 if passed < len then
adamc@948 421 ls
adamc@948 422 else
adamc@948 423 ls @ [Unsure]
adamc@948 424 else
adamc@948 425 ls
adamc@579 426 end
adamc@579 427 | ERel n => List.revAppend (ls,
adamc@579 428 if n = d then
adamc@579 429 [UseRel, Unsure]
adamc@579 430 else
adamc@579 431 [Unsure])
adamc@579 432 | EApp (f, x) =>
adamc@995 433 unravel (#1 f, passed + 1, List.revAppend (summarize d x,
adamc@995 434 ls))
adam@1394 435 | EError _ => [Abort]
adamc@579 436 | _ => [Unsure]
adamc@579 437 in
adamc@694 438 unravel (e, 0, [])
adamc@579 439 end
adamc@252 440
adamc@941 441 | EAbs _ => []
adamc@316 442
adamc@579 443 | EUnop (_, e) => summarize d e
adam@1360 444 | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2
adamc@470 445
adamc@579 446 | ERecord xets => List.concat (map (summarize d o #2) xets)
adamc@579 447 | EField (e, _) => summarize d e
adamc@470 448
adamc@1214 449 | ECase (e, pes, _) =>
adamc@1214 450 let
adamc@579 451 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
adam@1394 452
adam@1394 453 fun splitRel ls acc =
adam@1394 454 case ls of
adam@1394 455 [] => (acc, false, ls)
adam@1394 456 | UseRel :: ls => (acc, true, ls)
adam@1394 457 | v :: ls => splitRel ls (v :: acc)
adam@1394 458
adam@1394 459 val (pre, used, post) = foldl (fn (ls, (pre, used, post)) =>
adam@1394 460 let
adam@1394 461 val (pre', used', post') = splitRel ls []
adam@1394 462 in
adam@1394 463 (pre' @ pre, used' orelse used, post' @ post)
adam@1394 464 end)
adam@1394 465 ([], false, []) lss
adamc@579 466 in
adam@1394 467 summarize d e
adam@1394 468 @ pre
adam@1394 469 @ (if used then [UseRel] else [])
adam@1394 470 @ post
adamc@1214 471 end
adamc@579 472 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
adamc@316 473
adamc@1225 474 | EError (e, _) => summarize d e @ [Abort]
adamc@1225 475 | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
adamc@1225 476 | ERedirect (e, _) => summarize d e @ [Abort]
adamc@318 477
adamc@579 478 | EWrite e => summarize d e @ [WritePage]
adamc@579 479
adamc@579 480 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 481 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
adamc@456 482
adamc@579 483 | EClosure (_, es) => List.concat (map (summarize d) es)
adamc@470 484
adamc@579 485 | EQuery {query, body, initial, ...} =>
adamc@579 486 List.concat [summarize d query,
adamc@579 487 summarize d initial,
adamc@941 488 [ReadDb],
adamc@941 489 summarize (d + 2) body]
adamc@470 490
adam@1293 491 | EDml (e, _) => summarize d e @ [WriteDb]
adamc@579 492 | ENextval e => summarize d e @ [WriteDb]
adamc@1073 493 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
adamc@1112 494 | EUnurlify (e, _, _) => summarize d e
adamc@815 495 | EJavaScript (_, e) => summarize d e
adamc@579 496 | ESignalReturn e => summarize d e
adamc@579 497 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
adamc@579 498 | ESignalSource e => summarize d e
adamc@608 499
adamc@1020 500 | EServerCall (e, _, _) => summarize d e @ [Unsure]
adamc@1021 501 | ERecv (e, _) => summarize d e @ [Unsure]
adamc@1021 502 | ESleep e => summarize d e @ [Unsure]
adamc@1021 503 | ESpawn e => summarize d e @ [Unsure]
adamc@579 504 in
adamc@579 505 (*Print.prefaces "Summarize"
adamc@579 506 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
adamc@579 507 ("d", Print.PD.string (Int.toString d)),
adamc@579 508 ("s", p_events s)];*)
adamc@579 509 s
adamc@579 510 end
adamc@470 511
adamc@919 512 val impure = fn env => fn e =>
adamc@948 513 simpleImpure (timpures, impures) env e andalso impure e
adamc@916 514 andalso not (List.null (summarize ~1 e))
adamc@916 515
adamc@470 516 fun exp env e =
adamc@470 517 let
adamc@470 518 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
adamc@470 519
adamc@1017 520 fun doLet (x, t, e', b) =
adamc@1017 521 let
adamc@1017 522 fun doSub () =
adamc@1017 523 let
adamc@1017 524 val r = subExpInExp (0, e') b
adamc@1017 525 in
adamc@1017 526 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
adam@1423 527 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adam@1423 528 ("r", MonoPrint.p_exp env r)];*)
adamc@1017 529 #1 (reduceExp env r)
adamc@1017 530 end
adamc@1017 531
adamc@1017 532 fun trySub () =
adamc@1017 533 ((*Print.prefaces "trySub"
adamc@1017 534 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
adamc@1017 535 case t of
adamc@1017 536 (TFfi ("Basis", "string"), _) => doSub ()
adamc@1017 537 | (TSignal _, _) => e
adamc@1017 538 | _ =>
adamc@1017 539 case e' of
adamc@1017 540 (ECase _, _) => e
adamc@1017 541 | _ => doSub ())
adamc@1017 542 in
adamc@1017 543 if impure env e' then
adamc@1017 544 let
adamc@1017 545 val effs_e' = summarize 0 e'
adamc@1017 546 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
adamc@1017 547 val effs_b = summarize 0 b
adamc@1017 548
adam@1394 549 (*val () = Print.fprefaces outf "Try"
adam@1394 550 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
adamc@1017 551 ("e'", MonoPrint.p_exp env e'),
adamc@1017 552 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 553 ("e'_eff", p_events effs_e'),
adamc@1017 554 ("b_eff", p_events effs_b)]*)
adamc@1017 555
adamc@1017 556 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
adamc@1017 557 val writesPage = does WritePage
adamc@1017 558 val readsDb = does ReadDb
adamc@1017 559 val writesDb = does WriteDb
adamc@1225 560 val readsCookie = does ReadCookie
adamc@1225 561 val writesCookie = does ReadCookie
adamc@1017 562
adamc@1017 563 fun verifyUnused eff =
adamc@1017 564 case eff of
adamc@1017 565 UseRel => false
adamc@1017 566 | _ => true
adamc@1017 567
adamc@1017 568 fun verifyCompatible effs =
adamc@1017 569 case effs of
adamc@1017 570 [] => false
adamc@1017 571 | eff :: effs =>
adamc@1017 572 case eff of
adamc@1017 573 Unsure => false
adamc@1017 574 | UseRel => List.all verifyUnused effs
adamc@1017 575 | WritePage => not writesPage andalso verifyCompatible effs
adamc@1017 576 | ReadDb => not writesDb andalso verifyCompatible effs
adamc@1017 577 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
adamc@1225 578 | ReadCookie => not writesCookie andalso verifyCompatible effs
adamc@1225 579 | WriteCookie => not writesCookie andalso not readsCookie
adamc@1225 580 andalso verifyCompatible effs
adamc@1225 581 | Abort => true
adamc@1017 582 in
adamc@1017 583 (*Print.prefaces "verifyCompatible"
adamc@1017 584 [("e'", MonoPrint.p_exp env e'),
adamc@1017 585 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
adamc@1017 586 ("effs_e'", Print.p_list p_event effs_e'),
adamc@1017 587 ("effs_b", Print.p_list p_event effs_b)];*)
adamc@1017 588 if (List.null effs_e'
adamc@1017 589 orelse (List.all (fn eff => eff <> Unsure) effs_e'
adamc@1017 590 andalso verifyCompatible effs_b)
adamc@1017 591 orelse (case effs_b of
adamc@1017 592 UseRel :: effs => List.all verifyUnused effs
adamc@1017 593 | _ => false))
adamc@1017 594 andalso countFree 0 0 b = 1
adamc@1017 595 andalso not (freeInAbs b) then
adamc@1017 596 trySub ()
adamc@1017 597 else
adamc@1017 598 e
adamc@1017 599 end
adamc@1017 600 else
adamc@1017 601 trySub ()
adamc@1017 602 end
adamc@1017 603
adamc@470 604 val r =
adamc@470 605 case e of
adamc@470 606 ERel n =>
adamc@470 607 (case E.lookupERel env n of
adamc@470 608 (_, _, SOME e') => #1 e'
adamc@470 609 | _ => e)
adamc@470 610 | ENamed n =>
adamc@470 611 (case E.lookupENamed env n of
adamc@470 612 (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
adamc@470 613 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 614 #1 e')
adamc@470 615 | _ => e)
adamc@470 616
adamc@470 617 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
adamc@470 618 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
adamc@694 619 ("e2", MonoPrint.p_exp env e2),
adamc@694 620 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
adamc@975 621 if impure env e2 orelse countFree 0 0 e1 > 1 then
adamc@470 622 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
adamc@470 623 else
adamc@470 624 #1 (reduceExp env (subExpInExp (0, e2) e1)))
adamc@470 625
adamc@470 626 | ECase (e', pes, {disc, result}) =>
adamc@442 627 let
adamc@470 628 fun push () =
adamc@470 629 case result of
adamc@470 630 (TFun (dom, result), loc) =>
adamc@1107 631 let
adamc@1107 632 fun safe (e, _) =
adamc@1107 633 case e of
adamc@1107 634 EAbs _ => true
adam@1445 635 | EError _ => true
adamc@1107 636 | _ => false
adamc@1107 637 in
adamc@1107 638 if List.all (safe o #2) pes then
adamc@1107 639 EAbs ("y", dom, result,
adamc@1107 640 (ECase (liftExpInExp 0 e',
adamc@1107 641 map (fn (p, (EAbs (_, _, _, e), _)) =>
adamc@1107 642 (p, swapExpVarsPat (0, patBinds p) e)
adam@1445 643 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
adam@1445 644 (p, (EError (e, t), loc))
adamc@1107 645 | _ => raise Fail "MonoReduce ECase") pes,
adamc@1107 646 {disc = disc, result = result}), loc))
adamc@1107 647 else
adamc@1107 648 e
adamc@1107 649 end
adamc@470 650 | _ => e
adamc@318 651
adamc@470 652 fun search pes =
adamc@470 653 case pes of
adamc@470 654 [] => push ()
adamc@470 655 | (p, body) :: pes =>
adamc@814 656 case match ([], p, e') of
adamc@470 657 No => search pes
adamc@470 658 | Maybe => push ()
adamc@814 659 | Yes subs =>
adamc@800 660 let
adamc@829 661 val (body, remaining) =
adamc@829 662 foldl (fn (e, (body, remaining)) =>
adamc@829 663 (subExpInExp (0, multiLift remaining e) body, remaining - 1))
adamc@829 664 (body, length subs - 1) subs
adamc@920 665 val r = reduceExp (E.patBinds env p) body
adamc@800 666 in
adamc@829 667 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
adamc@800 668 (*Print.prefaces "ECase"
adamc@829 669 [("old", MonoPrint.p_exp env body),
adamc@829 670 ("body", MonoPrint.p_exp env body),
adamc@800 671 ("r", MonoPrint.p_exp env r)];*)
adamc@800 672 #1 r
adamc@800 673 end
adamc@470 674 in
adamc@941 675 if impure env e' then
adamc@941 676 e
adamc@941 677 else
adamc@941 678 search pes
adamc@470 679 end
adamc@318 680
adamc@470 681 | EField ((ERecord xes, _), x) =>
adamc@470 682 (case List.find (fn (x', _, _) => x' = x) xes of
adamc@470 683 SOME (_, e, _) => #1 e
adamc@470 684 | NONE => e)
adamc@398 685
adamc@470 686 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
adamc@470 687 let
adamc@470 688 val e' = (ELet (x2, t2, e1,
adamc@470 689 (ELet (x1, t1, b1,
adamc@470 690 liftExpInExp 1 b2), loc)), loc)
adamc@442 691 in
adamc@470 692 (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
adamc@470 693 ("e'", MonoPrint.p_exp env e')];*)
adamc@470 694 #1 (reduceExp env e')
adamc@470 695 end
adamc@470 696 | EApp ((ELet (x, t, e, b), loc), e') =>
adamc@470 697 #1 (reduceExp env (ELet (x, t, e,
adamc@470 698 (EApp (b, liftExpInExp 0 e'), loc)), loc))
adamc@470 699
adamc@1017 700 | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
adamc@919 701 if impure env e' then
adamc@1017 702 doLet (x, t, e', b)
adamc@848 703 else
adamc@920 704 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
adamc@920 705 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
adamc@470 706
adamc@1017 707 | ELet (x, t, e', b) => doLet (x, t, e', b)
adamc@252 708
adamc@470 709 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
adamc@470 710 EPrim (Prim.String (s1 ^ s2))
adamc@268 711
adamc@572 712 | ESignalBind ((ESignalReturn e1, loc), e2) =>
adamc@572 713 #1 (reduceExp env (EApp (e2, e1), loc))
adamc@572 714
adamc@470 715 | _ => e
adamc@470 716 in
adamc@829 717 (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
adamc@829 718 ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
adamc@470 719 r
adamc@470 720 end
adamc@470 721
adamc@470 722 and bind (env, b) =
adamc@470 723 case b of
adamc@470 724 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
adamc@470 725 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
adamc@1017 726 | U.Decl.NamedE (x, n, t, eo, s) =>
adamc@1017 727 let
adamc@1017 728 val eo = case eo of
adamc@1017 729 NONE => NONE
adam@1393 730 | SOME e => if mayInline (n, e, t, s) then
adamc@1017 731 SOME e
adamc@1017 732 else
adamc@1017 733 NONE
adamc@1017 734 in
adamc@1017 735 E.pushENamed env x n t (Option.map (reduceExp env) eo) s
adamc@1017 736 end
adamc@470 737
adamc@470 738 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
adamc@470 739
adamc@801 740 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
adamc@801 741 d)
adamc@398 742 in
adamc@470 743 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
adamc@398 744 end
adamc@133 745
adamc@133 746 end