Remove the (very) old strictness analyser
[ghc-hetmet.git] / compiler / coreSyn / CoreUtils.lhs
index 56a84a5..9761db1 100644 (file)
@@ -26,7 +26,7 @@ module CoreUtils (
        -- * Properties of expressions
        exprType, coreAltType, coreAltsType,
        exprIsDupable, exprIsTrivial, exprIsCheap, exprIsExpandable,
-       exprIsHNF,exprOkForSpeculation, exprIsBig, 
+       exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike,
        rhsIsStatic,
 
        -- * Expression and bindings size
@@ -210,7 +210,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 +377,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 +423,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 +462,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
@@ -489,17 +507,20 @@ 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]
+                                           and [exprIsCheap' is_conlike 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
       | 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
   = go other_expr []
@@ -554,6 +575,12 @@ exprIsExpandable :: CoreExpr -> Bool
 exprIsExpandable = exprIsCheap' isConLikeId    -- See Note [CONLIKE pragma] in BasicTypes
 \end{code}
 
+%************************************************************************
+%*                                                                     *
+             exprOkForSpeculation
+%*                                                                     *
+%************************************************************************
+
 \begin{code}
 -- | 'exprOkForSpeculation' returns True of an expression that is:
 --
@@ -639,41 +666,27 @@ isDivOp DoubleDivOp      = True
 isDivOp _                = False
 \end{code}
 
-\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
--}
-\end{code}
+%************************************************************************
+%*                                                                     *
+             exprIsHNF, exprIsConLike
+%*                                                                     *
+%************************************************************************
 
 \begin{code}
-
--- | This returns true for expressions that are certainly /already/ 
+-- 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:
+--    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
@@ -682,7 +695,7 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 -- > (:) (f x) (map f xs)
 -- > map (...redex...)
 --
--- Because 'seq' on such things completes immediately.
+-- because 'seq' on such things completes immediately.
 --
 -- For unlifted argument types, we have to be careful:
 --
@@ -692,36 +705,62 @@ idAppIsBottom id n_val_args = appIsBottom (idNewStrictness id) n_val_args
 -- 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 (Var v)      -- NB: There are no value args at this point
-  =  isDataConWorkId v         -- Catches nullary constructors, 
+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.
+--
+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_con v      -- Catches nullary constructors, 
                        --      so that [] and () are values, for example
-  || idArity v > 0     -- Catches (e.g.) primops that don't have unfoldings
-  || isEvaldUnfolding (idUnfolding v)
+      || 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...
-
-exprIsHNF (Lit _)          = True
-exprIsHNF (Type _)         = True       -- Types are honorary Values;
-                                        -- we don't mind copying them
-exprIsHNF (Lam b e)        = isRuntimeVar b || exprIsHNF e
-exprIsHNF (Note _ e)       = exprIsHNF e
-exprIsHNF (Cast e _)       = exprIsHNF e
-exprIsHNF (App e (Type _)) = exprIsHNF e
-exprIsHNF (App e a)        = app_is_value e [a]
-exprIsHNF _                = False
-
--- There is at least one value argument
-app_is_value :: CoreExpr -> [CoreArg] -> Bool
-app_is_value (Var fun) args
-  = idArity fun > valArgCount args       -- Under-applied function
-    || isDataConWorkId fun               --  or data constructor
-app_is_value (Note _ f) as = app_is_value f as
-app_is_value (Cast f _) as = app_is_value f as
-app_is_value (App f a)  as = app_is_value f (a:as)
-app_is_value _          _  = False
+       -- 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;
+                                              -- we don't mind copying them
+    is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e
+    is_hnf_like (Note _ e)       = is_hnf_like e
+    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
+    app_is_value :: CoreExpr -> [CoreArg] -> Bool
+    app_is_value (Var fun) args
+      = idArity fun > valArgCount args   -- Under-applied function
+        || is_con fun                    --  or constructor-like
+    app_is_value (Note _ f) as = app_is_value f as
+    app_is_value (Cast f _) as = app_is_value f as
+    app_is_value (App f a)  as = app_is_value f (a:as)
+    app_is_value _          _  = False
 \end{code}
 
+
+%************************************************************************
+%*                                                                     *
+             Instantiating data constructors
+%*                                                                     *
+%************************************************************************
+
 These InstPat functions go here to avoid circularity between DataCon and Id
 
 \begin{code}