Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/d19f2a372759356ea10223f8d29fa45568d5c0e6 >--------------------------------------------------------------- commit d19f2a372759356ea10223f8d29fa45568d5c0e6 Author: David Terei <[email protected]> Date: Mon Apr 25 17:27:33 2011 -0700 SafeHaskell: Force all FFI imports to be in IO >--------------------------------------------------------------- compiler/iface/MkIface.lhs | 2 +- compiler/typecheck/TcForeign.lhs | 28 +++++++++++++++++++--------- 2 files changed, 20 insertions(+), 10 deletions(-) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index e9e921f..ccfa710 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -232,7 +232,7 @@ mkIface_ hsc_env maybe_old_fingerprint ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_vect_info = flattenVectInfo vect_info - ; trust_info = (setSafeMode . safeHaskell . hsc_dflags) hsc_env + ; trust_info = (setSafeMode . safeHaskell) dflags ; intermediate_iface = ModIface { mi_module = this_mod, diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 8f53d6e..a24eb47 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -107,8 +107,8 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ CWrapper) = do checkSafety safety case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys - checkForeignRes nonIOok isFFIExportResultTy res1_ty - checkForeignRes mustBeIO isFFIDynResultTy res_ty + checkForeignRes nonIOok False isFFIExportResultTy res1_ty + checkForeignRes mustBeIO False isFFIDynResultTy res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) @@ -128,7 +128,9 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar check (isFFIDynArgumentTy arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty return idecl | cconv == PrimCallConv = do dflags <- getDOpts @@ -140,7 +142,9 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar (text "The safe/unsafe annotation should not be used with `foreign import prim'.") checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) - checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIPrimResultTy dflags) res_ty return idecl | otherwise = do -- Normal foreign import checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) @@ -149,7 +153,9 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction tar checkCTarget target dflags <- getDOpts checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty checkMissingAmpersand dflags arg_tys res_ty return idecl @@ -221,7 +227,7 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do check (isCLabelString str) (badCName str) checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys - checkForeignRes nonIOok isFFIExportResultTy res_ty + checkForeignRes nonIOok False isFFIExportResultTy res_ty where -- Drop the foralls before inspecting n -- the structure of the foreign type. @@ -249,13 +255,13 @@ checkForeignArgs pred tys -- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () +checkForeignRes :: Bool -> Bool -> (Type -> Bool) -> Type -> TcM () nonIOok, mustBeIO :: Bool nonIOok = True mustBeIO = False -checkForeignRes non_io_result_ok pred_res_ty ty +checkForeignRes non_io_result_ok safehs_check pred_res_ty ty -- (IO t) is ok, and so is any newtype wrapping thereof | Just (_, res_ty, _) <- tcSplitIOType_maybe ty, pred_res_ty res_ty @@ -263,7 +269,7 @@ checkForeignRes non_io_result_ok pred_res_ty ty | otherwise = check (non_io_result_ok && pred_res_ty ty) - (illegalForeignTyErr result ty) + (illegalForeignTyErr result ty $+$ safeHsErr safehs_check) \end{code} \begin{code} @@ -338,6 +344,10 @@ illegalForeignTyErr arg_or_res ty ptext (sLit "type in foreign declaration:")]) 2 (hsep [ppr ty]) +safeHsErr :: Bool -> SDoc +safeHsErr False = empty +safeHsErr True = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad" + -- Used for 'arg_or_res' argument to illegalForeignTyErr argument, result :: SDoc argument = text "argument" _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
