X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=b78c0dbef21d09ec49968a6f2eca9008c3b3734c;hb=3deca8f44135bd1a146902f498189af00dd4d7b4;hp=0245978491c1c1f58e4b35ef8886ff9846fef35f;hpb=bc115352a6211fa8814eb1b584fe5284bf57ca00;p=ghc-hetmet.git diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 0245978..b78c0db 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} @@ -300,7 +302,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,6 +354,15 @@ tidyProgram hsc_env (ModGuts { mg_module = mod, mg_exports = exports, (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) )) + ; let dir_imp_mods = moduleEnvKeys dir_imps ; return (CgGuts { cg_module = mod, @@ -454,7 +465,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 +571,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 @@ -709,10 +720,10 @@ addExternal expose_all id = (new_needed_ids, show_unfold) 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 (unf_ext_ids src 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 @@ -725,7 +736,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 +864,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 +1075,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 +1103,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 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} %************************************************************************ @@ -1139,12 +1129,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