{-# LANGUAGE CPP #-}
{-# LANGUAGE QuasiQuotes #-}
module Language.Embedded.Backend.C
( module Language.Embedded.Backend.C.Expression
, module Language.Embedded.Backend.C
, Default (..)
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
import Data.Monoid
#endif
import Control.Exception
import Data.Time (getCurrentTime, formatTime, defaultTimeLocale)
import System.Directory (getTemporaryDirectory, removeFile)
import System.Exit (ExitCode (..))
import System.IO
import System.Process (system, readProcess)
import Data.Default.Class
import Data.Loc (noLoc)
import qualified Language.C.Syntax as C
import Text.PrettyPrint.Mainland (pretty)
import Control.Monad.Operational.Higher
import System.IO.Fake
import Language.C.Monad
import Language.Embedded.Backend.C.Expression
namedType :: String -> C.Type
namedType t = C.Type
(C.DeclSpec [] [] (C.Tnamed (C.Id t noLoc) [] noLoc) noLoc)
(C.DeclRoot noLoc)
noLoc
viewNotExp :: C.Exp -> Maybe C.Exp
viewNotExp (C.UnOp C.Lnot a _) = Just a
viewNotExp (C.FnCall (C.Var (C.Id "!" _) _) [a] _) = Just a
viewNotExp _ = Nothing
arrayInit :: [C.Exp] -> C.Initializer
arrayInit as = C.CompoundInitializer
[(Nothing, C.ExpInitializer a noLoc) | a <- as]
noLoc
compile :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>
Program instr (Param2 exp pred) a -> String
compile = snd . head . compileAll
compileAll :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>
Program instr (Param2 exp pred) a -> [(String, String)]
compileAll
= map (("", pretty 80) <*>) . prettyCGen . liftSharedLocals
. wrapMain . interpret
icompile :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>
Program instr (Param2 exp pred) a -> IO ()
icompile prog = case compileAll prog of
[m] -> putStrLn $ snd m
ms -> mapM_ (\(n, m) -> putStrLn ("// module " ++ n) >> putStrLn m) ms
removeFileIfPossible :: FilePath -> IO ()
removeFileIfPossible file =
catch (removeFile file) (\(_ :: SomeException) -> return ())
data ExternalCompilerOpts = ExternalCompilerOpts
{ externalKeepFiles :: Bool
, externalFlagsPre :: [String]
, externalFlagsPost :: [String]
, externalSilent :: Bool
}
instance Default ExternalCompilerOpts
where
def = ExternalCompilerOpts
{ externalKeepFiles = False
, externalFlagsPre = []
, externalFlagsPost = []
, externalSilent = False
}
maybePutStrLn :: Bool -> String -> IO ()
maybePutStrLn False str = putStrLn str
maybePutStrLn _ _ = return ()
compileC :: (Interp instr CGen (Param2 exp pred), HFunctor instr)
=> ExternalCompilerOpts
-> Program instr (Param2 exp pred) a
-> IO FilePath
compileC (ExternalCompilerOpts {..}) prog = do
tmp <- getTemporaryDirectory
t <- fmap (formatTime defaultTimeLocale format) getCurrentTime
(exeFile,exeh) <- openTempFile tmp ("edsl_" ++ t)
hClose exeh
let cFile = exeFile ++ ".c"
writeFile cFile $ compile prog
when externalKeepFiles $ maybePutStrLn externalSilent $
"Created temporary file: " ++ cFile
let compileCMD = unwords
$ ["cc", "-std=c99"]
++ externalFlagsPre
++ [cFile, "-o", exeFile]
++ externalFlagsPost
maybePutStrLn externalSilent compileCMD
exit <- system compileCMD
unless externalKeepFiles $ removeFileIfPossible cFile
case exit of
ExitSuccess -> return exeFile
err -> do removeFileIfPossible exeFile
error "compileC: failed to compile generated C code"
where
format = if externalKeepFiles then "%a-%H-%M-%S_" else ""
compileAndCheck' :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>
ExternalCompilerOpts -> Program instr (Param2 exp pred) a -> IO ()
compileAndCheck' opts prog = do
let opts' = opts {externalFlagsPre = "-c" : externalFlagsPre opts}
exe <- compileC opts' prog
removeFileIfPossible exe
compileAndCheck :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>
Program instr (Param2 exp pred) a -> IO ()
compileAndCheck = compileAndCheck' def
runCompiled' :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>
ExternalCompilerOpts -> Program instr (Param2 exp pred) a -> IO ()
runCompiled' opts@(ExternalCompilerOpts {..}) prog = bracket
(compileC opts prog)
removeFileIfPossible
( \exe -> do
maybePutStrLn externalSilent ""
maybePutStrLn externalSilent "#### Running:"
system exe >> return ()
)
runCompiled :: (Interp instr CGen (Param2 exp pred), HFunctor instr) =>
Program instr (Param2 exp pred) a -> IO ()
runCompiled = runCompiled' def
withCompiled' :: (Interp instr CGen (Param2 exp pred), HFunctor instr)
=> ExternalCompilerOpts
-> Program instr (Param2 exp pred) a
-> ((String -> IO String) -> IO b)
-> IO b
withCompiled' opts prog body = bracket
(compileC opts prog)
removeFileIfPossible
(\exe -> body $ readProcess exe [])
withCompiled :: (Interp instr CGen (Param2 exp pred), HFunctor instr)
=> Program instr (Param2 exp pred) a
-> ((String -> IO String) -> IO b)
-> IO b
withCompiled = withCompiled' def {externalSilent = True}
captureCompiled' :: (Interp instr CGen (Param2 exp pred), HFunctor instr)
=> ExternalCompilerOpts
-> Program instr (Param2 exp pred) a
-> String
-> IO String
captureCompiled' opts prog inp = withCompiled' opts prog ($ inp)
captureCompiled :: (Interp instr CGen (Param2 exp pred), HFunctor instr)
=> Program instr (Param2 exp pred) a
-> String
-> IO String
captureCompiled = captureCompiled' def
compareCompiled' :: (Interp instr CGen (Param2 exp pred), HFunctor instr)
=> ExternalCompilerOpts
-> Program instr (Param2 exp pred) a
-> IO a
-> String
-> IO ()
compareCompiled' opts@(ExternalCompilerOpts {..}) prog ref inp = do
maybePutStrLn externalSilent "#### Reference program:"
outRef <- fakeIO ref inp
maybePutStrLn externalSilent outRef
maybePutStrLn externalSilent "#### runCompiled:"
outComp <- captureCompiled' opts prog inp
maybePutStrLn externalSilent outComp
if outRef /= outComp
then error "runCompiled differs from reference program"
else maybePutStrLn externalSilent
" -- runCompiled is consistent with reference program\n\n\n\n"
compareCompiled :: (Interp instr CGen (Param2 exp pred), HFunctor instr)
=> Program instr (Param2 exp pred) a
-> IO a
-> String
-> IO ()
compareCompiled = compareCompiled' def