+\begin{code}
+getContArgs :: OutId -> SimplCont
+ -> SimplM ([(InExpr, SubstEnv, Bool)], -- Arguments; the Bool is true for strict args
+ SimplCont, -- Remaining continuation
+ Bool) -- Whether we came across an InlineCall
+-- getContArgs id k = (args, k', inl)
+-- args are the leading ApplyTo items in k
+-- (i.e. outermost comes first)
+-- augmented with demand info from the functionn
+getContArgs fun orig_cont
+ = getSwitchChecker `thenSmpl` \ chkr ->
+ let
+ -- Ignore strictness info if the no-case-of-case
+ -- flag is on. Strictness changes evaluation order
+ -- and that can change full laziness
+ stricts | switchIsOn chkr NoCaseOfCase = vanilla_stricts
+ | otherwise = computed_stricts
+ in
+ go [] stricts False orig_cont
+ where
+ ----------------------------
+
+ -- Type argument
+ go acc ss inl (ApplyTo _ arg@(Type _) se cont)
+ = go ((arg,se,False) : acc) ss inl cont
+ -- NB: don't bother to instantiate the function type
+
+ -- Value argument
+ go acc (s:ss) inl (ApplyTo _ arg se cont)
+ = go ((arg,se,s) : acc) ss inl cont
+
+ -- An Inline continuation
+ go acc ss inl (InlinePlease cont)
+ = go acc ss True cont
+
+ -- We're run out of arguments, or else we've run out of demands
+ -- The latter only happens if the result is guaranteed bottom
+ -- This is the case for
+ -- * case (error "hello") of { ... }
+ -- * (error "Hello") arg
+ -- * f (error "Hello") where f is strict
+ -- etc
+ go acc ss inl cont
+ | null ss && discardableCont cont = tick BottomFound `thenSmpl_`
+ returnSmpl (reverse acc, discardCont cont, inl)
+ | otherwise = returnSmpl (reverse acc, cont, inl)
+
+ ----------------------------
+ vanilla_stricts, computed_stricts :: [Bool]
+ vanilla_stricts = repeat False
+ computed_stricts = zipWith (||) fun_stricts arg_stricts
+
+ ----------------------------
+ (val_arg_tys, _) = splitRepFunTys (idType fun)
+ arg_stricts = map isStrictType val_arg_tys ++ repeat False
+ -- These argument types are used as a cheap and cheerful way to find
+ -- unboxed arguments, which must be strict. But it's an InType
+ -- and so there might be a type variable where we expect a function
+ -- type (the substitution hasn't happened yet). And we don't bother
+ -- doing the type applications for a polymorphic function.
+ -- Hence the split*Rep*FunTys
+
+ ----------------------------
+ -- If fun_stricts is finite, it means the function returns bottom
+ -- after that number of value args have been consumed
+ -- Otherwise it's infinite, extended with False
+ fun_stricts
+ = case splitStrictSig (idNewStrictness fun) of
+ (demands, result_info)
+ | not (demands `lengthExceeds` countValArgs orig_cont)
+ -> -- Enough args, use the strictness given.
+ -- For bottoming functions we used to pretend that the arg
+ -- is lazy, so that we don't treat the arg as an
+ -- interesting context. This avoids substituting
+ -- top-level bindings for (say) strings into
+ -- calls to error. But now we are more careful about
+ -- inlining lone variables, so its ok (see SimplUtils.analyseCont)
+ if isBotRes result_info then
+ map isStrictDmd demands -- Finite => result is bottom
+ else
+ map isStrictDmd demands ++ vanilla_stricts
+
+ other -> vanilla_stricts -- Not enough args, or no strictness
+
+-------------------
+interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
+ -- An argument is interesting if it has *some* structure
+ -- We are here trying to avoid unfolding a function that
+ -- is applied only to variables that have no unfolding
+ -- (i.e. they are probably lambda bound): f x y z
+ -- There is little point in inlining f here.
+interestingArg in_scope arg subst
+ = analyse (substExpr (mkSubst in_scope subst) arg)
+ -- 'analyse' only looks at the top part of the result
+ -- and substExpr is lazy, so this isn't nearly as brutal
+ -- as it looks.
+ where
+ analyse (Var v) = hasSomeUnfolding (idUnfolding v)
+ -- Was: isValueUnfolding (idUnfolding v')
+ -- But that seems over-pessimistic
+ analyse (Type _) = False
+ analyse (App fn (Type _)) = analyse fn
+ analyse (Note _ a) = analyse a
+ analyse other = True
+ -- Consider let x = 3 in f x
+ -- The substitution will contain (x -> ContEx 3), and we want to
+ -- to say that x is an interesting argument.
+ -- But consider also (\x. f x y) y
+ -- The substitution will contain (x -> ContEx y), and we want to say
+ -- that x is not interesting (assuming y has no unfolding)
+\end{code}