diff options
Diffstat (limited to 'src/Compile')
| -rw-r--r-- | src/Compile/Exec.hs | 56 |
1 files changed, 42 insertions, 14 deletions
diff --git a/src/Compile/Exec.hs b/src/Compile/Exec.hs index 83ce4ff..9b9fb15 100644 --- a/src/Compile/Exec.hs +++ b/src/Compile/Exec.hs @@ -4,31 +4,34 @@ module Compile.Exec ( KernelLib, buildKernel, callKernelFun, + + -- * misc + lineNumbers, ) where import Control.Monad (when) import Data.IORef -import qualified Data.Map.Strict as Map -import Data.Map.Strict (Map) 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 debug = False -- The IORef wrapper is required for the finalizer to attach properly (see the 'Weak' docs) -data KernelLib = KernelLib !(IORef (Map String (FunPtr (Ptr () -> IO ())))) +data KernelLib = KernelLib !(IORef (FunPtr (Ptr () -> IO ()))) -buildKernel :: String -> [String] -> IO KernelLib -buildKernel csource funnames = do +buildKernel :: String -> String -> IO KernelLib +buildKernel csource funname = do template <- (++ "/tmp.chad.") <$> getTempDir path <- mkdtemp template @@ -37,8 +40,26 @@ buildKernel csource funnames = do ,"-shared", "-fPIC" ,"-std=c99", "-x", "c" ,"-o", outso, "-" - ,"-Wall", "-Wextra", "-Wno-unused-variable", "-Wno-unused-parameter"] - _ <- readProcess "gcc" args csource + ,"-Wall", "-Wextra" + ,"-Wno-unused-variable", "-Wno-unused-but-set-variable" + ,"-Wno-unused-parameter", "-Wno-unused-function"] + (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{} -> do + removeDirectoryRecursive path + 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)" @@ -46,8 +67,7 @@ buildKernel csource funnames = do removeDirectoryRecursive path -- we keep a reference anyway because we have the file open now - ptrs <- Map.fromList <$> sequence [(name,) <$> dlsym dl name | name <- funnames] - ref <- newIORef ptrs + ref <- newIORef =<< dlsym dl funname _ <- mkWeakIORef ref (do numLeft <- atomicModifyIORef' numLoadedCounter (\n -> (n-1, n-1)) when debug $ hPutStrLn stderr $ "[chad] unloading kernel " ++ path ++ " (" ++ show numLeft ++ " left)" dlclose dl) @@ -58,10 +78,10 @@ foreign import ccall "dynamic" -- Ensure that keeping a reference to the returned function also keeps the 'KernelLib' alive {-# NOINLINE callKernelFun #-} -callKernelFun :: String -> KernelLib -> Ptr () -> IO () -callKernelFun key (KernelLib ref) arg = do - mp <- readIORef ref - wrapKernelFun (mp Map.! key) arg +callKernelFun :: KernelLib -> Ptr () -> IO () +callKernelFun (KernelLib ref) arg = do + ptr <- readIORef ref + wrapKernelFun ptr arg getTempDir :: IO FilePath getTempDir = @@ -72,3 +92,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) |