Mercurial > urweb

annotate src/mono_opt.sml @ 473:04b91c33ef54

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Resolve all tag named in [Basis]; deal with C compilation failure without leaving /tmp files
author Adam Chlipala <adamc@hcoop.net>
date Sat, 08 Nov 2008 10:33:58 -0500
parents 3f1b9231a37b
children 8e055bbbd28b
rev   line source
adamc@96 1 (* Copyright (c) 2008, Adam Chlipala
adamc@96 2 * All rights reserved.
adamc@96 3 *
adamc@96 4 * Redistribution and use in source and binary forms, with or without
adamc@96 5 * modification, are permitted provided that the following conditions are met:
adamc@96 6 *
adamc@96 7 * - Redistributions of source code must retain the above copyright notice,
adamc@96 8 * this list of conditions and the following disclaimer.
adamc@96 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@96 10 * this list of conditions and the following disclaimer in the documentation
adamc@96 11 * and/or other materials provided with the distribution.
adamc@96 12 * - The names of contributors may not be used to endorse or promote products
adamc@96 13 * derived from this software without specific prior written permission.
adamc@96 14 *
adamc@96 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@96 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@96 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@96 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@96 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@96 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@96 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@96 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@96 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@96 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@96 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@96 26 *)
adamc@96 27
adamc@96 28 structure MonoOpt :> MONO_OPT = struct
adamc@96 29
adamc@96 30 open Mono
adamc@96 31 structure U = MonoUtil
adamc@96 32
adamc@96 33 fun typ t = t
adamc@96 34 fun decl d = d
adamc@96 35
adamc@107 36 fun attrifyInt n =
adamc@107 37 if n < 0 then
adamc@107 38 "-" ^ Int64.toString (Int64.~ n)
adamc@107 39 else
adamc@107 40 Int64.toString n
adamc@107 41
adamc@107 42 fun attrifyFloat n =
adamc@107 43 if n < 0.0 then
adamc@107 44 "-" ^ Real.toString (Real.~ n)
adamc@107 45 else
adamc@107 46 Real.toString n
adamc@107 47
adamc@107 48 val attrifyString = String.translate (fn #"\"" => "&quot;"
adamc@135 49 | #"&" => "&amp;"
adamc@107 50 | ch => if Char.isPrint ch then
adamc@107 51 str ch
adamc@107 52 else
adamc@107 53 "&#" ^ Int.toString (ord ch) ^ ";")
adamc@107 54
adamc@120 55 val urlifyInt = attrifyInt
adamc@120 56 val urlifyFloat = attrifyFloat
adamc@120 57
adamc@286 58 val htmlifyInt = attrifyInt
adamc@286 59 val htmlifyFloat = attrifyFloat
adamc@135 60 val htmlifyString = String.translate (fn ch => case ch of
adamc@135 61 #"<" => "&lt;"
adamc@135 62 | #"&" => "&amp;"
adamc@135 63 | _ =>
adamc@135 64 if Char.isPrint ch orelse Char.isSpace ch then
adamc@135 65 str ch
adamc@135 66 else
adamc@135 67 "&#" ^ Int.toString (ord ch) ^ ";")
adamc@135 68
adamc@120 69 fun hexIt ch =
adamc@120 70 let
adamc@120 71 val s = Int.fmt StringCvt.HEX (ord ch)
adamc@120 72 in
adamc@120 73 case size s of
adamc@120 74 0 => "00"
adamc@120 75 | 1 => "0" ^ s
adamc@120 76 | _ => s
adamc@120 77 end
adamc@120 78
adamc@120 79 val urlifyString = String.translate (fn #" " => "+"
adamc@120 80 | ch => if Char.isAlphaNum ch then
adamc@120 81 str ch
adamc@120 82 else
adamc@120 83 "%" ^ hexIt ch)
adamc@253 84
adamc@253 85
adamc@281 86 fun sqlifyInt n = attrifyInt n ^ "::int8"
adamc@281 87 fun sqlifyFloat n = attrifyFloat n ^ "::float8"
adamc@253 88
adamc@259 89 fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'"
adamc@259 90 | ch => str ch)
adamc@281 91 (String.toString s) ^ "'::text"
adamc@453 92
adamc@96 93 fun exp e =
adamc@96 94 case e of
adamc@96 95 EPrim (Prim.String s) =>
adamc@96 96 let
adamc@96 97 val (_, chs) =
adamc@96 98 CharVector.foldl (fn (ch, (lastSpace, chs)) =>
adamc@96 99 let
adamc@96 100 val isSpace = Char.isSpace ch
adamc@96 101 in
adamc@96 102 if isSpace andalso lastSpace then
adamc@96 103 (true, chs)
adamc@96 104 else
adamc@96 105 (isSpace, ch :: chs)
adamc@96 106 end)
adamc@96 107 (false, []) s
adamc@96 108 in
adamc@96 109 EPrim (Prim.String (String.implode (rev chs)))
adamc@96 110 end
adamc@96 111
adamc@96 112 | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) =>
adamc@96 113 let
adamc@96 114 val s =
adamc@96 115 if size s1 > 0 andalso size s2 > 0
adamc@96 116 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@96 117 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@96 118 s1 ^ String.extract (s2, 1, NONE)
adamc@96 119 else
adamc@96 120 s1 ^ s2
adamc@96 121 in
adamc@96 122 EPrim (Prim.String s)
adamc@96 123 end
adamc@105 124
adamc@105 125 | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) =>
adamc@105 126 let
adamc@105 127 val s =
adamc@105 128 if size s1 > 0 andalso size s2 > 0
adamc@105 129 andalso Char.isSpace (String.sub (s1, size s1 - 1))
adamc@105 130 andalso Char.isSpace (String.sub (s2, 0)) then
adamc@105 131 s1 ^ String.extract (s2, 1, NONE)
adamc@105 132 else
adamc@105 133 s1 ^ s2
adamc@105 134 in
adamc@105 135 EStrcat ((EPrim (Prim.String s), loc), rest)
adamc@105 136 end
adamc@105 137
adamc@105 138 | EStrcat ((EStrcat (e1, e2), loc), e3) =>
adamc@105 139 optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc)
adamc@105 140
adamc@106 141 | EWrite (EStrcat (e1, e2), loc) =>
adamc@106 142 ESeq ((optExp (EWrite e1, loc), loc),
adamc@106 143 (optExp (EWrite e2, loc), loc))
adamc@106 144
adamc@183 145 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@183 146 (EWrite (EPrim (Prim.String s2), _), _)) =>
adamc@183 147 EWrite (EPrim (Prim.String (s1 ^ s2)), loc)
adamc@196 148 | ESeq ((EWrite (EPrim (Prim.String s1), _), loc),
adamc@196 149 (ESeq ((EWrite (EPrim (Prim.String s2), _), _),
adamc@196 150 e), _)) =>
adamc@196 151 ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc),
adamc@196 152 e)
adamc@183 153
adamc@286 154 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", [(EPrim (Prim.Int n), _)]), _)]) =>
adamc@286 155 EPrim (Prim.String (htmlifyInt n))
adamc@286 156 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", es), _)]) =>
adamc@286 157 EFfiApp ("Basis", "htmlifyInt", es)
adamc@320 158 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320 159 (EPrim (Prim.Int n), _)), _)]) =>
adamc@320 160 EPrim (Prim.String (htmlifyInt n))
adamc@320 161 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
adamc@320 162 e), _)]) =>
adamc@320 163 EFfiApp ("Basis", "htmlifyInt", [e])
adamc@286 164 | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) =>
adamc@286 165 EFfiApp ("Basis", "htmlifyInt_w", [e])
adamc@286 166
adamc@286 167 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", [(EPrim (Prim.Float n), _)]), _)]) =>
adamc@286 168 EPrim (Prim.String (htmlifyFloat n))
adamc@286 169 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", es), _)]) =>
adamc@286 170 EFfiApp ("Basis", "htmlifyFloat", es)
adamc@320 171 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320 172 (EPrim (Prim.Float n), _)), _)]) =>
adamc@320 173 EPrim (Prim.String (htmlifyFloat n))
adamc@320 174 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
adamc@320 175 e), _)]) =>
adamc@320 176 EFfiApp ("Basis", "htmlifyFloat", [e])
adamc@286 177 | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) =>
adamc@286 178 EFfiApp ("Basis", "htmlifyFloat_w", [e])
adamc@286 179
adamc@286 180 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286 181 [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), _)]) =>
adamc@286 182 EPrim (Prim.String "True")
adamc@286 183 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
adamc@286 184 [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), _)]) =>
adamc@286 185 EPrim (Prim.String "False")
adamc@286 186 | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", es), _)]) =>
adamc@286 187 EFfiApp ("Basis", "htmlifyBool", es)
adamc@320 188 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 189 (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _)]) =>
adamc@320 190 EPrim (Prim.String "True")
adamc@320 191 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 192 (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _)]) =>
adamc@320 193 EPrim (Prim.String "False")
adamc@320 194 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
adamc@320 195 e), _)]) =>
adamc@320 196 EFfiApp ("Basis", "htmlifyBool", [e])
adamc@286 197 | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) =>
adamc@286 198 EFfiApp ("Basis", "htmlifyBool_w", [e])
adamc@286 199
adamc@436 200 | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436 201 EFfiApp ("Basis", "htmlifyTime", [e])
adamc@436 202 | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
adamc@436 203 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 204 | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) =>
adamc@436 205 EFfiApp ("Basis", "htmlifyTime_w", [e])
adamc@436 206
adamc@135 207 | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@135 208 EPrim (Prim.String (htmlifyString s))
adamc@135 209 | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@135 210 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 211 | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) =>
adamc@135 212 EFfiApp ("Basis", "htmlifyString_w", [e])
adamc@196 213 | EFfiApp ("Basis", "htmlifyString_w", [(EPrim (Prim.String s), loc)]) =>
adamc@196 214 EWrite (EPrim (Prim.String (htmlifyString s)), loc)
adamc@135 215
adamc@107 216 | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@107 217 EPrim (Prim.String (attrifyInt n))
adamc@107 218 | EWrite (EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@107 219 EWrite (EPrim (Prim.String (attrifyInt n)), loc)
adamc@106 220 | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
adamc@106 221 EFfiApp ("Basis", "attrifyInt_w", [e])
adamc@107 222
adamc@107 223 | EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@107 224 EPrim (Prim.String (attrifyFloat n))
adamc@107 225 | EWrite (EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@107 226 EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
adamc@106 227 | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
adamc@106 228 EFfiApp ("Basis", "attrifyFloat_w", [e])
adamc@107 229
adamc@107 230 | EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]) =>
adamc@107 231 EPrim (Prim.String (attrifyString s))
adamc@107 232 | EWrite (EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@107 233 EWrite (EPrim (Prim.String (attrifyString s)), loc)
adamc@106 234 | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
adamc@106 235 EFfiApp ("Basis", "attrifyString_w", [e])
adamc@106 236
adamc@120 237 | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@120 238 EPrim (Prim.String (urlifyInt n))
adamc@120 239 | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
adamc@120 240 EWrite (EPrim (Prim.String (urlifyInt n)), loc)
adamc@120 241 | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
adamc@120 242 EFfiApp ("Basis", "urlifyInt_w", [e])
adamc@120 243
adamc@120 244 | EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@120 245 EPrim (Prim.String (urlifyFloat n))
adamc@120 246 | EWrite (EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
adamc@120 247 EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
adamc@120 248 | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
adamc@120 249 EFfiApp ("Basis", "urlifyFloat_w", [e])
adamc@120 250
adamc@120 251 | EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]) =>
adamc@120 252 EPrim (Prim.String (urlifyString s))
adamc@120 253 | EWrite (EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]), loc) =>
adamc@120 254 EWrite (EPrim (Prim.String (urlifyString s)), loc)
adamc@120 255 | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
adamc@120 256 EFfiApp ("Basis", "urlifyString_w", [e])
adamc@120 257
adamc@188 258 | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]) =>
adamc@187 259 EPrim (Prim.String "1")
adamc@188 260 | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]) =>
adamc@187 261 EPrim (Prim.String "0")
adamc@188 262 | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), loc) =>
adamc@187 263 EWrite (EPrim (Prim.String "1"), loc)
adamc@188 264 | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), loc) =>
adamc@187 265 EWrite (EPrim (Prim.String "0"), loc)
adamc@187 266 | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) =>
adamc@187 267 EFfiApp ("Basis", "urlifyBool_w", [e])
adamc@187 268
adamc@253 269 | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) =>
adamc@253 270 EPrim (Prim.String (sqlifyInt n))
adamc@467 271 | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) =>
adamc@467 272 EPrim (Prim.String "NULL")
adamc@467 273 | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) =>
adamc@467 274 EPrim (Prim.String (sqlifyInt n))
adamc@467 275
adamc@253 276 | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) =>
adamc@253 277 EPrim (Prim.String (sqlifyFloat n))
adamc@253 278 | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) =>
adamc@253 279 optExp (ECase (b,
adamc@253 280 [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc),
adamc@253 281 (EPrim (Prim.String "TRUE"), loc)),
adamc@253 282 ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc),
adamc@253 283 (EPrim (Prim.String "FALSE"), loc))],
adamc@253 284 {disc = (TFfi ("Basis", "bool"), loc),
adamc@253 285 result = (TFfi ("Basis", "string"), loc)}), loc)
adamc@253 286 | EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) =>
adamc@253 287 EPrim (Prim.String (sqlifyString n))
adamc@253 288
adamc@184 289 | EWrite (ECase (discE, pes, {disc, ...}), loc) =>
adamc@184 290 optExp (ECase (discE,
adamc@184 291 map (fn (p, e) => (p, (EWrite e, loc))) pes,
adamc@184 292 {disc = disc,
adamc@184 293 result = (TRecord [], loc)}), loc)
adamc@184 294
adamc@453 295 | EApp ((ECase (discE, pes, {disc, ...}), loc), arg as (ERecord [], _)) =>
adamc@453 296 let
adamc@453 297 fun doBody e =
adamc@453 298 case #1 e of
adamc@453 299 EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body
adamc@453 300 | _ => (EApp (e, arg), loc)
adamc@453 301 in
adamc@453 302 optExp (ECase (discE,
adamc@453 303 map (fn (p, e) => (p, doBody e)) pes,
adamc@453 304 {disc = disc,
adamc@453 305 result = (TRecord [], loc)}), loc)
adamc@453 306 end
adamc@453 307
adamc@331 308 | EWrite (EQuery {exps, tables, state, query,
adamc@331 309 initial = (EPrim (Prim.String ""), _),
adamc@331 310 body = (EStrcat ((EPrim (Prim.String s), _),
adamc@331 311 (EStrcat ((ERel 0, _),
adamc@331 312 e'), _)), _)}, loc) =>
adamc@331 313 if CharVector.all Char.isSpace s then
adamc@331 314 EQuery {exps = exps, tables = tables, query = query,
adamc@331 315 state = (TRecord [], loc),
adamc@331 316 initial = (ERecord [], loc),
adamc@331 317 body = (optExp (EWrite e', loc), loc)}
adamc@331 318 else
adamc@331 319 e
adamc@331 320
adamc@334 321 | EWrite (EQuery {exps, tables, state, query,
adamc@334 322 initial = (EPrim (Prim.String ""), _),
adamc@334 323 body = (EStrcat ((ERel 0, _), e'), _)}, loc) =>
adamc@334 324 EQuery {exps = exps, tables = tables, query = query,
adamc@334 325 state = (TRecord [], loc),
adamc@334 326 initial = (ERecord [], loc),
adamc@334 327 body = (optExp (EWrite e', loc), loc)}
adamc@334 328
adamc@340 329 | EWrite (ELet (x, t, e1, e2), loc) =>
adamc@340 330 optExp (ELet (x, t, e1, (EWrite e2, loc)), loc)
adamc@340 331
adamc@451 332 | EWrite (EPrim (Prim.String ""), loc) =>
adamc@451 333 ERecord []
adamc@451 334
adamc@96 335 | _ => e
adamc@96 336
adamc@105 337 and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
adamc@105 338
adamc@96 339 val optimize = U.File.map {typ = typ, exp = exp, decl = decl}
adamc@96 340
adamc@96 341 end