X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FMkIface.lhs;h=8cfc08f329573a5c66b80198c7cef3fada3a4fcd;hb=33f4c84c22896ffd2a8aabf163fcced38faf523d;hp=285f17197dbdf2eec181d65cc01ea91e7a70133c;hpb=9bcd95bad83ee937c178970e8b729732e680fe1e;p=ghc-hetmet.git diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 285f171..8cfc08f 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -67,6 +67,7 @@ import TcType import InstEnv import FamInstEnv import TcRnMonad +import HsSyn import HscTypes import Finder import DynFlags @@ -100,7 +101,6 @@ import Control.Monad import Data.List import Data.IORef import System.FilePath -import System.Exit ( exitWith, ExitCode(..) ) \end{code} @@ -116,8 +116,9 @@ mkIface :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it -> ModDetails -- The trimmed, tidied interface -> ModGuts -- Usages, deprecations, etc - -> IO (ModIface, -- The new one - Bool) -- True <=> there was an old Iface, and the + -> IO (Messages, + Maybe (ModIface, -- The new one + Bool)) -- True <=> there was an old Iface, and the -- new one is identical, so no need -- to write it @@ -134,7 +135,7 @@ mkIface hsc_env maybe_old_fingerprint mod_details = mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names deps rdr_env fix_env warns hpc_info dir_imp_mods mod_details - + -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('HscNothing'). @@ -142,8 +143,7 @@ mkIfaceTc :: HscEnv -> Maybe Fingerprint -- The old fingerprint, if we have it -> ModDetails -- gotten from mkBootModDetails, probably -> TcGblEnv -- Usages, deprecations, etc - -> IO (ModIface, - Bool) + -> IO (Messages, Maybe (ModIface, Bool)) mkIfaceTc hsc_env maybe_old_fingerprint mod_details tc_result@TcGblEnv{ tcg_mod = this_mod, tcg_src = hsc_src, @@ -214,7 +214,7 @@ mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface -> NameEnv FixItem -> Warnings -> HpcInfo -> ImportedMods -> ModDetails - -> IO (ModIface, Bool) + -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info dir_imp_mods @@ -305,10 +305,9 @@ mkIface_ hsc_env maybe_old_fingerprint | r <- iface_rules , isNothing (ifRuleOrph r) ] - ; when (not (isEmptyBag orph_warnings)) - (do { printErrorsAndWarnings dflags errs_and_warns -- XXX - ; when (errorsFound dflags errs_and_warns) - (exitWith (ExitFailure 1)) }) + ; if errorsFound dflags errs_and_warns + then return ( errs_and_warns, Nothing ) + else do { -- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) @@ -322,7 +321,7 @@ mkIface_ hsc_env maybe_old_fingerprint -- with the old GlobalRdrEnv (mi_globals). ; let final_iface = new_iface{ mi_globals = Just rdr_env } - ; return (final_iface, no_change_at_all) } + ; return (errs_and_warns, Just (final_iface, no_change_at_all)) }} where r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 i1 `le_inst` i2 = ifDFun i1 `le_occ` ifDFun i2 @@ -1117,8 +1116,8 @@ checkDependencies hsc_env summary iface orM = foldr f (return False) where f m rest = do b <- m; if b then return True else rest - dep_missing (L _ mod) = do - find_res <- liftIO $ findImportedModule hsc_env mod Nothing + dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do + find_res <- liftIO $ findImportedModule hsc_env mod pkg case find_res of Found _ mod | pkg == this_pkg @@ -1272,9 +1271,10 @@ tyThingToIfaceDecl :: TyThing -> IfaceDecl -- Reason: Iface stuff uses OccNames, and the conversion here does -- not do tidying on the way tyThingToIfaceDecl (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType (idType id), - ifIdInfo = info } + = IfaceId { ifName = getOccName id, + ifType = toIfaceType (idType id), + ifIdDetails = toIfaceIdDetails (idDetails id), + ifIdInfo = info } where info = case toIfaceIdInfo (idInfo id) of [] -> NoInfo @@ -1352,6 +1352,7 @@ tyThingToIfaceDecl (ATyCon tycon) ifaceConDecl data_con = IfCon { ifConOcc = getOccName (dataConName data_con), ifConInfix = dataConIsInfix data_con, + ifConWrapper = isJust (dataConWrapId_maybe data_con), ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), ifConEqSpec = to_eq_spec (dataConEqSpec data_con), @@ -1439,10 +1440,17 @@ toIfaceLetBndr id = IfLetBndr (occNameFS (getOccName id)) -- See Note [IdInfo on nested let-bindings] in IfaceSyn id_info = idInfo id inline_prag = inlinePragInfo id_info - prag_info | isAlwaysActive inline_prag = NoInfo - | otherwise = HasInfo [HsInline inline_prag] + prag_info | isDefaultInlinePragma inline_prag = NoInfo + | otherwise = HasInfo [HsInline inline_prag] -------------------------- +toIfaceIdDetails :: IdDetails -> IfaceIdDetails +toIfaceIdDetails VanillaId = IfVanillaId +toIfaceIdDetails DFunId = IfVanillaId +toIfaceIdDetails (RecSelId { sel_naughty = n }) = IfRecSelId n +toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) + IfVanillaId -- Unexpected + toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, @@ -1487,11 +1495,13 @@ toIfaceIdInfo id_info ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info - inline_hsinfo | isAlwaysActive inline_prag = Nothing - | no_unfolding && not has_worker = Nothing + inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing + | no_unfolding && not has_worker + && isFunLike (inlinePragmaRuleMatchInfo inline_prag) + = Nothing -- If the iface file give no unfolding info, we -- don't need to say when inlining is OK! - | otherwise = Just (HsInline inline_prag) + | otherwise = Just (HsInline inline_prag) -------------------------- coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule