X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=b4296cbb072c6f8c549c5462f9a76b47aea681a2;hp=6a0a2cfcde848e9c8a0aa4e851a829e997a7d213;hb=c0687066474aa4ce4912f31a5c09c1bcd673fb06;hpb=a90dc3907a491bfb478262441534b24fb0eb22f4 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 6a0a2cf..b4296cb 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -20,7 +20,7 @@ import CoreMonad import CoreUtils import Rules import CoreArity ( exprArity, exprBotStrictness_maybe ) -import Class ( classSelIds ) +import Class ( classAllSelIds ) import VarEnv import VarSet import Var @@ -37,6 +37,7 @@ import TcType import DataCon import TyCon import Module +import Packages( isDllName ) import HscTypes import Maybes import UniqSupply @@ -45,6 +46,7 @@ import FastBool hiding ( fastOr ) import Util import FastString +import Control.Monad ( when ) import Data.List ( sortBy ) import Data.IORef ( IORef, readIORef, writeIORef ) \end{code} @@ -290,8 +292,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, 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, @@ -300,7 +301,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, = 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 CoreTidy @@ -352,13 +353,19 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, (ptext (sLit "rules")) (pprRulesForUser 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, + -- 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 }, @@ -454,7 +461,7 @@ mustExposeTyCon exports tc | 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 @@ -560,7 +567,7 @@ 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 (AClass cls) = classAllSelIds cls implicit_ids _ = [] get_defn :: Id -> CoreBind @@ -711,7 +718,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold) CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } | show_unfolding src guide -> Just (unf_ext_ids src unf_rhs) - DFunUnfolding _ _ ops -> Just (exprsFvsInOrder ops) + DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops)) _ -> Nothing where unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v]) @@ -725,7 +732,7 @@ addExternal expose_all id = (new_needed_ids, show_unfold) = 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 @@ -853,10 +860,9 @@ tidyTopName mod nc_var maybe_ref occ_env id (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 @@ -1065,8 +1071,12 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info --------- 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 @@ -1089,30 +1099,6 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info -- 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 ar con ids) - = DFunUnfolding ar 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} %************************************************************************ @@ -1139,12 +1125,12 @@ CAF list to keep track of non-collectable CAFs. \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 @@ -1170,6 +1156,7 @@ cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts 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