Mercurial > urweb

annotate src/name_js.sml @ 2258:b1ba35ce2613

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bug where pure caching didn't treat FFI applications as effectful.
author Ziv Scully <ziv@mit.edu>
date Sun, 27 Sep 2015 17:02:14 -0400
parents e843a04499d4
children
rev   line source
adam@1847 1 (* Copyright (c) 2012-2013, Adam Chlipala
adam@1800 2 * All rights reserved.
adam@1800 3 *
adam@1800 4 * Redistribution and use in source and binary forms, with or without
adam@1800 5 * modification, are permitted provided that the following conditions are met:
adam@1800 6 *
adam@1800 7 * - Redistributions of source code must retain the above copyright notice,
adam@1800 8 * this list of conditions and the following disclaimer.
adam@1800 9 * - Redistributions in binary form must reproduce the above copyright notice,
adam@1800 10 * this list of conditions and the following disclaimer in the documentation
adam@1800 11 * and/or other materials provided with the distribution.
adam@1800 12 * - The names of contributors may not be used to endorse or promote products
adam@1800 13 * derived from this software without specific prior written permission.
adam@1800 14 *
adam@1800 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adam@1800 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adam@1800 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adam@1800 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
ziv@2252 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adam@1800 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adam@1800 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adam@1800 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adam@1800 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adam@1800 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adam@1800 25 * POSSIBILITY OF SUCH DAMAGE.
adam@1800 26 *)
adam@1800 27
adam@1800 28 (* Phase that introduces names for fragments of JavaScript code, so that they
adam@1800 29 * may be moved to app.js and not repeated in each generated page *)
adam@1800 30
adam@1800 31 structure NameJS :> NAME_JS = struct
adam@1800 32
adam@1800 33 open Mono
adam@1800 34
adam@1800 35 structure U = MonoUtil
adam@1800 36 structure IS = IntBinarySet
adam@1800 37
adam@1800 38 val freeVars = U.Exp.foldB {typ = #2,
adam@1800 39 exp = fn (free, e, vs) =>
adam@1800 40 case e of
adam@1800 41 ERel n =>
adam@1800 42 if n < free then
adam@1800 43 vs
adam@1800 44 else
adam@1800 45 IS.add (vs, n - free)
adam@1800 46 | _ => vs,
adam@1800 47 bind = fn (free, b) =>
adam@1800 48 case b of
adam@1800 49 U.Exp.RelE _ => free+1
adam@1800 50 | _ => free}
adam@1800 51 0 IS.empty
adam@1800 52
adam@1800 53 fun index (ls, v) =
adam@1800 54 case ls of
adam@1800 55 [] => raise Fail "NameJs.index"
adam@1800 56 | v' :: ls' => if v = v' then 0 else 1 + index (ls', v)
adam@1800 57
adam@1800 58 fun squish vs = U.Exp.mapB {typ = fn x => x,
adam@1800 59 exp = fn free => fn e =>
adam@1800 60 case e of
adam@1800 61 ERel n =>
adam@1800 62 if n < free then
adam@1800 63 e
adam@1800 64 else
adam@1800 65 ERel (free + index (vs, n - free) + 1)
adam@1800 66 | _ => e,
adam@1800 67 bind = fn (free, b) =>
adam@1800 68 case b of
adam@1800 69 U.Exp.RelE _ => free+1
adam@1800 70 | _ => free}
adam@1800 71 0
adam@1800 72
adam@1800 73 fun rewrite file =
adam@1800 74 let
adam@1847 75 fun isTricky' dontName e =
adam@1847 76 case e of
adam@1847 77 ENamed n => IS.member (dontName, n)
adam@1847 78 | EFfiApp ("Basis", "sigString", _) => true
adam@1847 79 | _ => false
adam@1847 80
adam@1847 81 fun isTricky dontName = U.Decl.exists {typ = fn _ => false,
adam@1847 82 exp = isTricky' dontName,
adam@1847 83 decl = fn _ => false}
adam@1847 84
adam@1847 85 fun isTrickyE dontName = U.Exp.exists {typ = fn _ => false,
adam@1847 86 exp = isTricky' dontName}
adam@1847 87
adam@1847 88 val dontName = foldl (fn (d, dontName) =>
adam@1847 89 if isTricky dontName d then
adam@1847 90 case #1 d of
adam@1847 91 DVal (_, n, _, _, _) => IS.add (dontName, n)
adam@1847 92 | DValRec vis => foldl (fn ((_, n, _, _, _), dontName) => IS.add (dontName, n)) dontName vis
adam@1847 93 | _ => dontName
adam@1847 94 else
ziv@2252 95 dontName) IS.empty (#1 file)
adam@1847 96
adam@1845 97 val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) =>
adam@1800 98 let
adam@1800 99 val (d, (nextName, newDs)) =
adam@1800 100 U.Decl.foldMapB {typ = fn x => x,
adam@1800 101 decl = fn (_, e, s) => (e, s),
adam@1800 102 exp = fn (env, e, st as (nextName, newDs)) =>
adam@1800 103 case e of
adam@1800 104 EJavaScript (mode, e') =>
adam@1800 105 (case mode of
adam@1800 106 Source _ => (e, st)
adam@1800 107 | _ =>
adam@1800 108 let
adam@1800 109 fun isTrulySimple (e, _) =
adam@1800 110 case e of
adam@1800 111 ERel _ => true
adam@1800 112 | ENamed _ => true
adam@1800 113 | ERecord [] => true
adam@1800 114 | _ => false
adam@1800 115
adam@1800 116 fun isAlreadySimple e =
adam@1800 117 case #1 e of
adam@1800 118 EApp (e, arg) => isTrulySimple arg andalso isAlreadySimple e
adam@1800 119 | _ => isTrulySimple e
adam@1800 120 in
adam@1847 121 if isAlreadySimple e' orelse isTrickyE dontName e' then
adam@1800 122 (e, st)
adam@1800 123 else
adam@1800 124 let
adam@1800 125 val loc = #2 e'
adam@1800 126
adam@1800 127 val vs = freeVars e'
adam@1800 128 val vs = IS.listItems vs
ziv@2252 129
adam@1800 130 val x = "script" ^ Int.toString nextName
ziv@2252 131
adam@1800 132 val un = (TRecord [], loc)
adam@1800 133 val s = (TFfi ("Basis", "string"), loc)
adam@1800 134 val base = (TFun (un, s), loc)
adam@1800 135 val t = foldl (fn (n, t) => (TFun (#2 (List.nth (env, n)), t), loc)) base vs
adam@1800 136 val e' = squish vs e'
adam@1800 137 val e' = (EAbs ("_", un, s, e'), loc)
adam@1800 138 val (e', _) = foldl (fn (n, (e', t)) =>
adam@1800 139 let
adam@1800 140 val (x, this) = List.nth (env, n)
adam@1800 141 in
adam@1800 142 ((EAbs (x, this, t, e'), loc),
adam@1800 143 (TFun (this, t), loc))
adam@1800 144 end) (e', base) vs
adam@1800 145 val d = (x, nextName, t, e', "<script>")
adam@1800 146
adam@1800 147 val e = (ENamed nextName, loc)
adam@1800 148 val e = foldr (fn (n, e) => (EApp (e, (ERel n, loc)), loc)) e vs
adam@1800 149 val e = (EApp (e, (ERecord [], loc)), loc)
adam@1800 150 val e = EJavaScript (Script, e)
adam@1800 151 in
adam@1800 152 (e, (nextName+1, d :: newDs))
adam@1800 153 end
adam@1800 154 end)
adam@1800 155 | _ => (e, st),
adam@1800 156 bind = fn (env, b) =>
adam@1800 157 case b of
adam@1800 158 U.Decl.RelE x => x :: env
adam@1800 159 | _ => env}
adam@1800 160 [] (nextName, []) d
adam@1800 161 in
adam@1800 162 (case newDs of
adam@1800 163 [] => [d]
adam@1800 164 | _ => case #1 d of
adam@1800 165 DValRec vis => [(DValRec (vis @ newDs), #2 d)]
adam@1800 166 | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]),
adam@1800 167 nextName)
ziv@2252 168 end) (U.File.maxName file + 1) (#1 file)
adam@1800 169 in
ziv@2252 170 (ds, #2 file)
adam@1800 171 end
adam@1800 172
adam@1800 173 end