Compile.Exec: Better diagnostics on GCC error

1 files changed, 26 insertions, 2 deletions

diff --git a/src/Compile/Exec.hs b/src/Compile/Exec.hs
index 83ce4ff..fa61910 100644
--- a/src/Compile/Exec.hs
+++ b/src/Compile/Exec.hs
@@ -14,11 +14,13 @@ import Foreign (Ptr)
 import Foreign.Ptr (FunPtr)
 import System.Directory (removeDirectoryRecursive)
 import System.Environment (lookupEnv)
+import System.Exit (ExitCode(..))
 import System.IO (hPutStrLn, stderr)
+import System.IO.Error (mkIOError, userErrorType)
 import System.IO.Unsafe (unsafePerformIO)
 import System.Posix.DynamicLinker
 import System.Posix.Temp (mkdtemp)
-import System.Process (readProcess)
+import System.Process (readProcessWithExitCode)
 
 
 debug :: Bool
@@ -38,7 +40,21 @@ buildKernel csource funnames = do
              ,"-std=c99", "-x", "c"
              ,"-o", outso, "-"
              ,"-Wall", "-Wextra", "-Wno-unused-variable", "-Wno-unused-parameter"]
-  _ <- readProcess "gcc" args csource
+  (ec, gccStdout, gccStderr) <- readProcessWithExitCode "gcc" args csource
+
+  -- Print the source before the GCC output.
+  case ec of
+    ExitSuccess -> return ()
+    ExitFailure{} -> hPutStrLn stderr $ "[chad] Kernel compilation failed! Source: <<<\n" ++ lineNumbers csource ++ ">>>"
+
+  when (not (null gccStdout)) $
+    hPutStrLn stderr $ "[chad] Kernel compilation: GCC stdout: <<<\n" ++ gccStdout ++ ">>>"
+  when (not (null gccStderr)) $
+    hPutStrLn stderr $ "[chad] Kernel compilation: GCC stderr: <<<\n" ++ gccStderr ++ ">>>"
+
+  case ec of
+    ExitSuccess -> return ()
+    ExitFailure{} -> ioError (mkIOError userErrorType "chad kernel compilation failed" Nothing Nothing)
 
   numLoaded <- atomicModifyIORef' numLoadedCounter (\n -> (n+1, n+1))
   when debug $ hPutStrLn stderr $ "[chad] loading kernel " ++ path ++ " (" ++ show numLoaded ++ " total)"
@@ -72,3 +88,11 @@ getTempDir =
 {-# NOINLINE numLoadedCounter #-}
 numLoadedCounter :: IORef Int
 numLoadedCounter = unsafePerformIO $ newIORef 0
+
+lineNumbers :: String -> String
+lineNumbers str =
+  let lns = lines str
+      numlines = length lns
+      width = length (show numlines)
+      pad s = replicate (width - length s) ' ' ++ s
+  in unlines (zipWith (\i ln -> pad (show i) ++ " | " ++ ln) [1::Int ..] lns)