inline-c 0.9.1.9 → 0.9.1.10
raw patch · 7 files changed
+155/−32 lines, 7 filesdep −Chartdep −Chart-caironew-uploader
Dependencies removed: Chart, Chart-cairo
Files
- changelog.md +5/−0
- examples/gsl-ode.hs +7/−7
- inline-c.cabal +2/−4
- src/Language/C/Inline.hs +1/−0
- src/Language/C/Inline/Context.hs +5/−0
- src/Language/C/Inline/FunPtr.hs +20/−6
- src/Language/C/Inline/Internal.hs +115/−15
changelog.md view
@@ -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.
examples/gsl-ode.hs view
@@ -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])]
inline-c.cabal view
@@ -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 <https://github.com/fpco/inline-c/blob/master/README.md>. 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
src/Language/C/Inline.hs view
@@ -42,6 +42,7 @@ , block , include , verbatim+ , emitBlock -- * 'Ptr' utils , withPtr
src/Language/C/Inline/Context.hs view
@@ -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
src/Language/C/Inline/FunPtr.hs view
@@ -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?
src/Language/C/Inline/Internal.hs view
@@ -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:+ -- <https://github.com/haskell/haskell-language-server/issues/365#issuecomment-976294466>+ -- 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