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