Allow RULES for seq, and exploit them

[ghc-hetmet.git] / compiler / simplCore / SimplCore.lhs

diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index 27ada80..bd1c920 100644 (file)
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -27,10 +27,7 @@ import Rules         ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase,
                          addSpecInfo, addIdSpecialisations )
 import PprCore         ( pprCoreBindings, pprCoreExpr, pprRules )
 import OccurAnal       ( occurAnalysePgm, occurAnalyseExpr )
                          addSpecInfo, addIdSpecialisations )
 import PprCore         ( pprCoreBindings, pprCoreExpr, pprRules )
 import OccurAnal       ( occurAnalysePgm, occurAnalyseExpr )

-import IdInfo          ( setNewStrictnessInfo, newStrictnessInfo, 
-                         setUnfoldingInfo, unfoldingInfo, setSpecInfoHead,
-                         setInlinePragInfo, inlinePragInfo,
-                         setSpecInfo, specInfo, specInfoRules )
+import IdInfo

 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )
 import SimplEnv                ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )
 import CoreUtils       ( coreBindsSize )
 import Simplify                ( simplTopBinds, simplExpr )
 import SimplEnv                ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet )

@@ -43,9 +40,9 @@ import FloatOut               ( floatOutwards )
 import FamInstEnv
 import Id
 import DataCon
 import FamInstEnv
 import Id
 import DataCon

-import TyCon           ( tyConSelIds, tyConDataCons )
+import TyCon           ( tyConDataCons )

 import Class           ( classSelIds )
 import Class           ( classSelIds )

-import BasicTypes       ( CompilerPhase, isActive )
+import BasicTypes       ( CompilerPhase, isActive, isDefaultInlinePragma )

 import VarSet
 import VarEnv
 import NameEnv         ( lookupNameEnv )
 import VarSet
 import VarEnv
 import NameEnv         ( lookupNameEnv )

@@ -100,22 +97,18 @@ core2core hsc_env guts = do
     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
     -- would mean our cached value would go out of date.
     let mod = mg_module guts
     -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which
     -- would mean our cached value would go out of date.
     let mod = mg_module guts

-    (guts, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do
+    (guts2, stats) <- runCoreM hsc_env ann_env imp_rule_base cp_us mod $ do

         -- FIND BUILT-IN PASSES
         let builtin_core_todos = getCoreToDo dflags
 
         -- FIND BUILT-IN PASSES
         let builtin_core_todos = getCoreToDo dflags
 

-        -- Note [Injecting implicit bindings]
-        let implicit_binds = getImplicitBinds (mg_types guts1)
-            guts2 = guts1 { mg_binds = implicit_binds ++ mg_binds guts1 }
-

         -- DO THE BUSINESS
         -- DO THE BUSINESS

-        doCorePasses builtin_core_todos guts2
+        doCorePasses builtin_core_todos guts1

 
     Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
         "Grand total simplifier statistics"
         (pprSimplCount stats)
 
 
     Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
         "Grand total simplifier statistics"
         (pprSimplCount stats)
 

-    return guts
+    return guts2

 
 
 type CorePass = CoreToDo
 
 
 type CorePass = CoreToDo

@@ -307,48 +300,6 @@ observe do_pass = doPassM $ \binds -> do
 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

-       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}
-
-
-%************************************************************************
-%*                                                                     *

        Dealing with rules
 %*                                                                     *
 %************************************************************************
        Dealing with rules
 %*                                                                     *
 %************************************************************************

@@ -368,34 +319,45 @@ prepareRules :: HscEnv
 
                    ModGuts)            -- Modified fields are 
                                        --      (a) Bindings have rules attached,
 
                    ModGuts)            -- Modified fields are 
                                        --      (a) Bindings have rules attached,

-                                       --              and INLINE rules simplified

                                        --      (b) Rules are now just orphan rules
 
 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
             guts@(ModGuts { mg_binds = binds, mg_deps = deps 
                           , mg_rules = local_rules, mg_rdr_env = rdr_env })
             us 
                                        --      (b) Rules are now just orphan rules
 
 prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
             guts@(ModGuts { mg_binds = binds, mg_deps = deps 
                           , mg_rules = local_rules, mg_rdr_env = rdr_env })
             us 

