diff --git a/haskell-gi.cabal b/haskell-gi.cabal --- a/haskell-gi.cabal +++ b/haskell-gi.cabal @@ -1,5 +1,5 @@ name: haskell-gi -version: 0.26.18 +version: 0.26.19 synopsis: Generate Haskell bindings for GObject Introspection capable libraries description: Generate Haskell bindings for GObject Introspection capable libraries. This includes most notably GTK, but many other libraries in the GObject ecosystem provide introspection data too. @@ -81,6 +81,7 @@ Data.GI.GIR.Union, Data.GI.GIR.XMLUtils, Data.GI.CodeGen.API, + Data.GI.CodeGen.StructLayout, Data.GI.CodeGen.CabalHooks, Data.GI.CodeGen.Callable, Data.GI.CodeGen.Code, diff --git a/lib/Data/GI/CodeGen/API.hs b/lib/Data/GI/CodeGen/API.hs --- a/lib/Data/GI/CodeGen/API.hs +++ b/lib/Data/GI/CodeGen/API.hs @@ -104,6 +104,8 @@ lookupAttrWithNamespace, GIRXMLNamespace(..), xmlLocalName) +import Data.GI.CodeGen.StructLayout (Aggregate(..), fixupStructLayouts) + import Data.GI.Base.BasicConversions (unpackStorableArrayWithLength) import Data.GI.Base.BasicTypes (GType(..), CGType, gtypeName) import Data.GI.Base.Utils (allocMem, freeMem) @@ -329,6 +331,7 @@ (fixup (fixupInterface typelibMap ctypes) >=> fixup (fixupStruct typelibMap) >=> fixup fixupUnion >=> + (return . fixupLayouts) >=> fixup (fixupMissingSymbols verbose typelibMap) ) (doc, deps) where fixup :: ((Name, API) -> IO (Name, API)) @@ -347,6 +350,42 @@ ctypes :: M.Map Text Name ctypes = M.unions (map girCTypes (doc:deps)) +-- | The typelib compiler ignores the widths of bitfields, and +-- anonymous unions and structs, when computing the layout of +-- structs, so we fix the layout of structs and unions (directly or +-- indirectly) containing these using the information in the GIR +-- file. See "Data.GI.CodeGen.StructLayout" for the details. This +-- needs to be done for all the loaded namespaces at once, since +-- structs may embed structs defined in other namespaces. +fixupLayouts :: (GIRInfo, [GIRInfo]) -> (GIRInfo, [GIRInfo]) +fixupLayouts (doc, deps) = (fixInfo doc, map fixInfo deps) + where aggregates :: M.Map Name Aggregate + aggregates = M.fromList [(n, agg) | info <- doc : deps + , (n, api) <- girAPIs info + , Just agg <- [toAggregate api]] + + toAggregate :: API -> Maybe Aggregate + toAggregate (APIStruct s) = Just (AggStruct s) + toAggregate (APIUnion u) = Just (AggUnion u) + toAggregate (APIEnum e) = Just (AggScalar (enumStorageBytes e)) + toAggregate (APIFlags (Flags e)) = Just (AggScalar (enumStorageBytes e)) + toAggregate (APIObject _) = Just AggPointer + toAggregate (APIInterface _) = Just AggPointer + toAggregate (APICallback _) = Just AggPointer + toAggregate _ = Nothing + + fixed :: M.Map Name Aggregate + fixed = fixupStructLayouts aggregates + + fixInfo :: GIRInfo -> GIRInfo + fixInfo info = info {girAPIs = map fixAPI (girAPIs info)} + + fixAPI :: (Name, API) -> (Name, API) + fixAPI (n, api) = case M.lookup n fixed of + Just (AggStruct s) -> (n, APIStruct s) + Just (AggUnion u) -> (n, APIUnion u) + _ -> (n, api) + foreign import ccall "g_type_interface_prerequisites" g_type_interface_prerequisites :: CGType -> Ptr CUInt -> IO (Ptr CGType) -- | List the prerequisites for a 'GType' corresponding to an interface. @@ -434,6 +473,10 @@ -- | Fixup the offsets of fields using the given offset map. fixupField :: M.Map Text FieldInfo -> Field -> Field +fixupField _ f@(Field {fieldAnonymous = Just _}) = + -- Not present in the typelib, the offset will be computed in + -- 'fixupLayouts'. + f fixupField offsetMap f = f {fieldOffset = case M.lookup (fieldName f) offsetMap of Nothing -> error $ "Could not find field " diff --git a/lib/Data/GI/CodeGen/Code.hs b/lib/Data/GI/CodeGen/Code.hs --- a/lib/Data/GI/CodeGen/Code.hs +++ b/lib/Data/GI/CodeGen/Code.hs @@ -965,6 +965,7 @@ , "import qualified GHC.Records as R" , "import qualified Data.Word as DW" , "import qualified Data.Int as DI" + , "import qualified Data.Bits as DB" , "import qualified System.Posix.Types as SPT" , "import qualified Foreign.C.Types as FCT"] diff --git a/lib/Data/GI/CodeGen/Conversions.hsc b/lib/Data/GI/CodeGen/Conversions.hsc --- a/lib/Data/GI/CodeGen/Conversions.hsc +++ b/lib/Data/GI/CodeGen/Conversions.hsc @@ -703,11 +703,13 @@ | (size == 0) = "unpackPtrArrayWithLength" | boxed = "unpackBoxedArrayWithLength " <> tshow size | otherwise = "unpackBlockArrayWithLength " <> tshow size - -- We always make a copy of the elements when unpacking - -- boxed types. - let transfer' | boxed = if transfer == TransferContainer - then TransferEverything - else transfer + -- When unpacking structs/unions stored inline in the + -- array (size > 0) the unpacker always makes a copy of + -- each element, which we then own, so we wrap it + -- directly instead of making a second copy (which would + -- leak the first one). + let transfer' | isScalar = transfer + | size > 0 = TransferEverything | otherwise = transfer innerConstructor <- fToH' t a hType fType transfer' return $ do diff --git a/lib/Data/GI/CodeGen/Struct.hs b/lib/Data/GI/CodeGen/Struct.hs --- a/lib/Data/GI/CodeGen/Struct.hs +++ b/lib/Data/GI/CodeGen/Struct.hs @@ -135,6 +135,56 @@ , "'Data.GI.Base.Attributes.get' " <> lowerName n <> " #" <> labelName field , "@"] +-- | If the given field is a C array whose length is given by another +-- field in the same struct/union, return the field holding the +-- length. +arrayLengthField :: [Field] -> Field -> ExcCodeGen (Maybe Field) +arrayLengthField fields field = + case fieldType field of + TCArray False (-1) idx _ + | idx < 0 -> return Nothing + | idx >= length fields -> + badIntroError $ "Array length field index " <> tshow idx + <> " for field “" <> fieldName field + <> "” is out of range." + | otherwise -> do + let lengthField = fields !! idx + case fieldType lengthField of + TBasicType t | t `elem` [TInt, TUInt, TLong, TULong, + TInt8, TUInt8, TInt16, TUInt16, + TInt32, TUInt32, TInt64, TUInt64, + TSize, TSSize] -> + return (Just lengthField) + t -> badIntroError $ "Array length field “" + <> fieldName lengthField + <> "” for field “" <> fieldName field + <> "” has non-integral type " <> tshow t + _ -> return Nothing + +-- | If the field is a bitfield, return its width and the shift of +-- its least significant bit inside the storage unit. +bitfieldInfo :: Field -> ExcCodeGen (Maybe (Int, Int)) +bitfieldInfo field = case fieldBits field of + Nothing -> return Nothing + Just width -> case fieldBitShift field of + Nothing -> notImplementedError "Could not determine the layout of the bitfield" + Just shift -> do + supported <- case fieldType field of + TBasicType t -> return $ t `elem` [TBoolean, TInt, TUInt, TLong, TULong, + TInt8, TUInt8, TInt16, TUInt16, + TInt32, TUInt32, TInt64, TUInt64, + TShort, TUShort, TSize, TSSize, + TUniChar] + t@(TInterface _) -> findAPI t >>= \case + Just (APIEnum _) -> return True + Just (APIFlags _) -> return True + _ -> return False + _ -> return False + if supported + then return (Just (width, shift)) + else notImplementedError $ "Bitfield of unsupported type " + <> tshow (fieldType field) + -- Notice that when reading the field we return a copy of any embedded -- structs, so modifications of the returned struct will not affect -- the original struct. This is on purpose, in order to increase @@ -142,12 +192,13 @@ -- parent structure while we are modifying the embedded one, and havoc -- will ensue). -- | Extract a field from a struct. -buildFieldReader :: Name -> Field -> ExcCodeGen () -buildFieldReader n field = group $ do +buildFieldReader :: Name -> [Field] -> Field -> ExcCodeGen () +buildFieldReader n fields field = group $ do let name' = upperName n getter = fieldGetter n field embedded <- isEmbedded field + bitfield <- bitfieldInfo field nullConvert <- if embedded then return Nothing else maybeNullConvert (fieldType field) @@ -172,12 +223,31 @@ <> " :: " <> peekedType else line $ "val <- peek (ptr `plusPtr` " <> tshow (fieldOffset field) <> ") :: IO " <> peekedType + -- For bitfields, we read the whole storage unit, and then + -- extract the relevant bits (with sign extension for signed + -- types). + valName <- case bitfield of + Nothing -> return "val" + Just (width, shift) -> do + line $ "let bitfield = DB.shiftR (DB.shiftL val (DB.finiteBitSize val P.- " + <> tshow (shift + width) <> ")) (DB.finiteBitSize val P.- " + <> tshow width <> ")" + return "bitfield" + -- C arrays whose length is given by another field in the struct + -- need the length in order to be unpacked. + converter <- arrayLengthField fields field >>= \case + Nothing -> return $ fToH (fieldType field) TransferNothing + Just lengthField -> do + lType <- typeShow <$> foreignType (fieldType lengthField) + line $ "len <- peek (ptr `plusPtr` " <> tshow (fieldOffset lengthField) + <> ") :: IO " <> lType + return $ unpackCArray "len" (fieldType field) TransferNothing result <- case nullConvert of - Nothing -> convert "val" $ fToH (fieldType field) TransferNothing + Nothing -> convert valName converter Just nullConverter -> do line $ "result <- " <> nullConverter <> " val $ \\val' -> do" indent $ do - val' <- convert "val'" $ fToH (fieldType field) TransferNothing + val' <- convert "val'" converter line $ "return " <> val' return "result" line $ "return " <> result @@ -220,12 +290,25 @@ line $ setter <> " :: MonadIO m => " <> name' <> " -> " <> hType <> " -> m ()" line $ setter <> " s val = liftIO $ withManagedPtr s $ \\ptr -> do" + bitfield <- bitfieldInfo field + indent $ do converted <- if isPtr then return "val" else convert "val" $ hToF (fieldType field) TransferNothing - line $ "poke (ptr `plusPtr` " <> tshow (fieldOffset field) - <> ") (" <> converted <> " :: " <> fType <> ")" + let location = "(ptr `plusPtr` " <> tshow (fieldOffset field) <> ")" + case bitfield of + Nothing -> + line $ "poke " <> location <> " (" <> converted <> " :: " <> fType <> ")" + Just (width, shift) -> do + -- Only modify the bits corresponding to the bitfield in the + -- storage unit. + line $ "old <- peek " <> location <> " :: IO " <> parenthesize fType + line $ "let mask = DB.shiftL (DB.shiftL 1 " <> tshow width + <> " P.- 1) " <> tshow shift <> " :: " <> fType + line $ "poke " <> location <> " ((old DB..&. DB.complement mask) DB..|. " + <> "(DB.shiftL (" <> converted <> " :: " <> fType <> ") " + <> tshow shift <> " DB..&. mask))" -- | Name for the clear function fieldClear :: Name -> Field -> Text @@ -398,8 +481,8 @@ return $ "'(\"" <> labelName field <> "\", " <> it <> ")" -- | Build code for a single field. -buildFieldAttributes :: Name -> Field -> ExcCodeGen (Maybe Text) -buildFieldAttributes n field +buildFieldAttributes :: Name -> [Field] -> Field -> ExcCodeGen (Maybe Text) +buildFieldAttributes n fields field | not (fieldVisible field) = return Nothing | privateType (fieldType field) = return Nothing | otherwise = group $ do @@ -417,7 +500,7 @@ addSectionDocumentation docSection (fieldDocumentation field) - buildFieldReader n field + buildFieldReader n fields field export docSection (fieldGetter n field) when (not embedded) $ do @@ -449,7 +532,7 @@ ":" <> fieldName field <> "\"") printCGError e return Nothing) - (buildFieldAttributes n field) + (buildFieldAttributes n fields field) blank @@ -567,6 +650,8 @@ line $ "-- XXX Wrapping a foreign struct/union with no known destructor or size, leak?" copy <- case allocCopy info of + -- Do not copy, the copy refers to the same memory. + AllocationOp "none" -> return "return" AllocationOp op -> do copy <- prefixedForeignImport (prefix "copy") op "Ptr a -> IO (Ptr a)" return ("\\p -> B.ManagedPtr.withManagedPtr p (" <> copy <> @@ -579,6 +664,8 @@ else return "return" free <- case allocFree info of + -- Never free the memory. + AllocationOp "none" -> return "\\_x -> return ()" AllocationOp op -> do free <- prefixedForeignImport (prefix "free") op "Ptr a -> IO ()" return $ "\\p -> B.ManagedPtr.withManagedPtr p " <> free diff --git a/lib/Data/GI/CodeGen/StructLayout.hsc b/lib/Data/GI/CodeGen/StructLayout.hsc new file mode 100644 --- /dev/null +++ b/lib/Data/GI/CodeGen/StructLayout.hsc @@ -0,0 +1,365 @@ +-- | Fix the memory layout of structs and unions. +-- +-- When compiling the typelib, the typelib compiler (both +-- @gi-compile-repository@ in GLib and @g-ir-compiler@ in +-- gobject-introspection) makes two simplifications when computing +-- the layout of structs and unions: +-- +-- * It ignores the width of bitfields: each bitfield is laid out as +-- if it was a full member of its declared type. +-- +-- * It ignores unions and structs declared inline (such as +-- @union { ... } u;@, or anonymous unions). +-- +-- This leads to wrong struct sizes, and wrong offsets for the fields +-- following the affected members. This affects the struct itself, +-- and any struct or union embedding it. See +-- . +-- +-- The GIR files do contain the required information, so here we +-- recompute the layout ourselves, following the rules of the C +-- ABI. To make sure that we are not missing any information (fields +-- that we could not parse, types of unknown size, ...), we first +-- check that by laying out the struct in the same way that the +-- typelib compiler does we reproduce the typelib data exactly. If +-- this is not the case we keep the data from the typelib. +module Data.GI.CodeGen.StructLayout + ( Aggregate(..) + , fixupStructLayouts + ) where + +#include + +#if !MIN_VERSION_base(4,13,0) +import Data.Monoid ((<>)) +#endif + +import Control.Monad (forM, unless, when) +import qualified Data.Map.Lazy as ML +import Data.Maybe (isJust) +import Data.Text (Text) +import qualified Data.Text as T +import Foreign.C.Types (CTime) +import Foreign.Storable (alignment, sizeOf) +import qualified System.Info + +import Data.GI.GIR.BasicTypes (BasicType(..), Name(..), Type(..)) +import Data.GI.GIR.Field (Field(..), AnonymousMember(..)) +import Data.GI.GIR.Struct (Struct(..)) +import Data.GI.GIR.Union (Union(..)) + +-- | The information about a named type that we need in order to +-- compute layouts. +data Aggregate = AggStruct Struct + | AggUnion Union + | AggScalar Int -- ^ Enums and flags, with their + -- storage size in bytes. + | AggPointer -- ^ Types which are always stored + -- as pointers in structs (objects, + -- interfaces, callbacks). + +-- | How to lay out the struct. +data Mode = TypelibMode -- ^ Mimic the typelib compiler. + | ABIMode -- ^ Follow the platform C ABI. + deriving (Eq) + +-- | Position of a field in a struct. +data FieldLayout = FieldLayout { + flOffset :: Int -- ^ Offset in bytes. + , flBitShift :: Maybe Int -- ^ Bit shift, for bitfields. + } + +-- | Layout of a struct or union. +data Layout = Layout { + lSize :: Int + , lAlign :: Int + , lFields :: [FieldLayout] + } + +-- | Size and alignment of a C type. +type SizeAlign = (Int, Int) + +-- | Given the structs, unions, and other named types in scope, +-- return the structs and unions whose layout has been +-- corrected. Bitfields in the corrected structs and unions will +-- also have their `fieldBitShift` set. +fixupStructLayouts :: ML.Map Name Aggregate -> ML.Map Name Aggregate +fixupStructLayouts aggs = ML.mapMaybeWithKey fix aggs + where + fix :: Name -> Aggregate -> Maybe Aggregate + fix n (AggStruct s) | needsFixing (structFields s) = do + layout <- either (const Nothing) Just (abiLayout n) + return $ AggStruct (s { structSize = lSize layout + , structFields = applyLayout layout + (structFields s) }) + fix n (AggUnion u) | needsFixing (unionFields u) = do + layout <- either (const Nothing) Just (abiLayout n) + return $ AggUnion (u { unionSize = lSize layout + , unionFields = applyLayout layout + (unionFields u) }) + fix _ _ = Nothing + + -- Structs whose layout may be wrong in the typelib: those + -- containing bitfields or inline unions or structs, and those + -- embedding other structs or unions (which may be wrong). + needsFixing :: [Field] -> Bool + needsFixing = any (\f -> isJust (fieldBits f) || embedsAggregate f) + + embedsAggregate :: Field -> Bool + embedsAggregate f + | isJust (fieldAnonymous f) = True + | isPointerField f = False + | otherwise = case elementType (fieldType f) of + TInterface n -> case ML.lookup n aggs of + Just (AggStruct _) -> True + Just (AggUnion _) -> True + _ -> False + TGValue -> True + TGClosure _ -> True + _ -> False + + elementType :: Type -> Type + elementType (TCArray _ fixed _ t) | fixed > 0 = elementType t + elementType t = t + + applyLayout :: Layout -> [Field] -> [Field] + applyLayout layout = + zipWith (\fl f -> f { fieldOffset = flOffset fl + , fieldBitShift = flBitShift fl }) + (lFields layout) + + -- Layouts computed by mimicking the typelib compiler, keeping + -- only those that reproduce exactly the data in the typelib. The + -- map is lazy, so we only compute what we need, and each layout + -- is computed at most once. + typelibLayouts :: ML.Map Name (Either Text Layout) + typelibLayouts = ML.mapMaybe verified aggs + where verified (AggStruct s) = + Just (verify (structSize s) (structFields s) + =<< structLayout TypelibMode (structFields s)) + verified (AggUnion u) = + Just (verify (unionSize u) (unionFields u) + =<< unionLayout TypelibMode (unionFields u)) + verified _ = Nothing + + verify :: Int -> [Field] -> Layout -> Either Text Layout + verify size fields layout = do + when (lSize layout /= size) $ + Left $ "Computed size " <> tshow (lSize layout) + <> " does not match typelib size " <> tshow size + let offsets = [(flOffset fl, fieldOffset f) + | (fl, f) <- zip (lFields layout) fields + , not (isJust (fieldAnonymous f))] + unless (all (uncurry (==)) offsets) $ + Left "Computed offsets do not match the typelib offsets" + return layout + + -- Layouts following the C ABI, for those types whose typelib + -- layout we can reproduce. + abiLayouts :: ML.Map Name (Either Text Layout) + abiLayouts = ML.mapMaybeWithKey abi aggs + where abi n (AggStruct s) = + Just (typelibLayout n >> structLayout ABIMode (structFields s)) + abi n (AggUnion u) = + Just (typelibLayout n >> unionLayout ABIMode (unionFields u)) + abi _ _ = Nothing + + typelibLayout :: Name -> Either Text Layout + typelibLayout n = case ML.lookup n typelibLayouts of + Just l -> l + Nothing -> Left ("No layout for " <> tshow n) + + abiLayout :: Name -> Either Text Layout + abiLayout n = case ML.lookup n abiLayouts of + Just l -> l + Nothing -> Left ("No layout for " <> tshow n) + + -- Size and alignment of an embedded struct or union. + embeddedSizeAlign :: Mode -> Name -> Either Text SizeAlign + embeddedSizeAlign mode n = do + layout <- case mode of + TypelibMode -> typelibLayout n + ABIMode -> abiLayout n + return (lSize layout, lAlign layout) + + structLayout :: Mode -> [Field] -> Either Text Layout + structLayout mode fields = do + sizes <- forM fields (fieldSizeAlign mode) + let bitfields = case mode of + TypelibMode -> map (const Nothing) fields + ABIMode -> map fieldBits fields + placed = zip3 fields sizes bitfields + if msBitfields + then msStructLayout placed + else sysvStructLayout placed + + unionLayout :: Mode -> [Field] -> Either Text Layout + unionLayout mode fields = do + sizes <- forM fields (fieldSizeAlign mode) + let align = maximum (1 : map snd sizes) + size = roundUp (maximum (0 : map fst sizes)) align + fl (f, (s, _)) = case (mode, fieldBits f) of + (ABIMode, Just w) -> FieldLayout 0 (Just (bitShift s 0 w)) + _ -> FieldLayout 0 Nothing + return $ Layout size align (map fl (zip fields sizes)) + + fieldSizeAlign :: Mode -> Field -> Either Text SizeAlign + fieldSizeAlign mode f = case fieldAnonymous f of + -- These are ignored by the typelib compiler. + Just _ | mode == TypelibMode -> Right (0, 1) + Just (AnonymousUnion members) -> do + layout <- unionLayout mode members + return (lSize layout, lAlign layout) + Just (AnonymousStruct members) -> do + layout <- structLayout mode members + return (lSize layout, lAlign layout) + Nothing + | isPointerField f -> Right pointerSizeAlign + | TCArray _ fixed _ _ <- fieldType f, fixed > 0, fieldArrayOfPointers f -> + let (size, align) = pointerSizeAlign + in Right (fixed * size, align) + | otherwise -> case typeSizeAlign mode (fieldType f) of + Left err -> Left ("Field “" <> fieldName f <> "”: " <> err) + r -> r + + -- Size and alignment of a type stored inline. + typeSizeAlign :: Mode -> Type -> Either Text SizeAlign + typeSizeAlign mode t = case t of + TBasicType b -> basicSizeAlign b + TInterface n -> case ML.lookup n aggs of + Just (AggStruct _) -> embeddedSizeAlign mode n + Just (AggUnion _) -> embeddedSizeAlign mode n + Just (AggScalar size) -> Right (size, size) + Just AggPointer -> Right pointerSizeAlign + Nothing -> Left ("Unknown type " <> tshow n) + TGValue -> embeddedSizeAlign mode (Name "GObject" "Value") + TGClosure _ -> embeddedSizeAlign mode (Name "GObject" "Closure") + TCArray _ fixed _ elemType + | fixed > 0 -> do + (size, align) <- typeSizeAlign mode elemType + return (fixed * size, align) + | otherwise -> Right pointerSizeAlign + _ -> Right pointerSizeAlign + +-- | Whether the field is a pointer (as opposed to being stored inline +-- in the struct). +isPointerField :: Field -> Bool +isPointerField f = isJust (fieldCallback f) || fieldIsPointer f == Just True + +-- | Lay out the fields in a struct following the rules of the System +-- V (and Itanium) ABIs: a bitfield is placed at the next available +-- bit, unless it would straddle a storage unit of its declared type, +-- in which case it is placed at the start of the next such unit. +sysvStructLayout :: [(Field, SizeAlign, Maybe Int)] -> Either Text Layout +sysvStructLayout = go 0 1 [] + where + -- We keep track of the position in bits. + go :: Int -> Int -> [FieldLayout] -> [(Field, SizeAlign, Maybe Int)] + -> Either Text Layout + go pos align acc [] = + Right $ Layout (roundUp (roundUp pos 8 `div` 8) align) align (reverse acc) + go pos align acc ((f, (size, falign), bits) : rest) = case bits of + Nothing -> + let offset = roundUp (roundUp pos 8 `div` 8) falign + in go ((offset + size) * 8) (max align falign) + (FieldLayout offset Nothing : acc) rest + Just w -> do + let unitBits = size * 8 + when (w > unitBits) $ + Left ("Bitfield “" <> fieldName f <> "” is wider than its type") + let start = if pos `mod` unitBits + w > unitBits + then roundUp pos unitBits + else pos + unit = (start `div` unitBits) * size + go (start + w) (max align falign) + (FieldLayout unit (Just (bitShift size (start - unit * 8) w)) : acc) + rest + +-- | Lay out the fields in a struct following the rules used by MSVC +-- (and by GCC with @-mms-bitfields@, the default on Windows): a +-- bitfield shares the storage unit of the previous bitfield only if +-- their declared types have the same size and there is enough space +-- left, otherwise a new storage unit is allocated. +msStructLayout :: [(Field, SizeAlign, Maybe Int)] -> Either Text Layout +msStructLayout = go 0 Nothing 1 [] + where + -- We keep track of the end of the struct so far in bytes, and of + -- the current storage unit (offset, size, bits used), if any. + go :: Int -> Maybe (Int, Int, Int) -> Int -> [FieldLayout] + -> [(Field, SizeAlign, Maybe Int)] -> Either Text Layout + go end _ align acc [] = + Right $ Layout (roundUp end align) align (reverse acc) + go end unit align acc ((f, (size, falign), bits) : rest) = case bits of + Nothing -> + let offset = roundUp end falign + in go (offset + size) Nothing (max align falign) + (FieldLayout offset Nothing : acc) rest + Just w -> do + when (w > size * 8) $ + Left ("Bitfield “" <> fieldName f <> "” is wider than its type") + case unit of + Just (uOffset, uSize, used) | uSize == size && used + w <= size * 8 -> + go end (Just (uOffset, uSize, used + w)) (max align falign) + (FieldLayout uOffset (Just (bitShift size used w)) : acc) rest + _ -> do + let offset = roundUp end falign + go (offset + size) (Just (offset, size, w)) (max align falign) + (FieldLayout offset (Just (bitShift size 0 w)) : acc) rest + +-- | Shift of the least significant bit of a bitfield of the given +-- width, starting at the given bit position in a storage unit of +-- the given size in bytes. On big endian machines bitfields are +-- allocated starting from the most significant bit. +bitShift :: Int -> Int -> Int -> Int +bitShift unitSize pos width + | bigEndian = unitSize * 8 - pos - width + | otherwise = pos + +-- | Whether we are running on a big endian machine. +bigEndian :: Bool +bigEndian = (#{const G_BYTE_ORDER} :: Int) == #{const G_BIG_ENDIAN} + +-- | Whether bitfields are laid out following the MSVC rules. +msBitfields :: Bool +msBitfields = System.Info.os == "mingw32" + +pointerSizeAlign :: SizeAlign +pointerSizeAlign = (#{size gpointer}, #{alignment gpointer}) + +-- | Size and alignment of the basic types. +basicSizeAlign :: BasicType -> Either Text SizeAlign +basicSizeAlign t = case t of + TBoolean -> Right (#{size gboolean}, #{alignment gboolean}) + TInt -> Right (#{size gint}, #{alignment gint}) + TUInt -> Right (#{size guint}, #{alignment guint}) + TLong -> Right (#{size glong}, #{alignment glong}) + TULong -> Right (#{size gulong}, #{alignment gulong}) + TInt8 -> Right (#{size gint8}, #{alignment gint8}) + TUInt8 -> Right (#{size guint8}, #{alignment guint8}) + TInt16 -> Right (#{size gint16}, #{alignment gint16}) + TUInt16 -> Right (#{size guint16}, #{alignment guint16}) + TInt32 -> Right (#{size gint32}, #{alignment gint32}) + TUInt32 -> Right (#{size guint32}, #{alignment guint32}) + TInt64 -> Right (#{size gint64}, #{alignment gint64}) + TUInt64 -> Right (#{size guint64}, #{alignment guint64}) + TFloat -> Right (#{size gfloat}, #{alignment gfloat}) + TDouble -> Right (#{size gdouble}, #{alignment gdouble}) + TUniChar -> Right (#{size gunichar}, #{alignment gunichar}) + TGType -> Right (#{size GType}, #{alignment GType}) + TUTF8 -> Right pointerSizeAlign + TFileName -> Right pointerSizeAlign + TPtr -> Right pointerSizeAlign + TIntPtr -> Right (#{size gintptr}, #{alignment gintptr}) + TUIntPtr -> Right (#{size guintptr}, #{alignment guintptr}) + TShort -> Right (#{size gshort}, #{alignment gshort}) + TUShort -> Right (#{size gushort}, #{alignment gushort}) + TSize -> Right (#{size gsize}, #{alignment gsize}) + TSSize -> Right (#{size gssize}, #{alignment gssize}) + Ttime_t -> Right (sizeOf (0 :: CTime), alignment (0 :: CTime)) + _ -> Left ("Unsupported basic type " <> tshow t) + +roundUp :: Int -> Int -> Int +roundUp n a = ((n + a - 1) `div` a) * a + +tshow :: Show a => a -> Text +tshow = T.pack . show diff --git a/lib/Data/GI/GIR/Field.hs b/lib/Data/GI/GIR/Field.hs --- a/lib/Data/GI/GIR/Field.hs +++ b/lib/Data/GI/GIR/Field.hs @@ -1,6 +1,7 @@ -- | Parsing of object/struct/union fields. module Data.GI.GIR.Field ( Field(..) + , AnonymousMember(..) , FieldInfoFlag , parseFields ) where @@ -13,7 +14,7 @@ #endif import Data.Text (Text, isSuffixOf) -import Data.GI.GIR.BasicTypes (Type(..)) +import Data.GI.GIR.BasicTypes (Type(..), BasicType(..)) import Data.GI.GIR.Callback (Callback, parseCallback) import Data.GI.GIR.Type (parseType, queryElementCType) import Data.GI.GIR.Parser @@ -23,8 +24,27 @@ fieldVisible :: Bool, fieldType :: Type, fieldIsPointer :: Maybe Bool, -- ^ `Nothing` if not known. + fieldArrayOfPointers :: Bool, + -- ^ For C arrays stored inline in the struct (that is, with a + -- fixed size), whether the elements are pointers. fieldCallback :: Maybe Callback, fieldOffset :: Int, + -- ^ For bitfields, this is the offset of the storage unit + -- containing the bitfield. + fieldBits :: Maybe Int, + -- ^ The width in bits, if the field is a bitfield. + fieldBitShift :: Maybe Int, + -- ^ For bitfields, the position of the least significant bit + -- of the bitfield inside its storage unit (a value of the + -- declared type of the field, stored at `fieldOffset`). This + -- is `Nothing` if the layout of the bitfield could not be + -- determined. + fieldAnonymous :: Maybe AnonymousMember, + -- ^ If this member is an (anonymous type) union or struct + -- declared inline, its contents. In this case `fieldType` + -- is meaningless, and the field is never visible. We keep + -- track of these members since they affect the layout of + -- the containing struct or union. fieldFlags :: [FieldInfoFlag], fieldDocumentation :: Documentation, fieldDeprecated :: Maybe DeprecationInfo } @@ -33,6 +53,12 @@ data FieldInfoFlag = FieldIsReadable | FieldIsWritable deriving Show +-- | Contents of a union or struct declared inline in a struct or +-- union. +data AnonymousMember = AnonymousUnion [Field] + | AnonymousStruct [Field] + deriving Show + -- | Parse a single field in a struct or union. We parse -- non-introspectable fields too (but set fieldVisible = False for -- them), this is necessary since they affect the computation of @@ -41,6 +67,7 @@ parseField = do name <- getAttr "name" deprecated <- parseDeprecation + bits <- optionalAttr "bits" Nothing (fmap Just . parseIntegral) readable <- optionalAttr "readable" True parseBool writable <- optionalAttr "writable" False parseBool let flags = if readable then [FieldIsReadable] else [] @@ -79,6 +106,11 @@ [n] -> return (TInterface n, Just True, Nothing) _ -> parseError "Multiple callbacks in field" + elementCTypes <- parseAllChildrenWithLocalName "array" queryElementCType + let arrayOfPointers = case elementCTypes of + [Just ct] -> "*" `isSuffixOf` ct + _ -> False + return $ Just $ Field { fieldName = name , fieldVisible = introspectable && not private @@ -86,12 +118,50 @@ , fieldIsPointer = if isJust callback then Just True else isPtr + , fieldArrayOfPointers = arrayOfPointers , fieldCallback = callback , fieldOffset = error ("unfixed field offset " ++ show name) + , fieldBits = if bits == Just 0 then Nothing else bits + , fieldBitShift = Nothing + , fieldAnonymous = Nothing , fieldFlags = flags , fieldDocumentation = doc , fieldDeprecated = deprecated } +-- | Parse an union or struct declared inline in a struct or union. +parseAnonymousMember :: Bool -> Parser Field +parseAnonymousMember isUnion = do + name <- optionalAttr "name" (if isUnion + then "" + else "") return + -- We do not keep track of the offsets of the members of the + -- anonymous union or struct, only of its total size. + members <- map (\f -> f {fieldOffset = 0}) <$> parseFields + doc <- parseDocumentation + return $ Field { + fieldName = name + , fieldVisible = False + , fieldType = TBasicType TPtr -- Not meaningful + , fieldIsPointer = Just False + , fieldArrayOfPointers = False + , fieldCallback = Nothing + , fieldOffset = 0 + , fieldBits = Nothing + , fieldBitShift = Nothing + , fieldAnonymous = Just (if isUnion + then AnonymousUnion members + else AnonymousStruct members) + , fieldFlags = [] + , fieldDocumentation = doc + , fieldDeprecated = Nothing + } + +-- | Parse the members of a struct or union, in order. parseFields :: Parser [Field] -parseFields = catMaybes <$> parseAllChildrenWithLocalName "field" parseField +parseFields = catMaybes <$> + parseAllChildrenWithLocalNames ["field", "union", "record"] parseMember + where parseMember :: Text -> Parser (Maybe Field) + parseMember "union" = Just <$> parseAnonymousMember True + parseMember "record" = Just <$> parseAnonymousMember False + parseMember _ = parseField diff --git a/lib/Data/GI/GIR/Parser.hs b/lib/Data/GI/GIR/Parser.hs --- a/lib/Data/GI/GIR/Parser.hs +++ b/lib/Data/GI/GIR/Parser.hs @@ -14,6 +14,7 @@ , parseBool , parseChildrenWithLocalName , parseAllChildrenWithLocalName + , parseAllChildrenWithLocalNames , parseChildrenWithNSName , getAttr @@ -53,7 +54,7 @@ import Data.GI.GIR.Documentation (Documentation, queryDocumentation) import Data.GI.GIR.XMLUtils (localName, GIRXMLNamespace(..), childElemsWithLocalName, childElemsWithNSName, - lookupAttr, lookupAttrWithNamespace) + lookupAttr, lookupAttrWithNamespace, subelements) -- | Info to carry around when parsing. data ParseContext = ParseContext { @@ -204,6 +205,15 @@ parseAllChildrenWithLocalName n parser = do ctx <- ask mapM (withElement parser) (childElemsWithLocalName n (currentElement ctx)) + +-- | Parse all subelements whose local name is one of the given +-- ones, in document order. The parser is passed the local name of +-- the subelement being parsed. +parseAllChildrenWithLocalNames :: [Text] -> (Text -> Parser a) -> Parser [a] +parseAllChildrenWithLocalNames names parser = do + ctx <- ask + mapM (\e -> withElement (parser (localName e)) e) + (filter ((`elem` names) . localName) (subelements (currentElement ctx))) -- | Parse all introspectable children with the given namespace and -- local name.