More work on the simplifier's inlining strategies
[ghc-hetmet.git] / compiler / coreSyn / CoreUtils.lhs
index 50a0109..1590978 100644 (file)
@@ -27,7 +27,7 @@ module CoreUtils (
        exprType, coreAltType, coreAltsType,
        exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
        exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
-       rhsIsStatic,
+       rhsIsStatic, isCheapApp, isExpandableApp,
 
        -- * Expression and bindings size
        coreBindsSize, exprSize,
@@ -61,6 +61,7 @@ import DataCon
 import PrimOp
 import Id
 import IdInfo
+import TcType  ( isPredTy )
 import Type
 import Coercion
 import TyCon
@@ -210,7 +211,7 @@ mkCoerce co expr
 --    if to_ty `coreEqType` from_ty
 --    then expr
 --    else 
-        ASSERT2(from_ty `coreEqType` (exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ ppr (coercionKindPredTy co))
+        WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
          (Cast expr co)
 \end{code}
 
@@ -377,10 +378,12 @@ filters down the matching alternatives in Simplify.rebuildCase.
 
 %************************************************************************
 %*                                                                     *
-         Figuring out things about expressions
+             exprIsTrivial
 %*                                                                     *
 %************************************************************************
 
+Note [exprIsTrivial]
+~~~~~~~~~~~~~~~~~~~~
 @exprIsTrivial@ is true of expressions we are unconditionally happy to
                duplicate; simple variables and constants, and type
                applications.  Note that primop Ids aren't considered
@@ -421,6 +424,14 @@ exprIsTrivial _                = False
 \end{code}
 
 
+%************************************************************************
+%*                                                                     *
+             exprIsDupable
+%*                                                                     *
+%************************************************************************
+
+Note [exprIsDupable]
+~~~~~~~~~~~~~~~~~~~~
 @exprIsDupable@        is true of expressions that can be duplicated at a modest
                cost in code size.  This will only happen in different case
                branches, so there's no issue about duplicating work.
@@ -452,6 +463,14 @@ dupAppSize :: Int
 dupAppSize = 4         -- Size of application we are prepared to duplicate
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+             exprIsCheap, exprIsExpandable
+%*                                                                     *
+%************************************************************************
+
+Note [exprIsCheap]
+~~~~~~~~~~~~~~~~~~
 @exprIsCheap@ looks at a Core expression and returns \tr{True} if
 it is obviously in weak head normal form, or is cheap to get to WHNF.
 [Note that that's not the same as exprIsDupable; an expression might be
@@ -481,27 +500,37 @@ Notice that a variable is considered 'cheap': we can push it inside a lambda,
 because sharing will make sure it is only evaluated once.
 
 \begin{code}
-exprIsCheap' :: (Id -> Bool) -> CoreExpr -> Bool
-exprIsCheap' _          (Lit _)           = True
-exprIsCheap' _          (Type _)          = True
-exprIsCheap' _          (Var _)           = True
-exprIsCheap' is_conlike (Note _ e)        = exprIsCheap' is_conlike e
-exprIsCheap' is_conlike (Cast e _)        = exprIsCheap' is_conlike e
-exprIsCheap' is_conlike (Lam x e)         = isRuntimeVar x
-                                            || exprIsCheap' is_conlike e
-exprIsCheap' is_conlike (Case e _ _ alts) = exprIsCheap' is_conlike e && 
-                               and [exprIsCheap' is_conlike rhs | (_,_,rhs) <- alts]
+exprIsCheap :: CoreExpr -> Bool
+exprIsCheap = exprIsCheap' isCheapApp
+
+exprIsExpandable :: CoreExpr -> Bool
+exprIsExpandable = exprIsCheap' isExpandableApp        -- See Note [CONLIKE pragma] in BasicTypes
+
+
+exprIsCheap' :: (Id -> Int -> Bool) -> CoreExpr -> Bool
+exprIsCheap' _          (Lit _)   = True
+exprIsCheap' _          (Type _)  = True
+exprIsCheap' _          (Var _)   = True
+exprIsCheap' good_app (Note _ e)  = exprIsCheap' good_app e
+exprIsCheap' good_app (Cast e _)  = exprIsCheap' good_app e
+exprIsCheap' good_app (Lam x e)   = isRuntimeVar x
+                                 || exprIsCheap' good_app e
+
+exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && 
+                                         and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
        -- Experimentally, treat (case x of ...) as cheap
        -- (and case __coerce x etc.)
        -- This improves arities of overloaded functions where
        -- there is only dictionary selection (no construction) involved
-exprIsCheap' is_conlike (Let (NonRec x _) e)  
-      | isUnLiftedType (idType x) = exprIsCheap' is_conlike e
+
+exprIsCheap' good_app (Let (NonRec x _) e)  
+      | isUnLiftedType (idType x) = exprIsCheap' good_app e
       | otherwise                = False
-       -- strict lets always have cheap right hand sides,
-       -- and do no allocation.
+       -- Strict lets always have cheap right hand sides,
+       -- and do no allocation, so just look at the body
+       -- Non-strict lets do allocation so we don't treat them as cheap
 
-exprIsCheap' is_conlike other_expr     -- Applications and variables
+exprIsCheap' good_app other_expr       -- Applications and variables
   = go other_expr []
   where
        -- Accumulate value arguments, then decide
@@ -512,14 +541,12 @@ exprIsCheap' is_conlike other_expr        -- Applications and variables
                                -- (f t1 t2 t3) counts as WHNF
     go (Var f) args
        = case idDetails f of
-               RecSelId {}  -> go_sel args
-               ClassOpId {} -> go_sel args
-               PrimOpId op  -> go_primop op args
-
-               _ | is_conlike f -> go_pap args
-                  | length args < idArity f -> go_pap args
-
-               _ -> isBottomingId f
+               RecSelId {}                  -> go_sel args
+               ClassOpId {}                 -> go_sel args
+               PrimOpId op                  -> go_primop op args
+               _ | good_app f (length args) -> go_pap args
+                  | isBottomingId f         -> True
+                  | otherwise               -> False
                        -- Application of a function which
                        -- always gives bottom; we treat this as cheap
                        -- because it certainly doesn't need to be shared!
@@ -534,26 +561,59 @@ exprIsCheap' is_conlike other_expr        -- Applications and variables
        -- We'll put up with one constructor application, but not dozens
        
     --------------
-    go_primop op args = primOpIsCheap op && all (exprIsCheap' is_conlike) args
+    go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args
        -- In principle we should worry about primops
        -- that return a type variable, since the result
        -- might be applied to something, but I'm not going
        -- to bother to check the number of args
  
     --------------
-    go_sel [arg] = exprIsCheap' is_conlike arg -- I'm experimenting with making record selection
+    go_sel [arg] = exprIsCheap' good_app arg   -- I'm experimenting with making record selection
     go_sel _     = False               -- look cheap, so we will substitute it inside a
                                        -- lambda.  Particularly for dictionary field selection.
                -- BUT: Take care with (sel d x)!  The (sel d) might be cheap, but
                --      there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)
 
-exprIsCheap :: CoreExpr -> Bool
-exprIsCheap = exprIsCheap' isDataConWorkId
+isCheapApp :: Id -> Int -> Bool
+isCheapApp fn n_val_args
+  = isDataConWorkId fn 
+  || n_val_args < idArity fn
 
-exprIsExpandable :: CoreExpr -> Bool
-exprIsExpandable = exprIsCheap' isConLikeId    -- See Note [CONLIKE pragma] in BasicTypes
+isExpandableApp :: Id -> Int -> Bool
+isExpandableApp fn n_val_args
+  =  isConLikeId fn
+  || n_val_args < idArity fn
+  || go n_val_args (idType fn)
+  where
+  -- See if all the arguments are PredTys (implicit params or classes)
+  -- If so we'll regard it as expandable; see Note [Expandable overloadings]
+     go 0 _ = True
+     go n_val_args ty 
+       | Just (_, ty) <- splitForAllTy_maybe ty   = go n_val_args ty
+       | Just (arg, ty) <- splitFunTy_maybe ty
+       , isPredTy arg                             = go (n_val_args-1) ty
+       | otherwise                                = False
 \end{code}
 
+Note [Expandable overloadings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose the user wrote this
+   {-# RULE  forall x. foo (negate x) = h x #-}
+   f x = ....(foo (negate x))....
+He'd expect the rule to fire. But since negate is overloaded, we might
+get this:
+    f = \d -> let n = negate d in \x -> ...foo (n x)...
+So we treat the application of a function (negate in this case) to a
+*dictionary* as expandable.  In effect, every function is CONLIKE when
+it's applied only to dictionaries.
+
+
+%************************************************************************
+%*                                                                     *
+             exprOkForSpeculation
+%*                                                                     *
+%************************************************************************
+
 \begin{code}
 -- | 'exprOkForSpeculation' returns True of an expression that is:
 --
@@ -639,29 +699,55 @@ isDivOp DoubleDivOp      = True
 isDivOp _                = False
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+             exprIsHNF, exprIsConLike
+%*                                                                     *
+%************************************************************************
+
 \begin{code}
-{-     Never used -- omitting
--- | True of expressions that are guaranteed to diverge upon execution
-exprIsBottom :: CoreExpr -> Bool       -- True => definitely bottom
-exprIsBottom e = go 0 e
-               where
-                -- n is the number of args
-                 go n (Note _ e)     = go n e
-                 go n (Cast e _)     = go n e
-                 go n (Let _ e)      = go n e
-                 go _ (Case e _ _ _) = go 0 e   -- Just check the scrut
-                 go n (App e _)      = go (n+1) e
-                 go n (Var v)        = idAppIsBottom v n
-                 go _ (Lit _)        = False
-                 go _ (Lam _ _)      = False
-                 go _ (Type _)       = False
-
-idAppIsBottom :: Id -> Int -> Bool
-idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
--}
+-- Note [exprIsHNF]
+-- ~~~~~~~~~~~~~~~~
+-- | exprIsHNF returns true for expressions that are certainly /already/ 
+-- evaluated to /head/ normal form.  This is used to decide whether it's ok 
+-- to change:
+--
+-- > case x of _ -> e
+--
+--    into:
+--
+-- > e
+--
+-- and to decide whether it's safe to discard a 'seq'.
+-- 
+-- So, it does /not/ treat variables as evaluated, unless they say they are.
+-- However, it /does/ treat partial applications and constructor applications
+-- as values, even if their arguments are non-trivial, provided the argument
+-- type is lifted. For example, both of these are values:
+--
+-- > (:) (f x) (map f xs)
+-- > map (...redex...)
+--
+-- because 'seq' on such things completes immediately.
+--
+-- For unlifted argument types, we have to be careful:
+--
+-- > C (f x :: Int#)
+--
+-- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't 
+-- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
+-- unboxed type must be ok-for-speculation (or trivial).
+exprIsHNF :: CoreExpr -> Bool          -- True => Value-lambda, constructor, PAP
+exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
 \end{code}
 
 \begin{code}
+-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
+-- data constructors. Conlike arguments are considered interesting by the
+-- inliner.
+exprIsConLike :: CoreExpr -> Bool      -- True => lambda, conlike, PAP
+exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
+
 -- | Returns true for values or value-like expressions. These are lambdas,
 -- constructors / CONLIKE functions (as determined by the function argument)
 -- or PAPs.
@@ -669,15 +755,15 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 exprIsHNFlike :: (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool
 exprIsHNFlike is_con is_con_unf = is_hnf_like
   where
-    is_hnf_like (Var v) 
-                        -- NB: There are no value args at this point
+    is_hnf_like (Var v) -- NB: There are no value args at this point
       =  is_con v      -- Catches nullary constructors, 
                        --      so that [] and () are values, for example
       || idArity v > 0         -- Catches (e.g.) primops that don't have unfoldings
       || is_con_unf (idUnfolding v)
        -- Check the thing's unfolding; it might be bound to a value
-       -- A worry: what if an Id's unfolding is just itself: 
-       -- then we could get an infinite loop...
+       -- We don't look through loop breakers here, which is a bit conservative
+       -- but otherwise I worry that if an Id's unfolding is just itself, 
+       -- we could get an infinite loop
 
     is_hnf_like (Lit _)          = True
     is_hnf_like (Type _)         = True       -- Types are honorary Values;
@@ -687,6 +773,7 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
     is_hnf_like (Cast e _)       = is_hnf_like e
     is_hnf_like (App e (Type _)) = is_hnf_like e
     is_hnf_like (App e a)        = app_is_value e [a]
+    is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us
     is_hnf_like _                = False
 
     -- There is at least one value argument
@@ -700,47 +787,12 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
     app_is_value _          _  = False
 \end{code}
 
-\begin{code}
-
--- | This returns true for expressions that are certainly /already/ 
--- evaluated to /head/ normal form.  This is used to decide whether it's ok 
--- to change:
---
--- > case x of _ -> e
---
--- into:
---
--- > e
---
--- and to decide whether it's safe to discard a 'seq'.
--- So, it does /not/ treat variables as evaluated, unless they say they are.
--- However, it /does/ treat partial applications and constructor applications
--- as values, even if their arguments are non-trivial, provided the argument
--- type is lifted. For example, both of these are values:
---
--- > (:) (f x) (map f xs)
--- > map (...redex...)
---
--- Because 'seq' on such things completes immediately.
---
--- For unlifted argument types, we have to be careful:
---
--- > C (f x :: Int#)
---
--- Suppose @f x@ diverges; then @C (f x)@ is not a value. However this can't 
--- happen: see "CoreSyn#let_app_invariant". This invariant states that arguments of
--- unboxed type must be ok-for-speculation (or trivial).
-exprIsHNF :: CoreExpr -> Bool          -- True => Value-lambda, constructor, PAP
-exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding
-\end{code}
 
-\begin{code}
--- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as
--- data constructors. Conlike arguments are considered interesting by the
--- inliner.
-exprIsConLike :: CoreExpr -> Bool      -- True => lambda, conlike, PAP
-exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding
-\end{code}
+%************************************************************************
+%*                                                                     *
+             Instantiating data constructors
+%*                                                                     *
+%************************************************************************
 
 These InstPat functions go here to avoid circularity between DataCon and Id