Commit 5952ef0d authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

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.
parent bddd4b23
......@@ -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
......
......@@ -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
%* *
%************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment