X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=b3f1a062273201154972ac63aee90a717e3ed5c7;hp=6a0a2cfcde848e9c8a0aa4e851a829e997a7d213;hb=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45;hpb=a90dc3907a491bfb478262441534b24fb0eb22f4 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 6a0a2cf..b3f1a06 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 @@ -480,12 +487,16 @@ tidyInstances tidy_dfun ispecs \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 @@ -497,6 +508,10 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars 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} @@ -560,7 +575,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 +726,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 +740,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 +868,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 +1079,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 +1107,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 +1133,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 +1164,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