Mercurial > urweb

annotate src/main.mlton.sml @ 2101:32e2752390ad

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fixing one small issue with changes to signature matching (grandfathered into release)
author Adam Chlipala <adam@chlipala.net>
date Sat, 03 Jan 2015 10:21:26 -0500
parents 057b08253a75
children fb113569519e 0ca11d57c175
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
adamc@0 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 [] => ()
adam@1733 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)
adam@1733 162 | "-moduleOf" :: fname :: _ =>
adam@1733 163 (print (Compiler.moduleOf fname ^ "\n");
adam@1733 164 raise Code OS.Process.success)
adam@1733 165 | "-noEmacs" :: rest =>
adam@1733 166 (Demo.noEmacs := true;
adam@1733 167 doArgs rest)
adam@1733 168 | "-limit" :: class :: num :: rest =>
adam@1733 169 (case Int.fromString num of
adam@1733 170 NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1733 171 | SOME n =>
adam@1733 172 if n < 0 then
adam@1733 173 raise Fail ("Invalid limit number '" ^ num ^ "'")
adam@1733 174 else
adam@1733 175 Settings.addLimit (class, n);
adam@1733 176 doArgs rest)
adam@1995 177 | "-explainEmbed" :: rest =>
adam@1995 178 (JsComp.explainEmbed := true;
adam@1995 179 doArgs rest)
adam@1733 180 | arg :: rest =>
adam@1733 181 (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
adam@1733 182 raise Fail ("Unknown flag " ^ arg)
adam@1733 183 else
adam@1733 184 sources := arg :: !sources;
adam@1733 185 doArgs rest)
adam@1733 186
adam@1733 187 val () = case args of
adam@1733 188 ["daemon", "stop"] => OS.Process.exit OS.Process.success
adam@1733 189 | _ => ()
adam@1733 190
adam@1733 191 val () = doArgs args
adam@1733 192
adam@1733 193 val job =
adam@1733 194 case !sources of
adam@1733 195 [file] => file
adam@1809 196 | files =>
adam@1808 197 if List.exists (fn s => s <> "-version") args then
adam@1809 198 raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: "
adam@1809 199 ^ String.concatWith ", " files)
adam@1808 200 else
adam@1808 201 printVersion ()
adam@1733 202 in
adam@1733 203 case (!css, !demo, !tutorial) of
adam@1733 204 (true, _, _) =>
adam@1733 205 (case Compiler.run Compiler.toCss job of
adam@1733 206 NONE => OS.Process.failure
adam@1733 207 | SOME {Overall = ov, Classes = cl} =>
adam@1733 208 (app (print o Css.inheritableToString) ov;
adam@1733 209 print "\n";
adam@1733 210 app (fn (x, (ins, ots)) =>
adam@1733 211 (print x;
adam@1733 212 print " ";
adam@1733 213 app (print o Css.inheritableToString) ins;
adam@1733 214 app (print o Css.othersToString) ots;
adam@1733 215 print "\n")) cl;
adam@1733 216 OS.Process.success))
adam@1733 217 | (_, SOME (prefix, guided), _) =>
adam@1733 218 if Demo.make' {prefix = prefix, dirname = job, guided = guided} then
adam@1733 219 OS.Process.success
adam@1733 220 else
adam@1733 221 OS.Process.failure
adam@1733 222 | (_, _, true) => (Tutorial.make job;
adam@1733 223 OS.Process.success)
adam@1733 224 | _ =>
adam@1733 225 if !tc then
adam@1733 226 (Compiler.check Compiler.toElaborate job;
adam@1733 227 if ErrorMsg.anyErrors () then
adam@1733 228 OS.Process.failure
adam@1733 229 else
adam@1733 230 OS.Process.success)
adam@1733 231 else if !timing then
adam@1733 232 (Compiler.time Compiler.toCjrize job;
adam@1733 233 OS.Process.success)
adam@1733 234 else
adam@1733 235 (if Compiler.compile job then
adam@1733 236 OS.Process.success
adam@1733 237 else
adam@1733 238 OS.Process.failure)
adam@1733 239 end handle Code n => n
adam@1733 240
adam@1733 241 fun send (sock, s) =
adam@1733 242 let
adam@1733 243 val n = Socket.sendVec (sock, Word8VectorSlice.full (Vector.map (Word8.fromInt o ord) s))
adam@1733 244 in
adam@1733 245 if n >= size s then
adam@1733 246 ()
adamc@384 247 else
adam@1733 248 send (sock, String.extract (s, n, NONE))
adam@1733 249 end
adam@1733 250
adam@1733 251 val () = case CommandLine.arguments () of
adam@1733 252 ["daemon", "start"] =>
adam@1733 253 (case Posix.Process.fork () of
adam@1733 254 SOME _ => ()
adam@1733 255 | NONE =>
adam@1733 256 let
adam@1733 257 val () = Elaborate.incremental := true
adam@1733 258 val listen = UnixSock.Strm.socket ()
adam@1733 259
adam@1733 260 fun loop () =
adam@1733 261 let
adam@1733 262 val (sock, _) = Socket.accept listen
adam@1733 263
adam@1733 264 fun loop' (buf, args) =
adam@1733 265 let
adam@1733 266 val s = if CharVector.exists (fn ch => ch = #"\n") buf then
adam@1733 267 ""
adam@1733 268 else
adam@1733 269 Vector.map (chr o Word8.toInt) (Socket.recvVec (sock, 1024))
adam@1733 270 val s = buf ^ s
adam@1733 271 val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
adam@1733 272 in
adam@1733 273 if Substring.isEmpty after then
adam@1733 274 loop' (s, args)
adam@1733 275 else
adam@1733 276 let
adam@1733 277 val cmd = Substring.string befor
adam@1733 278 val rest = Substring.string (Substring.slice (after, 1, NONE))
adam@1733 279 in
adam@1733 280 case cmd of
adam@1744 281 "" =>
adam@1744 282 let
adam@1744 283 val success = (oneRun (rev args))
adam@1744 284 handle ex => (print "unhandled exception:\n";
adam@1744 285 print (General.exnMessage ex ^ "\n");
adam@1744 286 OS.Process.failure)
adam@1744 287 in
adam@1744 288 TextIO.flushOut TextIO.stdOut;
adam@1744 289 TextIO.flushOut TextIO.stdErr;
adam@1744 290 send (sock, if OS.Process.isSuccess success then
adam@1744 291 "\001"
adam@1744 292 else
adam@1744 293 "\002")
adam@1744 294 end
adam@1733 295 | _ => loop' (rest, cmd :: args)
adam@1733 296 end
adam@1733 297 end handle OS.SysErr _ => ()
adam@1744 298
adam@1744 299 fun redirect old =
adam@1744 300 Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
adam@1744 301 new = old}
adam@1744 302
adam@1744 303 val oldStdout = Posix.IO.dup Posix.FileSys.stdout
adam@1744 304 val oldStderr = Posix.IO.dup Posix.FileSys.stderr
adam@1733 305 in
adam@1744 306 (* Redirect the daemon's output to the socket. *)
adam@1744 307 redirect Posix.FileSys.stdout;
adam@1744 308 redirect Posix.FileSys.stderr;
adam@1744 309
adam@1733 310 loop' ("", []);
adam@1733 311 Socket.close sock;
adam@1744 312
adam@1744 313 Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
adam@1744 314 Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
adam@1744 315 Posix.IO.close oldStdout;
adam@1744 316 Posix.IO.close oldStderr;
adam@1744 317
adam@1733 318 MLton.GC.pack ();
adam@1733 319 loop ()
adam@1733 320 end
adam@1733 321 in
adam@1733 322 OS.Process.atExit (fn () => OS.FileSys.remove socket);
adam@1733 323 Socket.bind (listen, UnixSock.toAddr socket);
adam@1733 324 Socket.listen (listen, 1);
adam@1733 325 loop ()
adam@1733 326 end)
mad@1830 327 | ["daemon", "stop"] =>
mad@1830 328 (OS.FileSys.remove socket handle OS.SysErr _ => OS.Process.exit OS.Process.success)
adam@1733 329 | args =>
adam@1733 330 let
adam@1733 331 val sock = UnixSock.Strm.socket ()
adam@1733 332
adam@1733 333 fun wait () =
adam@1733 334 let
adam@1744 335 val v = Socket.recvVec (sock, 1024)
adam@1733 336 in
adam@1733 337 if Vector.length v = 0 then
adam@1733 338 OS.Process.failure
adam@1733 339 else
adam@1744 340 let
adam@1744 341 val s = Vector.map (chr o Word8.toInt) v
adam@1744 342 val last = Vector.sub (v, Vector.length v - 1)
adam@1744 343 val (rc, s) = if last = Word8.fromInt 1 then
adam@1744 344 (SOME OS.Process.success, String.substring (s, 0, size s - 1))
adam@1744 345 else if last = Word8.fromInt 2 then
adam@1744 346 (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
adam@1744 347 else
adam@1744 348 (NONE, s)
adam@1744 349 in
adam@1744 350 print s;
adam@1744 351 case rc of
adam@1744 352 NONE => wait ()
adam@1744 353 | SOME rc => rc
adam@1744 354 end
adam@1733 355 end handle OS.SysErr _ => OS.Process.failure
adam@1733 356 in
adam@1733 357 if Socket.connectNB (sock, UnixSock.toAddr socket)
adam@1733 358 orelse not (List.null (#wrs (Socket.select {rds = [],
adam@1733 359 wrs = [Socket.sockDesc sock],
adam@1733 360 exs = [],
adam@1733 361 timeout = SOME (Time.fromSeconds 1)}))) then
adam@1733 362 (app (fn arg => send (sock, arg ^ "\n")) args;
adam@1733 363 send (sock, "\n");
adam@1733 364 OS.Process.exit (wait ()))
adam@1733 365 else
adam@1733 366 (OS.FileSys.remove socket;
adam@1733 367 raise OS.SysErr ("", NONE))
mad@1830 368 end handle OS.SysErr _ => OS.Process.exit (oneRun args)