import TcType
import DataCon
import TyCon
-import Class
import Module
import HscTypes
import Maybes
import ErrUtils
import UniqSupply
import Outputable
-import FastTypes hiding (fastOr)
+import FastBool hiding ( fastOr )
import Data.List ( partition )
import Data.Maybe ( isJust )
import Data.IORef ( IORef, readIORef, writeIORef )
-
-_dummy :: FS.FastString
-_dummy = FSLIT("")
\end{code}
, md_insts = insts'
, md_fam_insts = fam_insts
, md_rules = []
+ , md_anns = []
, md_exports = exports
, md_vect_info = noVectInfo
})
tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv
tidyBootTypeEnv exports type_env
- = tidyTypeEnv True exports type_env final_ids
+ = 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
-- (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
+ mkVanillaGlobal (idName id) (tidyTopType (idType id))
\end{code}
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
-IdEnv Bool
+ExtIdEnv = IdEnv Bool
Step 2: Tidy the program
\begin{code}
tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
-tidyProgram hsc_env
- (ModGuts { mg_module = mod, mg_exports = exports,
+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_vect_info = vect_info,
mg_dir_imps = dir_imps,
+ mg_anns = anns,
mg_deps = deps,
mg_foreign = foreign_stubs,
mg_hpc_info = hpc_info,
; 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 = []
; let { export_set = availsToNameSet exports
; final_ids = [ id | id <- bindersOfBinds tidy_binds,
isExternalName (idName id)]
- ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env
- final_ids
+ ; 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
-- and indeed it does, but if omit_prags is on, ext_rules is
-- empty
- ; 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 all_tidy_binds
+ ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
; dumpIfSet_core dflags Opt_D_dump_simpl
"Tidy Core Rules"
(pprRules tidy_rules)
- ; let dir_imp_mods = map fst (moduleEnvElts dir_imps)
+ ; let dir_imp_mods = moduleEnvKeys dir_imps
; return (CgGuts { cg_module = mod,
cg_tycons = alg_tycons,
- cg_binds = all_tidy_binds,
+ cg_binds = tidy_binds,
cg_dir_imps = dir_imp_mods,
cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps,
md_insts = tidy_insts,
md_fam_insts = fam_insts,
md_exports = exports,
- md_vect_info = vect_info -- is already tidy
+ md_anns = anns, -- are already tidy
+ md_vect_info = vect_info --
})
}
_other -> pprPanic "lookup_dfun" (ppr dfun_id)
--------------------------
-tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> 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
-- 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 final_ids
- = 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 (trimThing exports) type_env2
+ type_env3 | omit_prags = mapNameEnv (trimThing th exports) type_env2
| otherwise = type_env2
in
type_env3
isWiredInThing thing = isWiredInName (getName thing)
--------------------------
-trimThing :: NameSet -> TyThing -> TyThing
+trimThing :: Bool -> NameSet -> TyThing -> TyThing
-- Trim off inessentials, for boot files and no -O
-trimThing exports (ATyCon tc)
- | not (mustExposeTyCon exports tc)
- = ATyCon (makeTyConAbstract tc)
+trimThing th exports (ATyCon tc)
+ | not th && not (mustExposeTyCon exports tc)
+ = ATyCon (makeTyConAbstract tc) -- Note [Trimming and Template Haskell]
-trimThing _exports (AnId id)
+trimThing _th _exports (AnId id)
| not (isImplicitId id)
= AnId (id `setIdInfo` vanillaIdInfo)
-trimThing _exports other_thing
+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. -}
+
+
mustExposeTyCon :: NameSet -- Exports
-> TyCon -- The tycon
-> Bool -- Can its rep be hidden?
where
tidy ispec = setInstanceDFunId ispec $
tidy_dfun (instanceDFunId ispec)
-
-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 (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
\end{code}
%************************************************************************
\begin{code}
-findExternalIds :: Bool
- -> [CoreBind]
- -> IdEnv Bool -- In domain => external
- -- Range = True <=> show unfolding
+type ExtIdEnv = IdEnv Bool
+ -- In domain => Id is external
+ -- Range = True <=> show unfolding,
+ -- Always True for InlineRule
+
+findExternalIds :: Bool -> [CoreBind] -> ExtIdEnv
-- 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 = worker_ids `unionVarSet`
- unfold_ids `unionVarSet`
+ new_needed_ids = (mb_unfold_ids `orElse` emptyVarSet) `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
- -- 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
+ 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
\end{code}
tidyTopBinds :: HscEnv
-> Module
-> TypeEnv
- -> IdEnv Bool -- Domain = Ids that should be external
- -- True <=> their unfolding is external too
+ -> ExtIdEnv
-> [CoreBind]
-> IO (TidyEnv, [CoreBind])
tidyTopBind :: PackageId
-> Module
-> IORef NameCache -- For allocating new unique names
- -> IdEnv Bool -- Domain = Ids that should be external
- -- True <=> their unfolding is external too
+ -> ExtIdEnv
-> TidyEnv -> CoreBind
-> IO (TidyEnv, CoreBind)
-- 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'
+ -- Preserve the GlobalIdDetails of existing global-ids
+ details = case globalIdDetails bndr of
+ NotGlobalId -> VanillaGlobal
+ old_details -> old_details
ty' = tidyTopType (idType bndr)
rhs' = tidyExpr rhs_tidy_env rhs
idinfo = idInfo bndr
idinfo' = tidyTopIdInfo (isJust maybe_external)
- idinfo unfold_info worker_info
+ idinfo unfold_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 = mkTopUnfolding rhs'
+ unfold_info | show_unfold = tidyUnfolding rhs_tidy_env rhs' (unfoldingInfo idinfo)
| otherwise = noUnfolding
- worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo)
+ -- 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
-- 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
- -> WorkerInfo -> ArityInfo -> CafInfo
+ -> ArityInfo -> CafInfo
-> IdInfo
-tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info
+tidyTopIdInfo is_external idinfo unfold_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
------------- 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
+------------ 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
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff