Mercurial > urweb

annotate src/main.mlton.sml @ 2291:50ad02829abd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make cache flushes happen immediately instead of at end of transaction.
author Ziv Scully <ziv@mit.edu>
date Tue, 17 Nov 2015 02:44:37 -0500
parents 639e62ca2530
children 47d5c94aeeb8
rev   line source
adam@1677 1 (* Copyright (c) 2008-2012, Adam Chlipala
adamc@0 2 * All rights reserved.
adamc@0 3 *
adamc@0 4 * Redistribution and use in source and binary forms, with or without
adamc@0 5 * modification, are permitted provided that the following conditions are met:
adamc@0 6 *
adamc@0 7 * - Redistributions of source code must retain the above copyright notice,
adamc@0 8 * this list of conditions and the following disclaimer.
adamc@0 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@0 10 * this list of conditions and the following disclaimer in the documentation
adamc@0 11 * and/or other materials provided with the distribution.
adamc@0 12 * - The names of contributors may not be used to endorse or promote products
adamc@0 13 * derived from this software without specific prior written permission.
adamc@0 14 *
adamc@0 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@0 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@0 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@0 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
ziv@2209 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@0 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@0 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@0 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@0 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@0 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@0 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@0 26 *)
adamc@0 27
adam@1733 28 val socket = ".urweb_daemon"
adamc@857 29
adam@1733 30 (* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
adam@1540 31
adam@1733 32 exception Code of OS.Process.status
adam@1520 33
adam@1733 34 fun oneRun args =
adam@1733 35 let
adam@1733 36 val timing = ref false
adam@1733 37 val tc = ref false
adam@1733 38 val sources = ref ([] : string list)
adam@1733 39 val demo = ref (NONE : (string * bool) option)
adam@1733 40 val tutorial = ref false
adam@1733 41 val css = ref false
adamc@208 42
adam@1733 43 val () = (Compiler.debug := false;
adam@1744 44 Elaborate.verbose := false;
adam@1733 45 Elaborate.dumpTypes := false;
adam@1745 46 Elaborate.dumpTypesOnError := false;
adam@1733 47 Elaborate.unifyMore := false;
adam@1733 48 Compiler.dumpSource := false;
adam@1733 49 Compiler.doIflow := false;
adam@1733 50 Demo.noEmacs := false;
adam@1733 51 Settings.setDebug false)
adamc@208 52
adam@1733 53 val () = Compiler.beforeC := MLton.GC.pack
adamc@279 54
adam@1733 55 fun printVersion () = (print (Config.versionString ^ "\n");
adam@1733 56 raise Code OS.Process.success)
adam@1733 57 fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
adam@1733 58 raise Code OS.Process.success)
adam@1923 59 fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n");
adam@1923 60 raise Code OS.Process.success)
adam@1923 61 fun printCInclude () = (print (Config.includ ^ "\n");
adam@1923 62 raise Code OS.Process.success)
adam@1733 63
adam@1733 64 fun doArgs args =
adam@1733 65 case args of
adam@1733 66 [] => ()
ziv@2209 67 | "-version" :: rest =>
grrwlf@1871 68 printVersion ()
adam@1733 69 | "-numeric-version" :: rest =>
grrwlf@1871 70 printNumericVersion ()
adam@1733 71 | "-css" :: rest =>
adam@1733 72 (css := true;
adam@1733 73 doArgs rest)
grrwlf@1872 74 | "-print-ccompiler" :: rest =>
grrwlf@1872 75 printCCompiler ()
grrwlf@1922 76 | "-print-cinclude" :: rest =>
grrwlf@1922 77 printCInclude ()
grrwlf@1871 78 | "-ccompiler" :: ccomp :: rest =>
grrwlf@1871 79 (Settings.setCCompiler ccomp;
grrwlf@1871 80 doArgs rest)
adam@1733 81 | "-demo" :: prefix :: rest =>
adam@1733 82 (demo := SOME (prefix, false);
adam@1733 83 doArgs rest)
adam@1733 84 | "-guided-demo" :: prefix :: rest =>
adam@1733 85 (demo := SOME (prefix, true);
adam@1733 86 doArgs rest)
adam@1733 87 | "-tutorial" :: rest =>
adam@1733 88 (tutorial := true;
adam@1733 89 doArgs rest)
adam@1733 90 | "-protocol" :: name :: rest =>
adam@1733 91 (Settings.setProtocol name;
adam@1733 92 doArgs rest)
adam@1733 93 | "-prefix" :: prefix :: rest =>
adam@1733 94 (Settings.setUrlPrefix prefix;
adam@1733 95 doArgs rest)
adam@1733 96 | "-db" :: s :: rest =>
adam@1733 97 (Settings.setDbstring (SOME s);
adam@1733 98 doArgs rest)
adam@1733 99 | "-dbms" :: name :: rest =>
adam@1733 100 (Settings.setDbms name;
adam@1733 101 doArgs rest)
adam@1733 102 | "-debug" :: rest =>
adam@1733 103 (Settings.setDebug true;
adam@1733 104 doArgs rest)
adam@1733 105 | "-verbose" :: rest =>
adam@1733 106 (Compiler.debug := true;
adam@1744 107 Elaborate.verbose := true;
adam@1733 108 doArgs rest)
adam@1733 109 | "-timing" :: rest =>
adam@1733 110 (timing := true;
adam@1733 111 doArgs rest)
adam@1733 112 | "-tc" :: rest =>
adam@1733 113 (tc := true;
adam@1733 114 doArgs rest)
adam@1733 115 | "-dumpTypes" :: rest =>
adam@1733 116 (Elaborate.dumpTypes := true;
adam@1733 117 doArgs rest)
adam@1745 118 | "-dumpTypesOnError" :: rest =>
adam@1745 119 (Elaborate.dumpTypesOnError := true;
adam@1745 120 doArgs rest)
adam@1733 121 | "-unifyMore" :: rest =>
adam@1733 122 (Elaborate.unifyMore := true;
adam@1733 123 doArgs rest)
adam@1733 124 | "-dumpSource" :: rest =>
adam@1733 125 (Compiler.dumpSource := true;
adam@1733 126 doArgs rest)
adam@1989 127 | "-dumpVerboseSource" :: rest =>
adam@1989 128 (Compiler.dumpSource := true;
adam@1989 129 ElabPrint.debug := true;
adam@1989 130 ExplPrint.debug := true;
adam@1989 131 CorePrint.debug := true;
adam@1989 132 MonoPrint.debug := true;
adam@1989 133 doArgs rest)
adam@1733 134 | "-output" :: s :: rest =>
adam@1733 135 (Settings.setExe (SOME s);
adam@1733 136 doArgs rest)
adam@1733 137 | "-sql" :: s :: rest =>
adam@1733 138 (Settings.setSql (SOME s);
adam@1733 139 doArgs rest)
adam@1733 140 | "-static" :: rest =>
adam@1733 141 (Settings.setStaticLinking true;
adam@1733 142 doArgs rest)
adam@1961 143 | "-stop" :: phase :: rest =>
adam@1961 144 (Compiler.setStop phase;
adam@1961 145 doArgs rest)
adam@1733 146 | "-path" :: name :: path :: rest =>
adam@1733 147 (Compiler.addPath (name, path);
adam@1733 148 doArgs rest)
adam@1733 149 | "-root" :: name :: root :: rest =>
adam@1733 150 (Compiler.addModuleRoot (root, name);
adam@1733 151 doArgs rest)
ezyang@1739 152 | "-boot" :: rest =>
ezyang@1739 153 (Compiler.enableBoot ();
ezyang@1739 154 Settings.setStaticLinking true;
ezyang@1739 155 doArgs rest)
adam@1733 156 | "-sigfile" :: name :: rest =>
adam@1733 157 (Settings.setSigFile (SOME name);
adam@1733 158 doArgs rest)
adam@1733 159 | "-iflow" :: rest =>
adam@1733 160 (Compiler.doIflow := true;
adam@1733 161 doArgs rest)
ziv@2209 162 | "-sqlcache" :: rest =>
ziv@2215 163 (Settings.setSqlcache true;
ziv@2209 164 doArgs rest)
adam@1733 165 | "-moduleOf" :: fname :: _ =>
adam@1733 166 (print (Compiler.moduleOf fname ^ "\n");
adam@1733 167 raise Code OS.Process.success)
adam@1733 168 | "-noEmacs" :: rest =>
adam@1733 169 (Demo.noEmacs := true;
adam@1733 170 doArgs rest)
adam@1733 171 | "-limit" :: class :: num :: rest =>
adam@1733 172 (case Int.fromString num of
adam@1733 173 NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1733 174 | SOME n =>
adam@1733 175 if n < 0 then
adam@1733 176 raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1733 177 else
adam@1733 178 Settings.addLimit (class, n);
adam@1733 179 doArgs rest)
adam@1995 180 | "-explainEmbed" :: rest =>
adam@1995 181 (JsComp.explainEmbed := true;
adam@1995 182 doArgs rest)
adam@1733 183 | arg :: rest =>
adam@1733 184 (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
adam@1733 185 raise Fail ("Unknown flag " ^ arg)
adam@1733 186 else
adam@1733 187 sources := arg :: !sources;
adam@1733 188 doArgs rest)
adam@1733 189
adam@1733 190 val () = case args of
adam@1733 191 ["daemon", "stop"] => OS.Process.exit OS.Process.success
adam@1733 192 | _ => ()
adam@1733 193
adam@1733 194 val () = doArgs args
adam@1733 195
adam@1733 196 val job =
adam@1733 197 case !sources of
adam@1733 198 [file] => file
adam@1809 199 | files =>
adam@1808 200 if List.exists (fn s => s <> "-version") args then
adam@1809 201 raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: "
adam@1809 202 ^ String.concatWith ", " files)
adam@1808 203 else
adam@1808 204 printVersion ()
adam@1733 205 in
adam@1733 206 case (!css, !demo, !tutorial) of
adam@1733 207 (true, _, _) =>
adam@1733 208 (case Compiler.run Compiler.toCss job of
adam@1733 209 NONE => OS.Process.failure
adam@1733 210 | SOME {Overall = ov, Classes = cl} =>
adam@1733 211 (app (print o Css.inheritableToString) ov;
adam@1733 212 print "\n";
adam@1733 213 app (fn (x, (ins, ots)) =>
adam@1733 214 (print x;
adam@1733 215 print " ";
adam@1733 216 app (print o Css.inheritableToString) ins;
adam@1733 217 app (print o Css.othersToString) ots;
adam@1733 218 print "\n")) cl;
adam@1733 219 OS.Process.success))
adam@1733 220 | (_, SOME (prefix, guided), _) =>
adam@1733 221 if Demo.make' {prefix = prefix, dirname = job, guided = guided} then
adam@1733 222 OS.Process.success
adam@1733 223 else
adam@1733 224 OS.Process.failure
adam@1733 225 | (_, _, true) => (Tutorial.make job;
adam@1733 226 OS.Process.success)
adam@1733 227 | _ =>
adam@1733 228 if !tc then
adam@1733 229 (Compiler.check Compiler.toElaborate job;
adam@1733 230 if ErrorMsg.anyErrors () then
adam@1733 231 OS.Process.failure
adam@1733 232 else
adam@1733 233 OS.Process.success)
adam@1733 234 else if !timing then
adam@1733 235 (Compiler.time Compiler.toCjrize job;
adam@1733 236 OS.Process.success)
adam@1733 237 else
adam@1733 238 (if Compiler.compile job then
adam@1733 239 OS.Process.success
adam@1733 240 else
adam@1733 241 OS.Process.failure)
adam@1733 242 end handle Code n => n
adam@1733 243
adam@1733 244 fun send (sock, s) =
adam@1733 245 let
adam@1733 246 val n = Socket.sendVec (sock, Word8VectorSlice.full (Vector.map (Word8.fromInt o ord) s))
adam@1733 247 in
adam@1733 248 if n >= size s then
adam@1733 249 ()
adamc@384 250 else
adam@1733 251 send (sock, String.extract (s, n, NONE))
adam@1733 252 end
adam@1733 253
adam@1733 254 val () = case CommandLine.arguments () of
adam@1733 255 ["daemon", "start"] =>
adam@1733 256 (case Posix.Process.fork () of
adam@1733 257 SOME _ => ()
adam@1733 258 | NONE =>
adam@1733 259 let
adam@1733 260 val () = Elaborate.incremental := true
adam@1733 261 val listen = UnixSock.Strm.socket ()
adam@1733 262
adam@1733 263 fun loop () =
adam@1733 264 let
adam@1733 265 val (sock, _) = Socket.accept listen
adam@1733 266
adam@1733 267 fun loop' (buf, args) =
adam@1733 268 let
adam@1733 269 val s = if CharVector.exists (fn ch => ch = #"\n") buf then
adam@1733 270 ""
adam@1733 271 else
adam@1733 272 Vector.map (chr o Word8.toInt) (Socket.recvVec (sock, 1024))
adam@1733 273 val s = buf ^ s
adam@1733 274 val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
adam@1733 275 in
adam@1733 276 if Substring.isEmpty after then
adam@1733 277 loop' (s, args)
adam@1733 278 else
adam@1733 279 let
adam@1733 280 val cmd = Substring.string befor
adam@1733 281 val rest = Substring.string (Substring.slice (after, 1, NONE))
adam@1733 282 in
adam@1733 283 case cmd of
adam@1744 284 "" =>
adam@1744 285 let
adam@1744 286 val success = (oneRun (rev args))
adam@1744 287 handle ex => (print "unhandled exception:\n";
adam@1744 288 print (General.exnMessage ex ^ "\n");
adam@1744 289 OS.Process.failure)
adam@1744 290 in
adam@1744 291 TextIO.flushOut TextIO.stdOut;
adam@1744 292 TextIO.flushOut TextIO.stdErr;
adam@1744 293 send (sock, if OS.Process.isSuccess success then
adam@1744 294 "\001"
adam@1744 295 else
adam@1744 296 "\002")
adam@1744 297 end
adam@1733 298 | _ => loop' (rest, cmd :: args)
adam@1733 299 end
adam@1733 300 end handle OS.SysErr _ => ()
adam@1744 301
adam@1744 302 fun redirect old =
adam@1744 303 Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
adam@1744 304 new = old}
adam@1744 305
adam@1744 306 val oldStdout = Posix.IO.dup Posix.FileSys.stdout
adam@1744 307 val oldStderr = Posix.IO.dup Posix.FileSys.stderr
adam@1733 308 in
adam@1744 309 (* Redirect the daemon's output to the socket. *)
adam@1744 310 redirect Posix.FileSys.stdout;
adam@1744 311 redirect Posix.FileSys.stderr;
ziv@2209 312
adam@1733 313 loop' ("", []);
adam@1733 314 Socket.close sock;
adam@1744 315
adam@1744 316 Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
adam@1744 317 Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
adam@1744 318 Posix.IO.close oldStdout;
adam@1744 319 Posix.IO.close oldStderr;
adam@1744 320
adam@1733 321 MLton.GC.pack ();
adam@1733 322 loop ()
adam@1733 323 end
adam@1733 324 in
adam@1733 325 OS.Process.atExit (fn () => OS.FileSys.remove socket);
adam@1733 326 Socket.bind (listen, UnixSock.toAddr socket);
adam@1733 327 Socket.listen (listen, 1);
adam@1733 328 loop ()
adam@1733 329 end)
mad@1830 330 | ["daemon", "stop"] =>
ziv@2209 331 (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success)
adam@1733 332 | args =>
adam@1733 333 let
adam@1733 334 val sock = UnixSock.Strm.socket ()
adam@1733 335
adam@1733 336 fun wait () =
adam@1733 337 let
adam@1744 338 val v = Socket.recvVec (sock, 1024)
adam@1733 339 in
adam@1733 340 if Vector.length v = 0 then
adam@1733 341 OS.Process.failure
adam@1733 342 else
adam@1744 343 let
adam@1744 344 val s = Vector.map (chr o Word8.toInt) v
adam@1744 345 val last = Vector.sub (v, Vector.length v - 1)
adam@1744 346 val (rc, s) = if last = Word8.fromInt 1 then
adam@1744 347 (SOME OS.Process.success, String.substring (s, 0, size s - 1))
adam@1744 348 else if last = Word8.fromInt 2 then
adam@1744 349 (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
adam@1744 350 else
adam@1744 351 (NONE, s)
adam@1744 352 in
adam@1744 353 print s;
adam@1744 354 case rc of
adam@1744 355 NONE => wait ()
adam@1744 356 | SOME rc => rc
adam@1744 357 end
adam@1733 358 end handle OS.SysErr _ => OS.Process.failure
adam@1733 359 in
adam@1733 360 if Socket.connectNB (sock, UnixSock.toAddr socket)
adam@1733 361 orelse not (List.null (#wrs (Socket.select {rds = [],
adam@1733 362 wrs = [Socket.sockDesc sock],
adam@1733 363 exs = [],
adam@1733 364 timeout = SOME (Time.fromSeconds 1)}))) then
adam@1733 365 (app (fn arg => send (sock, arg ^ "\n")) args;
adam@1733 366 send (sock, "\n");
adam@1733 367 OS.Process.exit (wait ()))
adam@1733 368 else
adam@1733 369 (OS.FileSys.remove socket;
adam@1733 370 raise OS.SysErr ("", NONE))
mad@1830 371 end handle OS.SysErr _ => OS.Process.exit (oneRun args)