From: simonpj@microsoft.com Date: Tue, 5 Feb 2008 16:55:07 +0000 (+0000) Subject: Inject implicit bindings before the simplifier (Trac #2070) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=5952ef0dfd1a9eec38bd2756b37d040feb2b09d8 Inject implicit bindings before the simplifier (Trac #2070) With constructor unpacking, it's possible for constructors and record selectors to have non-trivial code, which should be optimised before being fed to the code generator. Example: data Foo = Foo { get :: {-# UNPACK #-} !Int } Then we do not want to get this: T2070.get = \ (tpl_B1 :: T2070.Foo) -> case tpl_B1 of tpl1_B2 { T2070.Foo rb_B4 -> let { ipv_B3 [Just S] :: GHC.Base.Int [Str: DmdType m] ipv_B3 = GHC.Base.I# rb_B4 } in ipv_B3 } If this goes through to codegen, we'll generate bad code. Admittedly, this only matters when the selector is used in a curried way (e.g map get xs), but nevertheless it's silly. This patch injects the implicit bindings in SimplCore, before the simplifier runs. That slows the simplifier a little, because it has to look at some extra bindings; but it's probably a slight effect. If it turns out to matter I suppose we can always inject them later, e.g. just before the final simplification. An unexpected (to me) consequence is that we get some specialisation rules for class-method selectors. E.g. we get a rule RULE (==) Int dInt = eqInt There's no harm in this, but not much benefit either, because the same result will happen when we inline (==) and dInt, but it's perhaps more direct. --- diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 2189f85..ca02122 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -20,7 +20,7 @@ import CoreLint import CoreUtils import VarEnv import VarSet -import Var +import Var hiding( mkGlobalId ) import Id import IdInfo import InstEnv @@ -34,7 +34,6 @@ import OccName import TcType import DataCon import TyCon -import Class import Module import HscTypes import Maybes @@ -306,12 +305,10 @@ tidyProgram hsc_env -- 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) @@ -320,7 +317,7 @@ tidyProgram hsc_env ; 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, @@ -425,31 +422,6 @@ tidyInstances tidy_dfun ispecs 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} @@ -744,12 +716,13 @@ tidyTopPair :: VarEnv Bool -- 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 diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs index bb9020d..a7671a4 100644 --- a/compiler/simplCore/SimplCore.lhs +++ b/compiler/simplCore/SimplCore.lhs @@ -19,9 +19,7 @@ import DynFlags ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..), DynFlags, DynFlag(..), dopt, getCoreToDo ) import CoreSyn -import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..), - Dependencies( dep_mods ), - hscEPS, hptRules ) +import HscTypes import CSE ( cseProgram ) import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, extendRuleBaseList, pprRuleBase, ruleCheckProgram, @@ -41,8 +39,10 @@ import CoreLint ( endPass, endIteration ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FamInstEnv -import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId, - idSpecialisation, idName ) +import Id +import DataCon +import TyCon ( tyConSelIds, tyConDataCons ) +import Class ( classSelIds ) import VarSet import VarEnv import NameEnv ( lookupNameEnv ) @@ -62,7 +62,7 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import IO ( hPutStr, stderr ) import Outputable import List ( partition ) -import Maybes ( orElse ) +import Maybes \end{code} %************************************************************************ @@ -77,26 +77,30 @@ core2core :: HscEnv -> IO ModGuts core2core hsc_env guts - = do - let dflags = hsc_dflags hsc_env - core_todos = getCoreToDo dflags + = do { + ; let dflags = hsc_dflags hsc_env + core_todos = getCoreToDo dflags - us <- mkSplitUniqSupply 's' - let (cp_us, ru_us) = splitUniqSupply us + ; us <- mkSplitUniqSupply 's' + ; let (cp_us, ru_us) = splitUniqSupply us -- COMPUTE THE RULE BASE TO USE - (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us + ; (imp_rule_base, guts1) <- prepareRules hsc_env guts ru_us + + -- Note [Injecting implicit bindings] + ; let implicit_binds = getImplicitBinds (mg_types guts1) + guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 } -- DO THE BUSINESS - (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us - (zeroSimplCount dflags) - guts' core_todos + ; (stats, guts3) <- doCorePasses hsc_env imp_rule_base cp_us + (zeroSimplCount dflags) + guts2 core_todos - dumpIfSet_dyn dflags Opt_D_dump_simpl_stats + ; dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" (pprSimplCount stats) - return guts'' + ; return guts3 } simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do @@ -212,10 +216,51 @@ observe do_pass hsc_env us rb guts \end{code} +%************************************************************************ +%* * + Implicit bindings +%* * +%************************************************************************ + +Note [Injecting implicit bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We used to inject the implict bindings right at the end, in CoreTidy. +But some of these bindings, notably record selectors, are not +constructed in an optimised form. E.g. record selector for + data T = MkT { x :: {-# UNPACK #-} !Int } +Then the unfolding looks like + x = \t. case t of MkT x1 -> let x = I# x1 in x +This generates bad code unless it's first simplified a bit. +(Only matters when the selector is used curried; eg map x ys.) +See Trac #2070. + +\begin{code} +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 (unfoldingTemplate (idUnfolding id)) +\end{code} + %************************************************************************ %* * -\subsection{Dealing with rules} + Dealing with rules %* * %************************************************************************