never executed always true always false
    1 {-
    2 (c) The University of Glasgow 2006
    3 (c) The AQUA Project, Glasgow University, 1998
    4 
    5 -}
    6 
    7 
    8 {-# LANGUAGE TypeFamilies #-}
    9 {-# LANGUAGE TypeApplications #-}
   10 {-# LANGUAGE ScopedTypeVariables #-}
   11 {-# LANGUAGE RankNTypes #-}
   12 {-# LANGUAGE ViewPatterns #-}
   13 
   14 -- | Typechecking @foreign@ declarations
   15 --
   16 -- A foreign declaration is used to either give an externally
   17 -- implemented function a Haskell type (and calling interface) or
   18 -- give a Haskell function an external calling interface. Either way,
   19 -- the range of argument and result types these functions can accommodate
   20 -- is restricted to what the outside world understands (read C), and this
   21 -- module checks to see if a foreign declaration has got a legal type.
   22 module GHC.Tc.Gen.Foreign
   23         ( tcForeignImports
   24         , tcForeignExports
   25 
   26         -- Low-level exports for hooks
   27         , isForeignImport, isForeignExport
   28         , tcFImport, tcFExport
   29         , tcForeignImports'
   30         , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes
   31         , normaliseFfiType
   32         , nonIOok, mustBeIO
   33         , checkSafe, noCheckSafe
   34         , tcForeignExports'
   35         , tcCheckFEType
   36         ) where
   37 
   38 import GHC.Prelude
   39 
   40 import GHC.Hs
   41 
   42 import GHC.Tc.Errors.Types
   43 import GHC.Tc.Utils.Monad
   44 import GHC.Tc.Gen.HsType
   45 import GHC.Tc.Gen.Expr
   46 import GHC.Tc.Utils.Env
   47 
   48 import GHC.Tc.Instance.Family
   49 import GHC.Core.FamInstEnv
   50 import GHC.Core.Coercion
   51 import GHC.Core.Reduction
   52 import GHC.Core.Type
   53 import GHC.Core.Multiplicity
   54 import GHC.Types.ForeignCall
   55 import GHC.Utils.Error
   56 import GHC.Types.Id
   57 import GHC.Types.Name
   58 import GHC.Types.Name.Reader
   59 import GHC.Core.DataCon
   60 import GHC.Core.TyCon
   61 import GHC.Core.TyCon.RecWalk
   62 import GHC.Tc.Utils.TcType
   63 import GHC.Builtin.Names
   64 import GHC.Driver.Session
   65 import GHC.Driver.Backend
   66 import GHC.Utils.Outputable as Outputable
   67 import GHC.Utils.Panic
   68 import GHC.Platform
   69 import GHC.Types.SrcLoc
   70 import GHC.Data.Bag
   71 import GHC.Driver.Hooks
   72 import qualified GHC.LanguageExtensions as LangExt
   73 
   74 import Control.Monad ( zipWithM )
   75 import Control.Monad.Trans.Writer.CPS
   76   ( WriterT, runWriterT, tell )
   77 import Control.Monad.Trans.Class
   78   ( lift )
   79 
   80 -- Defines a binding
   81 isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool
   82 isForeignImport (unXRec @name -> ForeignImport {}) = True
   83 isForeignImport _                        = False
   84 
   85 -- Exports a binding
   86 isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool
   87 isForeignExport (unXRec @name -> ForeignExport {}) = True
   88 isForeignExport _                        = False
   89 
   90 {-
   91 Note [Don't recur in normaliseFfiType']
   92 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
   93 normaliseFfiType' is the workhorse for normalising a type used in a foreign
   94 declaration. If we have
   95 
   96 newtype Age = MkAge Int
   97 
   98 we want to see that Age -> IO () is the same as Int -> IO (). But, we don't
   99 need to recur on any type parameters, because no paramaterized types (with
  100 interesting parameters) are marshalable! The full list of marshalable types
  101 is in the body of boxedMarshalableTyCon in GHC.Tc.Utils.TcType. The only members of that
  102 list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled
  103 the same way regardless of type parameter. So, no need to recur into
  104 parameters.
  105 
  106 Similarly, we don't need to look in AppTy's, because nothing headed by
  107 an AppTy will be marshalable.
  108 -}
  109 
  110 -- normaliseFfiType takes the type from an FFI declaration, and
  111 -- evaluates any type synonyms, type functions, and newtypes. However,
  112 -- we are only allowed to look through newtypes if the constructor is
  113 -- in scope.  We return a bag of all the newtype constructors thus found.
  114 -- Always returns a Representational coercion
  115 normaliseFfiType :: Type -> TcM (Reduction, Bag GlobalRdrElt)
  116 normaliseFfiType ty
  117     = do fam_envs <- tcGetFamInstEnvs
  118          normaliseFfiType' fam_envs ty
  119 
  120 normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Reduction, Bag GlobalRdrElt)
  121 normaliseFfiType' env ty0 = runWriterT $ go Representational initRecTc ty0
  122   where
  123     go :: Role -> RecTcChecker -> Type -> WriterT (Bag GlobalRdrElt) TcM Reduction
  124     go role rec_nts ty
  125       | Just ty' <- tcView ty     -- Expand synonyms
  126       = go role rec_nts ty'
  127 
  128       | Just (tc, tys) <- splitTyConApp_maybe ty
  129       = go_tc_app role rec_nts tc tys
  130 
  131       | (bndrs, inner_ty) <- splitForAllTyCoVarBinders ty
  132       , not (null bndrs)
  133       = do redn <- go role rec_nts inner_ty
  134            return $ mkHomoForAllRedn bndrs redn
  135 
  136       | otherwise -- see Note [Don't recur in normaliseFfiType']
  137       = return $ mkReflRedn role ty
  138 
  139     go_tc_app :: Role -> RecTcChecker -> TyCon -> [Type]
  140               -> WriterT (Bag GlobalRdrElt) TcM Reduction
  141     go_tc_app role rec_nts tc tys
  142         -- We don't want to look through the IO newtype, even if it is
  143         -- in scope, so we have a special case for it:
  144         | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey]
  145         = children_only
  146 
  147         | isNewTyCon tc         -- Expand newtypes
  148         , Just rec_nts' <- checkRecTc rec_nts tc
  149                    -- See Note [Expanding newtypes] in GHC.Core.TyCon
  150                    -- We can't just use isRecursiveTyCon; sometimes recursion is ok:
  151                    --     newtype T = T (Ptr T)
  152                    --   Here, we don't reject the type for being recursive.
  153                    -- If this is a recursive newtype then it will normally
  154                    -- be rejected later as not being a valid FFI type.
  155         = do { rdr_env <- lift $ getGlobalRdrEnv
  156              ; case checkNewtypeFFI rdr_env tc of
  157                  Nothing  -> nothing
  158                  Just gre ->
  159                    do { redn <- go role rec_nts' nt_rhs
  160                       ; tell (unitBag gre)
  161                       ; return $ nt_co `mkTransRedn` redn } }
  162 
  163         | isFamilyTyCon tc              -- Expand open tycons
  164         , Reduction co ty <- normaliseTcApp env role tc tys
  165         , not (isReflexiveCo co)
  166         = do redn <- go role rec_nts ty
  167              return $ co `mkTransRedn` redn
  168 
  169         | otherwise
  170         = nothing -- see Note [Don't recur in normaliseFfiType']
  171         where
  172           tc_key = getUnique tc
  173           children_only
  174             = do { args <- unzipRedns <$>
  175                             zipWithM ( \ ty r -> go r rec_nts ty )
  176                                      tys (tyConRolesX role tc)
  177                  ; return $ mkTyConAppRedn role tc args }
  178           nt_co  = mkUnbranchedAxInstCo role (newTyConCo tc) tys []
  179           nt_rhs = newTyConInstRhs tc tys
  180 
  181           ty      = mkTyConApp tc tys
  182           nothing = return $ mkReflRedn role ty
  183 
  184 checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt
  185 checkNewtypeFFI rdr_env tc
  186   | Just con <- tyConSingleDataCon_maybe tc
  187   , Just gre <- lookupGRE_Name rdr_env (dataConName con)
  188   = Just gre    -- See Note [Newtype constructor usage in foreign declarations]
  189   | otherwise
  190   = Nothing
  191 
  192 {-
  193 Note [Newtype constructor usage in foreign declarations]
  194 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  195 GHC automatically "unwraps" newtype constructors in foreign import/export
  196 declarations.  In effect that means that a newtype data constructor is
  197 used even though it is not mentioned expclitly in the source, so we don't
  198 want to report it as "defined but not used" or "imported but not used".
  199 eg     newtype D = MkD Int
  200        foreign import foo :: D -> IO ()
  201 Here 'MkD' us used.  See #7408.
  202 
  203 GHC also expands type functions during this process, so it's not enough
  204 just to look at the free variables of the declaration.
  205 eg     type instance F Bool = D
  206        foreign import bar :: F Bool -> IO ()
  207 Here again 'MkD' is used.
  208 
  209 So we really have wait until the type checker to decide what is used.
  210 That's why tcForeignImports and tecForeignExports return a (Bag GRE)
  211 for the newtype constructors they see. Then GHC.Tc.Module can add them
  212 to the module's usages.
  213 
  214 
  215 ************************************************************************
  216 *                                                                      *
  217 \subsection{Imports}
  218 *                                                                      *
  219 ************************************************************************
  220 -}
  221 
  222 tcForeignImports :: [LForeignDecl GhcRn]
  223                  -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
  224 tcForeignImports decls = do
  225     hooks <- getHooks
  226     case tcForeignImportsHook hooks of
  227         Nothing -> tcForeignImports' decls
  228         Just h  -> h decls
  229 
  230 tcForeignImports' :: [LForeignDecl GhcRn]
  231                   -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)
  232 -- For the (Bag GlobalRdrElt) result,
  233 -- see Note [Newtype constructor usage in foreign declarations]
  234 tcForeignImports' decls
  235   = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $
  236                                filter isForeignImport decls
  237        ; return (ids, decls, unionManyBags gres) }
  238 
  239 tcFImport :: LForeignDecl GhcRn
  240           -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)
  241 tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
  242                                     , fd_fi = imp_decl }))
  243   = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo)  $
  244     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
  245        ; (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
  246        ; let
  247            -- Drop the foralls before inspecting the
  248            -- structure of the foreign type.
  249              (arg_tys, res_ty) = tcSplitFunTys (dropForAlls norm_sig_ty)
  250              id                = mkLocalId nm Many sig_ty
  251                  -- Use a LocalId to obey the invariant that locally-defined
  252                  -- things are LocalIds.  However, it does not need zonking,
  253                  -- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it).
  254 
  255        ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl
  256           -- Can't use sig_ty here because sig_ty :: Type and
  257           -- we need HsType Id hence the undefined
  258        ; let fi_decl = ForeignImport { fd_name = L nloc id
  259                                      , fd_sig_ty = undefined
  260                                      , fd_i_ext = mkSymCo norm_co
  261                                      , fd_fi = imp_decl' }
  262        ; return (id, L dloc fi_decl, gres) }
  263 tcFImport d = pprPanic "tcFImport" (ppr d)
  264 
  265 -- ------------ Checking types for foreign import ----------------------
  266 
  267 tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
  268 
  269 tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
  270   -- Foreign import label
  271   = do checkCg checkCOrAsmOrLlvmOrInterp
  272        -- NB check res_ty not sig_ty!
  273        --    In case sig_ty is (forall a. ForeignPtr a)
  274        check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
  275        cconv' <- checkCConv cconv
  276        return (CImport (L lc cconv') safety mh l src)
  277 
  278 tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
  279         -- Foreign wrapper (former f.e.d.)
  280         -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
  281         -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.
  282         -- The use of the latter form is DEPRECATED, though.
  283     checkCg checkCOrAsmOrLlvmOrInterp
  284     cconv' <- checkCConv cconv
  285     case arg_tys of
  286         [Scaled arg1_mult arg1_ty] -> do
  287                         checkNoLinearFFI arg1_mult
  288                         checkForeignArgs isFFIExternalTy arg1_tys
  289                         checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty
  290                         checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
  291                   where
  292                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
  293         _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected"))
  294     return (CImport (L lc cconv') safety mh CWrapper src)
  295 
  296 tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
  297                                             (CFunction target) src)
  298   | isDynamicTarget target = do -- Foreign import dynamic
  299       checkCg checkCOrAsmOrLlvmOrInterp
  300       cconv' <- checkCConv cconv
  301       case arg_tys of           -- The first arg must be Ptr or FunPtr
  302         []                ->
  303           addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))
  304         (Scaled arg1_mult arg1_ty:arg_tys) -> do
  305           dflags <- getDynFlags
  306           let curried_res_ty = mkVisFunTys arg_tys res_ty
  307           checkNoLinearFFI arg1_mult
  308           check (isFFIDynTy curried_res_ty arg1_ty)
  309                 (illegalForeignTyErr argument)
  310           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
  311           checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
  312       return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
  313   | cconv == PrimCallConv = do
  314       dflags <- getDynFlags
  315       checkTc (xopt LangExt.GHCForeignImportPrim dflags)
  316               (TcRnUnknownMessage $ mkPlainError noHints $
  317                text "Use GHCForeignImportPrim to allow `foreign import prim'.")
  318       checkCg checkCOrAsmOrLlvmOrInterp
  319       checkCTarget target
  320       checkTc (playSafe safety)
  321               (TcRnUnknownMessage $ mkPlainError noHints $
  322               text "The safe/unsafe annotation should not be used with `foreign import prim'.")
  323       checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
  324       -- prim import result is more liberal, allows (#,,#)
  325       checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
  326       return idecl
  327   | otherwise = do              -- Normal foreign import
  328       checkCg checkCOrAsmOrLlvmOrInterp
  329       cconv' <- checkCConv cconv
  330       checkCTarget target
  331       dflags <- getDynFlags
  332       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
  333       checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty
  334       checkMissingAmpersand (map scaledThing arg_tys) res_ty
  335       case target of
  336           StaticTarget _ _ _ False
  337            | not (null arg_tys) ->
  338               addErrTc (TcRnUnknownMessage $ mkPlainError noHints $
  339               text "`value' imports cannot have function types")
  340           _ -> return ()
  341       return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src
  342 
  343 
  344 -- This makes a convenient place to check
  345 -- that the C identifier is valid for C
  346 checkCTarget :: CCallTarget -> TcM ()
  347 checkCTarget (StaticTarget _ str _ _) = do
  348     checkCg checkCOrAsmOrLlvmOrInterp
  349     checkTc (isCLabelString str) (badCName str)
  350 
  351 checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
  352 
  353 
  354 checkMissingAmpersand :: [Type] -> Type -> TcM ()
  355 checkMissingAmpersand arg_tys res_ty
  356   | null arg_tys && isFunPtrTy res_ty
  357   = addDiagnosticTc $ TcRnUnknownMessage $
  358       mkPlainDiagnostic (WarningWithFlag Opt_WarnDodgyForeignImports) noHints
  359                         (text "possible missing & in foreign import of FunPtr")
  360   | otherwise
  361   = return ()
  362 
  363 {-
  364 ************************************************************************
  365 *                                                                      *
  366 \subsection{Exports}
  367 *                                                                      *
  368 ************************************************************************
  369 -}
  370 
  371 tcForeignExports :: [LForeignDecl GhcRn]
  372              -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
  373 tcForeignExports decls = do
  374     hooks <- getHooks
  375     case tcForeignExportsHook hooks of
  376         Nothing -> tcForeignExports' decls
  377         Just h  -> h decls
  378 
  379 tcForeignExports' :: [LForeignDecl GhcRn]
  380              -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)
  381 -- For the (Bag GlobalRdrElt) result,
  382 -- see Note [Newtype constructor usage in foreign declarations]
  383 tcForeignExports' decls
  384   = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)
  385   where
  386    combine (binds, fs, gres1) (L loc fe) = do
  387        (b, f, gres2) <- setSrcSpanA loc (tcFExport fe)
  388        return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
  389 
  390 tcFExport :: ForeignDecl GhcRn
  391           -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)
  392 tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })
  393   = addErrCtxt (foreignDeclCtxt fo) $ do
  394 
  395     sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
  396     rhs <- tcCheckPolyExpr (nlHsVar nm) sig_ty
  397 
  398     (Reduction norm_co norm_sig_ty, gres) <- normaliseFfiType sig_ty
  399 
  400     spec' <- tcCheckFEType norm_sig_ty spec
  401 
  402            -- we're exporting a function, but at a type possibly more
  403            -- constrained than its declared/inferred type. Hence the need
  404            -- to create a local binding which will call the exported function
  405            -- at a particular type (and, maybe, overloading).
  406 
  407 
  408     -- We need to give a name to the new top-level binding that
  409     -- is *stable* (i.e. the compiler won't change it later),
  410     -- because this name will be referred to by the C code stub.
  411     id  <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc
  412     return ( mkVarBind id rhs
  413            , ForeignExport { fd_name = L loc id
  414                            , fd_sig_ty = undefined
  415                            , fd_e_ext = norm_co
  416                            , fd_fe = spec' }
  417            , gres)
  418 tcFExport d = pprPanic "tcFExport" (ppr d)
  419 
  420 -- ------------ Checking argument types for foreign export ----------------------
  421 
  422 tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport
  423 tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do
  424     checkCg checkCOrAsmOrLlvm
  425     checkTc (isCLabelString str) (badCName str)
  426     cconv' <- checkCConv cconv
  427     checkForeignArgs isFFIExternalTy arg_tys
  428     checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty
  429     return (CExport (L l (CExportStatic esrc str cconv')) src)
  430   where
  431       -- Drop the foralls before inspecting
  432       -- the structure of the foreign type.
  433     (arg_tys, res_ty) = tcSplitFunTys (dropForAlls sig_ty)
  434 
  435 {-
  436 ************************************************************************
  437 *                                                                      *
  438 \subsection{Miscellaneous}
  439 *                                                                      *
  440 ************************************************************************
  441 -}
  442 
  443 ------------ Checking argument types for foreign import ----------------------
  444 checkForeignArgs :: (Type -> Validity) -> [Scaled Type] -> TcM ()
  445 checkForeignArgs pred tys = mapM_ go tys
  446   where
  447     go (Scaled mult ty) = checkNoLinearFFI mult >>
  448                           check (pred ty) (illegalForeignTyErr argument)
  449 
  450 checkNoLinearFFI :: Mult -> TcM ()  -- No linear types in FFI (#18472)
  451 checkNoLinearFFI Many = return ()
  452 checkNoLinearFFI _    = addErrTc $ illegalForeignTyErr argument
  453                                    (text "Linear types are not supported in FFI declarations, see #18472")
  454 
  455 ------------ Checking result types for foreign calls ----------------------
  456 -- | Check that the type has the form
  457 --    (IO t) or (t) , and that t satisfies the given predicate.
  458 -- When calling this function, any newtype wrappers (should) have been
  459 -- already dealt with by normaliseFfiType.
  460 --
  461 -- We also check that the Safe Haskell condition of FFI imports having
  462 -- results in the IO monad holds.
  463 --
  464 checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()
  465 checkForeignRes non_io_result_ok check_safe pred_res_ty ty
  466   | Just (_, res_ty) <- tcSplitIOType_maybe ty
  467   =     -- Got an IO result type, that's always fine!
  468      check (pred_res_ty res_ty) (illegalForeignTyErr result)
  469 
  470   -- We disallow nested foralls in foreign types
  471   -- (at least, for the time being). See #16702.
  472   | tcIsForAllTy ty
  473   = addErrTc $ illegalForeignTyErr result (text "Unexpected nested forall")
  474 
  475   -- Case for non-IO result type with FFI Import
  476   | not non_io_result_ok
  477   = addErrTc $ illegalForeignTyErr result (text "IO result type expected")
  478 
  479   | otherwise
  480   = do { dflags <- getDynFlags
  481        ; case pred_res_ty ty of
  482                 -- Handle normal typecheck fail, we want to handle this first and
  483                 -- only report safe haskell errors if the normal type check is OK.
  484            NotValid msg -> addErrTc $ illegalForeignTyErr result msg
  485 
  486            -- handle safe infer fail
  487            _ | check_safe && safeInferOn dflags
  488                -> recordUnsafeInfer emptyMessages
  489 
  490            -- handle safe language typecheck fail
  491            _ | check_safe && safeLanguageOn dflags
  492                -> addErrTc (illegalForeignTyErr result safeHsErr)
  493 
  494            -- success! non-IO return is fine
  495            _ -> return () }
  496   where
  497     safeHsErr =
  498       text "Safe Haskell is on, all FFI imports must be in the IO monad"
  499 
  500 nonIOok, mustBeIO :: Bool
  501 nonIOok  = True
  502 mustBeIO = False
  503 
  504 checkSafe, noCheckSafe :: Bool
  505 checkSafe   = True
  506 noCheckSafe = False
  507 
  508 -- | Checking a supported backend is in use
  509 checkCOrAsmOrLlvm :: Backend -> Validity
  510 checkCOrAsmOrLlvm ViaC = IsValid
  511 checkCOrAsmOrLlvm NCG  = IsValid
  512 checkCOrAsmOrLlvm LLVM = IsValid
  513 checkCOrAsmOrLlvm _
  514   = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
  515 
  516 -- | Checking a supported backend is in use
  517 checkCOrAsmOrLlvmOrInterp :: Backend -> Validity
  518 checkCOrAsmOrLlvmOrInterp ViaC        = IsValid
  519 checkCOrAsmOrLlvmOrInterp NCG         = IsValid
  520 checkCOrAsmOrLlvmOrInterp LLVM        = IsValid
  521 checkCOrAsmOrLlvmOrInterp Interpreter = IsValid
  522 checkCOrAsmOrLlvmOrInterp _
  523   = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")
  524 
  525 checkCg :: (Backend -> Validity) -> TcM ()
  526 checkCg check = do
  527     dflags <- getDynFlags
  528     let bcknd = backend dflags
  529     case bcknd of
  530       NoBackend -> return ()
  531       _ ->
  532         case check bcknd of
  533           IsValid      -> return ()
  534           NotValid err ->
  535             addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal foreign declaration:" <+> err)
  536 
  537 -- Calling conventions
  538 
  539 checkCConv :: CCallConv -> TcM CCallConv
  540 checkCConv CCallConv    = return CCallConv
  541 checkCConv CApiConv     = return CApiConv
  542 checkCConv StdCallConv  = do dflags <- getDynFlags
  543                              let platform = targetPlatform dflags
  544                              if platformArch platform == ArchX86
  545                                  then return StdCallConv
  546                                  else do -- This is a warning, not an error. see #3336
  547                                          let msg = TcRnUnknownMessage $
  548                                               mkPlainDiagnostic (WarningWithFlag Opt_WarnUnsupportedCallingConventions)
  549                                                                 noHints
  550                                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")
  551                                          addDiagnosticTc msg
  552                                          return CCallConv
  553 checkCConv PrimCallConv = do
  554   addErrTc $ TcRnUnknownMessage $ mkPlainError noHints
  555     (text "The `prim' calling convention can only be used with `foreign import'")
  556   return PrimCallConv
  557 checkCConv JavaScriptCallConv = do dflags <- getDynFlags
  558                                    if platformArch (targetPlatform dflags) == ArchJavaScript
  559                                        then return JavaScriptCallConv
  560                                        else do
  561                                          addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $
  562                                            (text "The `javascript' calling convention is unsupported on this platform")
  563                                          return JavaScriptCallConv
  564 
  565 -- Warnings
  566 
  567 check :: Validity -> (SDoc -> TcRnMessage) -> TcM ()
  568 check IsValid _             = return ()
  569 check (NotValid doc) err_fn = addErrTc (err_fn doc)
  570 
  571 illegalForeignTyErr :: SDoc -> SDoc -> TcRnMessage
  572 illegalForeignTyErr arg_or_res extra
  573   = TcRnUnknownMessage $ mkPlainError noHints $ hang msg 2 extra
  574   where
  575     msg = hsep [ text "Unacceptable", arg_or_res
  576                , text "type in foreign declaration:"]
  577 
  578 -- Used for 'arg_or_res' argument to illegalForeignTyErr
  579 argument, result :: SDoc
  580 argument = text "argument"
  581 result   = text "result"
  582 
  583 badCName :: CLabelString -> TcRnMessage
  584 badCName target
  585   = TcRnUnknownMessage $ mkPlainError noHints $
  586   sep [quotes (ppr target) <+> text "is not a valid C identifier"]
  587 
  588 foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc
  589 foreignDeclCtxt fo
  590   = hang (text "When checking declaration:")
  591        2 (ppr fo)