-  = do { us <- mkSplitUniqSupply 'w'
-
-       ; let   -- Simplify the local rules; boringly, we need to make an in-scope set
+  = do { let   -- Simplify the local rules; boringly, we need to make an in-scope set

                -- from the local binders, to avoid warnings from Simplify.simplVar
              local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
              env              = setInScopeSet gentleSimplEnv local_ids 
                -- from the local binders, to avoid warnings from Simplify.simplVar
              local_ids        = mkInScopeSet (mkVarSet (bindersOfBinds binds))
              env              = setInScopeSet gentleSimplEnv local_ids 

-             (simpl_rules, _) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
-                                mapM (simplRule env) local_rules
-
-       ; let (rules_for_locals, rules_for_imps) = partition isLocalRule simpl_rules
-
-             home_pkg_rules = hptRules hsc_env (dep_mods deps)
-             hpt_rule_base  = mkRuleBase home_pkg_rules
-             imp_rule_base  = extendRuleBaseList hpt_rule_base rules_for_imps
-
-             binds_w_rules = updateBinders rules_for_locals binds
-
+             (better_rules,_) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $
+                                (mapM (simplRule env) local_rules)
+             home_pkg_rules   = hptRules hsc_env (dep_mods deps)
+
+               -- Find the rules for locally-defined Ids; then we can attach them
+               -- to the binders in the top-level bindings
+               -- 
+               -- Reason
+               --      - It makes the rules easier to look up
+               --      - It means that transformation rules and specialisations for
+               --        locally defined Ids are handled uniformly
+               --      - It keeps alive things that are referred to only from a rule
+               --        (the occurrence analyser knows about rules attached to Ids)
+               --      - It makes sure that, when we apply a rule, the free vars
+               --        of the RHS are more likely to be in scope
+               --      - The imported rules are carried in the in-scope set
+               --        which is extended on each iteration by the new wave of
+               --        local binders; any rules which aren't on the binding will
+               --        thereby get dropped
+             (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules
+             local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals
+             binds_w_rules   = updateBinders local_rule_base binds
+
+             hpt_rule_base = mkRuleBase home_pkg_rules
+             imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps

 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
                (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $
 
        ; Err.dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules"
                (withPprStyle (mkUserStyle (mkPrintUnqualified dflags rdr_env) AllTheWay) $

-                vcat [text "Local rules", pprRules simpl_rules,
+                vcat [text "Local rules", pprRules better_rules,

                       text "",
                       text "Imported rules", pprRuleBase imp_rule_base])
 
                       text "",
                       text "Imported rules", pprRuleBase imp_rule_base])
 

@@ -403,41 +365,18 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt })
                                        mg_rules = rules_for_imps })
     }
 
                                        mg_rules = rules_for_imps })
     }
 

--- Note [Attach rules to local ids]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- Find the rules for locally-defined Ids; then we can attach them
--- to the binders in the top-level bindings
--- 
--- Reason
---     - It makes the rules easier to look up
---     - It means that transformation rules and specialisations for
---       locally defined Ids are handled uniformly
---     - It keeps alive things that are referred to only from a rule
---       (the occurrence analyser knows about rules attached to Ids)
---     - It makes sure that, when we apply a rule, the free vars
---       of the RHS are more likely to be in scope
---     - The imported rules are carried in the in-scope set
---       which is extended on each iteration by the new wave of
---       local binders; any rules which aren't on the binding will
---       thereby get dropped
-
-updateBinders :: [CoreRule] -> [CoreBind] -> [CoreBind]
-updateBinders rules_for_locals binds
-  = map update_bind binds
+updateBinders :: RuleBase -> [CoreBind] -> [CoreBind]
+updateBinders local_rules binds
+  = map update_bndrs binds

   where
   where

