Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
88d61ccd
Commit
88d61ccd
authored
Apr 03, 2012
by
pcapriotti
Browse files
Improved checks for "dynamic" and "wrapper" foreign declarations (
#5664
)
parent
e7e5e277
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/typecheck/TcForeign.lhs
View file @
88d61ccd
...
...
@@ -219,8 +219,7 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport cconv safety mh CWrapper) = do
case arg_tys of
[arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty
checkForeignRes mustBeIO checkSafe isFFIDynResultTy res_ty
-- ToDo: Why are res1_ty and res_ty not equal?
checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
_ -> addErrTc (illegalForeignTyErr empty sig_ty)
...
...
@@ -235,7 +234,8 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety mh (CFunction ta
check False (illegalForeignTyErr empty sig_ty)
(arg1_ty:arg_tys) -> do
dflags <- getDynFlags
check (isFFIDynArgumentTy arg1_ty)
let curried_res_ty = foldr FunTy res_ty arg_tys
check (isFFIDynTy curried_res_ty arg1_ty)
(illegalForeignTyErr argument arg1_ty)
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
...
...
compiler/typecheck/TcType.lhs
View file @
88d61ccd
...
...
@@ -102,8 +102,7 @@ module TcType (
isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
isFFIExportResultTy, -- :: Type -> Bool
isFFIExternalTy, -- :: Type -> Bool
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFIDynTy, -- :: Type -> Type -> Bool
isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool
isFFIPrimResultTy, -- :: DynFlags -> Type -> Bool
isFFILabelTy, -- :: Type -> Bool
...
...
@@ -1338,15 +1337,22 @@ isFFIImportResultTy dflags ty
isFFIExportResultTy :: Type -> Bool
isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
isFFIDynArgumentTy :: Type -> Bool
-- The argument type of a foreign import dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
isFFIDynArgumentTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
isFFIDynResultTy :: Type -> Bool
-- The result type of a foreign export dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either.
isFFIDynResultTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
isFFIDynTy :: Type -> Type -> Bool
-- The type in a foreign import dynamic must be Ptr, FunPtr, Addr,
-- or a newtype of either, and the wrapped function type must be equal
-- to the given type.
-- We assume that all types have been run through normalizeFfiType, so we don't
-- need to worry about expanding newtypes here.
isFFIDynTy expected ty
-- Note [Foreign import dynamic]
-- In the example below, expected would be 'CInt -> IO ()', while ty would
-- be 'FunPtr (CDouble -> IO ())'.
| Just (tc, [ty']) <- splitTyConApp_maybe ty
, tyConUnique tc `elem` [ptrTyConKey, funPtrTyConKey]
, eqType ty' expected
= True
| otherwise
= False
isFFILabelTy :: Type -> Bool
-- The type of a foreign label must be Ptr, FunPtr, Addr,
...
...
@@ -1401,6 +1407,21 @@ checkRepTyConKey keys
= checkRepTyCon (\tc -> tyConUnique tc `elem` keys)
\end{code}
Note [Foreign import dynamic]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A dynamic stub must be of the form 'FunPtr ft -> ft' where ft is any foreign
type. Similarly, a wrapper stub must be of the form 'ft -> IO (FunPtr ft)'.
We use isFFIDynTy to check whether a signature is well-formed. For example,
given a (illegal) declaration like:
foreign import ccall "dynamic"
foo :: FunPtr (CDouble -> IO ()) -> CInt -> IO ()
isFFIDynTy will compare the 'FunPtr' type 'CDouble -> IO ()' with the curried
result type 'CInt -> IO ()', and return False, as they are not equal.
----------------------------------------------
These chaps do the work; they are not exported
----------------------------------------------
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment