Be a bit less aggressive in mark-many inside a cast

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

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 20f26c2..96857a3 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -147,8 +147,8 @@ instance Outputable SimplCont where
                                          {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
   ppr (StrictBind b _ _ _ cont)      = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
   ppr (StrictArg ai _ cont)          = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont
                                          {-  $$ nest 2 (pprSimplEnv se) -}) $$ ppr cont
   ppr (StrictBind b _ _ _ cont)      = (ptext (sLit "StrictBind") <+> ppr b) $$ ppr cont
   ppr (StrictArg ai _ cont)          = (ptext (sLit "StrictArg") <+> ppr (ai_fun ai)) $$ ppr cont

-  ppr (Select dup bndr alts _ cont)  = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ 
-                                      (nest 4 (ppr alts)) $$ ppr cont 
+  ppr (Select dup bndr alts se cont) = (ptext (sLit "Select") <+> ppr dup <+> ppr bndr) $$ 
+                                      (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont 

   ppr (CoerceIt co cont)            = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
 
 data DupFlag = OkToDup | NoDup
   ppr (CoerceIt co cont)            = (ptext (sLit "CoerceIt") <+> ppr co) $$ ppr cont
 
 data DupFlag = OkToDup | NoDup

@@ -222,12 +222,21 @@ countArgs :: SimplCont -> Int
 countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont
 countArgs _                    = 0
 
 countArgs (ApplyTo _ _ _ cont) = 1 + countArgs cont
 countArgs _                    = 0
 

-contArgs :: SimplCont -> ([OutExpr], SimplCont)
+contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)

 -- Uses substitution to turn each arg into an OutExpr
 -- Uses substitution to turn each arg into an OutExpr

-contArgs cont = go [] cont
+contArgs cont@(ApplyTo {})
+  = case go [] cont of { (args, cont') -> (False, args, cont') }

   where
   where

-    go args (ApplyTo _ arg se cont) = go (substExpr se arg : args) cont
-    go args cont                   = (reverse args, cont)
+    go args (ApplyTo _ arg se cont)
+      | isTypeArg arg = go args                           cont
+      | otherwise     = go (is_interesting arg se : args) cont
+    go args cont      = (reverse args, cont)
+
+    is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg)
+                  -- Do *not* use short-cutting substitution here
+                  -- because we want to get as much IdInfo as possible
+
+contArgs cont = (True, [], cont)

 
 pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
 pushArgs _env []         cont = cont
 
 pushArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
 pushArgs _env []         cont = cont

@@ -466,9 +475,9 @@ On the other hand, it is bad not to do ANY inlining into an
 InlineRule, because then recursive knots in instance declarations
 don't get unravelled.
 
 InlineRule, because then recursive knots in instance declarations
 don't get unravelled.
 

-However, *sometimes* SimplGently must do no call-site inlining at all.
-Before full laziness we must be careful not to inline wrappers,
-because doing so inhibits floating
+However, *sometimes* SimplGently must do no call-site inlining at all
+(hence sm_inline = False).  Before full laziness we must be careful
+not to inline wrappers, because doing so inhibits floating

     e.g. ...(case f x of ...)...
     ==> ...(case (case x of I# x# -> fw x#) of ...)...
     ==> ...(case x of I# x# -> case fw x# of ...)...
     e.g. ...(case f x of ...)...
     ==> ...(case (case x of I# x# -> fw x#) of ...)...
     ==> ...(case x of I# x# -> case fw x# of ...)...

@@ -493,6 +502,9 @@ RULES are enabled when doing "gentle" simplification.  Two reasons:
     to work in Template Haskell when simplifying
     splices, so we get simpler code for literal strings
 
     to work in Template Haskell when simplifying
     splices, so we get simpler code for literal strings
 

+But watch out: list fusion can prevent floating.  So use phase control
+to switch off those rules until after floating.
+

 Note [Simplifying inside InlineRules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We must take care with simplification inside InlineRules (which come from
 Note [Simplifying inside InlineRules]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We must take care with simplification inside InlineRules (which come from

@@ -688,6 +700,27 @@ let-float if you inline windowToViewport
 However, as usual for Gentle mode, do not inline things that are
 inactive in the intial stages.  See Note [Gentle mode].
 
 However, as usual for Gentle mode, do not inline things that are
 inactive in the intial stages.  See Note [Gentle mode].
 

+Note [InlineRule and preInlineUnconditionally]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!
+Example
+
+   {-# INLINE f #-}
+   f :: Eq a => a -> a
+   f x = ...
+   
+   fInt :: Int -> Int
+   fInt = f Int dEqInt
+
+   ...fInt...fInt...fInt...
+
+Here f occurs just once, in the RHS of f1. But if we inline it there
+we'll lose the opportunity to inline at each of fInt's call sites.
+The INLINE pragma will only inline when the application is saturated
+for exactly this reason; and we don't want PreInlineUnconditionally
+to second-guess it.  A live example is Trac #3736.
+    c.f. Note [InlineRule and postInlineUnconditionally]
+

 Note [Top-level botomming Ids]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Don't inline top-level Ids that are bottoming, even if they are used just
 Note [Top-level botomming Ids]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Don't inline top-level Ids that are bottoming, even if they are used just

@@ -698,6 +731,7 @@ Inlining them won't make the program run faster!
 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
 preInlineUnconditionally env top_lvl bndr rhs
   | not active                                      = False
 preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool
 preInlineUnconditionally env top_lvl bndr rhs
   | not active                                      = False

+  | isStableUnfolding (idUnfolding bndr)     = False    -- Note [InlineRule and preInlineUnconditionally]

   | isTopLevel top_lvl && isBottomingId bndr = False   -- Note [Top-level bottoming Ids]
   | opt_SimplNoPreInlining                   = False
   | otherwise = case idOccInfo bndr of
   | isTopLevel top_lvl && isBottomingId bndr = False   -- Note [Top-level bottoming Ids]
   | opt_SimplNoPreInlining                   = False
   | otherwise = case idOccInfo bndr of

@@ -962,6 +996,8 @@ Then there's a danger we'll optimise to
 and now postInlineUnconditionally, losing the InlineRule on f.  Now f'
 won't inline because 'e' is too big.
 
 and now postInlineUnconditionally, losing the InlineRule on f.  Now f'
 won't inline because 'e' is too big.
 

+    c.f. Note [InlineRule and preInlineUnconditionally]
+

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -977,7 +1013,7 @@ mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplM OutExpr
 
 mkLam _b [] body 
   = return body
 
 mkLam _b [] body 
   = return body

-mkLam env bndrs body
+mkLam _env bndrs body

   = do { dflags <- getDOptsSmpl
        ; mkLam' dflags bndrs body }
   where
   = do { dflags <- getDOptsSmpl
        ; mkLam' dflags bndrs body }
   where

@@ -991,6 +1027,11 @@ mkLam env bndrs body
        co_vars  = tyVarsOfType co
        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars      
 
        co_vars  = tyVarsOfType co
        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars      
 

+    mkLam' dflags bndrs body@(Lam {})
+      = mkLam' dflags (bndrs ++ bndrs1) body1
+      where
+        (bndrs1, body1) = collectBinders body
+

     mkLam' dflags bndrs body
       | dopt Opt_DoEtaReduction dflags,
         Just etad_lam <- tryEtaReduce bndrs body
     mkLam' dflags bndrs body
       | dopt Opt_DoEtaReduction dflags,
         Just etad_lam <- tryEtaReduce bndrs body

@@ -998,9 +1039,7 @@ mkLam env bndrs body
           ; return etad_lam }
 
       | dopt Opt_DoLambdaEtaExpansion dflags,
           ; return etad_lam }
 
       | dopt Opt_DoLambdaEtaExpansion dflags,

-        not (inGentleMode env),              -- In gentle mode don't eta-expansion
-       any isRuntimeVar bndrs        -- because it can clutter up the code
-                                     -- with casts etc that may not be removed
+       not (all isTyVar bndrs) -- Don't eta expand type abstractions

       = do { let body' = tryEtaExpansion dflags body
           ; return (mkLams bndrs body') }
    
       = do { let body' = tryEtaExpansion dflags body
           ; return (mkLams bndrs body') }
    

@@ -1282,7 +1321,7 @@ abstractFloats :: [OutTyVar] -> SimplEnv -> OutExpr -> SimplM ([OutBind], OutExp
 abstractFloats main_tvs body_env body
   = ASSERT( notNull body_floats )
     do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats
 abstractFloats main_tvs body_env body
   = ASSERT( notNull body_floats )
     do { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats

-       ; return (float_binds, CoreSubst.substExpr subst body) }
+       ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }

   where
     main_tv_set = mkVarSet main_tvs
     body_floats = getFloats body_env
   where
     main_tv_set = mkVarSet main_tvs
     body_floats = getFloats body_env

@@ -1295,7 +1334,7 @@ abstractFloats main_tvs body_env body
                 subst'   = CoreSubst.extendIdSubst subst id poly_app
           ; return (subst', (NonRec poly_id poly_rhs)) }
       where
                 subst'   = CoreSubst.extendIdSubst subst id poly_app
           ; return (subst', (NonRec poly_id poly_rhs)) }
       where

-       rhs' = CoreSubst.substExpr subst rhs
+       rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs

        tvs_here | any isCoVar main_tvs = main_tvs      -- Note [Abstract over coercions]
                 | otherwise 
                 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')
        tvs_here | any isCoVar main_tvs = main_tvs      -- Note [Abstract over coercions]
                 | otherwise 
                 = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs')

@@ -1319,7 +1358,8 @@ abstractFloats main_tvs body_env body
     abstract subst (Rec prs)
        = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
            ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)
     abstract subst (Rec prs)
        = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly tvs_here) ids
            ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)

-                 poly_rhss = [mkLams tvs_here (CoreSubst.substExpr subst' rhs) | rhs <- rhss]
+                 poly_rhss = [mkLams tvs_here (CoreSubst.substExpr (text "abstract_floats3") subst' rhs) 
+                              | rhs <- rhss]

            ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
        where
         (ids,rhss) = unzip prs
            ; return (subst', Rec (poly_ids `zip` poly_rhss)) }
        where
         (ids,rhss) = unzip prs