[Git][ghc/ghc][master] Disallow linear types in FFI (#18472)
Marge Bot
gitlab at gitlab.haskell.org
Sat Sep 26 17:19:07 UTC 2020
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
160fba4a by Krzysztof Gogolewski at 2020-09-26T13:19:00-04:00
Disallow linear types in FFI (#18472)
- - - - -
4 changed files:
- compiler/GHC/Tc/Gen/Foreign.hs
- + testsuite/tests/linear/should_fail/LinearFFI.hs
- + testsuite/tests/linear/should_fail/LinearFFI.stderr
- testsuite/tests/linear/should_fail/all.T
Changes:
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -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
=====================================
testsuite/tests/linear/should_fail/LinearFFI.hs
=====================================
@@ -0,0 +1,8 @@
+{-# 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 ()))
=====================================
testsuite/tests/linear/should_fail/LinearFFI.stderr
=====================================
@@ -0,0 +1,20 @@
+
+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 ()))
=====================================
testsuite/tests/linear/should_fail/all.T
=====================================
@@ -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, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/160fba4aa306c0649c72a6dcd7c98d9782a0e74b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/160fba4aa306c0649c72a6dcd7c98d9782a0e74b
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200926/64ad45b3/attachment-0001.html>
More information about the ghc-commits
mailing list