X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=5c78927c7de8ddca8bda0a270b08a6e9b8b90077;hp=2f5d31affa875922e7c2edb888e445af79f72cb1;hb=7bb3d1fc79521d591cd9f824893963141a7997b6;hpb=d95ce839533391e7118257537044f01cbb1d6694 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 2f5d31a..5c78927 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -4,7 +4,8 @@ \section{Tidying up Core} \begin{code} -module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram ) where +module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, + tidyProgram, globaliseAndTidyId ) where #include "HsVersions.h" @@ -18,6 +19,8 @@ import CoreTidy import PprCore import CoreLint import CoreUtils +import CoreArity ( exprArity ) +import Class ( classSelIds ) import VarEnv import VarSet import Var @@ -133,7 +136,7 @@ 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 + ; let { insts' = tidyInstances globaliseAndTidyId insts ; dfun_ids = map instanceDFunId insts' ; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids @@ -160,7 +163,7 @@ tidyBootTypeEnv exports type_env -- 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 + final_ids = [ globaliseAndTidyId id | id <- typeEnvIds type_env , isLocalId id , keep_it id ] @@ -171,13 +174,17 @@ tidyBootTypeEnv exports type_env keep_it id = isExportedId id || idName id `elemNameSet` exports -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)) +-- 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} @@ -208,7 +215,7 @@ unit. These are This exercise takes a sweep of the bindings bottom to top. Actually, in Step 2 we're also going to need to know which Ids should be exported with their unfoldings, so we produce not an IdSet but an -ExtIdEnv = IdEnv Bool +IdEnv Bool Step 2: Tidy the program @@ -304,10 +311,14 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, -- 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 + ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) } - ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds + ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" (pprRules tidy_rules) @@ -316,7 +327,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, ; return (CgGuts { cg_module = mod, cg_tycons = alg_tycons, - cg_binds = tidy_binds, + cg_binds = all_tidy_binds, cg_dir_imps = dir_imp_mods, cg_foreign = foreign_stubs, cg_dep_pkgs = dep_pkgs deps, @@ -440,18 +451,72 @@ tidyInstances tidy_dfun ispecs %************************************************************************ +%* * + 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_ids (typeEnvElts type_env)) + where + 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 (unfoldingTemplate (idUnfolding id)) +\end{code} + + +%************************************************************************ %* * \subsection{Step 1: finding externals} %* * %************************************************************************ \begin{code} -type ExtIdEnv = IdEnv Bool - -- In domain => Id is external - -- Range = True <=> show unfolding, - -- Always True for InlineRule - -findExternalIds :: Bool -> [CoreBind] -> ExtIdEnv +findExternalIds :: Bool + -> [CoreBind] + -> IdEnv Bool -- In domain => external + -- Range = True <=> show unfolding -- Step 1 from the notes above findExternalIds omit_prags binds | omit_prags @@ -491,33 +556,38 @@ addExternal (id,rhs) needed -- "False" because we don't know we need the Id's unfolding -- Don't override existing bindings; we might have already set it to True - new_needed_ids = (mb_unfold_ids `orElse` emptyVarSet) `unionVarSet` + new_needed_ids = worker_ids `unionVarSet` + unfold_ids `unionVarSet` spec_ids idinfo = idInfo id - dont_inline = isNeverActive (inlinePragInfo 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 -- Stuff to do with the Id's unfolding + -- The simplifier has put an up-to-date unfolding + -- in the IdInfo, but the RHS will do just as well + unfolding = unfoldingInfo idinfo + rhs_is_small = not (neverUnfold unfolding) + -- We leave the unfolding there even if there is a worker -- In GHCI the unfolding is used by importers - show_unfold = isJust mb_unfold_ids - - mb_unfold_ids :: Maybe IdSet -- Nothing => don't unfold - mb_unfold_ids = case unfoldingInfo idinfo of - InlineRule { uf_worker = Just wkr_id } -> Just (unitVarSet wkr_id) - InlineRule { uf_tmpl = rhs } -> Just (exprFreeIds rhs) - CoreUnfolding { uf_guidance = guide } - | not bottoming_fn -- Not necessary - , not dont_inline - , not loop_breaker - , not (neverUnfoldGuidance guide) - -> Just (exprFreeIds rhs) -- The simplifier has put an up-to-date unfolding - -- in the IdInfo, but the RHS will do just as well - - _ -> Nothing + -- When writing an interface file, we omit the unfolding + -- if there is a worker + show_unfold = not bottoming_fn && -- Not necessary + not dont_inline && + not loop_breaker && + rhs_is_small -- Small enough + + unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs + | otherwise = emptyVarSet + + worker_ids = case worker_info of + HasWorker work_id _ -> unitVarSet work_id + _otherwise -> emptyVarSet \end{code} @@ -574,7 +644,8 @@ findExternalRules binds non_local_rules ext_ids tidyTopBinds :: HscEnv -> Module -> TypeEnv - -> ExtIdEnv + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too -> [CoreBind] -> IO (TidyEnv, [CoreBind]) @@ -613,7 +684,8 @@ tidyTopBinds hsc_env mod type_env ext_ids binds tidyTopBind :: PackageId -> Module -> IORef NameCache -- For allocating new unique names - -> ExtIdEnv + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too -> TidyEnv -> CoreBind -> IO (TidyEnv, CoreBind) @@ -728,15 +800,12 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) = (bndr', rhs') where bndr' = mkGlobalId details name' ty' idinfo' - -- Preserve the GlobalIdDetails of existing global-ids - details = case globalIdDetails bndr of - NotGlobalId -> VanillaGlobal - old_details -> old_details + details = idDetails bndr -- Preserve the IdDetails ty' = tidyTopType (idType bndr) rhs' = tidyExpr rhs_tidy_env rhs idinfo = idInfo bndr idinfo' = tidyTopIdInfo (isJust maybe_external) - idinfo unfold_info + idinfo unfold_info worker_info arity caf_info -- Expose an unfolding if ext_ids tells us to @@ -744,21 +813,9 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) -- True to show the unfolding, False to hide it maybe_external = lookupVarEnv ext_ids bndr show_unfold = maybe_external `orElse` False - unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs' (unfoldingInfo idinfo) + unfold_info | show_unfold = mkTopUnfolding rhs' | otherwise = noUnfolding - -- 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 + 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. @@ -782,9 +839,9 @@ tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. -- CoreToStg makes use of this when constructing SRTs. tidyTopIdInfo :: Bool -> IdInfo -> Unfolding - -> ArityInfo -> CafInfo + -> WorkerInfo -> ArityInfo -> CafInfo -> IdInfo -tidyTopIdInfo is_external idinfo unfold_info arity caf_info +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; @@ -800,19 +857,32 @@ tidyTopIdInfo is_external idinfo unfold_info arity caf_info `setAllStrictnessInfo` newStrictnessInfo idinfo `setInlinePragInfo` inlinePragInfo idinfo `setUnfoldingInfo` unfold_info + `setWorkerInfo` worker_info -- NB: we throw away the Rules -- They have already been extracted by findExternalRules ------------- Unfolding -------------- -tidyUnfolding :: TidyEnv -> CoreExpr -> Unfolding -> Unfolding -tidyUnfolding tidy_env _ unf@(InlineRule { uf_tmpl = rhs, uf_worker = mb_wkr }) - = unf { uf_tmpl = tidyExpr tidy_env rhs, - uf_worker = fmap (tidyVarOcc tidy_env) mb_wkr } -tidyUnfolding _ tidy_rhs (CoreUnfolding {}) - = mkTopUnfolding tidy_rhs -tidyUnfolding _ _ unf = unf +------------ Worker -------------- +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} %************************************************************************