X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreTidy.lhs;h=acc2c77cf08bf1b8a1f9646de301b81cb09b171f;hb=7d841483081735f5f906a6bb5e80249d97f3226b;hp=0dccf946759edf7d6ac0f2e9c1c6741174a2f6bf;hpb=a1b59a18845ddaa5e752c9fbc0ad8b947642b50d;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 0dccf94..acc2c77 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -5,7 +5,7 @@ \begin{code} module CoreTidy ( - tidyCorePgm, tidyExpr, tidyCoreExpr, + tidyCorePgm, tidyExpr, tidyCoreExpr, tidyIdRules, tidyBndr, tidyBndrs ) where @@ -14,24 +14,22 @@ module CoreTidy ( import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) -import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars ) -import PprCore ( pprIdCoreRule ) +import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) +import PprCore ( pprIdRules ) import CoreLint ( showPass, endPass ) +import CoreUtils ( exprArity ) import VarEnv import VarSet import Var ( Id, Var ) -import Id ( idType, idInfo, idName, isExportedId, - idSpecialisation, idUnique, isDataConWrapId, - mkVanillaGlobal, mkGlobalId, isLocalId, - isDataConId, mkUserLocal, isGlobalId, globalIdDetails, - idNewDemandInfo, setIdNewDemandInfo, - idNewStrictness, setIdNewStrictness +import Id ( idType, idInfo, idName, idCoreRules, + isExportedId, idUnique, mkVanillaGlobal, isLocalId, + isImplicitId, mkUserLocal, setIdInfo ) import IdInfo {- loads of stuff -} -import NewDemand ( isBottomingSig, topSig, isStrictDmd, isTopSig ) +import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( isNeverActive ) -import Name ( getOccName, nameOccName, globaliseName, setNameOcc, - localiseName, isGlobalName, setNameUnique +import Name ( getOccName, nameOccName, mkInternalName, mkExternalName, + localiseName, isExternalName, nameSrcLoc ) import NameEnv ( filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) @@ -40,7 +38,7 @@ import Module ( Module, moduleName ) import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ), NameSupply( nsNames, nsUniqs ), - TypeEnv, extendTypeEnvList, + TypeEnv, extendTypeEnvList, typeEnvIds, ModDetails(..), TyThing(..) ) import FiniteMap ( lookupFM, addToFM ) @@ -51,7 +49,7 @@ import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) import Util ( mapAccumL ) -import Maybe ( isJust, fromJust, isNothing ) +import Maybe ( isJust ) import Outputable \end{code} @@ -138,6 +136,11 @@ tidyCorePgm dflags mod pcs cg_info_env ; let ext_ids = findExternalSet binds_in orphans_in ; let ext_rules = findExternalRules binds_in orphans_in ext_ids + -- findExternalRules filters ext_rules to avoid binders that + -- aren't externally visible; but the externally-visible binders + -- are computed (by findExternalSet) assuming that all orphan + -- rules are exported. So in fact we may export more than we + -- need. (It's a sort of mutual recursion.) -- We also make sure to avoid any exported binders. Consider -- f{-u1-} = 1 -- Local decl @@ -151,21 +154,29 @@ tidyCorePgm dflags mod pcs cg_info_env orig_ns = prsOrig prs init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in, - isGlobalName (idName bndr)] + avoids = [getOccName name | bndr <- typeEnvIds env_tc, + let name = idName bndr, + isExternalName name] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. ; let ((orig_ns', occ_env, subst_env), tidy_binds) = mapAccumL (tidyTopBind mod ext_ids cg_info_env) init_tidy_env binds_in - ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules + ; let tidy_rules = tidyIdCoreRules (occ_env,subst_env) ext_rules ; let prs' = prs { prsOrig = orig_ns' } pcs' = pcs { pcs_PRS = prs' } - ; let final_ids = [ id | bind <- tidy_binds + ; let final_ids = [ id + | bind <- tidy_binds , id <- bindersOf bind - , isGlobalName (idName id)] + , isExternalName (idName id)] -- Dfuns are local Ids that might have -- changed their unique during tidying @@ -184,7 +195,7 @@ tidyCorePgm dflags mod pcs cg_info_env ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" - (vcat (map pprIdCoreRule tidy_rules)) + (pprIdRules tidy_rules) ; return (pcs', tidy_details) } @@ -224,9 +235,9 @@ mkFinalTypeEnv type_env final_ids -- in interface files, because they are needed by importing modules when -- using the compilation manager - -- We keep constructor workers, - -- because they won't appear in the bindings from which final_ids are derived! - keep_it (AnId id) = isDataConId id -- Remove all Ids except constructor workers + -- We keep implicit Ids, because they won't appear + -- in the bindings from which final_ids are derived! + keep_it (AnId id) = isImplicitId id -- Remove all Ids except implicit ones keep_it other = True -- Keep all TyCons and Classes \end{code} @@ -241,17 +252,25 @@ findExternalRules :: [CoreBind] findExternalRules binds orphan_rules ext_ids | opt_OmitInterfacePragmas = [] | otherwise - = orphan_rules ++ local_rules + = filter needed_rule (orphan_rules ++ local_rules) where - local_rules = [ (id, rule) + local_rules = [ rule | id <- bindersOfBinds binds, id `elemVarEnv` ext_ids, - rule <- rulesRules (idSpecialisation id), - not (isBuiltinRule rule) - -- We can't print builtin rules in interface files - -- Since they are built in, an importing module - -- will have access to them anyway - ] + rule <- idCoreRules id + ] + needed_rule (id, rule) + = not (isBuiltinRule rule) + -- We can't print builtin rules in interface files + -- Since they are built in, an importing module + -- will have access to them anyway + + && not (any internal_id (varSetElems (ruleLhsFreeIds rule))) + -- Don't export a rule whose LHS mentions an Id that + -- is completely internal (i.e. not visible to an + -- importing module) + + internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids) \end{code} %************************************************************************ @@ -269,7 +288,7 @@ findExternalSet binds orphan_rules = foldr find init_needed binds where orphan_rule_ids :: IdSet - orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule + orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule | (_, rule) <- orphan_rules] init_needed :: IdEnv Bool init_needed = mapUFM (\_ -> False) orphan_rule_ids @@ -383,7 +402,8 @@ tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs) = ((orig,occ,subst) , NonRec bndr' rhs') where ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs' top_tidy_env bndr + = tidyTopBinder mod ext_ids cg_info_env + rec_tidy_env rhs rhs' top_tidy_env bndr rec_tidy_env = (occ,subst) rhs' = tidyExpr rec_tidy_env rhs @@ -397,48 +417,24 @@ tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs) = ((orig,occ,subst), (bndr',rhs')) where ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids cg_info_env - rec_tidy_env rhs' top_tidy_env bndr + = tidyTopBinder mod ext_ids cg_info_env + rec_tidy_env rhs rhs' top_tidy_env bndr rhs' = tidyExpr rec_tidy_env rhs -tidyTopBinder :: Module -> IdEnv Bool - -> CgInfoEnv - -> TidyEnv -> CoreExpr - -- The TidyEnv is used to tidy the IdInfo - -- The expr is the already-tided RHS - -- Both are knot-tied: don't look at them! +tidyTopBinder :: Module -> IdEnv Bool -> CgInfoEnv + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -> CoreExpr -- RHS *before* tidying + -> CoreExpr -- RHS *after* tidying + -- The TidyEnv and the after-tidying RHS are + -- both are knot-tied: don't look at them! -> TopTidyEnv -> Id -> (TopTidyEnv, Id) -- NB: tidyTopBinder doesn't affect the unique supply -tidyTopBinder mod ext_ids cg_info_env tidy_env rhs +tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs tidy_rhs env@(ns2, occ_env2, subst_env2) id - - | isDataConWrapId id -- Don't tidy constructor wrappers - = (env, id) -- The Id is stored in the TyCon, so it would be bad - -- if anything changed - --- HACK ALERT: we *do* tidy record selectors. Reason: they mention error --- messages, which may be floated out: --- x_field pt = case pt of --- Rect x y -> y --- Pol _ _ -> error "buggle wuggle" --- The error message will be floated out so we'll get --- lvl5 = error "buggle wuggle" --- x_field pt = case pt of --- Rect x y -> y --- Pol _ _ -> lvl5 --- --- When this happens, it's vital that the Id exposed to importing modules --- (by ghci) mentions lvl5 in its unfolding, not the un-tidied version. --- --- What about the Id in the TyCon? It probably shouldn't be in the TyCon at --- all, but in any case it will have the error message inline so it won't matter. - - - | otherwise -- This function is the heart of Step 2 - -- The second env is the one to use for the IdInfo + -- The rec_tidy_env is the one to use for the IdInfo -- It's necessary because when we are dealing with a recursive -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group @@ -450,14 +446,12 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2 is_external (idName id) - ty' = tidyTopType (idType id) - cg_info = lookupCgInfo cg_info_env name' - idinfo' = tidyIdInfo tidy_env is_external unfold_info cg_info id + ty' = tidyTopType (idType id) + idinfo = tidyTopIdInfo rec_tidy_env is_external + (idInfo id) unfold_info arity + (lookupCgInfo cg_info_env name') - id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo' - | otherwise = mkVanillaGlobal name' ty' idinfo' - -- The test ensures that record selectors (which must be tidied; see above) - -- retain their details. If it's forgotten, importing modules get confused. + id' = mkVanillaGlobal name' ty' idinfo subst_env' = extendVarEnv subst_env2 id id' @@ -465,36 +459,65 @@ tidyTopBinder mod ext_ids cg_info_env tidy_env rhs is_external = isJust maybe_external -- Expose an unfolding if ext_ids tells us to + -- Remember that ext_ids maps an Id to a Bool: + -- True to show the unfolding, False to hide it show_unfold = maybe_external `orElse` False - unfold_info | show_unfold = mkTopUnfolding rhs + unfold_info | show_unfold = mkTopUnfolding tidy_rhs | otherwise = noUnfolding + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity rhs -tidyIdInfo tidy_env is_external unfold_info cg_info id + + +-- tidyTopIdInfo creates the final IdInfo for top-level +-- binders. There are two delicate pieces: +-- +-- * Arity. After CoreTidy, this arity must not change any more. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. +-- +-- * CAF info, which comes from the CoreToStg pass via a knot. +-- The CAF info will not be looked at by the downstream stuff: +-- it *generates* it, and knot-ties it back. It will only be +-- looked at by (a) MkIface when generating an interface file +-- (b) In GHCi, importing modules +-- Nevertheless, we add the info here so that it propagates to all +-- occurrences of the binders in RHSs, and hence to occurrences in +-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. +-- +-- An alterative would be to do a second pass over the unfoldings +-- of Ids, and rules, right at the top, but that would be a pain. + +tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info | opt_OmitInterfacePragmas || not is_external - -- No IdInfo if the Id isn't external, or if we don't have -O - = vanillaIdInfo - `setCgInfo` cg_info - `setNewStrictnessInfo` newStrictnessInfo core_idinfo - -- Keep strictness; it's used by CorePrep + -- Only basic info if the Id isn't external, or if we don't have -O + = basic_info - | otherwise - = vanillaIdInfo - `setCgInfo` cg_info - `setNewStrictnessInfo` newStrictnessInfo core_idinfo - `setInlinePragInfo` inlinePragInfo core_idinfo + | otherwise -- Add extra optimisation info + = basic_info + `setInlinePragInfo` inlinePragInfo idinfo `setUnfoldingInfo` unfold_info - `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo) - -- NB: we throw away the Rules - -- They have already been extracted by findExternalRules + `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo) + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules + where - core_idinfo = idInfo id - + -- baasic_info is attached to every top-level binder + basic_info = vanillaIdInfo + `setCgInfo` cg_info + `setArityInfo` arity + `setAllStrictnessInfo` newStrictnessInfo idinfo -- This is where we set names to local/global based on whether they really are -- 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 globalise it. +-- we intend to externalise it. tidyTopName mod ns occ_env external name | global && internal = (ns, occ_env, localiseName name) @@ -503,22 +526,24 @@ tidyTopName mod ns occ_env external name -- so they already have the "right" unique -- And it's a system-wide unique too - | local && internal = (ns { nsUniqs = us2 }, occ_env', unique_name) + | local && internal = (ns_w_local, occ_env', new_local_name) -- Even local, internal names must get a unique occurrence, because - -- if we do -split-objs we globalise the name later, in the code generator + -- if we do -split-objs we externalise the name later, in the code generator -- -- Similarly, we must make sure it has a system-wide Unique, because -- the byte-code generator builds a system-wide Name->BCO symbol table | local && external = case lookupFM ns_names key of - Just orig -> (ns, occ_env', orig) - Nothing -> (ns { nsUniqs = us2, nsNames = ns_names' }, occ_env', global_name) - -- If we want to globalise a currently-local name, check + Just orig -> (ns, occ_env', orig) + Nothing -> (ns_w_global, occ_env', new_external_name) + -- 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 + -- If so, use it; if not, extend the table (ns_w_global). + -- This is needed when *re*-compiling a module in GHCi; we want to + -- use the same name for externally-visible things as we did before. where - global = isGlobalName name + global = isExternalName name local = not global internal = not external @@ -527,9 +552,14 @@ tidyTopName mod ns occ_env external name ns_names = nsNames ns ns_uniqs = nsUniqs ns (us1, us2) = splitUniqSupply ns_uniqs - unique_name = setNameUnique (setNameOcc name occ') (uniqFromSupply us1) - global_name = globaliseName unique_name mod - ns_names' = addToFM ns_names key global_name + uniq = uniqFromSupply us1 + loc = nameSrcLoc name + + new_local_name = mkInternalName uniq occ' loc + new_external_name = mkExternalName uniq mod occ' loc + + ns_w_local = ns { nsUniqs = us2 } + ns_w_global = ns { nsUniqs = us2, nsNames = addToFM ns_names key new_external_name } ------------ Worker -------------- @@ -539,11 +569,14 @@ tidyWorker tidy_env other = NoWorker ------------ Rules -------------- -tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule] -tidyIdRules env [] = [] -tidyIdRules env ((fn,rule) : rules) +tidyIdRules :: Id -> [IdCoreRule] +tidyIdRules id = tidyIdCoreRules emptyTidyEnv (idCoreRules id) + +tidyIdCoreRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule] +tidyIdCoreRules env [] = [] +tidyIdCoreRules env ((fn,rule) : rules) = tidyRule env rule =: \ rule -> - tidyIdRules env rules =: \ rules -> + tidyIdCoreRules env rules =: \ rules -> ((tidyVarOcc env fn, rule) : rules) tidyRule :: TidyEnv -> CoreRule -> CoreRule @@ -639,35 +672,38 @@ tidyLetBndr env (id,rhs) -- -- Similarly for the demand info - on a let binder, this tells -- CorePrep to turn the let into a case. - final_id - | totally_boring_info = new_id - | otherwise = new_id `setIdNewDemandInfo` dmd_info - `setIdNewStrictness` new_strictness - - -- override the env we get back from tidyId with the new IdInfo + -- + -- Similarly arity info for eta expansion in CorePrep + final_id = new_id `setIdInfo` new_info + idinfo = idInfo id + new_info = vanillaIdInfo + `setArityInfo` exprArity rhs + `setAllStrictnessInfo` newStrictnessInfo idinfo + `setNewDemandInfo` newDemandInfo idinfo + + -- Override the env we get back from tidyId with the new IdInfo -- so it gets propagated to the usage sites. new_var_env = extendVarEnv var_env id final_id - dmd_info = idNewDemandInfo id - new_strictness = idNewStrictness id - totally_boring_info = isTopSig new_strictness && not (isStrictDmd dmd_info) - +-- Non-top-level variables tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) tidyIdBndr env@(tidy_env, var_env) id - = -- Non-top-level variables + = -- do this pattern match strictly, otherwise we end up holding on to + -- stuff in the OccName. + case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> let -- Give the Id a fresh print-name, *and* rename its type -- The SrcLoc isn't important now, -- though we could extract it from the Id -- - -- All local Ids now have the same IdInfo, which should save some - -- space. - (tidy_env', occ') = tidyOccName tidy_env (getOccName id) + -- All nested Ids now have the same IdInfo, namely none, + -- which should save some space. ty' = tidyType env (idType id) id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc var_env' = extendVarEnv var_env id id' in ((tidy_env', var_env'), id') + } \end{code} \begin{code}