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 (file)
--- 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 (file)
--- 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
 %*                                                                     *
 %************************************************************************