Mercurial > urweb

annotate src/rpcify.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 385a1b799a74
children e15234fbb163
rev   line source
adam@1677 1 (* Copyright (c) 2009, 2012, Adam Chlipala
adamc@607 2 * All rights reserved.
adamc@607 3 *
adamc@607 4 * Redistribution and use in source and binary forms, with or without
adamc@607 5 * modification, are permitted provided that the following conditions are met:
adamc@607 6 *
adamc@607 7 * - Redistributions of source code must retain the above copyright notice,
adamc@607 8 * this list of conditions and the following disclaimer.
adamc@607 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@607 10 * this list of conditions and the following disclaimer in the documentation
adamc@607 11 * and/or other materials provided with the distribution.
adamc@607 12 * - The names of contributors may not be used to endorse or promote products
adamc@607 13 * derived from this software without specific prior written permission.
adamc@607 14 *
adamc@607 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@607 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@607 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@607 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@607 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@607 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@607 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@607 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@607 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@607 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@607 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@607 26 *)
adamc@607 27
adamc@607 28 structure Rpcify :> RPCIFY = struct
adamc@607 29
adamc@607 30 open Core
adamc@607 31
adamc@607 32 structure U = CoreUtil
adamc@607 33 structure E = CoreEnv
adamc@607 34
adamc@607 35 structure IS = IntBinarySet
adamc@607 36 structure IM = IntBinaryMap
adamc@607 37
adamc@607 38 type state = {
adamc@608 39 exported : IS.set,
adamc@957 40 export_decls : decl list
adamc@607 41 }
adamc@607 42
adamc@607 43 fun frob file =
adamc@607 44 let
adamc@908 45 val rpcBaseIds = foldl (fn ((d, _), rpcIds) =>
adamc@908 46 case d of
adamc@908 47 DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n)
adamc@908 48 | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then
adamc@908 49 IS.add (rpcIds, n)
adamc@908 50 else
adamc@908 51 rpcIds
adamc@908 52 | _ => rpcIds)
adamc@908 53 IS.empty file
adamc@607 54
adamc@609 55 val tfuncs = foldl
adamc@609 56 (fn ((d, _), tfuncs) =>
adamc@609 57 let
adamc@642 58 fun doOne ((x, n, t, e, _), tfuncs) =
adamc@609 59 let
adamc@642 60 val loc = #2 e
adamc@642 61
adamc@642 62 fun crawl (t, e, args) =
adamc@642 63 case (#1 t, #1 e) of
adamc@642 64 (CApp (_, ran), _) =>
adamc@642 65 SOME (x, rev args, ran, e)
adamc@642 66 | (TFun (arg, rest), EAbs (x, _, _, e)) =>
adamc@642 67 crawl (rest, e, (x, arg) :: args)
adamc@642 68 | (TFun (arg, rest), _) =>
adamc@642 69 crawl (rest, (EApp (e, (ERel (length args), loc)), loc), ("x", arg) :: args)
adamc@609 70 | _ => NONE
adamc@609 71 in
adamc@642 72 case crawl (t, e, []) of
adamc@609 73 NONE => tfuncs
adamc@609 74 | SOME sg => IM.insert (tfuncs, n, sg)
adamc@609 75 end
adamc@609 76 in
adamc@609 77 case d of
adamc@609 78 DVal vi => doOne (vi, tfuncs)
adamc@609 79 | DValRec vis => foldl doOne tfuncs vis
adamc@609 80 | _ => tfuncs
adamc@609 81 end)
adamc@609 82 IM.empty file
adamc@609 83
adamc@607 84 fun exp (e, st) =
adamc@649 85 let
adamc@649 86 fun getApp (e', args) =
adamc@908 87 case e' of
adamc@908 88 ENamed n => SOME (n, args)
adamc@908 89 | EApp (e1, e2) => getApp (#1 e1, e2 :: args)
adamc@908 90 | _ => NONE
adamc@642 91
adamc@908 92 fun newRpc (trans : exp, st : state) =
adamc@908 93 case getApp (#1 trans, []) of
adamc@908 94 NONE => (ErrorMsg.errorAt (#2 trans)
adamc@908 95 "RPC code doesn't use a named function or transaction";
adam@1677 96 (*Print.preface ("Expression",
adam@1677 97 CorePrint.p_exp CoreEnv.empty trans);*)
adamc@908 98 (#1 trans, st))
adamc@908 99 | SOME (n, args) =>
adamc@908 100 case IM.find (tfuncs, n) of
adamc@908 101 NONE => ((*Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))];*)
adamc@908 102 raise Fail ("Rpcify: Undetected transaction function " ^ Int.toString n))
adamc@908 103 | SOME (_, _, ran, _) =>
adamc@908 104 let
adamc@908 105 val loc = #2 trans
adamc@642 106
adamc@908 107 val (exported, export_decls) =
adamc@908 108 if IS.member (#exported st, n) then
adamc@908 109 (#exported st, #export_decls st)
adamc@908 110 else
adamc@908 111 (IS.add (#exported st, n),
adamc@1104 112 (DExport (Rpc ReadWrite, n, false), loc) :: #export_decls st)
adamc@642 113
adamc@908 114 val st = {exported = exported,
adamc@957 115 export_decls = export_decls}
adamc@642 116
adamc@1020 117 val e' = EServerCall (n, args, ran)
adamc@651 118 in
adamc@908 119 (e', st)
adamc@651 120 end
adamc@649 121 in
adamc@649 122 case e of
adamc@908 123 EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st)
adamc@908 124 | EApp ((ECApp ((ENamed n, _), ran), _), trans) =>
adamc@908 125 if IS.member (rpcBaseIds, n) then
adamc@908 126 newRpc (trans, st)
adamc@908 127 else
adamc@908 128 (e, st)
adamc@642 129
adamc@649 130 | _ => (e, st)
adamc@649 131 end
adamc@607 132
adamc@642 133 and doExp (e, st) = U.Exp.foldMap {kind = fn x => x,
adamc@642 134 con = fn x => x,
adamc@642 135 exp = exp} st (ReduceLocal.reduceExp e)
adamc@642 136
adamc@607 137 fun decl (d, st : state) =
adamc@607 138 let
adamc@607 139 val (d, st) = U.Decl.foldMap {kind = fn x => x,
adamc@607 140 con = fn x => x,
adamc@607 141 exp = exp,
adamc@607 142 decl = fn x => x}
adamc@607 143 st d
adamc@607 144 in
adam@1695 145 (d :: #export_decls st,
adamc@908 146 {exported = #exported st,
adamc@957 147 export_decls = []})
adamc@607 148 end
adamc@607 149
adamc@607 150 val (file, _) = ListUtil.foldlMapConcat decl
adamc@908 151 {exported = IS.empty,
adamc@957 152 export_decls = []}
adamc@607 153 file
adamc@607 154 in
adamc@607 155 file
adamc@607 156 end
adamc@607 157
adamc@607 158 end