Mercurial > urweb

annotate src/tag.sml @ 2110:9e9c915f554c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
A new MonoReduce optimization for lifting 'let' out of field projection; JavaScript compilation for exponentiation
author Adam Chlipala <adam@chlipala.net>
date Sun, 01 Feb 2015 12:29:14 -0500
parents f1485ed65d6c
children
rev   line source
adamc@110 1 (* Copyright (c) 2008, Adam Chlipala
adamc@110 2 * All rights reserved.
adamc@110 3 *
adamc@110 4 * Redistribution and use in source and binary forms, with or without
adamc@110 5 * modification, are permitted provided that the following conditions are met:
adamc@110 6 *
adamc@110 7 * - Redistributions of source code must retain the above copyright notice,
adamc@110 8 * this list of conditions and the following disclaimer.
adamc@110 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@110 10 * this list of conditions and the following disclaimer in the documentation
adamc@110 11 * and/or other materials provided with the distribution.
adamc@110 12 * - The names of contributors may not be used to endorse or promote products
adamc@110 13 * derived from this software without specific prior written permission.
adamc@110 14 *
adamc@110 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@110 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@110 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@110 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@110 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@110 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@110 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@110 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@110 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@110 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@110 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@110 26 *)
adamc@110 27
adamc@110 28 structure Tag :> TAG = struct
adamc@110 29
adamc@110 30 open Core
adamc@110 31
adamc@110 32 structure U = CoreUtil
adamc@110 33 structure E = CoreEnv
adamc@110 34
adamc@110 35 structure IM = IntBinaryMap
adamc@112 36 structure SM = BinaryMapFn(struct
adamc@112 37 type ord_key = string
adamc@112 38 val compare = String.compare
adamc@112 39 end)
adamc@110 40
adamc@110 41 fun kind (k, s) = (k, s)
adamc@110 42 fun con (c, s) = (c, s)
adamc@110 43
adam@1946 44 fun both (loc, f) = (ErrorMsg.errorAt loc ("Function " ^ f ^ " needed for multiple modes (link, form, RPC handler).");
adamc@1046 45 TextIO.output (TextIO.stdErr,
adam@1946 46 "Make sure that the signature of the containing module hides any form/RPC handlers.\n"))
adamc@1046 47
adamc@112 48 fun exp env (e, s) =
adamc@1065 49 let
adamc@1065 50 fun tagIt (e, ek : export_kind, newAttr, (count, tags, byTag, newTags)) =
adamc@1065 51 let
adamc@1065 52 val loc = #2 e
adamc@1065 53
adamc@1065 54 val eOrig = e
adamc@1065 55
adamc@1065 56 fun unravel (e, _) =
adamc@1065 57 case e of
adamc@1065 58 ENamed n => (n, [])
adamc@1065 59 | EApp (e1, e2) =>
adamc@1065 60 let
adamc@1065 61 val (n, es) = unravel e1
adamc@1065 62 in
adamc@1065 63 (n, es @ [e2])
adamc@1065 64 end
adamc@1065 65 | _ => (ErrorMsg.errorAt loc ("Invalid " ^ newAttr
adamc@1065 66 ^ " expression");
adamc@1065 67 Print.epreface ("Expression",
adam@1628 68 CorePrint.p_exp env eOrig);
adamc@1065 69 (0, []))
adamc@1065 70
adamc@1065 71 val (f, args) = unravel e
adam@1628 72 in
adam@1628 73 if f = 0 then
adam@1628 74 (e, (count, tags, byTag, newTags))
adam@1628 75 else
adam@1628 76 let
adam@1628 77 val (cn, count, tags, newTags) =
adam@1628 78 case IM.find (tags, f) of
adam@1628 79 NONE =>
adam@1628 80 (count, count + 1, IM.insert (tags, f, count),
adam@1628 81 (ek, f, count) :: newTags)
adam@1628 82 | SOME cn => (cn, count, tags, newTags)
adam@1628 83
adam@1628 84 val (_, _, _, s) = E.lookupENamed env f
adamc@1065 85
adam@1628 86 val byTag = case SM.find (byTag, s) of
adam@1628 87 NONE => SM.insert (byTag, s, (ek, f))
adam@1628 88 | SOME (ek', f') =>
adam@1628 89 (if f = f' then
adam@1628 90 ()
adam@1628 91 else
adam@1628 92 ErrorMsg.errorAt loc
adam@1628 93 ("Duplicate HTTP tag "
adam@1628 94 ^ s);
adam@1628 95 if ek = ek' then
adam@1628 96 ()
adam@1628 97 else
adam@1628 98 both (loc, s);
adam@1628 99 byTag)
adamc@1065 100
adam@1628 101 val e = (EClosure (cn, args), loc)
adam@1628 102 in
adam@1628 103 (e, (count, tags, byTag, newTags))
adam@1628 104 end
adamc@1065 105 end
adamc@1065 106 in
adamc@1065 107 case e of
adamc@1065 108 EApp (
adamc@1065 109 (EApp (
adamc@1065 110 (EApp (
adamc@1065 111 (EApp (
adam@1646 112 (EApp (
adam@1754 113 (EApp (
adam@1754 114 (EApp (
adamc@721 115 (ECApp (
adamc@1065 116 (ECApp (
adamc@1065 117 (ECApp (
adamc@110 118 (ECApp (
adamc@110 119 (ECApp (
adam@1646 120 (ECApp (
adam@1754 121 (ECApp (
adam@1754 122 (ECApp (
adam@1754 123 (EFfi ("Basis", "tag"),
adam@1754 124 loc), given), _), absent), _), outer), _), inner), _),
adam@1754 125 useOuter), _), useInner), _), bindOuter), _), bindInner), _),
adam@1754 126 class), _),
adam@1754 127 dynClass), _),
adam@1754 128 style), _),
adam@1754 129 dynStyle), _),
adamc@1065 130 attrs), _),
adamc@1065 131 tag), _),
adamc@1065 132 xml) =>
adamc@1065 133 (case attrs of
adamc@1065 134 (ERecord xets, _) =>
adamc@1065 135 let
adamc@1065 136 val (xets, s) =
adamc@1065 137 ListUtil.foldlMap (fn ((x, e, t), s) =>
adamc@1065 138 let
adamc@1065 139 fun tagIt' (ek, newAttr) =
adamc@1065 140 let
adamc@1065 141 val (e', s) = tagIt (e, ek, newAttr, s)
adamc@1065 142 val t = (CFfi ("Basis", "string"), loc)
adamc@1065 143 in
adamc@1065 144 (((CName newAttr, loc), e', t), s)
adamc@1065 145 end
adamc@1065 146 in
adamc@1065 147 case x of
adam@1946 148 (CName "Link", _) => tagIt' (Link ReadCookieWrite, "Link")
adamc@1065 149 | (CName "Action", _) => tagIt' (Action ReadWrite, "Action")
adamc@1065 150 | _ => ((x, e, t), s)
adamc@1065 151 end)
adamc@1065 152 s xets
adamc@1065 153 in
adamc@1065 154 (EApp (
adamc@1065 155 (EApp (
adamc@1065 156 (EApp (
adamc@1065 157 (EApp (
adam@1646 158 (EApp (
adam@1754 159 (EApp (
adam@1754 160 (EApp (
adamc@721 161 (ECApp (
adamc@1065 162 (ECApp (
adamc@1065 163 (ECApp (
adamc@1065 164 (ECApp (
adamc@1065 165 (ECApp (
adam@1646 166 (ECApp (
adam@1754 167 (ECApp (
adam@1754 168 (ECApp (
adam@1754 169 (EFfi ("Basis", "tag"),
adam@1754 170 loc), given), loc), absent), loc), outer), loc), inner), loc),
adam@1754 171 useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc),
adam@1754 172 class), loc), dynClass), loc), style), loc), dynStyle), loc),
adamc@1065 173 (ERecord xets, loc)), loc),
adamc@1065 174 tag), loc),
adamc@1065 175 xml), s)
adamc@1065 176 end
adamc@1271 177 | _ => (e, s))
adamc@110 178
adam@1663 179 | EFfiApp ("Basis", "url", [((ERel 0, _), _)]) => (e, s)
adamc@1065 180
adam@1663 181 | EFfiApp ("Basis", "url", [(e, t)]) =>
adamc@1065 182 let
adam@1946 183 val (e, s) = tagIt (e, Link ReadCookieWrite, "Url", s)
adamc@1065 184 in
adam@1663 185 (EFfiApp ("Basis", "url", [(e, t)]), s)
adamc@1065 186 end
adamc@1065 187
adam@1663 188 | EFfiApp ("Basis", "effectfulUrl", [((ERel 0, _), _)]) => (e, s)
adam@1370 189
adam@1663 190 | EFfiApp ("Basis", "effectfulUrl", [(e, t)]) =>
adam@1370 191 let
adam@1370 192 val (e, s) = tagIt (e, Extern ReadCookieWrite, "Url", s)
adam@1370 193 in
adam@1663 194 (EFfiApp ("Basis", "url", [(e, t)]), s)
adam@1370 195 end
adam@1370 196
adamc@1065 197 | EApp ((ENamed n, _), e') =>
adamc@1065 198 let
adamc@1065 199 val (_, _, eo, _) = E.lookupENamed env n
adamc@1065 200 in
adamc@1065 201 case eo of
adam@1663 202 SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) =>
adamc@1065 203 let
adam@1946 204 val (e, s) = tagIt (e', Link ReadCookieWrite, "Url", s)
adamc@1065 205 in
adam@1663 206 (EFfiApp ("Basis", "url", [(e, t)]), s)
adamc@1065 207 end
adamc@1065 208 | _ => (e, s)
adamc@1065 209 end
adamc@1065 210
adamc@1065 211 | _ => (e, s)
adamc@1065 212 end
adamc@110 213
adamc@110 214 fun decl (d, s) = (d, s)
adamc@110 215
adamc@110 216 fun tag file =
adamc@110 217 let
adamc@179 218 val count = U.File.maxName file
adamc@110 219
adamc@112 220 fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
adamc@112 221 case d' of
adamc@1104 222 DExport (ek, n, _) =>
adamc@112 223 let
adamc@112 224 val (_, _, _, s) = E.lookupENamed env n
adamc@112 225 in
adamc@112 226 case SM.find (byTag, s) of
adamc@112 227 NONE => ([d], (env, count, tags, byTag))
adamc@144 228 | SOME (ek', n') =>
adamc@144 229 (if ek = ek' then
adamc@144 230 ()
adamc@144 231 else
adamc@1046 232 both (loc, s);
adamc@144 233 ([], (env, count, tags, byTag)))
adamc@112 234 end
adamc@112 235 | _ =>
adamc@112 236 let
adamc@126 237 val env' = E.declBinds env d
adamc@126 238 val env'' = case d' of
adamc@126 239 DValRec _ => env'
adamc@126 240 | _ => env
adamc@126 241
adamc@112 242 val (d, (count, tags, byTag, newTags)) =
adamc@112 243 U.Decl.foldMap {kind = kind,
adamc@112 244 con = con,
adamc@126 245 exp = exp env'',
adamc@112 246 decl = decl}
adamc@112 247 (count, tags, byTag, []) d
adamc@110 248
adamc@126 249 val env = env'
adamc@110 250
adamc@126 251 val newDs = map
adamc@144 252 (fn (ek, f, cn) =>
adamc@112 253 let
adamc@492 254 val unit = (TRecord (CRecord ((KType, loc), []), loc), loc)
adamc@492 255
adamc@112 256 fun unravel (all as (t, _)) =
adamc@112 257 case t of
adamc@112 258 TFun (dom, ran) =>
adamc@112 259 let
adamc@112 260 val (args, result) = unravel ran
adamc@112 261 in
adamc@112 262 (dom :: args, result)
adamc@112 263 end
adamc@112 264 | _ => ([], all)
adamc@110 265
adamc@112 266 val (fnam, t, _, tag) = E.lookupENamed env f
adamc@112 267 val (args, result) = unravel t
adamc@110 268
adamc@119 269 val (abs, t) =
adamc@119 270 case args of
adamc@119 271 [] =>
adamc@119 272 let
adamc@492 273 val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc)
adamc@492 274 val body = (EWrite app, loc)
adamc@119 275 in
adamc@492 276 (body,
adamc@119 277 (TFun (unit, unit), loc))
adamc@119 278 end
adamc@119 279 | _ =>
adamc@119 280 let
adamc@119 281 val (app, _) = foldl (fn (t, (app, n)) =>
adamc@119 282 ((EApp (app, (ERel n, loc)), loc),
adamc@119 283 n - 1))
adamc@119 284 ((ENamed f, loc), length args - 1) args
adamc@280 285 val app = (EApp (app, (ERecord [], loc)), loc)
adamc@119 286 val body = (EWrite app, loc)
adamc@280 287 val t = (TFun (unit, unit), loc)
adamc@119 288 val (abs, _, t) = foldr (fn (t, (abs, n, rest)) =>
adamc@119 289 ((EAbs ("x" ^ Int.toString n,
adamc@119 290 t,
adamc@119 291 rest,
adamc@119 292 abs), loc),
adamc@119 293 n + 1,
adamc@119 294 (TFun (t, rest), loc)))
adamc@280 295 (body, 0, t) args
adamc@119 296 in
adamc@119 297 (abs, t)
adamc@119 298 end
adamc@112 299 in
adamc@126 300 (("wrap_" ^ fnam, cn, t, abs, tag),
adamc@1104 301 (DExport (ek, cn, false), loc))
adamc@112 302 end) newTags
adamc@126 303
adamc@126 304 val (newVals, newExports) = ListPair.unzip newDs
adamc@126 305
adamc@126 306 val ds = case d of
adamc@126 307 (DValRec vis, _) => [(DValRec (vis @ newVals), loc)]
adamc@126 308 | _ => map (fn vi => (DVal vi, loc)) newVals @ [d]
adamc@112 309 in
adamc@126 310 (ds @ newExports, (env, count, tags, byTag))
adamc@112 311 end
adamc@110 312
adamc@112 313 val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty, SM.empty) file
adamc@110 314 in
adamc@110 315 file
adamc@110 316 end
adamc@110 317
adamc@110 318 end