-    local_rules = extendRuleBaseList emptyRuleBase rules_for_locals
-
-    update_bind (NonRec b r) = NonRec (add_rules b) r
-    update_bind (Rec prs)    = Rec (mapFst add_rules prs)
-
-       -- See Note [Attach rules to local ids]
-       -- NB: the binder might have some existing rules,
-       -- arising from specialisation pragmas
-    add_rules bndr
-       | Just rules <- lookupNameEnv local_rules (idName bndr)
-       = bndr `addIdSpecialisations` rules
-       | otherwise
-       = bndr
+    update_bndrs (NonRec b r) = NonRec (update_bndr b) r
+    update_bndrs (Rec prs)    = Rec [(update_bndr b, r) | (b,r) <- prs]
+
+    update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of
+                         Nothing    -> bndr
+                         Just rules -> bndr `addIdSpecialisations` rules
+                               -- The binder might have some existing rules,
+                               -- arising from specialisation pragmas

 \end{code}
 
 Note [Simplifying the left-hand side of a RULE]
 \end{code}
 
 Note [Simplifying the left-hand side of a RULE]

@@ -454,9 +393,6 @@ we do not want to get
 otherwise we don't match when given an argument like
        augment (\a. h a a) (build h)
 
 otherwise we don't match when given an argument like
        augment (\a. h a a) (build h)
 

-The simplifier does indeed do eta reduction (it's in
-Simplify.completeLam) but only if -O is on.
-

 \begin{code}
 simplRule env rule@(BuiltinRule {})
   = return rule
 \begin{code}
 simplRule env rule@(BuiltinRule {})
   = return rule

@@ -465,6 +401,17 @@ simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })
        args' <- mapM (simplExprGently env) args
        rhs' <- simplExprGently env rhs
        return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })
        args' <- mapM (simplExprGently env) args
        rhs' <- simplExprGently env rhs
        return (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' })

+
+-- It's important that simplExprGently does eta reduction.
+-- For example, in a rule like:
+--     augment g (build h) 
+-- we do not want to get
+--     augment (\a. g a) (build h)
+-- otherwise we don't match when given an argument like
+--     (\a. h a a)
+--
+-- The simplifier does indeed do eta reduction (it's in
+-- Simplify.completeLam) but only if -O is on.

 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

@@ -689,22 +636,20 @@ save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and
 makes strictness information propagate better.  This used to happen in
 the final phase, but it's tidier to do it here.
 
 makes strictness information propagate better.  This used to happen in
 the final phase, but it's tidier to do it here.
 

+Note [Transferring IdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+We want to propagage any useful IdInfo on x_local to x_exported.
+

 STRICTNESS: if we have done strictness analysis, we want the strictness info on
 x_local to transfer to x_exported.  Hence the copyIdInfo call.
 
 RULES: we want to *add* any RULES for x_local to x_exported.
 
 STRICTNESS: if we have done strictness analysis, we want the strictness info on
 x_local to transfer to x_exported.  Hence the copyIdInfo call.
 
 RULES: we want to *add* any RULES for x_local to x_exported.
 

-Note [Rules and indirection-zapping]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Problem: what if x_exported has a RULE that mentions something in ...bindings...?
-Then the things mentioned can be out of scope!  Solution
- a) Make sure that in this pass the usage-info from x_exported is 
-       available for ...bindings...
- b) If there are any such RULES, rec-ify the entire top-level. 
-    It'll get sorted out next time round

 
 

