diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,37 @@ # Revision history for `c-expr` +## 0.2.0.0 -- 2026-10-16 + +### Breaking changes + +- Pointer arithmetic counts elements of the pointee, as in C, and not bytes: + `p + i` and `i + p` advance `p` by `i` elements, `p - i` moves `p` back by + `i` elements, and `p1 - p2` counts the elements between `p1` and `p2`. The + `Add` and `Sub` instances for `Ptr ty` now require the new class + `Pointee ty`: `Pointee`s are `Storable ty`, whose `sizeOf` is the size of the + step. In particular, neither `Void` nor `()` is an instance of `Pointee`. + Arithmetic on `Ptr ()` (`void *`) and on pointers to opaque types is a type + error, as in C; for byte arithmetic, cast to `Ptr Word8` first. See [issue + #2306][issue-2306]. +- `SPtr` now holds an `SPointee rec ty`: `SVoidPointee` for `void *`, or + `SObjPointee`, which carries the `Pointee ty` evidence. + +### New features + +- `C.Type` exports `Pointee`, `NotVoid`, `SPointee(..)`, and `unSPointee`. + +### Bug fixes + +- `p - i` for an unsigned `i` narrower than `Int` no longer wraps around: on + 64-bit platforms, `p - 1u` moved `p` forward by `UINT_MAX` bytes. + +[issue-2306]: https://github.com/well-typed/hs-bindgen/issues/2306 + ## 0.1.0.0 -- 2026-07-14 -* Remove the `C.Char` module; UTF-8 encoding of character and string literals +- Remove the `C.Char` module; UTF-8 encoding of character and string literals now lives in `c-expr-dsl`'s parser. ## 0.1.0-alpha -- 2026-02-06 -* Release candidate. +- Release candidate. diff --git a/c-expr-runtime.cabal b/c-expr-runtime.cabal --- a/c-expr-runtime.cabal +++ b/c-expr-runtime.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: c-expr-runtime -version: 0.1.0.0 +version: 0.2.0.0 license: BSD-3-Clause license-file: LICENSE author: Well-Typed LLP @@ -51,7 +51,7 @@ type: git location: https://github.com/well-typed/c-expr.git subdir: c-expr-runtime - tag: release-0.1.0.0 + tag: c-expr-runtime-0.2.0.0 common common ghc-options: @@ -123,7 +123,7 @@ -- Internal dependencies build-depends: , c-expr-runtime - , libclang-bindings + , libclang-bindings >=0.2 && <0.3 -- Inherited dependencies build-depends: diff --git a/core/C/Operator/Classes.hs b/core/C/Operator/Classes.hs --- a/core/C/Operator/Classes.hs +++ b/core/C/Operator/Classes.hs @@ -105,6 +105,10 @@ -- | Result type family of the C binary addition operator. type family AddRes a b :: Type -- | C binary addition operator. + -- + -- With a pointer operand, @p + i@ and @i + p@ advance @p :: 'Ptr' ty@ by @i@ + -- elements of @ty@, as in C. An element is + -- @'Foreign.Storable.sizeOf' (undefined :: ty)@ bytes; see 'C.Type.Pointee'. (+) :: a -> b -> AddRes a b infixl 2 - @@ -114,6 +118,11 @@ -- | Result type family of the C binary subtraction operator. type family SubRes a b :: Type -- | C binary subtraction operator. + -- + -- With pointer operands, @p - i@ moves @p :: 'Ptr' ty@ back by @i@ elements + -- of @ty@, and @p1 - p2@ is the number of elements of @ty@ from @p2@ to @p1@, + -- as in C. An element is @'Foreign.Storable.sizeOf' (undefined :: ty)@ + -- bytes; see 'C.Type.Pointee'. (-) :: a -> b -> SubRes a b infixl 1 * diff --git a/core/C/Operator/TH.hs b/core/C/Operator/TH.hs --- a/core/C/Operator/TH.hs +++ b/core/C/Operator/TH.hs @@ -34,7 +34,7 @@ ( on ) import Data.Kind qualified as Hs import Data.List - ( sortOn ) + ( nub, sortOn ) import Data.List.NonEmpty ( groupBy ) @@ -48,7 +48,7 @@ import Data.Void ( absurd ) import Foreign - ( Ptr, plusPtr, minusPtr ) + ( Ptr, sizeOf, advancePtr, minusPtr ) import Foreign.C import qualified GHC.Exts as Foreign.C ( Ptr(Ptr) ) @@ -419,7 +419,7 @@ args = zip argNms ( toList argTys ) proveNm = TH.mkName proveStr - ( provePats, mbProveGuard ) = mkSingPats ( toList argTys ) + ( provePats, mbProveGuard ) = mkSingPats pointees ( toList argTys ) proveRes = TH.TupE [ Just ( mkSingExp resTy ), Just $ TH.VarE meth ] mkConversions :: [ Conversion ] -> TH.Exp -> TH.Exp @@ -442,43 +442,52 @@ zipWith mkConversions ( toList convs ) ( map TH.VarE argNms ) AddIntegralAndPtr -> case argNms of - [ i, p ] -> - TH.VarE 'plusPtr - `TH.AppE` - ( TH.VarE p ) - `TH.AppE` - ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i ) + [ i, p ] -> advance p ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i ) _ -> error $ "genInstance AddIntegralAndPtr: expected 2 arguments, but got: " ++ show args AddPtrAndIntegral -> case argNms of - [ p, i ] -> - TH.VarE 'plusPtr - `TH.AppE` - ( TH.VarE p ) - `TH.AppE` - ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i ) + [ p, i ] -> advance p ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i ) _ -> error $ "genInstance AddPtrAndIntegral: expected 2 arguments, but got: " ++ show args SubPtrAndPtr -> - case argNms of - [ p1, p2 ] -> + case ( argNms, toList argTys ) of + ( [ p1, p2 ], Ptr ty : _ ) -> ( TH.VarE 'fromIntegral `TH.AppTypeE` TH.WildCardT `TH.AppTypeE` TH.ConT ''CPtrdiff ) `TH.AppE` - ( TH.VarE 'minusPtr `TH.AppE` TH.VarE p1 `TH.AppE` TH.VarE p2 ) - _ -> error $ "genInstance SubPtrAndPtr: expected 2 arguments, but got: " ++ show args + ( TH.VarE 'quot + `TH.AppE` + ( TH.VarE 'minusPtr `TH.AppE` TH.VarE p1 `TH.AppE` TH.VarE p2 ) + `TH.AppE` + ( TH.VarE 'sizeOf `TH.AppE` TH.SigE ( TH.VarE 'undefined ) ( TH.VarT ty ) ) + ) + _ -> error $ "genInstance SubPtrAndPtr: expected 2 pointer arguments, but got: " ++ show args SubPtrAndIntegral -> case argNms of [ p, i ] -> - TH.VarE 'plusPtr - `TH.AppE` - ( TH.VarE p ) - `TH.AppE` - ( TH.VarE 'fromIntegral `TH.AppE` ( TH.VarE 'Prelude.negate `TH.AppE` TH.VarE i ) ) + -- Negate after the conversion: negating an unsigned + -- offset would wrap around. + advance p ( TH.VarE 'Prelude.negate `TH.AppE` ( TH.VarE 'fromIntegral `TH.AppE` TH.VarE i ) ) _ -> error $ "genInstance SubPtrAndIntegral: expected 2 arguments, but got: " ++ show args + advance :: TH.Name -> TH.Exp -> TH.Exp + advance p n = TH.VarE 'advancePtr `TH.AppE` TH.VarE p `TH.AppE` n ] overlap :: Maybe TH.Overlap overlap = Nothing + pointees :: Pointees + pointees = + case methImpl of + ConvertThenOp {} -> AnyPointees + AddIntegralAndPtr -> ObjectPointees + AddPtrAndIntegral -> ObjectPointees + SubPtrAndPtr -> ObjectPointees + SubPtrAndIntegral -> ObjectPointees ctxt :: [ TH.Type ] - ctxt = [ ] + ctxt = + case pointees of + AnyPointees -> [] + ObjectPointees -> + [ TH.ConT ''Pointee `TH.AppT` TH.VarT ty + | ty <- nub [ ty | Ptr ty <- toList argTys ] + ] return $ ( TH.InstanceD overlap ctxt clsTy ( famDecs ++ methDecs ) , proveDecs @@ -504,16 +513,27 @@ mkSingTy :: TH.Type -> TH.Type mkSingTy ty = ( TH.ConT ''SType ) `TH.AppT` TH.VarT ( TH.mkName "rec" ) `TH.AppT` ty -mkSingPats :: [ Type TH.Name ] -> ( [ TH.Pat ], Maybe TH.Guard ) -mkSingPats tys = ( map ( mkSingPat . mkOne ) tickedTys, if null guards then Nothing else Just $ TH.PatG guards ) +-- | Which pointees the pointer arguments of an instance accept. +data Pointees + = -- | Any pointee, including @void@. + AnyPointees + | -- | Only object types: the instance needs t'Pointee'. + ObjectPointees + +mkSingPats :: Pointees -> [ Type TH.Name ] -> ( [ TH.Pat ], Maybe TH.Guard ) +mkSingPats pointees tys = ( map mkOne tickedTys, if null guards then Nothing else Just $ TH.PatG guards ) where tickedTys = mkTicked 0 tys mkTicked :: Int -> [ Type TH.Name ] -> [ Either ( TH.Name, Int ) ( Type TH.Name ) ] mkTicked _ [] = [] mkTicked i ( Ptr nm : rest ) = Left ( nm, i ) : mkTicked ( i + 1 )rest mkTicked i ( ty : rest ) = Right ty : mkTicked i rest - mkOne ( Left ( nm, i ) ) = Ptr $ mkTickedName nm i - mkOne ( Right ty ) = ty + mkOne ( Left ( nm, i ) ) = + case pointees of + AnyPointees -> mkSingPat $ Ptr $ mkTickedName nm i + ObjectPointees -> + TH.ConP 'SPtr [] [ TH.AsP ( mkTickedName nm i ) ( TH.ConP 'SObjPointee [] [ TH.WildP ] ) ] + mkOne ( Right ty ) = mkSingPat ty guards = concat $ mapMaybe mkGroup $ groupBy ( (==) `on` fst ) $ mapMaybe oneGuard tickedTys mkGroup :: NE.NonEmpty ( TH.Name, Int ) -> Maybe [ TH.Stmt ] mkGroup ( _ NE.:| [] ) = Nothing diff --git a/core/C/Type.hs b/core/C/Type.hs --- a/core/C/Type.hs +++ b/core/C/Type.hs @@ -4,6 +4,8 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} module C.Type ( -- * C types @@ -26,8 +28,14 @@ , Platform(..), WordWidth(..), OS(..) , hostPlatform + -- * Pointees + , Pointee + , NotVoid + -- * Singletons for C types , SType(..) + , SPointee(..) + , unSPointee , SArithmeticType(..) , SIntegralType(..) , SCharLikeType(..) @@ -66,8 +74,9 @@ import Data.Type.Equality import Foreign.C.Types import Foreign.Ptr qualified as Foreign (Ptr) -import Foreign.Storable (sizeOf) +import Foreign.Storable (Storable, sizeOf) import GHC.Generics (Generic) +import GHC.TypeLits (ErrorMessage (..), TypeError) import System.Info qualified (os) -------------------------------------------------------------------------------- @@ -293,15 +302,45 @@ Unsigned -> ( "unsigned " ++ ) -------------------------------------------------------------------------------- +-- Pointees + +-- | The pointee must not be @void@ because it has no size. +type NotVoid :: Hs.Type -> Hs.Constraint +type family NotVoid ty where + NotVoid () = TypeError ( 'Text "Pointer arithmetic on 'void *' is not allowed in C; cast the pointer first." ) + NotVoid _ = () + +-- | A valid pointee: an object type with non-zero 'sizeOf'. +-- +-- Pointer arithmetic can step over a pointee. +class ( Storable ty, NotVoid ty ) => Pointee ty +instance ( Storable ty, NotVoid ty ) => Pointee ty + +-------------------------------------------------------------------------------- -- Singletons type SType :: ( Hs.Type -> Hs.Type ) -> Hs.Type -> Hs.Type data SType rec a where SVoid :: SType rec () SArithmetic :: !( SArithmeticType ty ) -> SType rec ty - SPtr :: rec ty -> SType rec ( Foreign.Ptr ty ) + SPtr :: !( SPointee rec ty ) -> SType rec ( Foreign.Ptr ty ) deriving stock instance ( forall x. Show ( rec x ) ) => Show ( SType rec a ) +-- | Singleton for the pointee of 'SPtr'. +type SPointee :: ( Hs.Type -> Hs.Type ) -> Hs.Type -> Hs.Type +data SPointee rec ty where + -- | @void@: pointer arithmetic is not allowed. + SVoidPointee :: rec () -> SPointee rec () + -- | An object type: pointer arithmetic is allowed. + SObjPointee :: Pointee ty => rec ty -> SPointee rec ty +deriving stock instance ( forall x. Show ( rec x ) ) => Show ( SPointee rec ty ) + +-- | The singleton of the pointee type, whether @void@ or not. +unSPointee :: SPointee rec ty -> rec ty +unSPointee = \case + SVoidPointee a -> a + SObjPointee a -> a + data SArithmeticType ty where SIntegral :: !( SIntegralType ty ) -> SArithmeticType ty SFloatLike :: !( SFloatingType ty ) -> SArithmeticType ty @@ -345,6 +384,10 @@ Just Refl -> Just Refl Nothing -> Nothing geq _ _ = Nothing +instance GEq rec => GEq ( SPointee rec ) where + geq (SVoidPointee _) (SVoidPointee _) = Just Refl + geq (SObjPointee a) (SObjPointee b) = geq a b + geq _ _ = Nothing instance GEq SArithmeticType where geq (SIntegral a) (SIntegral b) = geq a b geq (SFloatLike a) (SFloatLike b) = geq a b @@ -378,7 +421,7 @@ geq SPtrDiff SPtrDiff = Just Refl geq _ _ = Nothing -promoteType :: ( a -> ( forall ty. rec ty -> r ) -> r ) -> Type a -> ( forall ty. ( Ord ty, Show ty ) => SType rec ty -> r ) -> r +promoteType :: ( a -> ( forall ty. SPointee rec ty -> r ) -> r ) -> Type a -> ( forall ty. ( Ord ty, Show ty ) => SType rec ty -> r ) -> r promoteType recur ty f = case ty of Void -> f SVoid Arithmetic i -> promoteArithmeticType i ( f . SArithmetic ) @@ -430,7 +473,7 @@ demoteType recur = \case SVoid -> Void SArithmetic a -> Arithmetic $ demoteArithmeticType a - SPtr a -> Ptr $ recur a + SPtr a -> Ptr $ recur $ unSPointee a demoteArithmeticType :: SArithmeticType ty -> ArithmeticType demoteArithmeticType = \case @@ -478,7 +521,7 @@ case ty of SVoid -> f SArithmetic i -> witnessArithmeticType @c i f - SPtr p -> recur p f + SPtr p -> recur ( unSPointee p ) f witnessArithmeticType :: forall c ty r diff --git a/test/CallClang.hs b/test/CallClang.hs --- a/test/CallClang.hs +++ b/test/CallClang.hs @@ -31,9 +31,9 @@ import Clang.Enum.Bitfield qualified as Clang (BitfieldEnum, bitfieldEnum) import Clang.Enum.Simple qualified as Clang (fromSimpleEnum) import Clang.HighLevel qualified as Clang hiding (clang_getCursorLocation) +import Clang.HighLevel.Types (SourcePath (..)) import Clang.HighLevel.Types qualified as Clang import Clang.LowLevel.Core qualified as Clang hiding (clang_visitChildren) -import Clang.Paths qualified as Paths -------------------------------------------------------------------------------- @@ -64,6 +64,7 @@ -- '__size_t', and '__signed_size_t' as 'CXType_Unexposed' (see -- upstream https://github.com/llvm/llvm-project/issues/192268). -- Fall back to the canonical type to recover the underlying kind. + -- LLVM/Clang 23 and later report 'CXType_PredefinedSugar' instead. Clang.CXType_Unexposed -> do { canTy <- Clang.clang_getCanonicalType cxTy ; case Clang.fromSimpleEnum $ Clang.cxtKind canTy of Right Clang.CXType_Unexposed -> return Nothing @@ -138,6 +139,8 @@ Clang.CXType_Attributed -> return Nothing Clang.CXType_ExtVector -> return Nothing Clang.CXType_Atomic -> return Nothing + Clang.CXType_PredefinedSugar -> do { canTy <- Clang.clang_getCanonicalType cxTy + ; parseClangType canTy } -- | Query @clang@ for canonical names for types. getExpansionTypeMapping :: Clang.ClangArgs -> [ CType ] -> IO ( Map CType CType ) @@ -297,8 +300,8 @@ headerName :: FilePath headerName = "src.c" - src :: Paths.SourcePath - src = Paths.SourcePath $ Text.pack headerName + src :: SourcePath + src = SourcePath $ Text.pack headerName args :: Clang.ClangArgs args = Clang.ClangArgs $ diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -17,9 +17,12 @@ import Data.Traversable (for) import Data.Type.Nat import Data.Vec.Lazy (Vec (..)) +import Foreign (Ptr, nullPtr, plusPtr) +import Foreign.C.Types (CDouble, CInt, CPtrdiff, CUInt) import System.Exit import System.Info qualified as Info +import C.Expr.HostPlatform qualified as C import C.Type import C.Type.Internal.Universe @@ -91,10 +94,42 @@ " FAILED:" : map ( showFailure . first show ) bad pure $ Just bad - if null badUnary && null badBinary + putStrLn "Pointer arithmetic" + ptrArith <- pointerArithmeticTests + let badPtrArith = [ name | ( name, False ) <- ptrArith ] + if null badPtrArith + then putStrLn $ " PASSED (" ++ show ( length ptrArith ) ++ " tests)" + else putStrLn $ unlines $ " FAILED:" : map ( " " ++ ) badPtrArith + if null badUnary && null badBinary && null badPtrArith then exitSuccess else exitFailure +-- | Pointer arithmetic counts elements of the pointee, not bytes. +pointerArithmeticTests :: IO [ ( String, Bool ) ] +pointerArithmeticTests = + pure + [ ( "int* + int" , ( ints C.+ ( 4 :: CInt ) ) == ints4 ) + , ( "int + int*" , ( ( 4 :: CInt ) C.+ ints ) == ints4 ) + , ( "int* - int" , ( ints4 C.- ( 4 :: CInt ) ) == ints ) + , ( "int* - unsigned" , ( ints4 C.- ( 4 :: CUInt ) ) == ints ) + , ( "int* - int*" , ( ints4 C.- ints ) == ( 4 :: CPtrdiff ) ) + , ( "int* - int* < 0" , ( ints C.- ints4 ) == ( -4 :: CPtrdiff ) ) + , ( "double* + int" , ( doubles C.+ ( 4 :: CInt ) ) == doubles `plusPtr` 32 ) + , ( "singAdd int* int" , snd ( C.singAdd sIntPtr sInt ) ints 4 == ints4 ) + , ( "singSub int* int*", snd ( C.singSub sIntPtr sIntPtr ) ints4 ints == 4 ) + ] + where + ints, ints4 :: Ptr CInt + ints = nullPtr + ints4 = nullPtr `plusPtr` 16 + doubles :: Ptr CDouble + doubles = nullPtr + sIntArith :: SArithmeticType CInt + sIntArith = SIntegral $ SIntLike SInt + sInt :: SType SArithmeticType CInt + sInt = SArithmetic sIntArith + sIntPtr :: SType SArithmeticType ( Ptr CInt ) + sIntPtr = SPtr $ SObjPointee sIntArith clangResourceDirArgs :: IO [ String ] clangResourceDirArgs = do