Commit 160fba4a authored by Krzysztof Gogolewski's avatar Krzysztof Gogolewski Committed by Marge Bot
Browse files

Disallow linear types in FFI (#18472)

parent bda55fa0
......@@ -243,7 +243,7 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
-- things are LocalIds. However, it does not need zonking,
-- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it).
; imp_decl' <- tcCheckFIType (map scaledThing arg_tys) res_ty imp_decl
; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
-- Can't use sig_ty here because sig_ty :: Type and
-- we need HsType Id hence the undefined
; let fi_decl = ForeignImport { fd_name = L nloc id
......@@ -255,14 +255,14 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
-- ------------ Checking types for foreign import ----------------------
tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
-- Foreign import label
= do checkCg checkCOrAsmOrLlvmOrInterp
-- NB check res_ty not sig_ty!
-- In case sig_ty is (forall a. ForeignPtr a)
check (isFFILabelTy (mkVisFunTysMany arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
cconv' <- checkCConv cconv
return (CImport (L lc cconv') safety mh l src)
......@@ -274,7 +274,9 @@ tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
case arg_tys of
[arg1_ty] -> do checkForeignArgs isFFIExternalTy (map scaledThing arg1_tys)
[Scaled arg1_mult arg1_ty] -> do
checkNoLinearFFI arg1_mult
checkForeignArgs isFFIExternalTy arg1_tys
checkForeignRes nonIOok checkSafe isFFIExportResultTy res1_ty
checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
where
......@@ -290,9 +292,10 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
case arg_tys of -- The first arg must be Ptr or FunPtr
[] ->
addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))
(arg1_ty:arg_tys) -> do
(Scaled arg1_mult arg1_ty:arg_tys) -> do
dflags <- getDynFlags
let curried_res_ty = mkVisFunTysMany arg_tys res_ty
let curried_res_ty = mkVisFunTys arg_tys res_ty
checkNoLinearFFI arg1_mult
check (isFFIDynTy curried_res_ty arg1_ty)
(illegalForeignTyErr argument)
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
......@@ -317,7 +320,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
dflags <- getDynFlags
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
checkMissingAmpersand dflags arg_tys res_ty
checkMissingAmpersand dflags (map scaledThing arg_tys) res_ty
case target of
StaticTarget _ _ _ False
| not (null arg_tys) ->
......@@ -405,7 +408,7 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
checkCg checkCOrAsmOrLlvm
checkTc (isCLabelString str) (badCName str)
cconv' <- checkCConv cconv
checkForeignArgs isFFIExternalTy (map scaledThing arg_tys)
checkForeignArgs isFFIExternalTy arg_tys
checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
return (CExport (L l (CExportStatic esrc str cconv')) src)
where
......@@ -422,10 +425,16 @@ tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
-}
------------ Checking argument types for foreign import ----------------------
checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()
checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()
checkForeignArgs pred tys = mapM_ go tys
where
go ty = check (pred ty) (illegalForeignTyErr argument)
go (Scaled mult ty) = checkNoLinearFFI mult >>
check (pred ty) (illegalForeignTyErr argument)
checkNoLinearFFI :: Mult -> TcM () -- No linear types in FFI (#18472)
checkNoLinearFFI Many = return ()
checkNoLinearFFI _ = addErrTc $ illegalForeignTyErr argument
(text "Linear types are not supported in FFI declarations, see #18472")
------------ Checking result types for foreign calls ----------------------
-- | Check that the type has the form
......
{-# LANGUAGE LinearTypes #-}
module LinearFFI where -- #18472
import Foreign.Ptr
foreign import ccall "exp" c_exp :: Double #-> Double
foreign import stdcall "dynamic" d8 :: FunPtr (IO Int) #-> IO Int
foreign import ccall "wrapper" mkF :: IO () #-> IO (FunPtr (IO ()))
LinearFFI.hs:6:1: error:
• Unacceptable argument type in foreign declaration:
Linear types are not supported in FFI declarations, see #18472
• When checking declaration:
foreign import ccall safe "exp" c_exp :: Double #-> Double
LinearFFI.hs:7:1: error:
• Unacceptable argument type in foreign declaration:
Linear types are not supported in FFI declarations, see #18472
• When checking declaration:
foreign import stdcall safe "dynamic" d8
:: FunPtr (IO Int) #-> IO Int
LinearFFI.hs:8:1: error:
• Unacceptable argument type in foreign declaration:
Linear types are not supported in FFI declarations, see #18472
• When checking declaration:
foreign import ccall safe "wrapper" mkF
:: IO () #-> IO (FunPtr (IO ()))
......@@ -28,3 +28,4 @@ test('LinearBottomMult', normal, compile_fail, [''])
test('LinearSequenceExpr', normal, compile_fail, [''])
test('LinearIf', normal, compile_fail, [''])
test('LinearPatternGuardWildcard', normal, compile_fail, [''])
test('LinearFFI', normal, compile_fail, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment