Completely new treatment of INLINE pragmas (big patch)

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

diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 84506d8..53c9149 100644 (file)
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -10,12 +10,12 @@ module SimplUtils (
 
        -- Inlining,
        preInlineUnconditionally, postInlineUnconditionally, 
 
        -- Inlining,
        preInlineUnconditionally, postInlineUnconditionally, 

-       activeInline, activeRule, inlineMode,
+       activeInline, activeRule, 

 
        -- The continuation type
        SimplCont(..), DupFlag(..), ArgInfo(..),
        contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 
 
        -- The continuation type
        SimplCont(..), DupFlag(..), ArgInfo(..),
        contIsDupable, contResultType, contIsTrivial, contArgs, dropArgs, 

-       countValArgs, countArgs, splitInlineCont,
+       countValArgs, countArgs, 

        mkBoringStop, mkLazyArgStop, contIsRhsOrArg,
        interestingCallContext, interestingArgContext,
 
        mkBoringStop, mkLazyArgStop, contIsRhsOrArg,
        interestingCallContext, interestingArgContext,
 

@@ -214,24 +214,6 @@ dropArgs :: Int -> SimplCont -> SimplCont
 dropArgs 0 cont = cont
 dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
 dropArgs n other               = pprPanic "dropArgs" (ppr n <+> ppr other)
 dropArgs 0 cont = cont
 dropArgs n (ApplyTo _ _ _ cont) = dropArgs (n-1) cont
 dropArgs n other               = pprPanic "dropArgs" (ppr n <+> ppr other)

-
---------------------
-splitInlineCont :: SimplCont -> Maybe (SimplCont, SimplCont)
--- Returns Nothing if the continuation should dissolve an InlineMe Note
--- Return Just (c1,c2) otherwise, 
---     where c1 is the continuation to put inside the InlineMe 
---     and   c2 outside
-
--- Example: (__inline_me__ (/\a. e)) ty
---     Here we want to do the beta-redex without dissolving the InlineMe
--- See test simpl017 (and Trac #1627) for a good example of why this is important
-
-splitInlineCont (ApplyTo dup (Type ty) se c)
-  | Just (c1, c2) <- splitInlineCont c = Just (ApplyTo dup (Type ty) se c1, c2)
-splitInlineCont cont@(Stop {})         = Just (mkBoringStop, cont)
-splitInlineCont cont@(StrictBind {})   = Just (mkBoringStop, cont)
-splitInlineCont cont@(StrictArg  {})   = Just (mkBoringStop, cont)
-splitInlineCont _                      = Nothing

 \end{code}
 
 
 \end{code}
 
 

@@ -308,17 +290,17 @@ interestingCallContext :: SimplCont -> CallCtxt
 interestingCallContext cont
   = interesting cont
   where
 interestingCallContext cont
   = interesting cont
   where

-    interestingCtxt = ArgCtxt False 2  -- Give *some* incentive!
-

     interesting (Select _ bndr _ _ _)
     interesting (Select _ bndr _ _ _)

-       | isDeadBinder bndr       = CaseCtxt
-       | otherwise               = interestingCtxt
+       | isDeadBinder bndr = CaseCtxt
+       | otherwise         = ArgCtxt False 2   -- If the binder is used, this
+                                               -- is like a strict let

                
                

-    interesting (ApplyTo {})      = interestingCtxt
-                               -- Can happen if we have (coerce t (f x)) y
-                               -- Perhaps interestingCtxt is a bit over-keen, but I've
-                               -- seen (coerce f) x, where f has an INLINE prag,
-                               -- So we have to give some motivation for inlining it
+    interesting (ApplyTo _ arg _ cont)
+       | isTypeArg arg = interesting cont
+       | otherwise     = ValAppCtxt    -- Can happen if we have (f Int |> co) y
+                                       -- If f has an INLINE prag we need to give it some
+                                       -- motivation to inline. See Note [Cast then apply]
+                                       -- in CoreUnfold

 
     interesting (StrictArg _ cci _ _)  = cci
     interesting (StrictBind {})                = BoringCtxt
 
     interesting (StrictArg _ cci _ _)  = cci
     interesting (StrictBind {})                = BoringCtxt

@@ -359,7 +341,7 @@ mkArgInfo fun n_val_args call_cont
     vanilla_discounts, arg_discounts :: [Int]
     vanilla_discounts = repeat 0
     arg_discounts = case idUnfolding fun of
     vanilla_discounts, arg_discounts :: [Int]
     vanilla_discounts = repeat 0
     arg_discounts = case idUnfolding fun of

-                       CoreUnfolding _ _ _ _ (UnfoldIfGoodArgs _ discounts _ _)
+                       CoreUnfolding {uf_guidance = UnfoldIfGoodArgs {ug_args = discounts}}

                              -> discounts ++ vanilla_discounts
                        _     -> vanilla_discounts
 
                              -> discounts ++ vanilla_discounts
                        _     -> vanilla_discounts
 

@@ -480,13 +462,7 @@ unboxed tuples and suchlike.
 
 INLINE pragmas
 ~~~~~~~~~~~~~~
 
 INLINE pragmas
 ~~~~~~~~~~~~~~

-SimplGently is also used as the mode to simplify inside an InlineMe note.
-
-\begin{code}
-inlineMode :: SimplifierMode
-inlineMode = SimplGently
-\end{code}
-
+We don't simplify inside InlineRules (which come from INLINE pragmas).

 It really is important to switch off inlinings inside such
 expressions.  Consider the following example 
 
 It really is important to switch off inlinings inside such
 expressions.  Consider the following example 
 

@@ -758,11 +734,11 @@ postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding
 --     in \y. ....case f of {...} ....
 -- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
 -- But
 --     in \y. ....case f of {...} ....
 -- Here f is used just once, and duplicating the case work is fine (exprIsCheap).
 -- But

--- * We can't preInlineUnconditionally because that woud invalidate
---   the occ info for b.  
--- * We can't postInlineUnconditionally because the RHS is big, and
---   that risks exponential behaviour
--- * We can't call-site inline, because the rhs is big
+--  - We can't preInlineUnconditionally because that woud invalidate
+--    the occ info for b.
+--  - We can't postInlineUnconditionally because the RHS is big, and
+--    that risks exponential behaviour
+--  - We can't call-site inline, because the rhs is big

 -- Alas!
 
   where
 -- Alas!
 
   where

@@ -797,7 +773,7 @@ activeInline env id
 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all
 activeRule dflags env
 activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool)
 -- Nothing => No rules at all
 activeRule dflags env

-  | not (dopt Opt_RewriteRules dflags)
+  | not (dopt Opt_EnableRewriteRules dflags)

   = Nothing    -- Rewriting is off
   | otherwise
   = case getMode env of
   = Nothing    -- Rewriting is off
   | otherwise
   = case getMode env of

@@ -934,10 +910,16 @@ There are some particularly delicate points here:
 
   So it's important to to the right thing.
 
 
   So it's important to to the right thing.
 

-* We need to be careful if we just look at f's arity. Currently (Dec07),
-  f's arity is visible in its own RHS (see Note [Arity robustness] in 
-  SimplEnv) so we must *not* trust the arity when checking that 'f' is
-  a value.  Instead, look at the unfolding. 
+* Note [Arity care]: we need to be careful if we just look at f's
+  arity. Currently (Dec07), f's arity is visible in its own RHS (see
+  Note [Arity robustness] in SimplEnv) so we must *not* trust the
+  arity when checking that 'f' is a value.  Otherwise we will
+  eta-reduce
+      f = \x. f x
+  to
+      f = f
+  Which might change a terminiating program (think (f `seq` e)) to a 
+  non-terminating one.  So we check for being a loop breaker first.

 
   However for GlobalIds we can look at the arity; and for primops we
   must, since they have no unfolding.  
 
   However for GlobalIds we can look at the arity; and for primops we
   must, since they have no unfolding.  

@@ -950,6 +932,11 @@ There are some particularly delicate points here:
   with both type and dictionary lambdas; hence the slightly 
   ad-hoc isDictId
 
   with both type and dictionary lambdas; hence the slightly 
   ad-hoc isDictId
 

+* Never *reduce* arity. For example
+      f = \xy. g x y
+  Then if h has arity 1 we don't want to eta-reduce because then
+  f's arity would decrease, and that is bad
+

 These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
 Alas.
 
 These delicacies are why we don't use exprIsTrivial and exprIsHNF here.
 Alas.
 

@@ -958,6 +945,8 @@ tryEtaReduce :: [OutBndr] -> OutExpr -> Maybe OutExpr
 tryEtaReduce bndrs body 
   = go (reverse bndrs) body
   where
 tryEtaReduce bndrs body 
   = go (reverse bndrs) body
   where

+    incoming_arity = count isId bndrs
+

     go (b : bs) (App fun arg) | ok_arg b arg = go bs fun       -- Loop round
     go []       fun           | ok_fun fun   = Just fun                -- Success!
     go _        _                           = Nothing          -- Failure!
     go (b : bs) (App fun arg) | ok_arg b arg = go bs fun       -- Loop round
     go []       fun           | ok_fun fun   = Just fun                -- Success!
     go _        _                           = Nothing          -- Failure!

@@ -971,11 +960,11 @@ tryEtaReduce bndrs body
        && (ok_fun_id fun_id || all ok_lam bndrs)
     ok_fun _fun = False
 
        && (ok_fun_id fun_id || all ok_lam bndrs)
     ok_fun _fun = False
 

-    ok_fun_id fun
-       | isLocalId fun       = isEvaldUnfolding (idUnfolding fun)
-       | isDataConWorkId fun = True
-       | isGlobalId fun      = idArity fun > 0
-        | otherwise           = panic "tryEtaReduce/ok_fun_id"
+    ok_fun_id fun = fun_arity fun >= incoming_arity
+
+    fun_arity fun            -- See Note [Arity care]
+       | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0
+       | otherwise = idArity fun             

 
     ok_lam v = isTyVar v || isDictId v
 
 
     ok_lam v = isTyVar v || isDictId v
 

@@ -1425,9 +1414,9 @@ prepareDefault _ _ case_bndr (Just (tycon, inst_tys)) imposs_cons (Just deflt_rh
 
        _ -> return [(DEFAULT, [], deflt_rhs)]
 
 
        _ -> return [(DEFAULT, [], deflt_rhs)]
 

-  | debugIsOn, isAlgTyCon tycon, [] <- tyConDataCons tycon
+  | debugIsOn, isAlgTyCon tycon, not (isOpenTyCon tycon), null (tyConDataCons tycon)
+       -- This can legitimately happen for type families, so don't report that

   = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)
   = pprTrace "prepareDefault" (ppr case_bndr <+> ppr tycon)

-       -- This can legitimately happen for type families

         $ return [(DEFAULT, [], deflt_rhs)]
 
 --------- Catch-all cases -----------
         $ return [(DEFAULT, [], deflt_rhs)]
 
 --------- Catch-all cases -----------