-exprIsCheap (Type _) = True
-exprIsCheap (Var _) = True
-exprIsCheap (Con con args) = conIsCheap con && all exprIsCheap args
-exprIsCheap (Note _ e) = exprIsCheap e
-exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e
-exprIsCheap (Let bind body) = all exprIsCheap (rhssOfBind bind) && exprIsCheap body
-exprIsCheap (Case scrut _ alts) = exprIsCheap scrut &&
- all (\(_,_,rhs) -> exprIsCheap rhs) alts
-
-exprIsCheap other_expr -- look for manifest partial application
- = case collectArgs other_expr of
-
- (Var f, args) | idAppIsBottom f (length args)
- -> True -- Application of a function which
- -- always gives bottom; we treat this as
- -- a WHNF, because it certainly doesn't
- -- need to be shared!
-
- (Var f, args) ->
- let
- num_val_args = valArgCount args
- in
- num_val_args == 0 || -- Just a type application of
- -- a variable (f t1 t2 t3)
- -- counts as WHNF
- num_val_args < arityLowerBound (getIdArity f)
-
- _ -> False
+exprIsCheap (Lit lit) = True
+exprIsCheap (Type _) = True
+exprIsCheap (Var _) = True
+exprIsCheap (Note InlineMe e) = True
+exprIsCheap (Note _ e) = exprIsCheap e
+exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e
+exprIsCheap (Case e _ alts) = exprIsCheap e &&
+ and [exprIsCheap 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 (Let (NonRec x _) e)
+ | isUnLiftedType (idType x) = exprIsCheap e
+ | otherwise = False
+ -- strict lets always have cheap right hand sides, and
+ -- do no allocation.
+
+exprIsCheap other_expr
+ = go other_expr 0 True
+ where
+ go (Var f) n_args args_cheap
+ = (idAppIsCheap f n_args && args_cheap)
+ -- A constructor, cheap primop, or partial application
+
+ || idAppIsBottom f n_args
+ -- Application of a function which
+ -- always gives bottom; we treat this as cheap
+ -- because it certainly doesn't need to be shared!
+
+ go (App f a) n_args args_cheap
+ | not (isRuntimeArg a) = go f n_args args_cheap
+ | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap)
+
+ go other n_args args_cheap = False
+
+idAppIsCheap :: Id -> Int -> Bool
+idAppIsCheap id n_val_args
+ | n_val_args == 0 = True -- Just a type application of
+ -- a variable (f t1 t2 t3)
+ -- counts as WHNF
+ | otherwise = case globalIdDetails id of
+ DataConId _ -> True
+ RecordSelId _ -> True -- I'm experimenting with making record selection
+ -- look cheap, so we will substitute it inside a
+ -- lambda. Particularly for dictionary field selection
+
+ PrimOpId op -> primOpIsCheap op -- 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
+ other -> n_val_args < idArity id
+\end{code}
+
+exprOkForSpeculation returns True of an expression that it is
+
+ * safe to evaluate even if normal order eval might not
+ evaluate the expression at all, or
+
+ * safe *not* to evaluate even if normal order would do so
+
+It returns True iff
+
+ the expression guarantees to terminate,
+ soon,
+ without raising an exception,
+ without causing a side effect (e.g. writing a mutable variable)
+
+E.G.
+ let x = case y# +# 1# of { r# -> I# r# }
+ in E
+==>
+ case y# +# 1# of { r# ->
+ let x = I# r#
+ in E
+ }
+
+We can only do this if the (y+1) is ok for speculation: it has no
+side effects, and can't diverge or raise an exception.
+
+\begin{code}
+exprOkForSpeculation :: CoreExpr -> Bool
+exprOkForSpeculation (Lit _) = True
+exprOkForSpeculation (Var v) = isUnLiftedType (idType v)
+exprOkForSpeculation (Note _ e) = exprOkForSpeculation e
+exprOkForSpeculation other_expr
+ = go other_expr 0 True
+ where
+ go (Var f) n_args args_ok
+ = case globalIdDetails f of
+ DataConId _ -> True -- The strictness of the constructor has already
+ -- been expressed by its "wrapper", so we don't need
+ -- to take the arguments into account
+
+ PrimOpId op -> primOpOkForSpeculation op && args_ok
+ -- A bit conservative: we don't really need
+ -- to care about lazy arguments, but this is easy
+
+ other -> False
+
+ go (App f a) n_args args_ok
+ | not (isRuntimeArg a) = go f n_args args_ok
+ | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok)
+
+ go other n_args args_ok = False