import CoreTidy
import CoreMonad
import CoreUtils
+import Rules
import CoreArity ( exprArity, exprBotStrictness_maybe )
-import Class ( classSelIds )
+import Class ( classAllSelIds )
import VarEnv
import VarSet
import Var
import DataCon
import TyCon
import Module
+import Packages( isDllName )
import HscTypes
import Maybes
-import ErrUtils
import UniqSupply
import Outputable
import FastBool hiding ( fastOr )
import Util
+import FastString
+import Control.Monad ( when )
import Data.List ( sortBy )
import Data.IORef ( IORef, readIORef, writeIORef )
\end{code}
-> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
mkBootModDetails hsc_env exports type_env insts fam_insts
= do { let dflags = hsc_dflags hsc_env
- ; showPass dflags "Tidy [hoot] type env"
+ ; showPass dflags CoreTidy
; let { insts' = tidyInstances globaliseAndTidyId insts
; dfun_ids = map instanceDFunId insts'
mg_binds = binds,
mg_rules = imp_rules,
mg_vect_info = vect_info,
- mg_dir_imps = dir_imps,
- mg_anns = anns,
+ mg_anns = anns,
mg_deps = deps,
mg_foreign = foreign_stubs,
mg_hpc_info = hpc_info,
= do { let { dflags = hsc_dflags hsc_env
; omit_prags = dopt Opt_OmitInterfacePragmas dflags
; expose_all = dopt Opt_ExposeAllUnfoldings dflags
- ; th = dopt Opt_TemplateHaskell dflags
+ ; th = xopt Opt_TemplateHaskell dflags
}
- ; showPass dflags "Tidy Core"
+ ; showPass dflags CoreTidy
; let { implicit_binds = getImplicitBinds type_env }
; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
}
- ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds tidy_rules
- ; let dir_imp_mods = moduleEnvKeys dir_imps
-
- ; return (CgGuts { cg_module = mod,
- cg_tycons = alg_tycons,
- cg_binds = all_tidy_binds,
- cg_dir_imps = dir_imp_mods,
- cg_foreign = foreign_stubs,
+ ; endPass dflags CoreTidy all_tidy_binds tidy_rules
+
+ -- If the endPass didn't print the rules, but ddump-rules is on, print now
+ ; dumpIfSet (dopt Opt_D_dump_rules dflags
+ && (not (dopt Opt_D_dump_simpl dflags)))
+ CoreTidy
+ (ptext (sLit "rules"))
+ (pprRulesForUser tidy_rules)
+
+ -- Print one-line size info
+ ; let cs = coreBindsStats tidy_binds
+ ; when (dopt Opt_D_dump_core_stats dflags)
+ (printDump (ptext (sLit "Tidy size (terms,types,coercions)")
+ <+> ppr (moduleName mod) <> colon
+ <+> int (cs_tm cs)
+ <+> int (cs_ty cs)
+ <+> int (cs_co cs) ))
+
+ ; return (CgGuts { cg_module = mod,
+ cg_tycons = alg_tycons,
+ cg_binds = all_tidy_binds,
+ cg_foreign = foreign_stubs,
cg_dep_pkgs = dep_pkgs deps,
cg_hpc_info = hpc_info,
cg_modBreaks = modBreaks },
| isEnumerationTyCon tc -- For an enumeration, exposing the constructors
= True -- won't lead to the need for further exposure
-- (This includes data types with no constructors.)
- | isOpenTyCon tc -- Open type family
+ | isFamilyTyCon tc -- Open type family
= True
| otherwise -- Newtype, datatype
\begin{code}
tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
-tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
- , vectInfoPADFun = pas
- , vectInfoIso = isos })
- = info { vectInfoVar = tidy_vars
- , vectInfoPADFun = tidy_pas
- , vectInfoIso = tidy_isos }
+tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
+ , vectInfoPADFun = pas
+ , vectInfoIso = isos
+ , vectInfoScalarVars = scalarVars
+ })
+ = info { vectInfoVar = tidy_vars
+ , vectInfoPADFun = tidy_pas
+ , vectInfoIso = tidy_isos
+ , vectInfoScalarVars = tidy_scalarVars
+ }
where
tidy_vars = mkVarEnv
$ map tidy_var_mapping
tidy_var_mapping (from, to) = (from', (from', lookup_var to))
where from' = lookup_var from
tidy_snd_var (x, var) = (x, lookup_var var)
+
+ tidy_scalarVars = mkVarSet
+ $ map lookup_var
+ $ varSetElems scalarVars
lookup_var var = lookupWithDefaultVarEnv var_env var var
\end{code}
= 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 (AClass cls) = classAllSelIds cls
implicit_ids _ = []
get_defn :: Id -> CoreBind
mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold
mb_unfold_ids = case unfoldingInfo idinfo of
CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide }
- | show_unfolding src guide
- -> Just (exprFvsInOrder unf_rhs)
- DFunUnfolding _ ops -> Just (exprsFvsInOrder ops)
- _ -> Nothing
+ | show_unfolding src guide
+ -> Just (unf_ext_ids src unf_rhs)
+ DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops))
+ _ -> Nothing
+ where
+ unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v])
+ unf_ext_ids _ unf_rhs = exprFvsInOrder unf_rhs
+ -- For a wrapper, externalise the wrapper id rather than the
+ -- fvs of the rhs. The two usually come down to the same thing
+ -- but I've seen cases where we had a wrapper id $w but a
+ -- rhs where $w had been inlined; see Trac #3922
show_unfolding unf_source unf_guidance
= expose_all -- 'expose_all' says to expose all
-- unfoldings willy-nilly
- || isInlineRuleSource unf_source -- Always expose things whose
+ || isStableSource unf_source -- Always expose things whose
-- source is an inline rule
|| not (bottoming_fn -- No need to inline bottom functions
(occ_env', occ') = tidyOccName occ_env new_occ
- mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
+ mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)
where
- (us1, us2) = splitUniqSupply (nsUniqs nc)
- uniq = uniqFromSupply us1
+ (uniq, us) = takeUniqFromSupply (nsUniqs nc)
mk_new_external nc = allocateGlobalBinder nc mod occ' loc
-- If we want to externalise a currently-local name, check
--------- Unfolding ------------
unf_info = unfoldingInfo idinfo
- unfold_info | show_unfold = tidyUnfolding rhs_tidy_env tidy_rhs final_sig unf_info
+ unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
| otherwise = noUnfolding
+ unf_from_rhs = mkTopUnfolding is_bot tidy_rhs
+ is_bot = case final_sig of
+ Just sig -> isBottomingSig sig
+ Nothing -> False
-- 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
-- it to the top level. So it seems more robust just to
-- fix it here.
arity = exprArity orig_rhs
-
-
-
------------- Unfolding --------------
-tidyUnfolding :: TidyEnv -> CoreExpr -> Maybe StrictSig -> Unfolding -> Unfolding
-tidyUnfolding tidy_env _ _ (DFunUnfolding con ids)
- = DFunUnfolding con (map (tidyExpr tidy_env) ids)
-tidyUnfolding tidy_env tidy_rhs strict_sig
- unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })
- | isInlineRuleSource src
- = unf { uf_tmpl = tidyExpr tidy_env unf_rhs, -- Preserves OccInfo
- uf_src = tidyInl tidy_env src }
- | otherwise
- = mkTopUnfolding is_bot tidy_rhs
- where
- is_bot = case strict_sig of
- Just sig -> isBottomingSig sig
- Nothing -> False
-
-tidyUnfolding _ _ _ unf = unf
-
-tidyInl :: TidyEnv -> UnfoldingSource -> UnfoldingSource
-tidyInl tidy_env (InlineWrapper w) = InlineWrapper (tidyVarOcc tidy_env w)
-tidyInl _ inl_info = inl_info
\end{code}
%************************************************************************
\begin{code}
hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
hasCafRefs this_pkg p arity expr
- | is_caf || mentions_cafs
- = MayHaveCafRefs
+ | is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
- is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
+ is_dynamic_name = isDllName this_pkg
+ is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr)
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
cafRefs p (Note _n e) = cafRefs p e
cafRefs p (Cast e _co) = cafRefs p e
cafRefs _ (Type _) = fastBool False
+cafRefs _ (Coercion _) = fastBool False
cafRefss :: VarEnv Id -> [Expr a] -> FastBool
cafRefss _ [] = fastBool False
projects / ghc-hetmet.git / blobdiff