summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2012-05-05 12:45:35 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2012-05-05 12:45:35 -0400
commitf2ae62f46ac8b9cefc841bd064c7ea8317cc9752 (patch)
tree85b4d5ef5bf9c2f5087c15d4d480ea04394dea8a /src
parentd216e49c1b5e7f25d95e9cb1dd8bcdbbc71389c5 (diff)
Send daemon output to calling process
Diffstat (limited to 'src')
-rw-r--r--src/elaborate.sig1
-rw-r--r--src/elaborate.sml6
-rw-r--r--src/main.mlton.sml61
3 files changed, 55 insertions, 13 deletions
diff --git a/src/elaborate.sig b/src/elaborate.sig
index 18e6c3b4..b4a4da88 100644
--- a/src/elaborate.sig
+++ b/src/elaborate.sig
@@ -42,5 +42,6 @@ signature ELABORATE = sig
* early phase. *)
val incremental : bool ref
+ val verbose : bool ref
end
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 5799d6bb..fe2e2f12 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -41,6 +41,7 @@
val dumpTypes = ref false
val unifyMore = ref false
val incremental = ref false
+ val verbose = ref false
structure IS = IntBinarySet
structure IM = IntBinaryMap
@@ -3931,6 +3932,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
(case ModDb.lookup dAll of
SOME d =>
let
+ val () = if !verbose then TextIO.print ("REUSE: " ^ x ^ "\n") else ()
val env' = E.declBinds env d
val denv' = dopenConstraints (loc, env', denv) {str = x, strs = []}
in
@@ -3938,6 +3940,8 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
end
| NONE =>
let
+ val () = if !verbose then TextIO.print ("CHECK: " ^ x ^ "\n") else ()
+
val () = if x = "Basis" then
raise Fail "Not allowed to redefine structure 'Basis'"
else
@@ -4680,7 +4684,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file =
val c = normClassKey env c
in
case resolveClass env c of
- SOME _ => raise Fail "Type class resolution succeeded unexpectedly"
+ SOME _ => ()
| NONE => expError env (Unresolvable (loc, c))
end)
gs)
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 9cc82da0..4e1f8e2c 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -41,6 +41,7 @@ fun oneRun args =
val css = ref false
val () = (Compiler.debug := false;
+ Elaborate.verbose := false;
Elaborate.dumpTypes := false;
Elaborate.unifyMore := false;
Compiler.dumpSource := false;
@@ -91,6 +92,7 @@ fun oneRun args =
doArgs rest)
| "-verbose" :: rest =>
(Compiler.debug := true;
+ Elaborate.verbose := true;
doArgs rest)
| "-timing" :: rest =>
(timing := true;
@@ -243,19 +245,43 @@ val () = case CommandLine.arguments () of
val rest = Substring.string (Substring.slice (after, 1, NONE))
in
case cmd of
- "" => send (sock, if OS.Process.isSuccess ((oneRun (rev args))
- handle ex => (print "unhandled exception:\n";
- print (General.exnMessage ex ^ "\n");
- OS.Process.failure)) then
- "0"
- else
- "1")
+ "" =>
+ 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;
+
MLton.GC.pack ();
loop ()
end
@@ -272,15 +298,26 @@ val () = case CommandLine.arguments () of
fun wait () =
let
- val v = Socket.recvVec (sock, 1)
+ val v = Socket.recvVec (sock, 1024)
in
if Vector.length v = 0 then
OS.Process.failure
else
- case chr (Word8.toInt (Vector.sub (v, 0))) of
- #"0" => OS.Process.success
- | #"1" => OS.Process.failure
- | _ => raise Fail "Weird return code from daemon"
+ let
+ val s = Vector.map (chr o Word8.toInt) v
+ val last = Vector.sub (v, Vector.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)