Mercurial > urweb
view src/mono_reduce.sml @ 1739:c414850f206f
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 |
line wrap: on
line source
(* Copyright (c) 2008, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without * modification, are permitted provided that the following conditions are met: * * - Redistributions of source code must retain the above copyright notice, * this list of conditions and the following disclaimer. * - Redistributions in binary form must reproduce the above copyright notice, * this list of conditions and the following disclaimer in the documentation * and/or other materials provided with the distribution. * - The names of contributors may not be used to endorse or promote products * derived from this software without specific prior written permission. * * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE * POSSIBILITY OF SUCH DAMAGE. *) (* Simplify a Mono program algebraically *) structure MonoReduce :> MONO_REDUCE = struct open Mono structure E = MonoEnv structure U = MonoUtil structure IM = IntBinaryMap structure IS = IntBinarySet fun simpleTypeImpure tsyms = U.Typ.exists (fn TFun _ => true | TDatatype (n, _) => IS.member (tsyms, n) | _ => false) fun simpleImpure (tsyms, syms) = U.Exp.existsB {typ = fn _ => false, exp = fn (env, e) => case e of EWrite _ => true | EQuery _ => true | EDml _ => true | ENextval _ => true | ESetval _ => true | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) | EServerCall _ => true | ERecv _ => true | ESleep _ => true | ENamed n => IS.member (syms, n) | ERel n => let val (_, t, _) = E.lookupERel env n in simpleTypeImpure tsyms t end | _ => false, bind = fn (env, b) => case b of U.Exp.RelE (x, t) => E.pushERel env x t NONE | _ => env} fun impure (e, _) = case e of EWrite _ => true | EQuery _ => true | EDml _ => true | ENextval _ => true | ESetval _ => true | EUnurlify (e, _, _) => impure e | EAbs _ => false | EPrim _ => false | ERel _ => false | ENamed _ => false | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e) | ENone _ => false | ESome (_, e) => impure e | EFfi _ => false | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) | EApp ((EFfi _, _), _) => false | EApp _ => true | EUnop (_, e) => impure e | EBinop (_, _, e1, e2) => impure e1 orelse impure e2 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes | EField (e, _) => impure e | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes | EError _ => true | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2 | ERedirect (e, _) => impure e | EStrcat (e1, e2) => impure e1 orelse impure e2 | ESeq (e1, e2) => impure e1 orelse impure e2 | ELet (_, _, e1, e2) => impure e1 orelse impure e2 | EClosure (_, es) => List.exists impure es | EJavaScript (_, e) => impure e | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e | EServerCall _ => true | ERecv _ => true | ESleep _ => true | ESpawn _ => true val liftExpInExp = Monoize.liftExpInExp fun multiLift n e = case n of 0 => e | _ => multiLift (n - 1) (liftExpInExp 0 e) val subExpInExp' = U.Exp.mapB {typ = fn t => t, exp = fn (xn, rep) => fn e => case e of ERel xn' => (case Int.compare (xn', xn) of EQUAL => #1 rep | GREATER=> ERel (xn' - 1) | LESS => e) | _ => e, bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) | (ctx, _) => ctx} fun subExpInExp (n, e1) e2 = let val r = subExpInExp' (n, e1) e2 in (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1), ("e2", MonoPrint.p_exp MonoEnv.empty e2), ("r", MonoPrint.p_exp MonoEnv.empty r)];*) r end fun typ c = c val swapExpVars = U.Exp.mapB {typ = fn t => t, exp = fn lower => fn e => case e of ERel xn => if xn = lower then ERel (lower + 1) else if xn = lower + 1 then ERel lower else e | _ => e, bind = fn (lower, U.Exp.RelE _) => lower+1 | (lower, _) => lower} val swapExpVarsPat = U.Exp.mapB {typ = fn t => t, exp = fn (lower, len) => fn e => case e of ERel xn => if xn = lower then ERel (lower + len) else if xn >= lower + 1 andalso xn < lower + 1 + len then ERel (xn - 1) else e | _ => e, bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len) | (st, _) => st} datatype result = Yes of exp list | No | Maybe fun match (env, p : pat, e : exp) = case (#1 p, #1 e) of (PWild, _) => Yes env | (PVar (x, t), _) => Yes (e :: env) | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => if String.isPrefix s' s then Maybe else No | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) => if String.isSuffix s' s then Maybe else No | (PPrim p, EPrim p') => if Prim.equal (p, p') then Yes env else No | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) => if n1 = n2 then case (po, eo) of (NONE, NONE) => Yes env | (SOME p, SOME e) => match (env, p, e) | _ => Maybe else No | (PCon (_, PConFfi {mod = m1, con = con1, ...}, NONE), ECon (_, PConFfi {mod = m2, con = con2, ...}, NONE)) => if m1 = m2 andalso con1 = con2 then Yes env else No | (PCon (_, PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (_, PConFfi {mod = m2, con = con2, ...}, SOME e)) => if m1 = m2 andalso con1 = con2 then match (env, p, e) else No | (PRecord xps, ERecord xes) => let fun consider (xps, env) = case xps of [] => Yes env | (x, p, _) :: rest => case List.find (fn (x', _, _) => x' = x) xes of NONE => No | SOME (_, e, _) => case match (env, p, e) of No => No | Maybe => Maybe | Yes env => consider (rest, env) in consider (xps, env) end | (PNone _, ENone _) => Yes env | (PNone _, ESome _) => No | (PSome (_, p), ESome (_, e)) => match (env, p, e) | (PSome _, ENone _) => No | _ => Maybe datatype event = WritePage | ReadDb | WriteDb | ReadCookie | WriteCookie | UseRel | Unsure | Abort fun p_event e = let open Print.PD in case e of WritePage => string "WritePage" | ReadDb => string "ReadDb" | WriteDb => string "WriteDb" | ReadCookie => string "ReadCookie" | WriteCookie => string "WriteCookie" | UseRel => string "UseRel" | Unsure => string "Unsure" | Abort => string "Abort" end val p_events = Print.p_list p_event fun patBinds (p, _) = case p of PWild => 0 | PVar _ => 1 | PPrim _ => 0 | PCon (_, _, NONE) => 0 | PCon (_, _, SOME p) => patBinds p | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts | PNone _ => 0 | PSome (_, p) => patBinds p val countFree = U.Exp.foldB {typ = fn (_, n) => n, exp = fn (x, e, n) => case e of ERel x' => if x = x' then n + 1 else n | _ => n, bind = fn (n, b) => case b of U.Exp.RelE _ => n + 1 | _ => n} val freeInAbs = U.Exp.existsB {typ = fn _ => false, exp = fn (n, e) => case e of EAbs (_, _, _, b) => countFree n 0 b > 0 | EJavaScript (_, b) => countFree n 0 b > 0 | _ => false, bind = fn (n, b) => case b of U.Exp.RelE _ => n + 1 | _ => n} 0 fun reduce file = let val (timpures, impures, absCounts) = foldl (fn ((d, _), (timpures, impures, absCounts)) => let fun countAbs (e, _) = case e of EAbs (_, _, _, e) => 1 + countAbs e | _ => 0 in case d of DDatatype dts => (if List.exists (fn (_, _, cs) => List.exists (fn (_, _, NONE) => false | (_, _, SOME t) => simpleTypeImpure timpures t) cs) dts then IS.addList (timpures, map #2 dts) else timpures, impures, absCounts) | DVal (_, n, _, e, _) => (timpures, if simpleImpure (timpures, impures) E.empty e then IS.add (impures, n) else impures, IM.insert (absCounts, n, countAbs e)) | DValRec vis => (timpures, if List.exists (fn (_, _, _, e, _) => simpleImpure (timpures, impures) E.empty e) vis then foldl (fn ((_, n, _, _, _), impures) => IS.add (impures, n)) impures vis else impures, foldl (fn ((x, n, _, e, _), absCounts) => IM.insert (absCounts, n, countAbs e)) absCounts vis) | _ => (timpures, impures, absCounts) end) (IS.empty, IS.empty, IM.empty) file val uses = U.File.fold {typ = fn (_, m) => m, exp = fn (e, m) => case e of ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0)) | _ => m, decl = fn (_, m) => m} IM.empty file val size = U.Exp.fold {typ = fn (_, n) => n, exp = fn (_, n) => n + 1} 0 val functionInside' = U.Typ.exists (fn c => case c of TFun _ => true | _ => false) fun functionInside t = case #1 t of TFun (t1, t2) => functionInside' t1 orelse functionInside t2 | _ => functionInside' t fun mayInline (n, e, t, s) = case IM.find (uses, n) of NONE => false | SOME count => count <= 1 orelse size e <= Settings.getMonoInline () orelse functionInside t orelse Settings.checkAlwaysInline s fun summarize d (e, _) = let val s = case e of EPrim _ => [] | ERel n => if n = d then [UseRel] else [] | ENamed _ => [] | ECon (_, _, NONE) => [] | ECon (_, _, SOME e) => summarize d e | ENone _ => [] | ESome (_, e) => summarize d e | EFfi _ => [] | EFfiApp ("Basis", "get_cookie", [(e, _)]) => summarize d e @ [ReadCookie] | EFfiApp ("Basis", "set_cookie", es) => List.concat (map (summarize d o #1) es) @ [WriteCookie] | EFfiApp ("Basis", "clear_cookie", es) => List.concat (map (summarize d o #1) es) @ [WriteCookie] | EFfiApp (m, x, es) => if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then WritePage else Unsure] else List.concat (map (summarize d o #1) es) | EApp ((EFfi _, _), e) => summarize d e | EApp _ => let fun unravel (e, passed, ls) = case e of ENamed n => let val ls = rev ls in if IS.member (impures, n) then case IM.find (absCounts, n) of NONE => [Unsure] | SOME len => if passed < len then ls else ls @ [Unsure] else ls end | ERel n => List.revAppend (ls, if n = d then [UseRel, Unsure] else [Unsure]) | EApp (f, x) => unravel (#1 f, passed + 1, List.revAppend (summarize d x, ls)) | EError _ => [Abort] | _ => [Unsure] in unravel (e, 0, []) end | EAbs _ => [] | EUnop (_, e) => summarize d e | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2 | ERecord xets => List.concat (map (summarize d o #2) xets) | EField (e, _) => summarize d e | ECase (e, pes, _) => let val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes fun splitRel ls acc = case ls of [] => (acc, false, ls) | UseRel :: ls => (acc, true, ls) | v :: ls => splitRel ls (v :: acc) val (pre, used, post) = foldl (fn (ls, (pre, used, post)) => let val (pre', used', post') = splitRel ls [] in (pre' @ pre, used' orelse used, post' @ post) end) ([], false, []) lss in summarize d e @ pre @ (if used then [UseRel] else []) @ post end | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 | EError (e, _) => summarize d e @ [Abort] | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort] | ERedirect (e, _) => summarize d e @ [Abort] | EWrite e => summarize d e @ [WritePage] | ESeq (e1, e2) => summarize d e1 @ summarize d e2 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2 | EClosure (_, es) => List.concat (map (summarize d) es) | EQuery {query, body, initial, ...} => List.concat [summarize d query, summarize d initial, [ReadDb], summarize (d + 2) body] | EDml (e, _) => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb] | EUnurlify (e, _, _) => summarize d e | EJavaScript (_, e) => summarize d e | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e | EServerCall (e, _, _) => summarize d e @ [Unsure] | ERecv (e, _) => summarize d e @ [Unsure] | ESleep e => summarize d e @ [Unsure] | ESpawn e => summarize d e @ [Unsure] in (*Print.prefaces "Summarize" [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), ("d", Print.PD.string (Int.toString d)), ("s", p_events s)];*) s end val impure = fn env => fn e => simpleImpure (timpures, impures) env e andalso impure e andalso not (List.null (summarize ~1 e)) fun exp env e = let (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) fun doLet (x, t, e', b) = let fun doSub () = let val r = subExpInExp (0, e') b in (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), ("r", MonoPrint.p_exp env r)];*) #1 (reduceExp env r) end fun trySub () = ((*Print.prefaces "trySub" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*) case t of (TFfi ("Basis", "string"), _) => doSub () | (TSignal _, _) => e | _ => case e' of (ECase _, _) => e | _ => doSub ()) in if impure env e' then let val effs_e' = summarize 0 e' val effs_e' = List.filter (fn x => x <> UseRel) effs_e' val effs_b = summarize 0 b (*val () = Print.fprefaces outf "Try" [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*) ("e'", MonoPrint.p_exp env e'), ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), ("e'_eff", p_events effs_e'), ("b_eff", p_events effs_b)]*) fun does eff = List.exists (fn eff' => eff' = eff) effs_e' val writesPage = does WritePage val readsDb = does ReadDb val writesDb = does WriteDb val readsCookie = does ReadCookie val writesCookie = does ReadCookie fun verifyUnused eff = case eff of UseRel => false | _ => true fun verifyCompatible effs = case effs of [] => false | eff :: effs => case eff of Unsure => false | UseRel => List.all verifyUnused effs | WritePage => not writesPage andalso verifyCompatible effs | ReadDb => not writesDb andalso verifyCompatible effs | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs | ReadCookie => not writesCookie andalso verifyCompatible effs | WriteCookie => not writesCookie andalso not readsCookie andalso verifyCompatible effs | Abort => true in (*Print.prefaces "verifyCompatible" [("e'", MonoPrint.p_exp env e'), ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), ("effs_e'", Print.p_list p_event effs_e'), ("effs_b", Print.p_list p_event effs_b)];*) if (List.null effs_e' orelse (List.all (fn eff => eff <> Unsure) effs_e' andalso verifyCompatible effs_b) orelse (case effs_b of UseRel :: effs => List.all verifyUnused effs | _ => false)) andalso countFree 0 0 b = 1 andalso not (freeInAbs b) then trySub () else e end else trySub () end val r = case e of ERel n => (case E.lookupERel env n of (_, _, SOME e') => #1 e' | _ => e) | ENamed n => (case E.lookupENamed env n of (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)), ("e'", MonoPrint.p_exp env e')];*) #1 e') | _ => e) | EApp ((EAbs (x, t, _, e1), loc), e2) => ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), ("e2", MonoPrint.p_exp env e2), ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) if impure env e2 orelse countFree 0 0 e1 > 1 then #1 (reduceExp env (ELet (x, t, e2, e1), loc)) else #1 (reduceExp env (subExpInExp (0, e2) e1))) | ECase (e', pes, {disc, result}) => let fun push () = case result of (TFun (dom, result), loc) => let fun safe (e, _) = case e of EAbs _ => true | EError _ => true | _ => false in if List.all (safe o #2) pes then EAbs ("y", dom, result, (ECase (liftExpInExp 0 e', map (fn (p, (EAbs (_, _, _, e), _)) => (p, swapExpVarsPat (0, patBinds p) e) | (p, (EError (e, (TFun (_, t), _)), loc)) => (p, (EError (e, t), loc)) | _ => raise Fail "MonoReduce ECase") pes, {disc = disc, result = result}), loc)) else e end | _ => e fun search pes = case pes of [] => push () | (p, body) :: pes => case match ([], p, e') of No => search pes | Maybe => push () | Yes subs => let val (body, remaining) = foldl (fn (e, (body, remaining)) => (subExpInExp (0, multiLift remaining e) body, remaining - 1)) (body, length subs - 1) subs val r = reduceExp (E.patBinds env p) body in (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*) (*Print.prefaces "ECase" [("old", MonoPrint.p_exp env body), ("body", MonoPrint.p_exp env body), ("r", MonoPrint.p_exp env r)];*) #1 r end in if impure env e' then e else search pes end | EField ((ERecord xes, _), x) => (case List.find (fn (x', _, _) => x' = x) xes of SOME (_, e, _) => #1 e | NONE => e) | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => let val e' = (ELet (x2, t2, e1, (ELet (x1, t1, b1, liftExpInExp 1 b2), loc)), loc) in (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)), ("e'", MonoPrint.p_exp env e')];*) #1 (reduceExp env e') end | EApp ((ELet (x, t, e, b), loc), e') => #1 (reduceExp env (ELet (x, t, e, (EApp (b, liftExpInExp 0 e'), loc)), loc)) | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => if impure env e' then doLet (x, t, e', b) else EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE) (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) | ELet (x, t, e', b) => doLet (x, t, e', b) | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => EPrim (Prim.String (s1 ^ s2)) | ESignalBind ((ESignalReturn e1, loc), e2) => #1 (reduceExp env (EApp (e2, e1), loc)) | _ => e in (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) r end and bind (env, b) = case b of U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs | U.Decl.RelE (x, t) => E.pushERel env x t NONE | U.Decl.NamedE (x, n, t, eo, s) => let val eo = case eo of NONE => NONE | SOME e => if mayInline (n, e, t, s) then SOME e else NONE in E.pushENamed env x n t (Option.map (reduceExp env) eo) s end and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*) d) in U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file end end