summaryrefslogtreecommitdiff
path: root/src/main.mlton.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/main.mlton.sml')
-rw-r--r--src/main.mlton.sml383
1 files changed, 383 insertions, 0 deletions
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
new file mode 100644
index 0000000..2caa43f
--- /dev/null
+++ b/src/main.mlton.sml
@@ -0,0 +1,383 @@
+(* Copyright (c) 2008-2012, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+val socket = ".urweb_daemon"
+
+(* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *)
+
+exception Code of OS.Process.status
+
+fun oneRun args =
+ let
+ val timing = ref false
+ val tc = ref false
+ val sources = ref ([] : string list)
+ val demo = ref (NONE : (string * bool) option)
+ val tutorial = ref false
+ val css = ref false
+
+ val () = (Compiler.debug := false;
+ Elaborate.verbose := false;
+ Elaborate.dumpTypes := false;
+ Elaborate.dumpTypesOnError := false;
+ Elaborate.unifyMore := false;
+ Compiler.dumpSource := false;
+ Compiler.doIflow := false;
+ Demo.noEmacs := false;
+ Settings.setDebug false)
+
+ val () = Compiler.beforeC := MLton.GC.pack
+
+ fun printVersion () = (print (Config.versionString ^ "\n");
+ raise Code OS.Process.success)
+ fun printNumericVersion () = (print (Config.versionNumber ^ "\n");
+ raise Code OS.Process.success)
+ fun printCCompiler () = (print (Settings.getCCompiler () ^ "\n");
+ raise Code OS.Process.success)
+ fun printCInclude () = (print (Config.includ ^ "\n");
+ raise Code OS.Process.success)
+
+ fun doArgs args =
+ case args of
+ [] => ()
+ | "-version" :: rest =>
+ printVersion ()
+ | "-numeric-version" :: rest =>
+ printNumericVersion ()
+ | "-css" :: rest =>
+ (css := true;
+ doArgs rest)
+ | "-print-ccompiler" :: rest =>
+ printCCompiler ()
+ | "-print-cinclude" :: rest =>
+ printCInclude ()
+ | "-ccompiler" :: ccomp :: rest =>
+ (Settings.setCCompiler ccomp;
+ doArgs rest)
+ | "-demo" :: prefix :: rest =>
+ (demo := SOME (prefix, false);
+ doArgs rest)
+ | "-guided-demo" :: prefix :: rest =>
+ (demo := SOME (prefix, true);
+ doArgs rest)
+ | "-tutorial" :: rest =>
+ (tutorial := true;
+ doArgs rest)
+ | "-protocol" :: name :: rest =>
+ (Settings.setProtocol name;
+ doArgs rest)
+ | "-prefix" :: prefix :: rest =>
+ (Settings.setUrlPrefix prefix;
+ doArgs rest)
+ | "-db" :: s :: rest =>
+ (Settings.setDbstring (SOME s);
+ doArgs rest)
+ | "-dbms" :: name :: rest =>
+ (Settings.setDbms name;
+ doArgs rest)
+ | "-debug" :: rest =>
+ (Settings.setDebug true;
+ doArgs rest)
+ | "-verbose" :: rest =>
+ (Compiler.debug := true;
+ Elaborate.verbose := true;
+ doArgs rest)
+ | "-timing" :: rest =>
+ (timing := true;
+ doArgs rest)
+ | "-tc" :: rest =>
+ (tc := true;
+ doArgs rest)
+ | "-dumpTypes" :: rest =>
+ (Elaborate.dumpTypes := true;
+ doArgs rest)
+ | "-dumpTypesOnError" :: rest =>
+ (Elaborate.dumpTypesOnError := true;
+ doArgs rest)
+ | "-unifyMore" :: rest =>
+ (Elaborate.unifyMore := true;
+ doArgs rest)
+ | "-dumpSource" :: rest =>
+ (Compiler.dumpSource := true;
+ doArgs rest)
+ | "-dumpVerboseSource" :: rest =>
+ (Compiler.dumpSource := true;
+ ElabPrint.debug := true;
+ ExplPrint.debug := true;
+ CorePrint.debug := true;
+ MonoPrint.debug := true;
+ doArgs rest)
+ | "-output" :: s :: rest =>
+ (Settings.setExe (SOME s);
+ doArgs rest)
+ | "-js" :: s :: rest =>
+ (Settings.setOutputJsFile (SOME s);
+ doArgs rest)
+ | "-sql" :: s :: rest =>
+ (Settings.setSql (SOME s);
+ doArgs rest)
+ | "-static" :: rest =>
+ (Settings.setStaticLinking true;
+ doArgs rest)
+ | "-stop" :: phase :: rest =>
+ (Compiler.setStop phase;
+ doArgs rest)
+ | "-path" :: name :: path :: rest =>
+ (Compiler.addPath (name, path);
+ doArgs rest)
+ | "-root" :: name :: root :: rest =>
+ (Compiler.addModuleRoot (root, name);
+ doArgs rest)
+ | "-boot" :: rest =>
+ (Compiler.enableBoot ();
+ Settings.setBootLinking true;
+ doArgs rest)
+ | "-sigfile" :: name :: rest =>
+ (Settings.setSigFile (SOME name);
+ doArgs rest)
+ | "-iflow" :: rest =>
+ (Compiler.doIflow := true;
+ doArgs rest)
+ | "-sqlcache" :: rest =>
+ (Settings.setSqlcache true;
+ doArgs rest)
+ | "-heuristic" :: h :: rest =>
+ (Sqlcache.setHeuristic h;
+ doArgs rest)
+ | "-moduleOf" :: fname :: _ =>
+ (print (Compiler.moduleOf fname ^ "\n");
+ raise Code OS.Process.success)
+ | "-noEmacs" :: rest =>
+ (Demo.noEmacs := true;
+ doArgs rest)
+ | "-limit" :: class :: num :: rest =>
+ (case Int.fromString num of
+ NONE => raise Fail ("Invalid limit number '" ^ num ^ "'")
+ | SOME n =>
+ if n < 0 then
+ raise Fail ("Invalid limit number '" ^ num ^ "'")
+ else
+ Settings.addLimit (class, n);
+ doArgs rest)
+ | "-explainEmbed" :: rest =>
+ (JsComp.explainEmbed := true;
+ doArgs rest)
+ | arg :: rest =>
+ (if size arg > 0 andalso String.sub (arg, 0) = #"-" then
+ raise Fail ("Unknown flag " ^ arg)
+ else
+ sources := arg :: !sources;
+ doArgs rest)
+
+ val () = case args of
+ ["daemon", "stop"] => OS.Process.exit OS.Process.success
+ | _ => ()
+
+ val () = doArgs args
+
+ val job =
+ case !sources of
+ [file] => file
+ | files =>
+ if List.exists (fn s => s <> "-version") args then
+ raise Fail ("Zero or multiple input files specified; only one is allowed.\nFiles: "
+ ^ String.concatWith ", " files)
+ else
+ printVersion ()
+ in
+ case (!css, !demo, !tutorial) of
+ (true, _, _) =>
+ (case Compiler.run Compiler.toCss job of
+ NONE => OS.Process.failure
+ | SOME {Overall = ov, Classes = cl} =>
+ (app (print o Css.inheritableToString) ov;
+ print "\n";
+ app (fn (x, (ins, ots)) =>
+ (print x;
+ print " ";
+ app (print o Css.inheritableToString) ins;
+ app (print o Css.othersToString) ots;
+ print "\n")) cl;
+ OS.Process.success))
+ | (_, SOME (prefix, guided), _) =>
+ if Demo.make' {prefix = prefix, dirname = job, guided = guided} then
+ OS.Process.success
+ else
+ OS.Process.failure
+ | (_, _, true) => (Tutorial.make job;
+ OS.Process.success)
+ | _ =>
+ if !tc then
+ (Compiler.check Compiler.toElaborate job;
+ if ErrorMsg.anyErrors () then
+ OS.Process.failure
+ else
+ OS.Process.success)
+ else if !timing then
+ (Compiler.time Compiler.toCjrize job;
+ OS.Process.success)
+ else
+ (if Compiler.compile job then
+ OS.Process.success
+ else
+ OS.Process.failure)
+ end handle Code n => n
+
+fun send (sock, s) =
+ let
+ val n = Socket.sendVec (sock, Word8VectorSlice.full (MLton.Word8Vector.fromPoly (Vector.map (Word8.fromInt o ord) (MLton.CharVector.toPoly s))))
+ in
+ if n >= size s then
+ ()
+ else
+ send (sock, String.extract (s, n, NONE))
+ end
+
+val () = (Globals.setResetTime ();
+ case CommandLine.arguments () of
+ ["daemon", "start"] =>
+ (case Posix.Process.fork () of
+ SOME _ => ()
+ | NONE =>
+ let
+ val () = Elaborate.incremental := true
+ val listen = UnixSock.Strm.socket ()
+
+ fun loop () =
+ let
+ val (sock, _) = Socket.accept listen
+
+ fun loop' (buf, args) =
+ let
+ val s = if CharVector.exists (fn ch => ch = #"\n") buf then
+ ""
+ else
+ MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024))))
+ val s = buf ^ s
+ val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s)
+ in
+ if Substring.isEmpty after then
+ loop' (s, args)
+ else
+ let
+ val cmd = Substring.string befor
+ val rest = Substring.string (Substring.slice (after, 1, NONE))
+ in
+ case cmd of
+ "" =>
+ (case args of
+ ["stop", "daemon"] =>
+ (((Socket.close listen;
+ OS.FileSys.remove socket) handle OS.SysErr _ => ());
+ OS.Process.exit OS.Process.success)
+ | _ =>
+ let
+ val success = (oneRun (rev args))
+ handle ex => (print "unhandled exception:\n";
+ print (General.exnMessage ex ^ "\n");
+ OS.Process.failure)
+ in
+ TextIO.flushOut TextIO.stdOut;
+ TextIO.flushOut TextIO.stdErr;
+ send (sock, if OS.Process.isSuccess success then
+ "\001"
+ else
+ "\002")
+ end)
+ | _ => loop' (rest, cmd :: args)
+ end
+ end handle OS.SysErr _ => ()
+
+ fun redirect old =
+ Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)),
+ new = old}
+
+ val oldStdout = Posix.IO.dup Posix.FileSys.stdout
+ val oldStderr = Posix.IO.dup Posix.FileSys.stderr
+ in
+ (* Redirect the daemon's output to the socket. *)
+ redirect Posix.FileSys.stdout;
+ redirect Posix.FileSys.stderr;
+
+ loop' ("", []);
+ Socket.close sock;
+
+ Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout};
+ Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr};
+ Posix.IO.close oldStdout;
+ Posix.IO.close oldStderr;
+
+ Settings.reset ();
+ MLton.GC.pack ();
+ loop ()
+ end
+ in
+ OS.Process.atExit (fn () => OS.FileSys.remove socket);
+ Socket.bind (listen, UnixSock.toAddr socket);
+ Socket.listen (listen, 1);
+ loop ()
+ end)
+ | args =>
+ let
+ val sock = UnixSock.Strm.socket ()
+
+ fun wait () =
+ let
+ val v = Socket.recvVec (sock, 1024)
+ in
+ if Word8Vector.length v = 0 then
+ OS.Process.failure
+ else
+ let
+ val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v))
+ val last = Word8Vector.sub (v, Word8Vector.length v - 1)
+ val (rc, s) = if last = Word8.fromInt 1 then
+ (SOME OS.Process.success, String.substring (s, 0, size s - 1))
+ else if last = Word8.fromInt 2 then
+ (SOME OS.Process.failure, String.substring (s, 0, size s - 1))
+ else
+ (NONE, s)
+ in
+ print s;
+ case rc of
+ NONE => wait ()
+ | SOME rc => rc
+ end
+ end handle OS.SysErr _ => OS.Process.failure
+ in
+ if Socket.connectNB (sock, UnixSock.toAddr socket)
+ orelse not (List.null (#wrs (Socket.select {rds = [],
+ wrs = [Socket.sockDesc sock],
+ exs = [],
+ timeout = SOME (Time.fromSeconds 1)}))) then
+ (app (fn arg => send (sock, arg ^ "\n")) args;
+ send (sock, "\n");
+ OS.Process.exit (wait ()))
+ else
+ (OS.FileSys.remove socket;
+ raise OS.SysErr ("", NONE))
+ end handle OS.SysErr _ => OS.Process.exit (oneRun args))
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-25 02:20:08 +0000