-Messing up the rules
-~~~~~~~~~~~~~~~~~~~~
+Note [Messing up the exported Id's IdInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We must be careful about discarding the IdInfo on the old Id
+

 The example that went bad on me at one stage was this one:
        
     iterate :: (a -> a) -> a -> [a]
 The example that went bad on me at one stage was this one:
        
     iterate :: (a -> a) -> a -> [a]

@@ -738,13 +683,28 @@ And now we get an infinite loop in the rule system
                    -> iterateFB (:) f x
                    -> iterate f x
 
                    -> iterateFB (:) f x
                    -> iterate f x
 

-Tiresome old solution: 
-       don't do shorting out if f has rewrite rules (see shortableIdInfo)
-
-New solution (I think): 
+Old "solution": 

        use rule switching-off pragmas to get rid 
        of iterateList in the first place
 
        use rule switching-off pragmas to get rid 
        of iterateList in the first place
 

+But in principle the user *might* want rules that only apply to the Id
+he says.  And inline pragmas are similar
+   {-# NOINLINE f #-}
+   f = local
+   local = <stuff>
+Then we do not want to get rid of the NOINLINE.
+
+Hence hasShortableIdinfo.
+
+
+Note [Rules and indirection-zapping]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Problem: what if x_exported has a RULE that mentions something in ...bindings...?
+Then the things mentioned can be out of scope!  Solution
+ a) Make sure that in this pass the usage-info from x_exported is 
+       available for ...bindings...
+ b) If there are any such RULES, rec-ify the entire top-level. 
+    It'll get sorted out next time round

 
 Other remarks
 ~~~~~~~~~~~~~
 
 Other remarks
 ~~~~~~~~~~~~~

@@ -815,6 +775,7 @@ makeIndEnv binds
     add_pair (exported_id, rhs) env
        = env
                        
     add_pair (exported_id, rhs) env
        = env
                        

+-----------------

 shortMeOut ind_env exported_id local_id
 -- The if-then-else stuff is just so I can get a pprTrace to see
 -- how often I don't get shorting out becuase of IdInfo stuff
 shortMeOut ind_env exported_id local_id
 -- The if-then-else stuff is just so I can get a pprTrace to see
 -- how often I don't get shorting out becuase of IdInfo stuff

@@ -829,23 +790,27 @@ shortMeOut ind_env exported_id local_id
    
        not (local_id `elemVarEnv` ind_env)     -- Only if not already substituted for
     then
    
        not (local_id `elemVarEnv` ind_env)     -- Only if not already substituted for
     then

-       True
-
-{- No longer needed
-       if isEmptySpecInfo (specInfo (idInfo exported_id))      -- Only if no rules
-       then True       -- See note on "Messing up rules"
-       else 
-#ifdef DEBUG 
-          pprTrace "shortMeOut:" (ppr exported_id)
-#endif
-                                                False
--}
+       if hasShortableIdInfo exported_id
+       then True       -- See Note [Messing up the exported Id's IdInfo]
+       else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
+             False

     else
     else

-       False
+        False

 
 

+-----------------
+hasShortableIdInfo :: Id -> Bool
+-- True if there is no user-attached IdInfo on exported_id,
+-- so we can safely discard it
+-- See Note [Messing up the exported Id's IdInfo]
+hasShortableIdInfo id
+  =  isEmptySpecInfo (specInfo info)
+  && isDefaultInlinePragma (inlinePragInfo info)
+  where
+     info = idInfo id

 
 -----------------
 transferIdInfo :: Id -> Id -> Id
 
 -----------------
 transferIdInfo :: Id -> Id -> Id

+-- See Note [Transferring IdInfo]

 -- If we have
 --     lcl_id = e; exp_id = lcl_id
 -- and lcl_id has useful IdInfo, we don't want to discard it by going
 -- If we have
 --     lcl_id = e; exp_id = lcl_id
 -- and lcl_id has useful IdInfo, we don't want to discard it by going

@@ -857,7 +822,7 @@ transferIdInfo exported_id local_id
   where
     local_info = idInfo local_id
     transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info
   where
     local_info = idInfo local_id
     transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info

-                                `setUnfoldingInfo`     unfoldingInfo local_info
+                                `setWorkerInfo`        workerInfo local_info

                                 `setInlinePragInfo`    inlinePragInfo local_info
                                 `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
     new_info = setSpecInfoHead (idName exported_id) 
                                 `setInlinePragInfo`    inlinePragInfo local_info
                                 `setSpecInfo`          addSpecInfo (specInfo exp_info) new_info
     new_info = setSpecInfoHead (idName exported_id)