[Gtkhs] c2hs Revision
Axel Simon
A.Simon@kent.ac.uk
Sun, 6 Jul 2003 20:44:40 +0100
--sm4nu43k4a2Rpi4c
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline
Hi Manuel,
I played around with your new release of c2hs (0.11.5):
-- The C preprocessor now works for me on FreeBSD (gcc 3.2.2), I haven't
tried Solaris yet. Did you change anything?
-- On a clean tree, compiling c2hs yields
*** Selecting system-dependent code...
gmake -C base/sysdep config
gmake[1]: Entering directory `/home/as49/source/c2hs-0.11.5/base/sysdep'
SysDepGHC6.hs in SysDepGHC3.hs SysDepGHC4.hs SysDepNHC1.hs
SysDepPosixAVAIL.hs SysDepPosixUNAVAIL.hs SysDepGHC5.hs SysDepGHC6.hs
*** Unsupported Haskell compiler `ghc6' specified!
gmake[1]: *** [config] Error 1
gmake[1]: Leaving directory `/home/as49/source/c2hs-0.11.5/base/sysdep'
gmake: *** [config] Error 2
. It runs through the second time.
-- On Mac OS the --whole-archive options is not understood by the linker.
I managed to compile by commenting out ctk.o in base/Makefile
-- ForeignPtrs as arguments to foreign imports are no longer accepted in
GHC 6.00. I patched version 0.11.5 so that at least {#pointer Blah foreign
newtype#} works again. I got rid of the (clumsy) isResult flags which is
set when extractFunType (and extractSimpleType and extractCompType)
calculate the return type of a function. When this flag is set,
extractCompType changed the ForeignPtr into a Ptr. In my version it's
extractFunType which turns ForeignPtrs into Ptrs. Furthermore it tells
callImport what arguments were ForeignPtrs. The trick is to let DefinedET
keep track of what the External Type is a synonym of. The code got simpler
by this patch, so I think it was the right way to go.
callImport now spits out
(\(GObject arg1) arg2 arg3 -> withForeignPtr arg1 $ \argPtr1 ->
g_object_set_property argPtr1 arg2 arg3)
instead of
g_object_set_property
for every function with ForeignPtrs. I might have broken support for
{#pointer Blah foreign#}
which emits only
type Blah = ForeignPtr Blah
as far as I remember. The pattern matching shouldn't happen in this case.
Furthermore there is this complex funDef function, which I haven't altered
yet because I don't understand it (it's not documented anywhere, is it?).
Hope this patch helps.
-- To avoid all the warnings, could c2hs emit the "unsafe" keyword after
"ccall"? If you want backwards compatibility I propose to replace the
--old-ffi switch so that it takes the version number of GHC. Then you
could emit Addr and different FFI standards based on that number.
Thanks,
Axel.
--sm4nu43k4a2Rpi4c
Content-Type: text/plain; charset=us-ascii
Content-Disposition: attachment; filename="foreignFix.patch"
*** gen/GBMonad.hs Wed Feb 12 09:41:03 2003
--- /home/as49/source/c2hs-0.11.5/c2hs/gen/GBMonad.hs Sun Jul 6 16:44:59 2003
***************
*** 172,178 ****
-- for type arguments to parametrised pointer types, ie, it holds for `res'
-- in `Int -> IO res', but not in `Int -> Ptr res'
--
! type PointerMap = FiniteMap (Bool, Ident) (String, String)
-- map that maintains key information about some of the Haskell objects
-- generated by c2hs
--- 172,178 ----
-- for type arguments to parametrised pointer types, ie, it holds for `res'
-- in `Int -> IO res', but not in `Int -> Ptr res'
--
! type PointerMap = FiniteMap (Bool, Ident) (CHSPtrType, String)
-- map that maintains key information about some of the Haskell objects
-- generated by c2hs
***************
*** 296,302 ****
-- add an entry to the pointer map
--
! ptrMapsTo :: (Bool, Ident) -> (String, String) -> GB ()
(isStar, cName) `ptrMapsTo` hsRepr =
transCT (\state -> (state {
ptrmap = addToFM (isStar, cName) hsRepr (ptrmap state)
--- 296,302 ----
-- add an entry to the pointer map
--
! ptrMapsTo :: (Bool, Ident) -> (CHSPtrType, String) -> GB ()
(isStar, cName) `ptrMapsTo` hsRepr =
transCT (\state -> (state {
ptrmap = addToFM (isStar, cName) hsRepr (ptrmap state)
***************
*** 304,310 ****
-- query the pointer map
--
! queryPtr :: (Bool, Ident) -> GB (Maybe (String, String))
queryPtr pcName = do
fm <- readCT ptrmap
return $ lookupFM fm pcName
--- 304,310 ----
-- query the pointer map
--
! queryPtr :: (Bool, Ident) -> GB (Maybe (CHSPtrType, String))
queryPtr pcName = do
fm <- readCT ptrmap
return $ lookupFM fm pcName
*** gen/GenBind.hs Thu May 22 05:15:02 2003
--- /home/as49/source/c2hs-0.11.5/c2hs/gen/GenBind.hs Sun Jul 6 20:37:21 2003
***************
*** 380,386 ****
do
traceInfoType
decl <- findAndChaseDecl ide False True -- no indirection, but shadows
! ty <- extractSimpleType False pos decl
traceInfoDump decl ty
return $ "(" ++ showExtType ty ++ ")"
where
--- 380,386 ----
do
traceInfoType
decl <- findAndChaseDecl ide False True -- no indirection, but shadows
! ty <- extractSimpleType pos decl
traceInfoDump decl ty
return $ "(" ++ showExtType ty ++ ")"
where
***************
*** 428,434 ****
hsLexeme = ideLexeme `maybe` identToLexeme $ oalias
cdecl' = ide `simplifyDecl` cdecl
callImport hook isPure isUns ideLexeme hsLexeme cdecl' pos
- return hsLexeme
where
traceEnter = traceGenBind $
"** Call hook for `" ++ identToLexeme ide ++ "':\n"
--- 428,433 ----
***************
*** 456,462 ****
traceInfoField
(decl, offsets) <- accessPath path
traceDepth offsets
! ty <- extractSimpleType False pos decl
traceValueType ty
setGet pos access offsets ty
where
--- 455,461 ----
traceInfoField
(decl, offsets) <- accessPath path
traceDepth offsets
! ty <- extractSimpleType pos decl
traceValueType ty
setGet pos access offsets ty
where
***************
*** 654,670 ****
-- want to import into Haskell land
--
callImport :: CHSHook -> Bool -> Bool -> String -> String -> CDecl -> Position
! -> GB ()
callImport hook isPure isUns ideLexeme hsLexeme cdecl pos =
do
-- compute the external type from the declaration, get the library, and
-- delay the foreign export declaration
--
! extType <- extractFunType pos cdecl isPure
lib <- getLibrary
delayCode hook (foreignImport lib ideLexeme hsLexeme isUns extType)
traceFunType extType
! where
traceFunType et = traceGenBind $
"Imported function type: " ++ showExtType et ++ "\n"
--- 653,692 ----
-- want to import into Haskell land
--
callImport :: CHSHook -> Bool -> Bool -> String -> String -> CDecl -> Position
! -> GB String
callImport hook isPure isUns ideLexeme hsLexeme cdecl pos =
do
-- compute the external type from the declaration, get the library, and
-- delay the foreign export declaration
--
! (foreignSyn, extType) <- extractFunType pos cdecl isPure
lib <- getLibrary
delayCode hook (foreignImport lib ideLexeme hsLexeme isUns extType)
traceFunType extType
! -- if the type contained ForeignPtrs, generate a lambda expression
! -- which strips off the constructors
! if any isJust foreignSyn
! then createLambdaExpr foreignSyn
! else return hsLexeme
! where
! createLambdaExpr :: [Maybe String] -> GB String
! createLambdaExpr foreignVec = return $
! "(\\" ++
! unwords (zipWith wrPattern foreignVec [1..])++ " -> "++
! concat (zipWith wrForPtr foreignVec [1..])++hsLexeme++" "++
! unwords (zipWith (\s n ->
! (if isJust s then "argPtr" else "arg")++
! show n)
! foreignVec [1..])++")"
!
! wrPattern (Just syn) n = "("++syn++" arg"++show n++")"
! wrPattern Nothing n = "arg"++show n
!
! wrForPtr (Just _) n = "withForeignPtr arg"++show n++" $ \\argPtr"++
! show n++" ->"
! wrForPtr Nothing n = ""
!
!
traceFunType et = traceGenBind $
"Imported function type: " ++ showExtType et ++ "\n"
***************
*** 809,815 ****
addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> CDecl
-> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller pos parms parm cdecl = do
! (resTy, argTys) <- splitFunTy `liftM` extractFunType pos cdecl True
(parm' , isImpure1) <- checkResMarsh parm resTy
(parms', isImpure2) <- addDft parms argTys
return (parms', parm', isImpure1 || isImpure2)
--- 831,838 ----
addDftMarshaller :: Position -> [CHSParm] -> CHSParm -> CDecl
-> GB ([CHSParm], CHSParm, Bool)
addDftMarshaller pos parms parm cdecl = do
! (foreignVec, fType) <- extractFunType pos cdecl True
! let (resTy, argTys) = splitFunTy fType
(parm' , isImpure1) <- checkResMarsh parm resTy
(parms', isImpure2) <- addDft parms argTys
return (parms', parm', isImpure1 || isImpure2)
***************
*** 1052,1058 ****
checkType (IOET _ ) = interr "GenBind.setGet: Illegal \
\type!"
checkType (UnitET ) = voidFieldErr pos
! checkType (DefinedET _ _ ) = return Nothing-- can't check further
checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs)
checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs)
checkType _ = return Nothing
--- 1075,1081 ----
checkType (IOET _ ) = interr "GenBind.setGet: Illegal \
\type!"
checkType (UnitET ) = voidFieldErr pos
! checkType (DefinedET _ _ _) = return Nothing-- can't check further
checkType (PrimET (CUFieldPT bs)) = return $ Just (False, bs)
checkType (PrimET (CSFieldPT bs)) = return $ Just (True , bs)
checkType _ = return Nothing
***************
*** 1085,1093 ****
_ -> show ptrKind
ptrType = ptrCon ++ " (" ++ ptrArg ++ ")"
thePtr = (isStar, cNameFull)
! case ptrKind of
! CHSForeignPtr -> thePtr `ptrMapsTo` (hsName, "Ptr (" ++ ptrArg ++ ")")
! _ -> thePtr `ptrMapsTo` (hsName, hsName)
return $
if isNewtype
then "newtype " ++ hsName ++ " = " ++ hsName ++ " (" ++ ptrType ++ ")"
--- 1108,1115 ----
_ -> show ptrKind
ptrType = ptrCon ++ " (" ++ ptrArg ++ ")"
thePtr = (isStar, cNameFull)
!
! thePtr `ptrMapsTo` (ptrKind, hsName)
return $
if isNewtype
then "newtype " ++ hsName ++ " = " ++ hsName ++ " (" ++ ptrType ++ ")"
***************
*** 1173,1179 ****
-- declaration; the latter is for functions interpreting the following
-- structure; an aliased type is always a pointer type that is contained in
-- the pointer map (and got there either from a .chi or from a pointer hook
! -- in the same module)
--
-- * the representation for pointers does not distinguish between normal,
-- function, foreign, and stable pointers; function pointers are identified
--- 1195,1202 ----
-- declaration; the latter is for functions interpreting the following
-- structure; an aliased type is always a pointer type that is contained in
-- the pointer map (and got there either from a .chi or from a pointer hook
! -- in the same module); in addition to this, a third field yields whether
! -- this synonym contains a Ptr, a StablePtr or a ForeignPtr.
--
-- * the representation for pointers does not distinguish between normal,
-- function, foreign, and stable pointers; function pointers are identified
***************
*** 1183,1189 ****
data ExtType = FunET ExtType ExtType -- function
| IOET ExtType -- operation with side effect
| PtrET ExtType -- typed pointer
! | DefinedET CDecl String -- aliased type
| PrimET CPrimType -- basic C type
| UnitET -- void
--- 1206,1212 ----
data ExtType = FunET ExtType ExtType -- function
| IOET ExtType -- operation with side effect
| PtrET ExtType -- typed pointer
! | DefinedET CDecl String CHSPtrType-- aliased type
| PrimET CPrimType -- basic C type
| UnitET -- void
***************
*** 1191,1197 ****
(FunET t1 t2) == (FunET t1' t2') = t1 == t1' && t2 == t2'
(IOET t ) == (IOET t' ) = t == t'
(PtrET t ) == (PtrET t' ) = t == t'
! (DefinedET _ s ) == (DefinedET _ s' ) = s == s'
(PrimET t ) == (PrimET t' ) = t == t'
UnitET == UnitET = True
--- 1214,1220 ----
(FunET t1 t2) == (FunET t1' t2') = t1 == t1' && t2 == t2'
(IOET t ) == (IOET t' ) = t == t'
(PtrET t ) == (PtrET t' ) = t == t'
! (DefinedET _ s _) == (DefinedET _ s' _) = s == s'
(PrimET t ) == (PrimET t' ) = t == t'
UnitET == UnitET = True
***************
*** 1223,1229 ****
in
"(" ++ ptrCon ++ " " ++ showExtType t
++ ")"
! showExtType (DefinedET _ str) = "(" ++ str ++ ")"
showExtType (PrimET CPtrPT) = "(Ptr ())"
showExtType (PrimET CFunPtrPT) = "(FunPtr ())"
showExtType (PrimET CCharPT) = "CChar"
--- 1246,1252 ----
in
"(" ++ ptrCon ++ " " ++ showExtType t
++ ")"
! showExtType (DefinedET _ str _) = "(" ++ str ++ ")"
showExtType (PrimET CPtrPT) = "(Ptr ())"
showExtType (PrimET CFunPtrPT) = "(FunPtr ())"
showExtType (PrimET CCharPT) = "CChar"
***************
*** 1254,1260 ****
-- * the caller has to guarantee that the object does indeed refer to a
-- function
--
! extractFunType :: Position -> CDecl -> Bool -> GB ExtType
extractFunType pos cdecl isPure =
do
-- remove all declarators except that of the function we are processing;
--- 1277,1288 ----
-- * the caller has to guarantee that the object does indeed refer to a
-- function
--
! -- * the returned list contains an entry for each function argument which
! -- contains (Just s) for each ForeignPtr synonym s. All ForeignPtrs
! -- are changed into (Ptr s) in the returned function type
! --
! extractFunType :: Position -> CDecl -> Bool
! -> GB ([Maybe String], ExtType)
extractFunType pos cdecl isPure =
do
-- remove all declarators except that of the function we are processing;
***************
*** 1265,1271 ****
let (args, resultDecl, variadic) = funResultAndArgs cdecl
when variadic $
variadicErr pos cpos
! preResultType <- extractSimpleType True pos resultDecl
--
-- we can now add the `IO' monad if this is no pure function
--
--- 1293,1301 ----
let (args, resultDecl, variadic) = funResultAndArgs cdecl
when variadic $
variadicErr pos cpos
! preResultType <- liftM (snd . expandForeignPtrs) $
! extractSimpleType pos resultDecl
!
--
-- we can now add the `IO' monad if this is no pure function
--
***************
*** 1277,1287 ****
-- prototype with `void' as its single argument declares a nullary
-- function)
--
! argTypes <- mapM (extractSimpleType False pos) args
! return $ foldr FunET resultType argTypes
where
cpos = posOf cdecl
-- compute a non-struct/union type from the given declaration
--
-- * the declaration may have at most one declarator
--- 1307,1326 ----
-- prototype with `void' as its single argument declares a nullary
-- function)
--
! (foreignSyn, argTypes) <- liftM (unzip . map expandForeignPtrs) $
! mapM (extractSimpleType pos) args
!
!
! return (foreignSyn, foldr FunET resultType argTypes)
where
cpos = posOf cdecl
+ -- change synonyms for ForeignPtrs into explicit Ptrs
+ expandForeignPtrs :: ExtType -> (Maybe String, ExtType)
+ expandForeignPtrs all@(DefinedET cdecl name CHSForeignPtr) =
+ (Just name, PtrET all)
+ expandForeignPtrs all = (Nothing, all)
+
-- compute a non-struct/union type from the given declaration
--
-- * the declaration may have at most one declarator
***************
*** 1289,1306 ****
-- * C functions are represented as `Ptr (FunEt ...)' or `Addr' if in
-- compatibility mode (ie, `--old-ffi=yes')
--
! extractSimpleType :: Bool -> Position -> CDecl -> GB ExtType
! extractSimpleType isResult pos cdecl =
do
traceEnter
! ct <- extractCompType isResult cdecl
case ct of
ExtType et -> return et
SUType _ -> illegalStructUnionErr (posOf cdecl) pos
where
traceEnter = traceGenBind $
! "Entering `extractSimpleType' (" ++ (if isResult then "" else "not ")
! ++ "for a result)...\n"
-- compute a Haskell type for a type referenced in a C pointer type
--
--- 1328,1344 ----
-- * C functions are represented as `Ptr (FunEt ...)' or `Addr' if in
-- compatibility mode (ie, `--old-ffi=yes')
--
! extractSimpleType :: Position -> CDecl -> GB ExtType
! extractSimpleType pos cdecl =
do
traceEnter
! ct <- extractCompType cdecl
case ct of
ExtType et -> return et
SUType _ -> illegalStructUnionErr (posOf cdecl) pos
where
traceEnter = traceGenBind $
! "Entering `extractSimpleType'...\n"
-- compute a Haskell type for a type referenced in a C pointer type
--
***************
*** 1308,1318 ****
--
-- * struct/union types are mapped to `()'
--
- -- * NB: this is by definition not a result type
- --
extractPtrType :: CDecl -> GB ExtType
extractPtrType cdecl = do
! ct <- extractCompType False cdecl
case ct of
ExtType et -> return et
SUType _ -> return UnitET
--- 1346,1354 ----
--
-- * struct/union types are mapped to `()'
--
extractPtrType :: CDecl -> GB ExtType
extractPtrType cdecl = do
! ct <- extractCompType cdecl
case ct of
ExtType et -> return et
SUType _ -> return UnitET
***************
*** 1327,1334 ****
--
-- * typedef'ed types are chased
--
! -- * the first argument specifies whether the type specifies the result of a
! -- function (this is only applicable to direct results and not to type
-- parameters for pointers that are a result)
--
-- * takes the pointer map into account
--- 1363,1371 ----
--
-- * typedef'ed types are chased
--
! -- * the first argument specifies whether Haskell newtype wrappers should
! -- be stripped off the returned type
! -- (this is only applicable to direct results and not to type
-- parameters for pointers that are a result)
--
-- * takes the pointer map into account
***************
*** 1340,1347 ****
-- `extractCompType' from looking further "into" the
-- definition of that pointer.
--
! extractCompType :: Bool -> CDecl -> GB CompType
! extractCompType isResult cdecl@(CDecl specs declrs ats) =
if length declrs > 1
then interr "GenBind.extractCompType: Too many declarators!"
else case declrs of
--- 1377,1384 ----
-- `extractCompType' from looking further "into" the
-- definition of that pointer.
--
! extractCompType :: CDecl -> GB CompType
! extractCompType cdecl@(CDecl specs declrs ats) =
if length declrs > 1
then interr "GenBind.extractCompType: Too many declarators!"
else case declrs of
***************
*** 1363,1369 ****
case oHsRepr of
Just repr -> ptrAlias repr -- got an alias
Nothing -> do -- no alias => recurs
! ct <- extractCompType False cdecl'
returnX $ case ct of
ExtType et -> PtrET et
SUType _ -> PtrET UnitET
--- 1400,1406 ----
case oHsRepr of
Just repr -> ptrAlias repr -- got an alias
Nothing -> do -- no alias => recurs
! ct <- extractCompType cdecl'
returnX $ case ct of
ExtType et -> PtrET et
SUType _ -> PtrET UnitET
***************
*** 1375,1381 ****
--
funType = do
traceFunType
! et <- extractFunType (posOf cdecl) cdecl False
returnX et
--
-- handle all types, which are not obviously pointers or functions
--- 1412,1418 ----
--
funType = do
traceFunType
! (_, et) <- extractFunType (posOf cdecl) cdecl False
returnX et
--
-- handle all types, which are not obviously pointers or functions
***************
*** 1395,1407 ****
ide `simplifyDecl` cdecl'
sdecl = CDecl specs [(declr, init, size)] at
-- propagate `size' down (slightly kludgy)
! extractCompType isResult sdecl
Just repr -> ptrAlias repr -- found a pointer hook alias
--
-- compute the result for a pointer alias
--
! ptrAlias (repr1, repr2) =
! returnX $ DefinedET cdecl (if isResult then repr2 else repr1)
--
-- wrap an `ExtType' into a `CompType' and convert parametrised pointers
-- to `Addr' if needed
--- 1432,1443 ----
ide `simplifyDecl` cdecl'
sdecl = CDecl specs [(declr, init, size)] at
-- propagate `size' down (slightly kludgy)
! extractCompType sdecl
Just repr -> ptrAlias repr -- found a pointer hook alias
--
-- compute the result for a pointer alias
--
! ptrAlias (ptrTy, alias) = returnX $ DefinedET cdecl alias ptrTy
--
-- wrap an `ExtType' into a `CompType' and convert parametrised pointers
-- to `Addr' if needed
***************
*** 1628,1634 ****
--
sizeAlignOf cdecl =
do
! ct <- extractCompType False cdecl
case ct of
ExtType (FunET _ _ ) -> return (bitSize CFunPtrPT,
alignment CFunPtrPT)
--- 1664,1670 ----
--
sizeAlignOf cdecl =
do
! ct <- extractCompType cdecl
case ct of
ExtType (FunET _ _ ) -> return (bitSize CFunPtrPT,
alignment CFunPtrPT)
***************
*** 1637,1643 ****
| isFunExtType t -> return (bitSize CFunPtrPT,
alignment CFunPtrPT)
| otherwise -> return (bitSize CPtrPT, alignment CPtrPT)
! ExtType (DefinedET _ _ ) -> return (bitSize CPtrPT, alignment CPtrPT)
-- FIXME: The defined type could be a function pointer!!!
ExtType (PrimET pt ) -> return (bitSize pt, alignment pt)
ExtType UnitET -> voidFieldErr (posOf cdecl)
--- 1673,1679 ----
| isFunExtType t -> return (bitSize CFunPtrPT,
alignment CFunPtrPT)
| otherwise -> return (bitSize CPtrPT, alignment CPtrPT)
! ExtType (DefinedET _ _ _ ) -> return (bitSize CPtrPT, alignment CPtrPT)
-- FIXME: The defined type could be a function pointer!!!
ExtType (PrimET pt ) -> return (bitSize pt, alignment pt)
ExtType UnitET -> voidFieldErr (posOf cdecl)
--sm4nu43k4a2Rpi4c--