X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCoreTidy.lhs;h=acc2c77cf08bf1b8a1f9646de301b81cb09b171f;hb=7d841483081735f5f906a6bb5e80249d97f3226b;hp=d0234cec5dc713e9d014ac1283a774b8d070a59b;hpb=f6cd95ff9a2bddbd78682dcd9287aec7d152cc13;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index d0234ce..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,39 +14,42 @@ module CoreTidy ( import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) -import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars ) +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, isLocalId, isRecordSelector, - setIdUnfolding, hasNoBinding, mkUserLocal +import Id ( idType, idInfo, idName, idCoreRules, + isExportedId, idUnique, mkVanillaGlobal, isLocalId, + isImplicitId, mkUserLocal, setIdInfo ) import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig ) -import Name ( getOccName, nameOccName, globaliseName, setNameOcc, - localiseName, isGlobalName, setNameUnique +import BasicTypes ( isNeverActive ) +import Name ( getOccName, nameOccName, mkInternalName, mkExternalName, + localiseName, isExternalName, nameSrcLoc ) import NameEnv ( filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) -import Type ( tidyTopType, tidyType, tidyTyVar ) +import Type ( tidyTopType, tidyType, tidyTyVarBndr ) 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 ) -import Maybes ( maybeToBool, orElse ) -import ErrUtils ( showPass ) +import Maybes ( orElse ) +import ErrUtils ( showPass, dumpIfSet_core ) import SrcLoc ( noSrcLoc ) import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) import Util ( mapAccumL ) +import Maybe ( isJust ) import Outputable \end{code} @@ -94,7 +97,8 @@ binder to ensure that the unique assigned is the same as the Id had in any previous compilation run. - 3. If it's an external Id, make it have a global Name and vice versa. + 3. If it's an external Id, make it have a global Name, otherwise + make it have a local Name. This is used by the code generator to decide whether to make the label externally visible @@ -132,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 @@ -145,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 @@ -176,6 +193,9 @@ tidyCorePgm dflags mod pcs cg_info_env md_binds = tidy_binds } ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds + ; dumpIfSet_core dflags Opt_D_dump_simpl + "Tidy Core Rules" + (pprIdRules tidy_rules) ; return (pcs', tidy_details) } @@ -215,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 "hasNoBinding" Ids, notably constructor workers, - -- because they won't appear in the bindings from which final_ids are derived! - keep_it (AnId id) = hasNoBinding 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} @@ -232,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} %************************************************************************ @@ -260,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 @@ -305,7 +333,7 @@ addExternal (id,rhs) needed spec_ids idinfo = idInfo id - dont_inline = isNeverInlinePrag (inlinePragInfo idinfo) + dont_inline = isNeverActive (inlinePragInfo idinfo) loop_breaker = isLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) spec_ids = rulesRhsFreeVars (specInfo idinfo) @@ -374,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 @@ -388,53 +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. - - - | isRecordSelector id -- We can't use the "otherwise" case, because that - -- forgets the IdDetails, which forgets that this is - -- a record selector, which confuses an importing module - = (env, id `setIdUnfolding` unfold_info) - - | 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 @@ -446,47 +446,78 @@ 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' = mkVanillaGlobal name' ty' idinfo - id' = mkVanillaGlobal name' ty' idinfo' subst_env' = extendVarEnv subst_env2 id id' maybe_external = lookupVarEnv ext_ids id - is_external = maybeToBool maybe_external + 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) @@ -495,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 @@ -519,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 -------------- @@ -531,19 +569,22 @@ 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 -tidyRule env rule@(BuiltinRule _) = rule -tidyRule env (Rule name vars tpl_args rhs) +tidyRule env rule@(BuiltinRule _ _) = rule +tidyRule env (Rule name act vars tpl_args rhs) = tidyBndrs env vars =: \ (env', vars) -> map (tidyExpr env') tpl_args =: \ tpl_args -> - (Rule name vars tpl_args (tidyExpr env' rhs)) + (Rule name act vars tpl_args (tidyExpr env' rhs)) \end{code} %************************************************************************ @@ -558,11 +599,11 @@ tidyBind :: TidyEnv -> (TidyEnv, CoreBind) tidyBind env (NonRec bndr rhs) - = tidyBndrWithRhs env (bndr,rhs) =: \ (env', bndr') -> + = tidyLetBndr env (bndr,rhs) =: \ (env', bndr') -> (env', NonRec bndr' (tidyExpr env' rhs)) tidyBind env (Rec prs) - = mapAccumL tidyBndrWithRhs env prs =: \ (env', bndrs') -> + = mapAccumL tidyLetBndr env prs =: \ (env', bndrs') -> map (tidyExpr env') (map snd prs) =: \ rhss' -> (env', Rec (zip bndrs' rhss')) @@ -609,32 +650,60 @@ tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of -- tidyBndr is used for lambda and case binders tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var - | isTyVar var = tidyTyVar env var - | otherwise = tidyId env var + | isTyVar var = tidyTyVarBndr env var + | otherwise = tidyIdBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) tidyBndrs env vars = mapAccumL tidyBndr env vars --- tidyBndrWithRhs is used for let binders -tidyBndrWithRhs :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var) -tidyBndrWithRhs env (id,rhs) = tidyId env id - -tidyId :: TidyEnv -> Id -> (TidyEnv, Id) -tidyId env@(tidy_env, var_env) id - = -- Non-top-level variables +tidyLetBndr :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var) +-- Used for local (non-top-level) let(rec)s +tidyLetBndr env (id,rhs) + = ((tidy_env,new_var_env), final_id) + where + ((tidy_env,var_env), new_id) = tidyIdBndr env id + + -- We need to keep around any interesting strictness and demand info + -- because later on we may need to use it when converting to A-normal form. + -- eg. + -- f (g x), where f is strict in its argument, will be converted + -- into case (g x) of z -> f z by CorePrep, but only if f still + -- has its strictness info. + -- + -- Similarly for the demand info - on a let binder, this tells + -- CorePrep to turn the let into a case. + -- + -- 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 + +-- Non-top-level variables +tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id) +tidyIdBndr env@(tidy_env, var_env) id + = -- 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) - ty' = tidyType (tidy_env,var_env) (idType 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}