adamc@732: (* Copyright (c) 2009, Adam Chlipala adamc@732: * All rights reserved. adamc@732: * adamc@732: * Redistribution and use in source and binary forms, with or without adamc@732: * modification, are permitted provided that the following conditions are met: adamc@732: * adamc@732: * - Redistributions of source code must retain the above copyright notice, adamc@732: * this list of conditions and the following disclaimer. adamc@732: * - Redistributions in binary form must reproduce the above copyright notice, adamc@732: * this list of conditions and the following disclaimer in the documentation adamc@732: * and/or other materials provided with the distribution. adamc@732: * - The names of contributors may not be used to endorse or promote products adamc@732: * derived from this software without specific prior written permission. adamc@732: * adamc@732: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@732: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@732: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@732: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@732: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@732: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@732: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@732: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@732: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@732: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@732: * POSSIBILITY OF SUCH DAMAGE. adamc@732: *) adamc@732: adamc@732: structure Effective :> EFFECTIZE = struct adamc@732: adamc@732: open Core adamc@732: adamc@732: structure U = CoreUtil adamc@732: adamc@732: structure IM = IntBinaryMap adamc@732: structure SS = BinarySetFn(struct adamc@732: type ord_key = string adamc@732: val compare = String.compare adamc@732: end) adamc@732: adamc@765: fun effectful x = Settings.isEffectful x andalso not (Settings.isClientOnly x) adamc@732: adamc@732: fun effectize file = adamc@732: let adamc@782: fun expOnload evs e = adamc@782: case e of adamc@782: EFfi f => effectful f adamc@782: | EFfiApp (m, x, _) => effectful (m, x) adamc@782: | ENamed n => IM.inDomain (evs, n) adamc@1020: | EServerCall (n, _, _) => IM.inDomain (evs, n) adamc@782: | _ => false adamc@782: adamc@782: fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false, adamc@782: con = fn _ => false, adamc@782: exp = expOnload evs} adamc@782: adamc@732: fun exp evs e = adamc@732: case e of adamc@765: EFfi f => effectful f adamc@765: | EFfiApp (m, x, _) => effectful (m, x) adamc@732: | ENamed n => IM.inDomain (evs, n) adamc@782: | ERecord xets => List.exists (fn ((CName "Onload", _), e, _) => couldWriteOnload evs e adamc@782: | _ => false) xets adamc@732: | _ => false adamc@732: adamc@732: fun couldWrite evs = U.Exp.exists {kind = fn _ => false, adamc@732: con = fn _ => false, adamc@732: exp = exp evs} adamc@732: adamc@735: fun exp evs e = adamc@735: case e of adamc@735: EFfi ("Basis", "getCookie") => true adamc@735: | ENamed n => IM.inDomain (evs, n) adamc@1020: | EServerCall (n, _, _) => IM.inDomain (evs, n) adamc@735: | _ => false adamc@735: adamc@735: fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false, adamc@735: con = fn _ => false, adamc@735: exp = exp evs} adamc@735: adamc@735: fun doDecl (d, evs as (writers, readers)) = adamc@732: case #1 d of adamc@732: DVal (x, n, t, e, s) => adamc@735: (d, (if couldWrite writers e then adamc@735: IM.insert (writers, n, (#2 d, s)) adamc@735: else adamc@735: writers, adamc@735: if couldReadCookie readers e then adamc@735: IM.insert (readers, n, (#2 d, s)) adamc@735: else adamc@735: readers)) adamc@732: | DValRec vis => adamc@732: let adamc@732: fun oneRound evs = adamc@735: foldl (fn ((_, n, _, e, s), (changed, (writers, readers))) => adamc@735: let adamc@735: val (changed, writers) = adamc@735: if couldWrite writers e andalso not (IM.inDomain (writers, n)) then adamc@735: (true, IM.insert (writers, n, (#2 d, s))) adamc@735: else adamc@735: (changed, writers) adamc@735: adamc@735: val (changed, readers) = adamc@735: if couldReadCookie readers e andalso not (IM.inDomain (readers, n)) then adamc@735: (true, IM.insert (readers, n, (#2 d, s))) adamc@735: else adamc@735: (changed, readers) adamc@735: in adamc@735: (changed, (writers, readers)) adamc@735: end) (false, evs) vis adamc@732: adamc@732: fun loop evs = adamc@732: let adamc@732: val (b, evs) = oneRound evs adamc@732: in adamc@732: if b then adamc@732: loop evs adamc@732: else adamc@732: evs adamc@732: end adamc@732: in adamc@735: (d, loop (writers, readers)) adamc@732: end adamc@732: | DExport (Link, n) => adamc@735: (case IM.find (writers, n) of adamc@732: NONE => () adamc@732: | SOME (loc, s) => ErrorMsg.errorAt loc ("A link (" ^ s ^ ") could cause side effects; try implementing it with a form instead"); adamc@732: (d, evs)) adamc@732: | DExport (Action _, n) => adamc@735: ((DExport (Action (if IM.inDomain (writers, n) then adamc@735: if IM.inDomain (readers, n) then adamc@735: ReadCookieWrite adamc@735: else adamc@735: ReadWrite adamc@732: else adamc@732: ReadOnly), n), #2 d), adamc@732: evs) adamc@732: | DExport (Rpc _, n) => adamc@735: ((DExport (Rpc (if IM.inDomain (writers, n) then adamc@735: if IM.inDomain (readers, n) then adamc@735: ReadCookieWrite adamc@735: else adamc@735: ReadWrite adamc@732: else adamc@732: ReadOnly), n), #2 d), adamc@732: evs) adamc@732: | _ => (d, evs) adamc@732: adamc@735: val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file adamc@732: in adamc@732: file adamc@732: end adamc@732: adamc@732: end