- ----------------------------
-
- -- 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
- -- Then, especially in the first of these cases, we'd like to discard
- -- the continuation, leaving just the bottoming expression. But the
- -- type might not be right, so we may have to add a coerce.
- go acc ss inl cont
- | null ss && discardableCont cont = (reverse acc, discardCont cont, inl)
- | otherwise = (reverse acc, cont, inl)
-
- ----------------------------
- vanilla_stricts, computed_stricts :: [Bool]
- vanilla_stricts = repeat False
- computed_stricts = zipWith (||) fun_stricts arg_stricts
-
- ----------------------------
- (val_arg_tys, _) = splitFunTys (dropForAlls (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 splitFunTys*IgnoringForAlls*
-
- ----------------------------
- -- 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 :: OutExpr -> 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 (Var v) = hasSomeUnfolding (idUnfolding v)
- -- Was: isValueUnfolding (idUnfolding v')
- -- But that seems over-pessimistic
- || isDataConWorkId v
- -- This accounts for an argument like
- -- () or [], which is definitely interesting
-interestingArg (Type _) = False
-interestingArg (App fn (Type _)) = interestingArg fn
-interestingArg (Note _ a) = interestingArg a
-interestingArg 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)
+ go args (ApplyTo _ arg se cont)
+ | isTypeArg arg = go args cont
+ | otherwise = go (is_interesting arg se : args) cont
+ go args cont = (reverse args, cont)
+
+ is_interesting arg se = interestingArg (substExpr (text "contArgs") se arg)
+ -- Do *not* use short-cutting substitution here
+ -- because we want to get as much IdInfo as possible
+
+contArgs cont = (True, [], cont)
+
+pushSimplifiedArgs :: SimplEnv -> [CoreExpr] -> SimplCont -> SimplCont
+pushSimplifiedArgs _env [] cont = cont
+pushSimplifiedArgs env (arg:args) cont = ApplyTo Simplified arg env (pushSimplifiedArgs env args cont)
+ -- The env has an empty SubstEnv
+
+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)