import VarSet
import Var
import Id
+import Class
import IdInfo
import InstEnv
import NewDemand
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
-- 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)
; 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,
%************************************************************************
+%* *
+ 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.
+
+
+\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
+ 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 = []
+
+ 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
-- "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
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}
tidyTopBinds :: HscEnv
-> Module
-> TypeEnv
- -> ExtIdEnv
+ -> IdEnv Bool -- Domain = Ids that should be external
+ -- True <=> their unfolding is external too
-> [CoreBind]
-> IO (TidyEnv, [CoreBind])
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)
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
-- 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.
-- 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;
`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}
%************************************************************************