X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=dec5c6b0d3ed5b46d8120b588d3b029cb2fd2808;hp=4e01fd31975b2a71e58cf3d532236f88715ba526;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hpb=a835e9faf19400aa6b7999b6f64e60cb1c7737dd diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 4e01fd3..dec5c6b 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,6 +4,13 @@ \section{Tidying up Core} \begin{code} +{-# OPTIONS_GHC -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/WorkingConventions#Warnings +-- for details + module TidyPgm( mkBootModDetails, tidyProgram ) where #include "HsVersions.h" @@ -21,16 +28,14 @@ import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector, - idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo + idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo, + isTickBoxOp ) import IdInfo {- loads of stuff -} import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) import NewDemand ( isBottomingSig, topSig ) -import BasicTypes ( Arity, isNeverActive ) -import Name ( Name, getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc, nameParent_maybe, - isWiredInName, getName - ) +import BasicTypes ( Arity, isNeverActive, isNonRuleLoopBreaker ) +import Name import NameSet ( NameSet, elemNameSet ) import IfaceEnv ( allocateGlobalBinder ) import NameEnv ( filterNameEnv, mapNameEnv ) @@ -43,22 +48,17 @@ import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, isEnumerationTyCon, isOpenTyCon ) import Class ( classSelIds ) import Module ( Module ) -import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), - TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, - extendTypeEnvWithIds, lookupTypeEnv, - mkDetailsFamInstCache, - ModGuts(..), TyThing(..), ModDetails(..), - Dependencies(..) - ) +import HscTypes import Maybes ( orElse, mapCatMaybes ) import ErrUtils ( showPass, dumpIfSet_core ) import PackageConfig ( PackageId ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) -import List ( partition ) -import Maybe ( isJust ) import Outputable -import DATA_IOREF ( IORef, readIORef, writeIORef ) import FastTypes hiding ( fastOr ) + +import Data.List ( partition ) +import Data.Maybe ( isJust ) +import Data.IORef ( IORef, readIORef, writeIORef ) \end{code} @@ -124,24 +124,30 @@ mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails -- We don't look at the bindings at all -- there aren't any -- for hs-boot files -mkBootModDetails hsc_env (ModGuts { mg_module = mod, - mg_exports = exports, - mg_types = type_env, - mg_insts = ispecs }) +mkBootModDetails hsc_env (ModGuts { mg_module = mod + , mg_exports = exports + , mg_types = type_env + , mg_insts = insts + , mg_fam_insts = fam_insts + , mg_modBreaks = modBreaks + }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy [hoot] type env" - ; let { ispecs' = tidyInstances tidyExternalId ispecs - ; type_env1 = filterNameEnv (not . isWiredInThing) type_env - ; type_env2 = mapNameEnv tidyBootThing type_env1 - ; type_env' = extendTypeEnvWithIds type_env2 - (map instanceDFunId ispecs') + ; 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') } - ; return (ModDetails { md_types = type_env', - md_insts = ispecs', - md_fam_insts = mkDetailsFamInstCache type_env', - md_rules = [], - md_exports = exports }) + ; return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_exports = exports + , md_modBreaks = modBreaks + , md_vect_info = noVectInfo + }) } where @@ -238,11 +244,15 @@ RHSs, so that they print nicely in interfaces. tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) tidyProgram hsc_env mod_impl@(ModGuts { mg_module = mod, mg_exports = exports, - mg_types = type_env, mg_insts = insts_tc, + mg_types = type_env, + mg_insts = insts, mg_fam_insts = fam_insts, mg_binds = binds, mg_rules = imp_rules, + mg_vect_info = vect_info, mg_dir_imps = dir_imps, mg_deps = deps, - mg_foreign = foreign_stubs }) + mg_foreign = foreign_stubs, + mg_hpc_info = hpc_info, + mg_modBreaks = modBreaks }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy Core" @@ -260,18 +270,23 @@ tidyProgram hsc_env -- (It's a sort of mutual recursion.) } - ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds + ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids + binds - ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds - ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc + ; let { export_set = availsToNameSet exports + ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env + tidy_binds + ; 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 -- Its name will be unchanged since it was born, but - -- we want Global, IdInfo-rich (or not) DFunId in the tidy_ispecs + -- we want Global, IdInfo-rich (or not) DFunId in the + -- tidy_insts ; tidy_rules = tidyRules tidy_env ext_rules -- You might worry that the tidy_env contains IdInfo-rich stuff - -- and indeed it does, but if omit_prags is on, ext_rules is empty + -- and indeed it does, but if omit_prags is on, ext_rules is + -- empty ; implicit_binds = getImplicitBinds type_env ; all_tidy_binds = implicit_binds ++ tidy_binds @@ -288,14 +303,17 @@ tidyProgram hsc_env cg_binds = all_tidy_binds, cg_dir_imps = dir_imps, cg_foreign = foreign_stubs, - cg_dep_pkgs = dep_pkgs deps }, - - ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_ispecs, - md_fam_insts = mkDetailsFamInstCache - tidy_type_env, - md_exports = exports }) + cg_dep_pkgs = dep_pkgs deps, + cg_hpc_info = hpc_info }, + + ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_insts, + md_fam_insts = fam_insts, + md_exports = exports, + md_modBreaks = modBreaks, + md_vect_info = vect_info -- is already tidy + }) } lookup_dfun type_env dfun_id @@ -451,9 +469,10 @@ addExternal (id,rhs) needed = extendVarEnv (foldVarSet add_occ needed new_needed_ids) id show_unfold where - add_occ id needed = extendVarEnv needed id False + add_occ id needed | id `elemVarEnv` needed = needed + | otherwise = extendVarEnv needed id False -- "False" because we don't know we need the Id's unfolding - -- We'll override it later when we find the binding site + -- Don't override existing bindings; we might have already set it to True new_needed_ids = worker_ids `unionVarSet` unfold_ids `unionVarSet` @@ -461,7 +480,7 @@ addExternal (id,rhs) needed idinfo = idInfo id dont_inline = isNeverActive (inlinePragInfo idinfo) - loop_breaker = isLoopBreaker (occInfo idinfo) + loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) worker_info = workerInfo idinfo @@ -659,8 +678,7 @@ tidyTopName mod nc_var ext_ids occ_env id global = isExternalName name local = not global internal = not external - mb_parent = nameParent_maybe name - loc = nameSrcLoc name + loc = nameSrcSpan name (occ_env', occ') = tidyOccName occ_env (nameOccName name) @@ -669,7 +687,7 @@ tidyTopName mod nc_var ext_ids occ_env id (us1, us2) = splitUniqSupply (nsUniqs nc) uniq = uniqFromSupply us1 - mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc + mk_new_external nc = allocateGlobalBinder nc mod occ' loc -- If we want to externalise a currently-local name, check -- whether we have already assigned a unique for it. -- If so, use it; if not, extend the table. @@ -788,11 +806,13 @@ CAF list to keep track of non-collectable CAFs. \begin{code} hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo hasCafRefs this_pkg p arity expr - | is_caf || mentions_cafs = MayHaveCafRefs + | is_caf || mentions_cafs + = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefs p expr) is_caf = not (arity > 0 || rhsIsStatic this_pkg expr) + -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity -- knows how much eta expansion is going to be done by