Disallow linear types in FFI (#18472)

4 files changed, 48 insertions, 10 deletions

diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index 040a246091..5f392e6028 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/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
diff --git a/testsuite/tests/linear/should_fail/LinearFFI.hs b/testsuite/tests/linear/should_fail/LinearFFI.hs
new file mode 100644
index 0000000000..6c6e1c562a
--- /dev/null
+++ b/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 ()))
diff --git a/testsuite/tests/linear/should_fail/LinearFFI.stderr b/testsuite/tests/linear/should_fail/LinearFFI.stderr
new file mode 100644
index 0000000000..41dd5e66a7
--- /dev/null
+++ b/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 ()))
diff --git a/testsuite/tests/linear/should_fail/all.T b/testsuite/tests/linear/should_fail/all.T
index 941966673c..5a79b031b6 100644
--- a/testsuite/tests/linear/should_fail/all.T
+++ b/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, [''])