From ff47e1a8f7c8305bd6674ad42c425240f611c17d Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Fri, 9 Aug 2024 19:26:12 +0200 Subject: [PATCH] Support typed folds over the Clang AST --- hs-bindgen-patterns/hs-bindgen-patterns.cabal | 3 +- hs-bindgen-patterns/src/HsBindgen/Patterns.hs | 18 +-- .../Patterns/{Stack.hs => Backtrace.hs} | 51 +++--- .../src/HsBindgen/Patterns/SafeForeignPtr.hs | 110 ------------- hs-bindgen/cbits/clang_wrappers.c | 12 +- hs-bindgen/cbits/clang_wrappers.h | 5 +- hs-bindgen/hs-bindgen.cabal | 1 + hs-bindgen/src/HsBindgen/C/AST.hs | 16 ++ hs-bindgen/src/HsBindgen/C/Clang.hs | 145 ++++++++++-------- hs-bindgen/src/HsBindgen/C/Clang/Fold.hs | 138 +++++++++++++++++ hs-bindgen/src/HsBindgen/C/Parser.hs | 74 ++++++--- 11 files changed, 328 insertions(+), 245 deletions(-) rename hs-bindgen-patterns/src/HsBindgen/Patterns/{Stack.hs => Backtrace.hs} (51%) delete mode 100644 hs-bindgen-patterns/src/HsBindgen/Patterns/SafeForeignPtr.hs create mode 100644 hs-bindgen/src/HsBindgen/C/Clang/Fold.hs diff --git a/hs-bindgen-patterns/hs-bindgen-patterns.cabal b/hs-bindgen-patterns/hs-bindgen-patterns.cabal index b24586cc..60cc90fb 100644 --- a/hs-bindgen-patterns/hs-bindgen-patterns.cabal +++ b/hs-bindgen-patterns/hs-bindgen-patterns.cabal @@ -34,9 +34,8 @@ library exposed-modules: HsBindgen.Patterns other-modules: + HsBindgen.Patterns.Backtrace HsBindgen.Patterns.Enum.Bitfield HsBindgen.Patterns.Enum.Simple - HsBindgen.Patterns.SafeForeignPtr - HsBindgen.Patterns.Stack hs-source-dirs: src diff --git a/hs-bindgen-patterns/src/HsBindgen/Patterns.hs b/hs-bindgen-patterns/src/HsBindgen/Patterns.hs index ea617779..5302582e 100644 --- a/hs-bindgen-patterns/src/HsBindgen/Patterns.hs +++ b/hs-bindgen-patterns/src/HsBindgen/Patterns.hs @@ -21,21 +21,13 @@ module HsBindgen.Patterns ( , bitfieldEnum , fromBitfieldEnum , flagIsSet - -- * Foreign pointers - , SafeForeignPtr - , AccessedFinalizedForeignPtrException - -- ** API - , newSafeForeignPtr - , withSafeForeignPtr - , finalizeSafeForeignPtr -- * Backtrace - , Stack - , getStack - , prettyStack - , ContainsStack(..) + , Backtrace + , collectBacktrace + , prettyBacktrace + , CollectedBacktrace(..) ) where +import HsBindgen.Patterns.Backtrace import HsBindgen.Patterns.Enum.Bitfield import HsBindgen.Patterns.Enum.Simple -import HsBindgen.Patterns.SafeForeignPtr -import HsBindgen.Patterns.Stack diff --git a/hs-bindgen-patterns/src/HsBindgen/Patterns/Stack.hs b/hs-bindgen-patterns/src/HsBindgen/Patterns/Backtrace.hs similarity index 51% rename from hs-bindgen-patterns/src/HsBindgen/Patterns/Stack.hs rename to hs-bindgen-patterns/src/HsBindgen/Patterns/Backtrace.hs index f056f95b..4cb62a12 100644 --- a/hs-bindgen-patterns/src/HsBindgen/Patterns/Stack.hs +++ b/hs-bindgen-patterns/src/HsBindgen/Patterns/Backtrace.hs @@ -1,11 +1,11 @@ {-# LANGUAGE CPP #-} --- | Shim to provide stack support -module HsBindgen.Patterns.Stack ( - Stack - , prettyStack - , getStack - , ContainsStack(..) +-- | Shim to provide backtrace support +module HsBindgen.Patterns.Backtrace ( + Backtrace + , prettyBacktrace + , collectBacktrace + , CollectedBacktrace(..) ) where import Control.Exception @@ -24,35 +24,35 @@ import Control.Exception.Backtrace -- Take advantage of the new backtrace support in ghc 9.10 and up. -newtype Stack = WrapStack { +newtype Backtrace = WrapStack { unwrapStack :: Backtraces } -instance Show Stack where - show = prettyStack +instance Show Backtrace where + show = prettyBacktrace -prettyStack :: Stack -> String -prettyStack = displayBacktraces . unwrapStack +prettyBacktrace :: Backtrace -> String +prettyBacktrace = displayBacktraces . unwrapStack -getStack :: HasCallStack => IO Stack -getStack = WrapStack <$> collectBacktraces +collectBacktrace :: HasCallStack => IO Backtrace +collectBacktrace = WrapStack <$> collectBacktraces #else -- For older ghc (< 9.10), we just use the 'CallStack'. -newtype Stack = WrapStack { +newtype Backtrace = WrapStack { unwrapStack :: CallStack } -instance Show Stack where - show = prettyStack +instance Show Backtrace where + show = prettyBacktrace -prettyStack :: Stack -> String -prettyStack = prettyCallStack . unwrapStack +prettyBacktrace :: Backtrace -> String +prettyBacktrace = prettyCallStack . unwrapStack -getStack :: HasCallStack => IO Stack -getStack = return $ WrapStack callStack +collectBacktrace :: HasCallStack => IO Backtrace +collectBacktrace = return $ WrapStack callStack #endif @@ -64,15 +64,16 @@ getStack = return $ WrapStack callStack -- -- In ghc 9.10 and higher, 'throwIO' will include a backtrace immediately, but -- this is not true for older versions. It is therefore useful to include an --- explicit stack in exceptions, but if we do, we should then /also/ have --- @ghc@'s stack annotation. Example usage: +-- explicit backtrace in exceptions, but if we do, we should then not /also/ +-- have @ghc@'s automatic backtrace annotation. Example usage: -- --- > data CallFailed = CallFailed Stack +-- > data CallFailed = CallFailed Backtrace -- > deriving stock (Show) -newtype ContainsStack a = ContainsStack a +-- > deriving Exception via CollectedBacktrac CallFailed +newtype CollectedBacktrace a = CollectedBacktrace a deriving newtype Show -instance (Show a, Typeable a) => Exception (ContainsStack a) where +instance (Show a, Typeable a) => Exception (CollectedBacktrace a) where #if MIN_VERSION_base(4,20,0) backtraceDesired _ = False #endif diff --git a/hs-bindgen-patterns/src/HsBindgen/Patterns/SafeForeignPtr.hs b/hs-bindgen-patterns/src/HsBindgen/Patterns/SafeForeignPtr.hs deleted file mode 100644 index e6c6a9b7..00000000 --- a/hs-bindgen-patterns/src/HsBindgen/Patterns/SafeForeignPtr.hs +++ /dev/null @@ -1,110 +0,0 @@ -module HsBindgen.Patterns.SafeForeignPtr ( - SafeForeignPtr -- opaque - , AccessedFinalizedForeignPtrException - -- * API - , newSafeForeignPtr - , withSafeForeignPtr - , finalizeSafeForeignPtr - ) where - -import Control.Exception -import Control.Monad -import Data.IORef -import Foreign -import Foreign.Concurrent qualified as Concurrent -import GHC.Stack - -import HsBindgen.Patterns.Stack - -{------------------------------------------------------------------------------- - Definition --------------------------------------------------------------------------------} - --- | Like 'ForeignPtr', but we can detect when the pointer has been freed --- --- This is only useful when 'finalizeSafeForeignPtr' is explicitly called; --- otherwise (barring bugs) it should never be possible for a foreign pointer --- to be deallocated when it's still referenced somewhere. -data SafeForeignPtr a = Wrap { - unwrap :: IORef (State a) - , allocatedAt :: Stack - } - --- | State of the 'SafeForeignPtr' --- --- This is an internal API. -data State a = - Allocated (ForeignPtr a) - | GarbageCollected - | ExplicitlyFreedAt Stack - -data AccessedFinalizedForeignPtrException = - -- | An attempt was made to access a 'SafeForeignPtr' that was finalized - -- - -- We record where the 'SafeForeignPtr' was allocated, where it was freed - -- if freed explicitly (this will be 'Nothing' if it was GCed), and where - -- the invalid access happened. - AccessedFinalizedForeignPtr { - allocated :: Stack - , freed :: Maybe Stack - , accessed :: Stack - } - deriving stock (Show) - deriving anyclass (Exception) - -{------------------------------------------------------------------------------- - Main API --------------------------------------------------------------------------------} - --- | Construct 'SafeForeignPtr' from plain memory reference and a finalizer --- --- See 'newForeignPtr' for additional discussion. -newSafeForeignPtr :: HasCallStack => Ptr a -> IO () -> IO (SafeForeignPtr a) -newSafeForeignPtr ptr finalizer = do - stack <- getStack - ref <- newIORef undefined - - let finalizer' :: IO () - finalizer' = atomicWriteIORef ref GarbageCollected >> finalizer - - foreignPtr <- Concurrent.newForeignPtr ptr finalizer' - writeIORef ref $ Allocated foreignPtr - return $ Wrap ref stack - --- | Access the pointer --- --- Same provisos as for 'withForeignPtr' apply. -withSafeForeignPtr :: SafeForeignPtr a -> (Ptr a -> IO b) -> IO b -withSafeForeignPtr safePtr k = do - mForeign <- readIORef (unwrap safePtr) - case mForeign of - Allocated fptr -> do - withForeignPtr fptr k - GarbageCollected -> do - stack <- getStack - throwIO $ AccessedFinalizedForeignPtr { - allocated = allocatedAt safePtr - , freed = Nothing - , accessed = stack - } - ExplicitlyFreedAt freedAt -> do - stack <- getStack - throwIO $ AccessedFinalizedForeignPtr { - allocated = allocatedAt safePtr - , freed = Just freedAt - , accessed = stack - } - --- | Finalize the pointer --- --- This is a no-op if the pointer has already been finalized. --- --- See also 'finalizeForeignPtr'. -finalizeSafeForeignPtr :: SafeForeignPtr a -> IO () -finalizeSafeForeignPtr safePtr = do - stack <- getStack - mForeign <- atomicModifyIORef (unwrap safePtr) $ \st -> - case st of - Allocated fptr -> (ExplicitlyFreedAt stack, Just fptr) - _otherwise -> (st, Nothing) - forM_ mForeign finalizeForeignPtr diff --git a/hs-bindgen/cbits/clang_wrappers.c b/hs-bindgen/cbits/clang_wrappers.c index 188aa25c..0805409d 100644 --- a/hs-bindgen/cbits/clang_wrappers.c +++ b/hs-bindgen/cbits/clang_wrappers.c @@ -15,16 +15,24 @@ CXCursor* wrap_malloc_getTranslationUnitCursor (CXTranslationUnit unit) { return result; } +unsigned wrap_equalCursors(CXCursor* a, CXCursor* b) { + return clang_equalCursors(*a, *b); +} + /** * Traversing the AST with cursors */ enum CXChildVisitResult wrap_HsCXCursorVisitor(CXCursor cursor, CXCursor parent, CXClientData client_data) { HsCXCursorVisitor visitor = client_data; - return visitor(&cursor, &parent); + CXCursor* cursor_ = malloc(sizeof(CXCursor)); + CXCursor* parent_ = malloc(sizeof(CXCursor)); + *cursor_ = cursor; + *parent_ = parent; + return visitor(cursor_, parent_); } -unsigned wrap_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor) { +unsigned wrap_malloc_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor) { return clang_visitChildren(*parent, &wrap_HsCXCursorVisitor, visitor); } diff --git a/hs-bindgen/cbits/clang_wrappers.h b/hs-bindgen/cbits/clang_wrappers.h index 5cfedc97..9de678f7 100644 --- a/hs-bindgen/cbits/clang_wrappers.h +++ b/hs-bindgen/cbits/clang_wrappers.h @@ -14,7 +14,8 @@ * Cursor manipulations */ -CXCursor* wrap_malloc_getTranslationUnitCursor (CXTranslationUnit unit); +CXCursor* wrap_malloc_getTranslationUnitCursor(CXTranslationUnit unit); +unsigned wrap_equalCursors(CXCursor* a, CXCursor* b); /** * Traversing the AST with cursors @@ -22,7 +23,7 @@ CXCursor* wrap_malloc_getTranslationUnitCursor (CXTranslationUnit unit); typedef enum CXChildVisitResult(* HsCXCursorVisitor) (CXCursor* cursor, CXCursor* parent); -unsigned wrap_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor); +unsigned wrap_malloc_visitChildren(CXCursor* parent, HsCXCursorVisitor visitor); /** * Cross-referencing in the AST diff --git a/hs-bindgen/hs-bindgen.cabal b/hs-bindgen/hs-bindgen.cabal index 21f14d2b..c914d976 100644 --- a/hs-bindgen/hs-bindgen.cabal +++ b/hs-bindgen/hs-bindgen.cabal @@ -63,6 +63,7 @@ library HsBindgen.C.AST HsBindgen.C.Clang HsBindgen.C.Clang.Enums + HsBindgen.C.Clang.Fold HsBindgen.C.Clang.Instances HsBindgen.C.Clang.Util HsBindgen.C.Parser diff --git a/hs-bindgen/src/HsBindgen/C/AST.hs b/hs-bindgen/src/HsBindgen/C/AST.hs index 20225a6a..40dc4dee 100644 --- a/hs-bindgen/src/HsBindgen/C/AST.hs +++ b/hs-bindgen/src/HsBindgen/C/AST.hs @@ -10,6 +10,8 @@ module HsBindgen.C.AST ( Header(..) , Decl(..) , Struct(..) + , StructField(..) + , PrimType(..) ) where import GHC.Generics (Generic) @@ -36,7 +38,21 @@ data Decl = data Struct = Struct { sizeof :: Int , alignment :: Int + , fields :: [StructField] } deriving stock (Show, Eq, Generic) deriving anyclass (PrettyVal) +data StructField = StructField { + fieldName :: String + , fieldType :: PrimType + } + deriving stock (Show, Eq, Generic) + deriving anyclass (PrettyVal) + +data PrimType = + PrimInt -- @int@ + | PrimChar -- @char@ + | PrimFloat -- @float@ + deriving stock (Show, Eq, Generic) + deriving anyclass (PrettyVal) diff --git a/hs-bindgen/src/HsBindgen/C/Clang.hs b/hs-bindgen/src/HsBindgen/C/Clang.hs index 162affb5..984ec3c6 100644 --- a/hs-bindgen/src/HsBindgen/C/Clang.hs +++ b/hs-bindgen/src/HsBindgen/C/Clang.hs @@ -26,7 +26,7 @@ -- * For functions that take structs or return structs by value, we use our own -- wrappers from @cbits/clang_wrappers.h@. -- * In cases where we are responsible for calling @free@ (or some other --- finalizer), we use 'SafeForeignPtr' rather than 'Ptr' in argument position. +-- finalizer), we use 'ForeignPtr' rather than 'Ptr' in argument position. -- -- The sections in this module and in the export list correspond to -- , with the exception of @@ -49,6 +49,7 @@ module HsBindgen.C.Clang ( -- * Cursor manipulations , CXCursor , clang_getTranslationUnitCursor + , clang_equalCursors -- * Traversing the AST with cursors , CXChildVisitResult(..) , CXCursorVisitor @@ -84,6 +85,7 @@ import Data.ByteString qualified as BS.Strict import Data.ByteString qualified as Strict (ByteString) import Foreign import Foreign.C +import Foreign.Concurrent qualified as Concurrent import GHC.Stack import System.IO.Unsafe (unsafePerformIO) @@ -248,10 +250,29 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getTranslationUnitCurso -- clang_getTranslationUnitCursor :: Ptr CXTranslationUnit - -> IO (SafeForeignPtr CXCursor) -clang_getTranslationUnitCursor unit = attachFinalizer $ + -> IO (ForeignPtr CXCursor) +clang_getTranslationUnitCursor unit = attachFinalizer =<< clang_getTranslationUnitCursor' unit +foreign import capi unsafe "clang_wrappers.h wrap_equalCursors" + clang_equalCursors' :: + Ptr CXCursor + -> Ptr CXCursor + -> IO CUInt + +-- | Determine whether two cursors are equivalent. +-- +-- +clang_equalCursors :: + ForeignPtr CXCursor + -> ForeignPtr CXCursor + -> IO Bool +clang_equalCursors a b = + withForeignPtr a $ \a' -> + withForeignPtr b $ \b' -> + (/= 0) <$> clang_equalCursors' a' b' + + {------------------------------------------------------------------------------- Traversing the AST with cursors @@ -284,7 +305,7 @@ foreign import ccall "wrapper" -- -- /NOTE/: This is marked @safe@ rather than @unsafe@ as this calls back into -- Haskell. -foreign import capi safe "clang_wrappers.h wrap_visitChildren" +foreign import capi safe "clang_wrappers.h wrap_malloc_visitChildren" clang_visitChildren' :: Ptr CXCursor -> FunPtr CXCursorVisitor @@ -300,14 +321,14 @@ foreign import capi safe "clang_wrappers.h wrap_visitChildren" -- -- clang_visitChildren :: - SafeForeignPtr CXCursor + ForeignPtr CXCursor -- ^ @parent@ -- -- The cursor whose child may be visited. All kinds of cursors can be -- visited, including invalid cursors (which, by definition, have no -- children). - -> ( SafeForeignPtr CXCursor - -> SafeForeignPtr CXCursor + -> ( ForeignPtr CXCursor + -> ForeignPtr CXCursor -> IO (SimpleEnum CXChildVisitResult) ) -- ^ @visitor@ @@ -315,16 +336,18 @@ clang_visitChildren :: -- The visitor function that will be invoked for each child of parent. -- See 'CXCursorVisitor' for details. -- - -- /NOTE/: + -- /NOTE/: We omit the @client_data@ argument from @libclang@, as it is + -- not needed in Haskell (the IO action can have arbitrary data in its + -- closure). -> IO Bool -- ^ 'True' if the traversal was terminated prematurely by the visitor -- returning 'CXChildVisit_Break'. clang_visitChildren root visitor = do - visitor' <- mkCursorVisitor $ \current parent -> - ensureScoped current $ \current' -> - ensureScoped parent $ \parent' -> - visitor current' parent' - withSafeForeignPtr root $ \parent' -> + visitor' <- mkCursorVisitor $ \current parent -> do + current' <- attachFinalizer current + parent' <- attachFinalizer parent + visitor current' parent' + withForeignPtr root $ \parent' -> (/= 0) <$> clang_visitChildren' parent' visitor' {------------------------------------------------------------------------------- @@ -346,10 +369,10 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getCursorDisplayName" -- -- clang_getCursorDisplayName :: - SafeForeignPtr CXCursor + ForeignPtr CXCursor -> IO Strict.ByteString clang_getCursorDisplayName cursor = - withSafeForeignPtr cursor $ \cursor' -> packCXString $ + withForeignPtr cursor $ \cursor' -> packCXString =<< clang_getCursorDisplayName' cursor' foreign import capi unsafe "clang_wrappers.h wrap_malloc_getCursorSpelling" @@ -361,11 +384,12 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getCursorSpelling" -- -- clang_getCursorSpelling :: - SafeForeignPtr CXCursor + ForeignPtr CXCursor -> IO Strict.ByteString clang_getCursorSpelling cursor = - withSafeForeignPtr cursor $ \cursor' -> packCXString $ + withForeignPtr cursor $ \cursor' -> packCXString =<< clang_getCursorSpelling' cursor' + {------------------------------------------------------------------------------- Type information for CXCursors @@ -382,9 +406,9 @@ foreign import capi unsafe "clang_wrappers.h wrap_cxtKind" Ptr CXType -> IO (SimpleEnum CXTypeKind) -cxtKind :: SafeForeignPtr CXType -> SimpleEnum CXTypeKind +cxtKind :: ForeignPtr CXType -> SimpleEnum CXTypeKind cxtKind typ = unsafePerformIO $ - withSafeForeignPtr typ $ \typ' -> + withForeignPtr typ $ \typ' -> cxtKind' typ' foreign import capi unsafe "clang_wrappers.h wrap_malloc_getCursorType" @@ -395,9 +419,9 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getCursorType" -- | Retrieve the type of a CXCursor (if any). -- -- -clang_getCursorType :: SafeForeignPtr CXCursor -> IO (SafeForeignPtr CXType) +clang_getCursorType :: ForeignPtr CXCursor -> IO (ForeignPtr CXType) clang_getCursorType cursor = - withSafeForeignPtr cursor $ \cursor' -> attachFinalizer $ + withForeignPtr cursor $ \cursor' -> attachFinalizer =<< clang_getCursorType' cursor' foreign import capi unsafe "clang_wrappers.h wrap_malloc_getTypeKindSpelling" @@ -411,7 +435,7 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getTypeKindSpelling" clang_getTypeKindSpelling :: SimpleEnum CXTypeKind -> IO Strict.ByteString -clang_getTypeKindSpelling kind = packCXString $ +clang_getTypeKindSpelling kind = packCXString =<< clang_getTypeKindSpelling' kind foreign import capi unsafe "clang_wrappers.h wrap_malloc_getTypeSpelling" @@ -424,10 +448,10 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getTypeSpelling" -- -- If the type is invalid, an empty string is returned. clang_getTypeSpelling :: - SafeForeignPtr CXType + ForeignPtr CXType -> IO Strict.ByteString clang_getTypeSpelling typ = - withSafeForeignPtr typ $ \typ' -> packCXString $ + withForeignPtr typ $ \typ' -> packCXString =<< clang_getTypeSpelling' typ' foreign import capi unsafe "clang_wrappers.h wrap_malloc_getPointeeType" @@ -439,10 +463,10 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getPointeeType" -- -- clang_getPointeeType :: - SafeForeignPtr CXType - -> IO (SafeForeignPtr CXType) + ForeignPtr CXType + -> IO (ForeignPtr CXType) clang_getPointeeType typ = - withSafeForeignPtr typ $ \typ' -> attachFinalizer $ + withForeignPtr typ $ \typ' -> attachFinalizer =<< clang_getPointeeType' typ' foreign import capi unsafe "clang_wrappers.h wrap_Type_getSizeOf" @@ -456,10 +480,10 @@ foreign import capi unsafe "clang_wrappers.h wrap_Type_getSizeOf" -- -- clang_Type_getSizeOf :: - SafeForeignPtr CXType + ForeignPtr CXType -> IO CLLong clang_Type_getSizeOf typ = - withSafeForeignPtr typ $ \typ' -> ensure (>= 0) CXTypeLayoutException $ + withForeignPtr typ $ \typ' -> ensure (>= 0) CXTypeLayoutException $ clang_Type_getSizeOf' typ' foreign import capi unsafe "clang_wrappers.h wrap_Type_getAlignOf" @@ -473,10 +497,10 @@ foreign import capi unsafe "clang_wrappers.h wrap_Type_getAlignOf" -- -- clang_Type_getAlignOf :: - SafeForeignPtr CXType + ForeignPtr CXType -> IO CLLong clang_Type_getAlignOf typ = - withSafeForeignPtr typ $ \typ' -> ensure (>= 0) CXTypeLayoutException $ + withForeignPtr typ $ \typ' -> ensure (>= 0) CXTypeLayoutException $ clang_getAlignOf' typ' {------------------------------------------------------------------------------- @@ -502,10 +526,10 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getCursorExtent" -- -- clang_getCursorExtent :: - SafeForeignPtr CXCursor - -> IO (SafeForeignPtr CXSourceRange) + ForeignPtr CXCursor + -> IO (ForeignPtr CXSourceRange) clang_getCursorExtent cursor = - withSafeForeignPtr cursor $ \cursor' -> attachFinalizer $ + withForeignPtr cursor $ \cursor' -> attachFinalizer =<< clang_getCursorExtent' cursor' {------------------------------------------------------------------------------- @@ -530,10 +554,10 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getRangeStart" -- -- clang_getRangeStart :: - SafeForeignPtr CXSourceRange - -> IO (SafeForeignPtr CXSourceLocation) + ForeignPtr CXSourceRange + -> IO (ForeignPtr CXSourceLocation) clang_getRangeStart range = - withSafeForeignPtr range $ \range' -> attachFinalizer $ + withForeignPtr range $ \range' -> attachFinalizer =<< clang_getRangeStart' range' foreign import capi unsafe "clang_wrappers.h wrap_malloc_getRangeEnd" @@ -546,10 +570,10 @@ foreign import capi unsafe "clang_wrappers.h wrap_malloc_getRangeEnd" -- -- clang_getRangeEnd :: - SafeForeignPtr CXSourceRange - -> IO (SafeForeignPtr CXSourceLocation) + ForeignPtr CXSourceRange + -> IO (ForeignPtr CXSourceLocation) clang_getRangeEnd range = - withSafeForeignPtr range $ \range' -> attachFinalizer $ + withForeignPtr range $ \range' -> attachFinalizer =<< clang_getRangeEnd' range' -- | A particular source file that is part of a translation unit. @@ -581,10 +605,10 @@ foreign import capi "clang_wrappers.h wrap_getExpansionLocation" -- -- clang_getExpansionLocation :: - SafeForeignPtr CXSourceLocation + ForeignPtr CXSourceLocation -> IO (Ptr CXFile, CUInt, CUInt, CUInt) clang_getExpansionLocation location = - withSafeForeignPtr location $ \location' -> + withForeignPtr location $ \location' -> alloca $ \file -> alloca $ \line -> alloca $ \column -> @@ -635,9 +659,8 @@ foreign import capi unsafe "clang_wrappers.h wrap_disposeString" -- The @libclang@ functions that return a @CXString@ do so by /value/; we -- allocate this on the heap in our wrapper functions. Since we no longer need -- this after packing, we free the pointer after packing. -packCXString :: IO (Ptr CXString) -> IO Strict.ByteString -packCXString mkStr = do - str <- mkStr +packCXString :: Ptr CXString -> IO Strict.ByteString +packCXString str = bracket (clang_getCString str) (\_ -> clang_disposeString str >> free str) $ @@ -649,24 +672,24 @@ packCXString mkStr = do We do the actual checks in this module, and export only the exception types. -------------------------------------------------------------------------------} -data CallFailed = CallFailed Stack +data CallFailed = CallFailed Backtrace deriving stock (Show) - deriving Exception via ContainsStack CallFailed + deriving Exception via CollectedBacktrace CallFailed -- | Ensure that a function did not return 'nullPtr' (indicating error) ensureNotNull :: HasCallStack => IO (Ptr a) -> IO (Ptr a) ensureNotNull call = do ptr <- call if ptr == nullPtr then do - stack <- getStack + stack <- collectBacktrace throwIO $ CallFailed stack else return ptr data CXTypeLayoutException = - CXTypeLayoutException Stack CInt (Maybe CXTypeLayoutError) + CXTypeLayoutException Backtrace CInt (Maybe CXTypeLayoutError) deriving stock (Show) - deriving Exception via ContainsStack CXTypeLayoutException + deriving Exception via CollectedBacktrace CXTypeLayoutException -- | Check that an (integral) result from @libclang@ function is not an error ensure :: @@ -676,36 +699,22 @@ ensure :: , Integral c ) => (c -> Bool) - -> (Stack -> CInt -> Maybe hs -> e) + -> (Backtrace -> CInt -> Maybe hs -> e) -> IO c -> IO c ensure p mkErr call = do c <- call if p c then return c else do - stack <- getStack + stack <- collectBacktrace throwIO $ mkErr stack (fromIntegral c) (simpleFromC $ fromIntegral c) {------------------------------------------------------------------------------- Internal: auxiliary -------------------------------------------------------------------------------} -attachFinalizer :: IO (Ptr a) -> IO (SafeForeignPtr a) -attachFinalizer mkPtr = do - ptr <- mkPtr - newSafeForeignPtr ptr $ free ptr - --- | Ensure that a 'Ptr' is used within the given scope --- --- We don't attach a finalizer (we are not responsible for freeing any memory), --- but take advantage of 'SafeForeignPtr' to ensure that if the 'SafeForeignPtr' --- is accessed outside the scope, an exception is thrown. --- --- (We cannot prevent the underlying 'Ptr' from leaking, but this is an --- implementation detail that is not visible outside the scope of this module.) -ensureScoped :: Ptr a -> (SafeForeignPtr a -> IO r) -> IO r -ensureScoped ptr = - bracket (newSafeForeignPtr ptr $ return ()) finalizeSafeForeignPtr +attachFinalizer :: Ptr a -> IO (ForeignPtr a) +attachFinalizer ptr = Concurrent.newForeignPtr ptr $ free ptr -- | Extension of 'withCString' for multiple CStrings withCStrings :: [String] -> (Ptr CString -> CInt -> IO r) -> IO r diff --git a/hs-bindgen/src/HsBindgen/C/Clang/Fold.hs b/hs-bindgen/src/HsBindgen/C/Clang/Fold.hs new file mode 100644 index 00000000..6928f27b --- /dev/null +++ b/hs-bindgen/src/HsBindgen/C/Clang/Fold.hs @@ -0,0 +1,138 @@ +-- | Higher-level bindings for traversing the API +module HsBindgen.C.Clang.Fold ( + Fold + , Next(..) + , clang_fold + ) where + +import Control.Monad +import Data.IORef +import Foreign + +import HsBindgen.C.Clang +import HsBindgen.Patterns + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +type Fold a = ForeignPtr CXCursor -> IO (Next a) + +data Next a where + Stop :: Maybe a -> Next a + Continue :: Maybe a -> Next a + Recurse :: Fold b -> ([b] -> IO a) -> Next a + +{------------------------------------------------------------------------------- + Internal: stack +-------------------------------------------------------------------------------} + +data Processing a = Processing { + -- | The AST node whose children we are processing + parent :: ForeignPtr CXCursor + + -- | The 'Fold' we are applying at this level + , currentFold :: Fold a + + -- | Results collected so far (in reverse order) + , partialResults :: IORef [a] + } + +data Stack a where + Bottom :: Processing a -> Stack a + Push :: Processing a -> ([a] -> IO b) -> Stack b -> Stack a + +topProcessing :: Stack a -> Processing a +topProcessing (Bottom p) = p +topProcessing (Push p _ _) = p + +topParent :: Stack a -> ForeignPtr CXCursor +topParent = parent . topProcessing + +topResults :: Stack a -> IORef [a] +topResults = partialResults . topProcessing + +data SomeStack where + SomeStack :: Stack a -> SomeStack + +initStack :: + ForeignPtr CXCursor + -> Fold a + -> IO (Stack a) +initStack root topLevelFold = do + partialResults <- newIORef [] + let p = Processing { + parent = root + , currentFold = topLevelFold + , partialResults + } + return $ Bottom p + +push :: ForeignPtr CXCursor -> Fold b -> ([b] -> IO a) -> Stack a -> IO (Stack b) +push newParent fold collect stack = do + partialResults <- newIORef [] + let p = Processing { + parent = newParent + , currentFold = fold + , partialResults + } + return $ Push p collect stack + +popUntil :: IORef SomeStack -> ForeignPtr CXCursor -> IO () +popUntil someStack newParent = do + SomeStack stack <- readIORef someStack + writeIORef someStack =<< loop stack + where + loop :: Stack a -> IO SomeStack + loop stack = do + arrived <- clang_equalCursors (topParent stack) newParent + if arrived then + return $ SomeStack stack + else + case stack of + Bottom _ -> + error "popUntil: something has gone horribly wrong" + Push p collect stack' -> do + as <- readIORef (partialResults p) + b <- collect (reverse as) + modifyIORef (topResults stack') (b:) + loop stack' + +{------------------------------------------------------------------------------- + Traversal proper +-------------------------------------------------------------------------------} + +-- | Fold the AST +-- +-- This provides a higher-level API to 'clang_visitChildren', in which +-- +-- * visitors can return results +-- * we can specify different visitors at different levels of the AST +clang_fold :: ForeignPtr CXCursor -> Fold a -> IO [a] +clang_fold root topLevelFold = do + stack <- initStack root topLevelFold + someStack <- newIORef $ SomeStack stack + _terminatedEarly <- clang_visitChildren root $ visitor someStack + reverse <$> readIORef (topResults stack) + where + visitor :: + IORef SomeStack + -> ForeignPtr CXCursor + -> ForeignPtr CXCursor + -> IO (SimpleEnum CXChildVisitResult) + visitor someStack current parent = do + popUntil someStack parent + SomeStack stack <- readIORef someStack + let p = topProcessing stack + next <- currentFold p current + case next of + Stop a -> do + forM_ a $ modifyIORef (partialResults p) . (:) + return $ simpleEnum CXChildVisit_Break + Continue a -> do + forM_ a $ modifyIORef (partialResults p) . (:) + return $ simpleEnum CXChildVisit_Continue + Recurse fold collect -> do + stack' <- push current fold collect stack + writeIORef someStack $ SomeStack stack' + return $ simpleEnum CXChildVisit_Recurse diff --git a/hs-bindgen/src/HsBindgen/C/Parser.hs b/hs-bindgen/src/HsBindgen/C/Parser.hs index 2e12e69d..b0a398d9 100644 --- a/hs-bindgen/src/HsBindgen/C/Parser.hs +++ b/hs-bindgen/src/HsBindgen/C/Parser.hs @@ -5,14 +5,15 @@ -- > import Hsbindgen.C.Parser qualified as C module HsBindgen.C.Parser (parseHeader) where -import Control.Monad -import Data.IORef +import Data.ByteString qualified as Strict (ByteString) +import Data.ByteString.Char8 qualified as BS.Strict.Char8 import HsBindgen.C.AST qualified as C import HsBindgen.C.Clang import HsBindgen.Patterns import HsBindgen.Spec import HsBindgen.Util.Tracer +import HsBindgen.C.Clang.Fold {------------------------------------------------------------------------------- Parsing @@ -27,38 +28,65 @@ parseHeader tracer args fp = do unit <- clang_parseTranslationUnit index fp args flags cursor <- clang_getTranslationUnitCursor unit - decls :: IORef [C.Decl] <- newIORef [] - - void $ clang_visitChildren cursor $ \current _parent -> do - cursorType <- clang_getCursorType current - case fromSimpleEnum $ cxtKind cursorType of - Right CXType_Record -> do - sizeof <- fromIntegral <$> clang_Type_getSizeOf cursorType - alignment <- fromIntegral <$> clang_Type_getAlignOf cursorType - let decl = C.DeclStruct C.Struct{sizeof, alignment} - modifyIORef decls $ (decl :) - -- TODO: We should use Recurse here rather than Continue, - -- so that we process the fields - return $ simpleEnum CXChildVisit_Continue - _otherwise -> do - traceWith tracer Warning $ Skipping (cxtKind cursorType) - return $ simpleEnum CXChildVisit_Continue - - C.Header <$> readIORef decls + C.Header <$> clang_fold cursor (topLevel tracer) where flags :: CXTranslationUnit_Flags flags = bitfieldEnum [ CXTranslationUnit_SkipFunctionBodies ] +topLevel :: Tracer IO LogMsg -> Fold C.Decl +topLevel tracer current = do + cursorType <- clang_getCursorType current + case fromSimpleEnum $ cxtKind cursorType of + Right CXType_Record -> do + sizeof <- fromIntegral <$> clang_Type_getSizeOf cursorType + alignment <- fromIntegral <$> clang_Type_getAlignOf cursorType + let decl fields = C.DeclStruct C.Struct{sizeof, alignment, fields} + return $ Recurse (structFields tracer) (return . decl) + _otherwise -> do + traceWith tracer Warning $ Skipping (cxtKind cursorType) + return $ Continue Nothing + +structFields :: Tracer IO LogMsg -> Fold C.StructField +structFields tracer current = do + cursorType <- clang_getCursorType current + case primType $ cxtKind cursorType of + Just fieldType -> do + fieldName <- decodeString <$> clang_getCursorDisplayName current + let field = C.StructField{fieldName, fieldType} + return $ Continue (Just field) + _otherwise -> do + traceWith tracer Warning $ UnrecognizedStructField (cxtKind cursorType) + return $ Continue Nothing + +primType :: SimpleEnum CXTypeKind -> Maybe C.PrimType +primType = either (const Nothing) aux . fromSimpleEnum + where + aux :: CXTypeKind -> Maybe C.PrimType + aux CXType_Int = Just C.PrimInt + aux CXType_Char_S = Just C.PrimChar + aux CXType_Float = Just C.PrimFloat + aux _ = Nothing + +-- TODO: +-- Deal with file encodings other than ASCII +decodeString :: Strict.ByteString -> String +decodeString = BS.Strict.Char8.unpack + {------------------------------------------------------------------------------- Logging -------------------------------------------------------------------------------} data LogMsg = - -- | We skipped over an element in the Clang AST we did not recognize - Skipping (SimpleEnum CXTypeKind) + -- | We skipped over an element in the Clang AST we did not recognize + Skipping (SimpleEnum CXTypeKind) + + -- | Struct contained an element we did not recognize + | UnrecognizedStructField (SimpleEnum CXTypeKind) instance PrettyLogMsg LogMsg where prettyLogMsg (Skipping kind) = - "Skipping over unrecognized " ++ show kind \ No newline at end of file + "Unrecognized top-level declaration: " ++ show kind + prettyLogMsg (UnrecognizedStructField kind) = + "Unrecognized struct field: " ++ show kind \ No newline at end of file