X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=530e54ccac8505e8eea82c8d5c0a18d81bf66f3c;hp=c0d19df90a3cc077375d4ea370ee50084f30a69c;hb=703ca1542c8e0983cc9d8eebce6e9f3dd3fd71e2;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index c0d19df..530e54c 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -1,61 +1,51 @@ -% + % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section{Tidying up Core} \begin{code} -module TidyPgm( mkBootModDetails, tidyProgram ) where +module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, + tidyProgram, globaliseAndTidyId ) where #include "HsVersions.h" -import DynFlags ( DynFlag(..), DynFlags(..), dopt ) +import TcRnTypes +import FamInstEnv +import DynFlags import CoreSyn -import CoreUnfold ( noUnfolding, mkTopUnfolding ) -import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) -import CoreTidy ( tidyExpr, tidyVarOcc, tidyRules ) -import PprCore ( pprRules ) -import CoreLint ( showPass, endPass ) -import CoreUtils ( exprArity, rhsIsStatic ) +import CoreUnfold +import CoreFVs +import CoreTidy +import PprCore +import CoreLint +import CoreUtils +import CoreArity ( exprArity ) +import Class ( classSelIds ) import VarEnv import VarSet -import Var ( Id, Var ) -import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, - isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector, - idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo - ) -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 NameSet ( NameSet, elemNameSet ) -import IfaceEnv ( allocateGlobalBinder ) -import NameEnv ( filterNameEnv, mapNameEnv ) -import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) -import Type ( tidyTopType ) -import TcType ( isFFITy ) -import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe ) -import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, - newTyConRep, tyConSelIds, isAlgTyCon, isEnumerationTyCon ) -import Class ( classSelIds ) -import Module ( Module ) -import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), - TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, - extendTypeEnvWithIds, lookupTypeEnv, - ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..) - ) -import Maybes ( orElse, mapCatMaybes ) -import ErrUtils ( showPass, dumpIfSet_core ) -import PackageConfig ( PackageId ) -import UniqSupply ( splitUniqSupply, uniqFromSupply ) -import List ( partition ) -import Maybe ( isJust ) +import Var +import Id +import IdInfo +import InstEnv +import NewDemand +import BasicTypes +import Name +import NameSet +import IfaceEnv +import NameEnv +import TcType +import DataCon +import TyCon +import Module +import HscTypes +import Maybes +import ErrUtils +import UniqSupply import Outputable -import DATA_IOREF ( IORef, readIORef, writeIORef ) -import FastTypes hiding ( fastOr ) +import FastBool hiding ( fastOr ) + +import Data.List ( partition ) +import Data.IORef ( IORef, readIORef, writeIORef ) \end{code} @@ -114,48 +104,85 @@ 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_module = mod, - mg_exports = exports, - mg_types = type_env, - mg_insts = ispecs }) +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 { 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 globaliseAndTidyId 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 = ispecs', - md_rules = [], - md_exports = exports }) + ; return (ModDetails { md_types = type_env' + , md_insts = insts' + , md_fam_insts = fam_insts + , md_rules = [] + , md_anns = [] + , md_exports = exports + , md_vect_info = noVectInfo + }) } where -isWiredInThing :: TyThing -> Bool -isWiredInThing thing = isWiredInName (getName thing) +tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv +tidyBootTypeEnv exports type_env + = tidyTypeEnv True False 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 = [ globaliseAndTidyId 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 + +globaliseAndTidyId :: Id -> Id -- Takes an LocalId with an External Name, --- makes it into a GlobalId with VanillaIdInfo, and tidies its type --- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.) -tidyExternalId id - = ASSERT2( isLocalId id && isExternalName (idName id), ppr id ) - mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo +-- makes it into a GlobalId +-- * unchanged Name (might be Internal or External) +-- * unchanged details +-- * VanillaIdInfo (makes a conservative assumption about Caf-hood) +globaliseAndTidyId id + = Id.setIdType (globaliseId id) tidy_type + where + tidy_type = tidyTopType (idType id) \end{code} @@ -232,18 +259,24 @@ RHSs, so that they print nicely in interfaces. \begin{code} 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, +tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, + mg_types = type_env, + mg_insts = insts, mg_fam_insts = fam_insts, mg_binds = binds, mg_rules = imp_rules, - mg_dir_imps = dir_imps, mg_deps = deps, - mg_foreign = foreign_stubs }) + mg_vect_info = vect_info, + mg_dir_imps = dir_imps, + mg_anns = anns, + mg_deps = deps, + mg_foreign = foreign_stubs, + mg_hpc_info = hpc_info, + mg_modBreaks = modBreaks }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy Core" ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags + ; th = dopt Opt_TemplateHaskell dflags ; ext_ids = findExternalIds omit_prags binds ; ext_rules | omit_prags = [] @@ -256,21 +289,30 @@ 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 + ; final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] + ; tidy_type_env = tidyTypeEnv omit_prags th export_set + type_env 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 -- 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 + + -- See Note [Injecting implicit bindings] + ; implicit_binds = getImplicitBinds type_env + ; all_tidy_binds = implicit_binds ++ tidy_binds - ; implicit_binds = getImplicitBinds type_env - ; all_tidy_binds = implicit_binds ++ tidy_binds ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } @@ -279,25 +321,37 @@ tidyProgram hsc_env "Tidy Core Rules" (pprRules tidy_rules) + ; let dir_imp_mods = moduleEnvKeys 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 }, - - ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_ispecs, - md_exports = exports }) + cg_dep_pkgs = dep_pkgs deps, + cg_hpc_info = hpc_info, + cg_modBreaks = modBreaks }, + + ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_insts, + md_fam_insts = fam_insts, + md_exports = exports, + md_anns = anns, -- are already tidy + md_vect_info = vect_info -- + }) } +lookup_dfun :: TypeEnv -> Var -> Id lookup_dfun type_env dfun_id = case lookupTypeEnv type_env (idName dfun_id) of Just (AnId dfun_id') -> dfun_id' - other -> pprPanic "lookup_dfun" (ppr dfun_id) + _other -> pprPanic "lookup_dfun" (ppr dfun_id) -tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv +-------------------------- +tidyTypeEnv :: Bool -- Compiling without -O, so omit prags + -> Bool -- Template Haskell is on + -> NameSet -> TypeEnv -> [Id] -> TypeEnv -- The competed type environment is gotten from -- Dropping any wired-in things, and then @@ -311,33 +365,51 @@ 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 - = let type_env1 = filterNameEnv keep_it type_env +tidyTypeEnv omit_prags th 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 th 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.) keep_it thing | isWiredInThing thing = False keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops) - keep_it other = True -- Keep all TyCons, DataCons, and Classes + keep_it _other = True -- Keep all TyCons, DataCons, and Classes + +-------------------------- +isWiredInThing :: TyThing -> Bool +isWiredInThing thing = isWiredInName (getName thing) + +-------------------------- +trimThing :: Bool -> NameSet -> TyThing -> TyThing +-- Trim off inessentials, for boot files and no -O +trimThing th exports (ATyCon tc) + | not th && not (mustExposeTyCon exports tc) + = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell] - trim_thing thing - = case thing of - ATyCon tc | mustExposeTyCon exports tc -> thing - | otherwise -> ATyCon (makeTyConAbstract tc) +trimThing _th _exports (AnId id) + | not (isImplicitId id) + = AnId (id `setIdInfo` vanillaIdInfo) - AnId id | isImplicitId id -> thing - | otherwise -> AnId (id `setIdInfo` vanillaIdInfo) +trimThing _th _exports other_thing + = other_thing + + +{- Note [Trimming and Template Haskell] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider (Trac #2386) this + module M(T, makeOne) where + data T = Yay String + makeOne = [| Yay "Yep" |] +Notice that T is exported abstractly, but makeOne effectively exports it too! +A module that splices in $(makeOne) will then look for a declartion of Yay, +so it'd better be there. Hence, brutally but simply, we switch off type +constructor trimming if TH is enabled in this module. -} - other -> thing mustExposeTyCon :: NameSet -- Exports -> TyCon -- The tycon @@ -351,11 +423,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 + = 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 @@ -370,31 +445,62 @@ tidyInstances tidy_dfun ispecs where tidy ispec = setInstanceDFunId ispec $ tidy_dfun (instanceDFunId ispec) +\end{code} + + +%************************************************************************ +%* * + Implicit bindings +%* * +%************************************************************************ + +Note [Injecting implicit bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We inject the implict bindings right at the end, in CoreTidy. +Some of these bindings, notably record selectors, are not +constructed in an optimised form. E.g. record selector for + data T = MkT { x :: {-# UNPACK #-} !Int } +Then the unfolding looks like + x = \t. case t of MkT x1 -> let x = I# x1 in x +This generates bad code unless it's first simplified a bit. That is +why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of +optimisation first. (Only matters when the selector is used curried; +eg map x ys.) See Trac #2070. + +At one time I tried injecting the implicit bindings *early*, at the +beginning of SimplCore. But that gave rise to real difficulty, +becuase GlobalIds are supposed to have *fixed* IdInfo, but the +simplifier and other core-to-core passes mess with IdInfo all the +time. The straw that broke the camels back was when a class selector +got the wrong arity -- ie the simplifier gave it arity 2, whereas +importing modules were expecting it to have arity 1 (Trac #2844). +It's much safer just to inject them right at the end, after tidying. + +Oh: two other reasons for injecting them late: + - If implicit Ids are already in the bindings when we start TidyPgm, + we'd have to be careful not to treat them as external Ids (in + the sense of findExternalIds); else the Ids mentioned in *their* + RHSs will be treated as external and you get an interface file + saying a18 = + but nothing refererring to a18 (because the implicit Id is the + one that does). + + - More seriously, the tidied type-envt will include the implicit + Id replete with a18 in its unfolding; but we won't take account + of a18 when computing a fingerprint for the class; result chaos. + +\begin{code} getImplicitBinds :: TypeEnv -> [CoreBind] getImplicitBinds type_env - = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env) - ++ concatMap other_implicit_ids (typeEnvElts type_env)) - -- Put the constructor wrappers first, because - -- other implicit bindings (notably the fromT functions arising - -- from generics) use the constructor wrappers. At least that's - -- what External Core likes + = map get_defn (concatMap implicit_ids (typeEnvElts type_env)) where - implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) - - other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc) - -- The "naughty" ones are not real functions at all - -- They are there just so we can get decent error messages - -- See Note [Naughty record selectors] in MkId.lhs - other_implicit_ids (AClass cl) = classSelIds cl - other_implicit_ids other = [] + implicit_ids (ATyCon tc) = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) + implicit_ids (AClass cls) = classSelIds cls + implicit_ids _ = [] get_defn :: Id -> CoreBind - get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs) - where - rhs = unfoldingTemplate (idUnfolding id) - -- Don't forget to tidy the body ! Otherwise you get silly things like - -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl + get_defn id = NonRec id (unfoldingTemplate (idUnfolding id)) \end{code} @@ -434,7 +540,7 @@ findExternalIds omit_prags binds -- interface file emissions. If the Id isn't in this set, and isn't -- exported, there's no need to emit anything need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id - need_pr needed_set (id,rhs) = need_id needed_set id + need_pr needed_set (id,_) = need_id needed_set id addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool -- The Id is needed; extend the needed set @@ -443,17 +549,18 @@ 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` spec_ids idinfo = idInfo id - dont_inline = isNeverActive (inlinePragInfo idinfo) - loop_breaker = isLoopBreaker (occInfo idinfo) + dont_inline = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) + loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = specInfoFreeVars (specInfo idinfo) worker_info = workerInfo idinfo @@ -478,7 +585,7 @@ addExternal (id,rhs) needed worker_ids = case worker_info of HasWorker work_id _ -> unitVarSet work_id - otherwise -> emptyVarSet + _otherwise -> emptyVarSet \end{code} @@ -580,7 +687,7 @@ tidyTopBind :: PackageId -> TidyEnv -> CoreBind -> IO (TidyEnv, CoreBind) -tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) +tidyTopBind this_pkg mod nc_var ext_ids (occ_env1,subst1) (NonRec bndr rhs) = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs) ; subst2 = extendVarEnv subst1 bndr bndr' @@ -589,7 +696,7 @@ tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr where caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs -tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) +tidyTopBind this_pkg mod nc_var ext_ids (occ_env1,subst1) (Rec prs) = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info) names' prs @@ -612,7 +719,9 @@ tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) -- externally visible (see comment at the top of this module). If the name -- was previously local, we have to give it a unique occurrence name if -- we intend to externalise it. -tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, []) +tidyTopNames :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv + -> [Id] -> IO (TidyOccEnv, [Name]) +tidyTopNames _mod _nc_var _ext_ids occ_env [] = return (occ_env, []) tidyTopNames mod nc_var ext_ids occ_env (id:ids) = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids @@ -645,14 +754,15 @@ tidyTopName mod nc_var ext_ids occ_env id ; let (nc', new_external_name) = mk_new_external nc ; writeIORef nc_var nc' ; return (occ_env', new_external_name) } + + | otherwise = panic "tidyTopName" where name = idName id external = id `elemVarEnv` ext_ids 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) @@ -661,7 +771,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. @@ -685,17 +795,16 @@ tidyTopPair :: VarEnv Bool -- in the IdInfo of one early in the group tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) - | isGlobalId bndr -- Injected binding for record selector, etc - = (bndr, tidyExpr rhs_tidy_env rhs) - | otherwise = (bndr', rhs') where - bndr' = mkVanillaGlobal name' ty' idinfo' + bndr' = mkGlobalId details name' ty' idinfo' + details = idDetails bndr -- Preserve the IdDetails ty' = tidyTopType (idType bndr) rhs' = tidyExpr rhs_tidy_env rhs - idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external) - (idInfo bndr) unfold_info arity - caf_info + idinfo = idInfo bndr + idinfo' = tidyTopIdInfo (isJust maybe_external) + idinfo unfold_info worker_info + arity caf_info -- Expose an unfolding if ext_ids tells us to -- Remember that ext_ids maps an Id to a Bool: @@ -704,6 +813,7 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) show_unfold = maybe_external `orElse` False unfold_info | show_unfold = mkTopUnfolding rhs' | otherwise = noUnfolding + worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo) -- Usually the Id will have an accurate arity on it, because -- the simplifier has just run, but not always. @@ -726,8 +836,10 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) -- occurrences of the binders in RHSs, and hence to occurrences in -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. -- CoreToStg makes use of this when constructing SRTs. - -tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info +tidyTopIdInfo :: Bool -> IdInfo -> Unfolding + -> WorkerInfo -> ArityInfo -> CafInfo + -> IdInfo +tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info | not is_external -- For internal Ids (not externally visible) = vanillaIdInfo -- we only need enough info for code generation -- Arity and strictness info are enough; @@ -743,17 +855,32 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info `setAllStrictnessInfo` newStrictnessInfo idinfo `setInlinePragInfo` inlinePragInfo idinfo `setUnfoldingInfo` unfold_info - `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo) + `setWorkerInfo` worker_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules ------------ Worker -------------- -tidyWorker tidy_env (HasWorker work_id wrap_arity) - = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity -tidyWorker tidy_env other +tidyWorker :: TidyEnv -> Bool -> WorkerInfo -> WorkerInfo +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 = 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 + -- This is important: if you expose the worker for a loop-breaker + -- then you can make the simplifier go into an infinite loop, because + -- in effect the unfolding is exposed. See Trac #1709 + -- + -- 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} %************************************************************************ @@ -780,17 +907,20 @@ 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 -- CorePrep later on, and we don't want to duplicate that -- knowledge in rhsIsStatic below. +cafRefs :: VarEnv Id -> Expr a -> FastBool cafRefs p (Var id) -- imported Ids first: | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) @@ -800,17 +930,20 @@ cafRefs p (Var id) Just id' -> fastBool (mayHaveCafRefs (idCafInfo id')) Nothing -> fastBool False -cafRefs p (Lit l) = fastBool False +cafRefs _ (Lit _) = fastBool False cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a -cafRefs p (Lam x e) = cafRefs p e +cafRefs p (Lam _ e) = cafRefs p e cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e -cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) -cafRefs p (Note n e) = cafRefs p e -cafRefs p (Type t) = fastBool False +cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) +cafRefs p (Note _n e) = cafRefs p e +cafRefs p (Cast e _co) = cafRefs p e +cafRefs _ (Type _) = fastBool False -cafRefss p [] = fastBool False +cafRefss :: VarEnv Id -> [Expr a] -> FastBool +cafRefss _ [] = fastBool False cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es +fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool -- hack for lazy-or over FastBool. fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) \end{code}