X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=2189f8530f4cd2cb51ab1033a4604b095f45e7a8;hb=c395b75ce4f20583a5b28c5df79c4de019beecb9;hp=b63c79399aa181ed6073c2a762125815418ec024;hpb=cfd81c04484f5ef8beb90743c795f4bf7f3aa4d8;p=ghc-hetmet.git diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b63c793..2189f85 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,10 +4,12 @@ \section{Tidying up Core} \begin{code} -module TidyPgm( mkBootModDetails, tidyProgram ) where +module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram ) where #include "HsVersions.h" +import TcRnTypes +import FamInstEnv import DynFlags import CoreSyn import CoreUnfold @@ -39,7 +41,7 @@ import Maybes import ErrUtils import UniqSupply import Outputable -import FastTypes hiding (fastOr) +import FastBool hiding ( fastOr ) import Data.List ( partition ) import Data.Maybe ( isJust ) @@ -105,26 +107,40 @@ Plan A: mkBootModDetails: omit pragmas, make interfaces small distinct OccNames in case of object-file splitting \begin{code} -mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails -- This is Plan A: make a small type env when typechecking only, -- or when compiling a hs-boot file, or simply when not using -O -- -- We don't look at the bindings at all -- there aren't any -- for hs-boot files -mkBootModDetails hsc_env (ModGuts { mg_exports = exports - , mg_types = type_env - , mg_insts = insts - , mg_fam_insts = fam_insts - }) +mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails +mkBootModDetailsTc hsc_env + TcGblEnv{ tcg_exports = exports, + tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts + } + = mkBootModDetails hsc_env exports type_env insts fam_insts + +mkBootModDetailsDs :: HscEnv -> ModGuts -> IO ModDetails +mkBootModDetailsDs hsc_env + ModGuts{ mg_exports = exports, + mg_types = type_env, + mg_insts = insts, + mg_fam_insts = fam_insts + } + = mkBootModDetails hsc_env exports type_env insts fam_insts + +mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing + -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails +mkBootModDetails hsc_env exports type_env insts fam_insts = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy [hoot] type env" ; let { insts' = tidyInstances tidyExternalId insts - ; type_env1 = filterNameEnv (not . isWiredInThing) type_env - ; type_env2 = mapNameEnv tidyBootThing type_env1 - ; type_env' = extendTypeEnvWithIds type_env2 - (map instanceDFunId insts') + ; dfun_ids = map instanceDFunId insts' + ; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env + ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids } ; return (ModDetails { md_types = type_env' , md_insts = insts' @@ -136,13 +152,27 @@ mkBootModDetails hsc_env (ModGuts { mg_exports = exports } where -isWiredInThing :: TyThing -> Bool -isWiredInThing thing = isWiredInName (getName thing) +tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv +tidyBootTypeEnv exports type_env + = tidyTypeEnv True exports type_env final_ids + where + -- Find the LocalIds in the type env that are exported + -- Make them into GlobalIds, and tidy their types + -- + -- It's very important to remove the non-exported ones + -- because we don't tidy the OccNames, and if we don't remove + -- the non-exported ones we'll get many things with the + -- same name in the interface file, giving chaos. + final_ids = [ tidyExternalId id + | id <- typeEnvIds type_env + , isLocalId id + , keep_it id ] + + -- default methods have their export flag set, but everything + -- else doesn't (yet), because this is pre-desugaring, so we + -- must test both. + keep_it id = isExportedId id || idName id `elemNameSet` exports -tidyBootThing :: TyThing -> TyThing --- Just externalise the Ids; keep everything -tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id) -tidyBootThing thing = thing tidyExternalId :: Id -> Id -- Takes an LocalId with an External Name, @@ -234,7 +264,8 @@ tidyProgram hsc_env mg_binds = binds, mg_rules = imp_rules, mg_vect_info = vect_info, - mg_dir_imps = dir_imps, mg_deps = deps, + mg_dir_imps = dir_imps, + mg_deps = deps, mg_foreign = foreign_stubs, mg_hpc_info = hpc_info, mg_modBreaks = modBreaks }) @@ -259,8 +290,10 @@ tidyProgram hsc_env binds ; let { export_set = availsToNameSet exports + ; final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env - tidy_binds + final_ids ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts -- A DFunId will have a binding in tidy_binds, and so -- will now be in final_env, replete with IdInfo @@ -283,10 +316,12 @@ tidyProgram hsc_env "Tidy Core Rules" (pprRules tidy_rules) + ; let dir_imp_mods = map fst (moduleEnvElts dir_imps) + ; return (CgGuts { cg_module = mod, cg_tycons = alg_tycons, cg_binds = all_tidy_binds, - cg_dir_imps = dir_imps, + cg_dir_imps = dir_imp_mods, cg_foreign = foreign_stubs, cg_dep_pkgs = dep_pkgs deps, cg_hpc_info = hpc_info, @@ -307,7 +342,8 @@ lookup_dfun type_env dfun_id Just (AnId dfun_id') -> dfun_id' _other -> pprPanic "lookup_dfun" (ppr dfun_id) -tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv +-------------------------- +tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> TypeEnv -- The competed type environment is gotten from -- Dropping any wired-in things, and then @@ -321,17 +357,14 @@ tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space -tidyTypeEnv omit_prags exports type_env tidy_binds +tidyTypeEnv omit_prags exports type_env final_ids = let type_env1 = filterNameEnv keep_it type_env type_env2 = extendTypeEnvWithIds type_env1 final_ids - type_env3 | omit_prags = mapNameEnv trim_thing type_env2 + type_env3 | omit_prags = mapNameEnv (trimThing exports) type_env2 | otherwise = type_env2 in type_env3 where - final_ids = [ id | id <- bindersOfBinds tidy_binds, - isExternalName (idName id)] - -- We keep GlobalIds, because they won't appear -- in the bindings from which final_ids are derived! -- (The bindings bind LocalIds.) @@ -339,15 +372,24 @@ tidyTypeEnv omit_prags exports type_env tidy_binds keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops) keep_it _other = True -- Keep all TyCons, DataCons, and Classes - trim_thing thing - = case thing of - ATyCon tc | mustExposeTyCon exports tc -> thing - | otherwise -> ATyCon (makeTyConAbstract tc) +-------------------------- +isWiredInThing :: TyThing -> Bool +isWiredInThing thing = isWiredInName (getName thing) + +-------------------------- +trimThing :: NameSet -> TyThing -> TyThing +-- Trim off inessentials, for boot files and no -O +trimThing exports (ATyCon tc) + | not (mustExposeTyCon exports tc) + = ATyCon (makeTyConAbstract tc) + +trimThing _exports (AnId id) + | not (isImplicitId id) + = AnId (id `setIdInfo` vanillaIdInfo) - AnId id | isImplicitId id -> thing - | otherwise -> AnId (id `setIdInfo` vanillaIdInfo) +trimThing _exports other_thing + = other_thing - _other -> thing mustExposeTyCon :: NameSet -- Exports -> TyCon -- The tycon @@ -361,13 +403,14 @@ mustExposeTyCon exports tc | isEnumerationTyCon tc -- For an enumeration, exposing the constructors = True -- won't lead to the need for further exposure -- (This includes data types with no constructors.) - | isOpenTyCon tc -- open type family + | isOpenTyCon tc -- Open type family = True + | otherwise -- Newtype, datatype = any exported_con (tyConDataCons tc) -- Expose rep if any datacon or field is exported - || (isNewTyCon tc && isFFITy (snd (newTyConRep tc))) + || (isNewTyCon tc && isFFITy (snd (newTyConRhs tc))) -- Expose the rep for newtypes if the rep is an FFI type. -- For a very annoying reason. 'Foreign import' is meant to -- be able to look through newtypes transparently, but it @@ -775,7 +818,7 @@ tidyWorker _tidy_env _show_unfold NoWorker = NoWorker tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity) | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity - | otherwise = WARN( True, ppr work_id ) NoWorker + | otherwise = NoWorker -- NB: do *not* expose the worker if show_unfold is off, -- because that means this thing is a loop breaker or -- marked NOINLINE or something like that @@ -783,8 +826,12 @@ tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity) -- then you can make the simplifier go into an infinite loop, because -- in effect the unfolding is exposed. See Trac #1709 -- - -- Mind you, it probably should not be w/w'd in the first place; - -- hence the WARN + -- You might think that if show_unfold is False, then the thing should + -- not be w/w'd in the first place. But a legitimate reason is this: + -- the function returns bottom + -- In this case, show_unfold will be false (we don't expose unfoldings + -- for bottoming functions), but we might still have a worker/wrapper + -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs \end{code} %************************************************************************