diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,8 @@ +- 0.9.1.10: + * Add -fcompact-unwind for darwin exceptions(#131). + * Fix Cpp.Exception error message line numbers(#133). + * Skip generating foreign calls under ghcide(HSL), generate stubs instead(#128). + * Add ctxRawObjectCompile option to support CUDA(#147). - 0.9.1.8: Tighten ansi-wl-pprint upper bound, see issue #144. - 0.9.1.7: Allow arbitrary number of C++ templates, see PR #141. - 0.9.1.6: Fix mistakenly unsafe call, see issue #137. diff --git a/examples/gsl-ode.hs b/examples/gsl-ode.hs --- a/examples/gsl-ode.hs +++ b/examples/gsl-ode.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiWayIf #-} -import Data.Coerce (coerce) +import Unsafe.Coerce (unsafeCoerce) import Data.Monoid ((<>)) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as VM @@ -11,11 +11,11 @@ import Foreign.ForeignPtr (newForeignPtr_) import Foreign.Ptr (Ptr) import Foreign.Storable (Storable) -import qualified Graphics.Rendering.Chart.Backend.Cairo as Chart -import qualified Graphics.Rendering.Chart.Easy as Chart import qualified Language.C.Inline as C import qualified Language.C.Inline.Unsafe as CU import System.IO.Unsafe (unsafePerformIO) +import Control.Monad (forM_) +import System.IO (withFile, hPutStrLn, IOMode(..)) C.context (C.baseCtx <> C.vecCtx <> C.funCtx) @@ -94,7 +94,7 @@ -> Either String (V.Vector Double) -- ^ Solution at end point, or error. solveOde fun x0 f0 xend = - coerce $ solveOdeC (coerce fun) (coerce x0) (coerce f0) (coerce xend) + unsafeCoerce $ solveOdeC (unsafeCoerce fun) (unsafeCoerce x0) (unsafeCoerce f0) (unsafeCoerce xend) lorenz :: Double @@ -121,9 +121,9 @@ ] main :: IO () -main = Chart.toFile Chart.def "lorenz.png" $ do - Chart.layout_title Chart..= "Lorenz" - Chart.plot $ Chart.line "curve" [pts] +main = withFile "lorenz.csv" WriteMode $ \h -> + forM_ pts $ \(x,y) -> + hPutStrLn h $ show x ++ ", " ++ show y where pts = [(f V.! 0, f V.! 2) | (_x, f) <- go 0 (V.fromList [10.0 , 1.0 , 1.0])] 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.9.1.9 +version: 0.9.1.10 synopsis: Write Haskell source files including C code inline. No FFI required. description: See . license: MIT @@ -8,7 +8,7 @@ maintainer: f@mazzo.li copyright: (c) 2015-2016 FP Complete Corporation, (c) 2017-2019 Francesco Mazzoli category: FFI -tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.2, GHC == 9.2.7 +tested-with: GHC == 9.2.8, GHC == 9.4.7, GHC == 9.6.2 build-type: Simple cabal-version: >=1.10 Extra-Source-Files: README.md, changelog.md @@ -88,7 +88,5 @@ build-depends: base >=4 && <5 , inline-c , vector - , Chart >= 1.3 - , Chart-cairo else buildable: False 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 @@ -42,6 +42,7 @@ , block , include , verbatim + , emitBlock -- * 'Ptr' utils , withPtr 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 @@ -161,6 +161,8 @@ , ctxForeignSrcLang :: Maybe TH.ForeignSrcLang -- ^ TH.LangC by default , ctxEnableCpp :: Bool + -- ^ Compile source code to raw object. + , ctxRawObjectCompile :: Maybe (String -> TH.Q FilePath) } @@ -172,6 +174,7 @@ , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2 , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2 , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2 + , ctxRawObjectCompile = ctxRawObjectCompile ctx1 <|> ctxRawObjectCompile ctx2 } #endif @@ -182,6 +185,7 @@ , ctxOutput = Nothing , ctxForeignSrcLang = Nothing , ctxEnableCpp = False + , ctxRawObjectCompile = Nothing } #if !MIN_VERSION_base(4,11,0) @@ -191,6 +195,7 @@ , ctxOutput = ctxOutput ctx1 <|> ctxOutput ctx2 , ctxForeignSrcLang = ctxForeignSrcLang ctx1 <|> ctxForeignSrcLang ctx2 , ctxEnableCpp = ctxEnableCpp ctx1 || ctxEnableCpp ctx2 + , ctxRawObjectCompile = ctxRawObjectCompile ctx1 <|> ctxRawObjectCompile ctx2 } #endif 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 @@ -9,7 +9,9 @@ , uniqueFfiImportName ) where +import Data.Maybe (isJust) import Foreign.Ptr (FunPtr) +import System.Environment (lookupEnv) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH @@ -27,9 +29,15 @@ mkFunPtr :: TH.TypeQ -> TH.ExpQ mkFunPtr hsTy = do ffiImportName <- uniqueFfiImportName - dec <- TH.forImpD TH.CCall TH.Safe "wrapper" ffiImportName [t| $(hsTy) -> IO (FunPtr $(hsTy)) |] - TH.addTopDecls [dec] - TH.varE ffiImportName + -- See note [ghcide-support] + usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__" + if usingGhcide + then do + [e|error "inline-c: A 'usingGhcide' mkFunPtr stub was evaluated -- this should not happen" :: $(hsTy) -> IO (FunPtr $(hsTy)) |] + else do -- Actual foreign function call generation. + dec <- TH.forImpD TH.CCall TH.Safe "wrapper" ffiImportName [t| $(hsTy) -> IO (FunPtr $(hsTy)) |] + TH.addTopDecls [dec] + TH.varE ffiImportName -- | @$('mkFunPtrFromName' 'foo)@, if @foo :: 'CDouble' -> 'IO' -- 'CDouble'@, splices in an expression of type @'IO' ('FunPtr' @@ -56,9 +64,15 @@ peekFunPtr :: TH.TypeQ -> TH.ExpQ peekFunPtr hsTy = do ffiImportName <- uniqueFfiImportName - dec <- TH.forImpD TH.CCall TH.Safe "dynamic" ffiImportName [t| FunPtr $(hsTy) -> $(hsTy) |] - TH.addTopDecls [dec] - TH.varE ffiImportName + usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__" + -- See note [ghcide-support] + if usingGhcide + then do + [e|error "inline-c: A 'usingGhcide' peekFunPtr stub was evaluated -- this should not happen" :: FunPtr $(hsTy) -> $(hsTy) |] + else do -- Actual foreign function call generation. + dec <- TH.forImpD TH.CCall TH.Safe "dynamic" ffiImportName [t| FunPtr $(hsTy) -> $(hsTy) |] + TH.addTopDecls [dec] + TH.varE ffiImportName -- TODO absurdly, I need to 'newName' twice for things to work. I found -- this hack in language-c-inline. Why is this? 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 @@ -32,6 +32,7 @@ -- ** Emitting C code , emitVerbatim + , emitBlock -- ** Inlining C code -- $embedding @@ -53,6 +54,11 @@ , runParserInQ , splitTypedC + -- * Line directives + , lineDirective + , here + , shiftLines + -- * Utility functions for writing quasiquoters , genericQuote , funPtrQuote @@ -64,12 +70,13 @@ import Control.Monad.Trans.Class (lift) import Data.Foldable (forM_) import qualified Data.Map as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Traversable (for) import Data.Typeable (Typeable, cast) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as TH import qualified Language.Haskell.TH.Syntax as TH +import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO, unsafeDupablePerformIO) import qualified Text.Parsec as Parsec import qualified Text.Parsec.Pos as Parsec @@ -163,11 +170,16 @@ Nothing -> fail "inline-c: ModuleState not present (initialiseModuleState)" Just ms -> return ms let lang = fromMaybe TH.LangC (ctxForeignSrcLang context) + addForeignSource = #if MIN_VERSION_base(4,12,0) - TH.addForeignSource lang (concat (reverse (msFileChunks ms))) + TH.addForeignSource #else - TH.addForeignFile lang (concat (reverse (msFileChunks ms))) + TH.addForeignFile #endif + src = (concat (reverse (msFileChunks ms))) + case (lang, ctxRawObjectCompile context) of + (TH.RawObject, Just compile) -> compile src >>= TH.addForeignFilePath lang + (_, _) -> addForeignSource lang src let moduleState = ModuleState { msContext = context , msGeneratedNames = 0 @@ -229,6 +241,15 @@ (ms{msFileChunks = chunk : msFileChunks ms}, ()) return [] +-- | Simply appends some string of block to the module's C file. Use with care. +emitBlock :: TH.QuasiQuoter +emitBlock = TH.QuasiQuoter + { TH.quoteExp = const $ fail "inline-c: quoteExp not implemented (quoteCode)" + , TH.quotePat = const $ fail "inline-c: quotePat not implemented (quoteCode)" + , TH.quoteType = const $ fail "inline-c: quoteType not implemented (quoteCode)" + , TH.quoteDec = emitVerbatim + } + ------------------------------------------------------------------------ -- Inlining @@ -295,16 +316,26 @@ -- Write out definitions ctx <- getContext let out = fromMaybe id $ ctxOutput ctx - let directive = maybe "" (\l -> "#line " ++ show (fst $ TH.loc_start l) ++ " " ++ show (TH.loc_filename l ) ++ "\n") codeLoc + let directive = maybe "" lineDirective codeLoc void $ emitVerbatim $ out $ directive ++ codeDefs -- Create and add the FFI declaration. ffiImportName <- uniqueFfiImportName - dec <- if codeFunPtr - then - TH.forImpD TH.CCall codeCallSafety ("&" ++ codeFunName) ffiImportName [t| FunPtr $(codeType) |] - else TH.forImpD TH.CCall codeCallSafety codeFunName ffiImportName codeType - TH.addTopDecls [dec] - TH.varE ffiImportName + -- Note [ghcide-support] + -- haskell-language-server / ghcide cannot handle code that use + -- `addForeignFile`/`addForeignSource` as we do here; it will result + -- in linker errors during TH evaluations, see: + -- + -- Thus for GHCIDE, simply generate a call to `error` instead of a call to a foreign import. + usingGhcide <- TH.runIO $ isJust <$> lookupEnv "__GHCIDE__" + if usingGhcide + then do + [e|error "inline-c: A 'usingGhcide' inlineCode stub was evaluated -- this should not happen" :: $(if codeFunPtr then [t| FunPtr $(codeType) |] else codeType) |] + else do -- Actual foreign function call generation. + dec <- if codeFunPtr + then TH.forImpD TH.CCall codeCallSafety ("&" ++ codeFunName) ffiImportName [t| FunPtr $(codeType) |] + else TH.forImpD TH.CCall codeCallSafety codeFunName ffiImportName codeType + TH.addTopDecls [dec] + TH.varE ffiImportName uniqueCName :: Maybe String -> TH.Q String uniqueCName mbPostfix = do @@ -681,14 +712,37 @@ go (paramType : params) = do [t| $(return paramType) -> $(go params) |] -splitTypedC :: String -> (String, String) - -- ^ Returns the type and the body separately -splitTypedC s = (trim ty, case body of - [] -> [] - r -> r) + +-- NOTE: splitTypedC wouldn't be necessary if inline-c-cpp could reuse C.block +-- internals with a clean interface. +-- This would be a significant refactoring but presumably it would lead to an +-- api that could let users write their own quasiquoters a bit more conveniently. + +-- | Returns the type and the body separately. +splitTypedC :: String -> (String, String, Int) +splitTypedC s = (trim ty, bodyIndent <> body, bodyLineShift) where (ty, body) = span (/= '{') s trim x = L.dropWhileEnd C.isSpace (dropWhile C.isSpace x) + -- We may need to correct the line number of the body + bodyLineShift = length (filter (== '\n') ty) + + -- Indentation is relevant for error messages when the syntax is: + -- [C.foo| type + -- { foo(); } + -- |] + bodyIndent = + let precedingSpaceReversed = + takeWhile (\c -> C.isSpace c) $ + reverse $ + ty + (precedingSpacesTabsReversed, precedingLine) = + span (`notElem` ("\n\r" :: [Char])) precedingSpaceReversed + in case precedingLine of + ('\n':_) -> reverse precedingSpacesTabsReversed + ('\r':_) -> reverse precedingSpacesTabsReversed + _ -> "" -- it wasn't indentation after all; just spaces after the type + -- | Data to parse for the 'funPtr' quasi-quoter. data FunPtrDecl = FunPtrDecl { funPtrReturnType :: C.Type C.CIdentifier @@ -755,6 +809,52 @@ return ("}" ++ s') ] return (s ++ s') + +------------------------------------------------------------------------ +-- Line directives + +-- | Tell the C compiler where the next line came from. +-- +-- Example: +-- +-- @@@ +-- there <- location +-- f (unlines +-- [ lineDirective $(here) +-- , "generated_code_user_did_not_write()" +-- , lineDirective there +-- ] ++ userCode +-- ]) +-- @@@ +-- +-- Use @lineDirective $(C.here)@ when generating code, so that any errors or +-- warnings report the location of the generating haskell module, rather than +-- tangentially related user code that doesn't contain the actual problem. +lineDirective :: TH.Loc -> String +lineDirective l = "#line " ++ show (fst $ TH.loc_start l) ++ " " ++ show (TH.loc_filename l ) ++ "\n" + +-- | Get the location of the code you're looking at, for use with +-- 'lineDirective'; place before generated code that user did not write. +here :: TH.ExpQ +here = [| $(TH.location >>= \(TH.Loc a b c (d1, d2) (e1, e2)) -> + [|Loc + $(TH.lift a) + $(TH.lift b) + $(TH.lift c) + ($(TH.lift d1), $(TH.lift d2)) + ($(TH.lift e1), $(TH.lift e2)) + |]) + |] + +shiftLines :: Int -> TH.Loc -> TH.Loc +shiftLines n l = l + { TH.loc_start = + let (startLn, startCol) = TH.loc_start l + in (startLn + n, startCol) + , TH.loc_end = + let (endLn, endCol) = TH.loc_end l + in (endLn + n, endCol) + } ------------------------------------------------------------------------ -- Utils