diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,6 @@ +- 0.5.3.3: + * Fix errors when using parallel builds. See issue #22. + * Use `fail` rather than `error` in the `Q` monad. - 0.5.3.2: Make type errors with default anti-quoter much saner. - 0.5.3.1: Fix leak of `FunPtr` when using `funCtx`. - 0.5.3.0: Recognize more standard library types. See pull request #19. diff --git a/inline-c.cabal b/inline-c.cabal --- a/inline-c.cabal +++ b/inline-c.cabal @@ -1,5 +1,5 @@ name: inline-c -version: 0.5.3.2 +version: 0.5.3.3 synopsis: Write Haskell source files including C code inline. No FFI required. description: See . license: MIT diff --git a/src/Language/C/Inline.hs b/src/Language/C/Inline.hs --- a/src/Language/C/Inline.hs +++ b/src/Language/C/Inline.hs @@ -264,7 +264,7 @@ -- @ include :: String -> TH.DecsQ include s - | null s = error "inline-c: empty string (include)" + | null s = fail "inline-c: empty string (include)" | head s == '<' = verbatim $ "#include " ++ s | otherwise = verbatim $ "#include \"" ++ s ++ "\"" diff --git a/src/Language/C/Inline/Context.hs b/src/Language/C/Inline/Context.hs --- a/src/Language/C/Inline/Context.hs +++ b/src/Language/C/Inline/Context.hs @@ -272,15 +272,15 @@ getHsVariable err s = do mbHsName <- TH.lookupValueName s case mbHsName of - Nothing -> error $ "Cannot capture Haskell variable " ++ s ++ - ", because it's not in scope. (" ++ err ++ ")" + Nothing -> fail $ "Cannot capture Haskell variable " ++ s ++ + ", because it's not in scope. (" ++ err ++ ")" Just hsName -> TH.varE hsName convertType_ :: String -> Purity -> TypesTable -> C.Type -> TH.Q TH.Type convertType_ err purity cTypes cTy = do mbHsType <- convertType purity cTypes cTy case mbHsType of - Nothing -> error $ "Cannot convert C type (" ++ err ++ ")" + Nothing -> fail $ "Cannot convert C type (" ++ err ++ ")" Just hsType -> return hsType -- | This 'Context' includes a 'AntiQuoter' that removes the need for @@ -305,7 +305,7 @@ { aqParser = do cTy <- Parser.parens C.parseParameterDeclaration case C.parameterDeclarationId cTy of - Nothing -> error "Every captured function must be named (funCtx)" + Nothing -> fail "Every captured function must be named (funCtx)" Just id' -> do let s = C.unIdentifier id' return (s, C.parameterDeclarationType cTy, s) @@ -321,7 +321,7 @@ return x |] return (hsTy, hsExp') - _ -> error "The `fun' marshaller captures function pointers only" + _ -> fail "The `fun' marshaller captures function pointers only" } -- | This 'Context' includes two 'AntiQuoter's that allow to easily use @@ -371,7 +371,7 @@ { aqParser = do cTy <- Parser.parens C.parseParameterDeclaration case C.parameterDeclarationId cTy of - Nothing -> error "Every captured vector must be named (vecCtx)" + Nothing -> fail "Every captured vector must be named (vecCtx)" Just id' -> do let s = C.unIdentifier id' return (s, C.parameterDeclarationType cTy, s) @@ -397,7 +397,7 @@ hsExp'' <- [| \cont -> cont $(return hsExp') |] return (hsTy, hsExp'') _ -> do - error "impossible: got type different from `long' (vecCtx)" + fail "impossible: got type different from `long' (vecCtx)" } @@ -427,7 +427,7 @@ hsExp' <- [| \cont -> BS.unsafeUseAsCString $(return hsExp) $ \ptr -> cont ptr |] return (hsTy, hsExp') _ -> - error "impossible: got type different from `unsigned char' (bsCtx)" + fail "impossible: got type different from `unsigned char' (bsCtx)" } bsLenAntiQuoter :: AntiQuoter String @@ -445,5 +445,5 @@ hsExp'' <- [| \cont -> cont $(return hsExp') |] return (hsTy, hsExp'') _ -> do - error "impossible: got type different from `long' (bsCtx)" + fail "impossible: got type different from `long' (bsCtx)" } diff --git a/src/Language/C/Inline/FunPtr.hs b/src/Language/C/Inline/FunPtr.hs --- a/src/Language/C/Inline/FunPtr.hs +++ b/src/Language/C/Inline/FunPtr.hs @@ -38,7 +38,7 @@ i <- TH.reify name case i of TH.VarI _ ty _ _ -> [| $(mkFunPtr (return ty)) $(TH.varE name) |] - _ -> error "mkFunPtrFromName: expecting a variable as argument." + _ -> fail "mkFunPtrFromName: expecting a variable as argument." -- | @$('peekFunPtr' [t| 'CDouble' -> 'IO' 'CDouble' |])@ generates a foreign import -- dynamic of type diff --git a/src/Language/C/Inline/Internal.hs b/src/Language/C/Inline/Internal.hs --- a/src/Language/C/Inline/Internal.hs +++ b/src/Language/C/Inline/Internal.hs @@ -48,14 +48,14 @@ ) where import Control.Applicative +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, readMVar) import Control.Exception (catch, throwIO) -import Control.Monad (forM, void, msum, when, unless) +import Control.Monad (forM, void, msum, unless) import Control.Monad.State (evalStateT, StateT, get, put) import Control.Monad.Trans.Class (lift) import qualified Crypto.Hash as CryptoHash import qualified Data.Binary as Binary import Data.Foldable (forM_) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) import qualified Data.Map as Map import Data.Maybe (fromMaybe) import Data.Typeable (Typeable, cast) @@ -80,17 +80,30 @@ import Language.C.Inline.FunPtr data ModuleState = ModuleState - { msModuleName :: String - , msContext :: Context + { msContext :: Context , msGeneratedNames :: Int } -{-# NOINLINE moduleStateRef #-} -moduleStateRef :: IORef (Maybe ModuleState) -moduleStateRef = unsafePerformIO $ newIORef Nothing +-- | Identifier for the current module. Currently we use the file name. +-- Since we're pairing Haskell files with C files, it makes more sense +-- to use the file name. I'm not sure if it's possible to compile two +-- modules with the same name in one run of GHC, but in this way we make +-- sure that we don't run into trouble even it is. +type ModuleId = String --- | Make sure that 'moduleStateRef' and the respective C file are up --- to date. +getModuleId :: TH.Q ModuleId +getModuleId = TH.loc_filename <$> TH.location + +-- | 'MVar' storing the state for all the modules we visited. Note that +-- currently we do not bother with cleaning up the state after we're +-- done compiling a module. TODO if there is an easy way, clean up the +-- state. +{-# NOINLINE moduleStatesVar #-} +moduleStatesVar :: MVar (Map.Map ModuleId ModuleState) +moduleStatesVar = unsafePerformIO $ newMVar Map.empty + +-- | Make sure that 'moduleStatesVar' and the respective C file are up +-- to date. initialiseModuleState :: Maybe Context -- ^ The 'Context' to use if we initialise the module. If 'Nothing', @@ -98,23 +111,20 @@ -> TH.Q Context initialiseModuleState mbContext = do cFile <- cSourceLoc context - mbModuleState <- TH.runIO $ readIORef moduleStateRef - thisModule <- TH.loc_module <$> TH.location - let recordThisModule = TH.runIO $ do + thisModule <- getModuleId + TH.runIO $ modifyMVar moduleStatesVar $ \moduleStates -> do + case Map.lookup thisModule moduleStates of + Just moduleState -> return (moduleStates, msContext moduleState) + Nothing -> do -- If the file exists and this is the first time we write -- something from this module (in other words, if we are -- recompiling the module), kill the file first. removeIfExists cFile - writeIORef moduleStateRef $ Just ModuleState - { msModuleName = thisModule - , msContext = context - , msGeneratedNames = 0 - } - return context - case mbModuleState of - Nothing -> recordThisModule - Just ms | msModuleName ms == thisModule -> return $ msContext ms - Just _ms -> recordThisModule + let moduleState = ModuleState + { msContext = context + , msGeneratedNames = 0 + } + return (Map.insert thisModule moduleState moduleStates, context) where context = fromMaybe baseCtx mbContext @@ -123,14 +133,15 @@ getContext :: TH.Q Context getContext = initialiseModuleState Nothing -getModuleState :: TH.Q ModuleState -getModuleState = do - mbModuleState <- TH.runIO $ readIORef moduleStateRef - thisModule <- TH.loc_module <$> TH.location - case mbModuleState of - Nothing -> error "inline-c: ModuleState not present" - Just ms | msModuleName ms == thisModule -> return ms - Just _ms -> error "inline-c: stale ModuleState" +modifyModuleState :: (ModuleState -> (ModuleState, a)) -> TH.Q a +modifyModuleState f = do + thisModule <- getModuleId + TH.runIO $ modifyMVar moduleStatesVar $ \moduleStates -> + case Map.lookup thisModule moduleStates of + Nothing -> fail "inline-c: ModuleState not present" + Just ms -> do + let (ms', x) = f ms + return (Map.insert thisModule ms' moduleStates, x) -- $context -- @@ -144,20 +155,17 @@ -- module. Fails if that's not the case. setContext :: Context -> TH.Q () setContext ctx = do - mbModuleState <- TH.runIO $ readIORef moduleStateRef - forM_ mbModuleState $ \ms -> do - thisModule <- TH.loc_module <$> TH.location - when (msModuleName ms == thisModule) $ - error "inline-c: The module has already been initialised (setContext)." + thisModule <- getModuleId + moduleStates <- TH.runIO $ readMVar moduleStatesVar + forM_ (Map.lookup thisModule moduleStates) $ \_ms -> + fail "inline-c: The module has already been initialised (setContext)." void $ initialiseModuleState $ Just ctx bumpGeneratedNames :: TH.Q Int bumpGeneratedNames = do - ms <- getModuleState - TH.runIO $ do + modifyModuleState $ \ms -> let c' = msGeneratedNames ms - writeIORef moduleStateRef $ Just ms{msGeneratedNames = c' + 1} - return c' + in (ms{msGeneratedNames = c' + 1}, c') ------------------------------------------------------------------------ -- Emitting @@ -335,7 +343,7 @@ case C.runCParser isTypeName' (TH.loc_filename loc) s p' of Left err -> do -- TODO consider prefixing with "error while parsing C" or similar - error $ show err + fail $ show err Right res -> do return res @@ -436,9 +444,9 @@ -> TH.QuasiQuoter quoteCode p = TH.QuasiQuoter { TH.quoteExp = p - , TH.quotePat = error "inline-c: quotePat not implemented (quoteCode)" - , TH.quoteType = error "inline-c: quoteType not implemented (quoteCode)" - , TH.quoteDec = error "inline-c: quoteDec not implemented (quoteCode)" + , TH.quotePat = fail "inline-c: quotePat not implemented (quoteCode)" + , TH.quoteType = fail "inline-c: quoteType not implemented (quoteCode)" + , TH.quoteDec = fail "inline-c: quoteDec not implemented (quoteCode)" } genericQuote @@ -459,8 +467,8 @@ mbHsName <- TH.lookupValueName s' hsExp <- case mbHsName of Nothing -> do - error $ "Cannot capture Haskell variable " ++ s' ++ - ", because it's not in scope. (genericQuote)" + fail $ "Cannot capture Haskell variable " ++ s' ++ + ", because it's not in scope. (genericQuote)" Just hsName -> do hsExp <- TH.varE hsName [| \cont -> cont ($(return hsExp) :: $(return hsTy)) |] @@ -468,12 +476,12 @@ AntiQuote antiId dyn -> do case Map.lookup antiId (ctxAntiQuoters ctx) of Nothing -> - error $ "IMPOSSIBLE: could not find anti-quoter " ++ show antiId ++ - ". (genericQuote)" + fail $ "IMPOSSIBLE: could not find anti-quoter " ++ show antiId ++ + ". (genericQuote)" Just (SomeAntiQuoter antiQ) -> case fromSomeEq dyn of Nothing -> - error $ "IMPOSSIBLE: could not cast value for anti-quoter " ++ - show antiId ++ ". (genericQuote)" + fail $ "IMPOSSIBLE: could not cast value for anti-quoter " ++ + show antiId ++ ". (genericQuote)" Just x -> aqMarshaller antiQ purity (ctxTypesTable ctx) cTy x let hsFunType = convertCFunSig hsType $ map fst hsParams @@ -488,7 +496,7 @@ cToHs ctx cTy = do mbHsTy <- convertType purity (ctxTypesTable ctx) cTy case mbHsTy of - Nothing -> error $ "Could not resolve Haskell type for C type " ++ pretty80 cTy + Nothing -> fail $ "Could not resolve Haskell type for C type " ++ pretty80 cTy Just hsTy -> return hsTy buildFunCall :: Context -> TH.ExpQ -> [TH.Exp] -> [TH.Name] -> TH.ExpQ