| ApplyTo DupFlag
InExpr SimplEnv -- The argument, as yet unsimplified,
SimplCont -- and its environment
| ApplyTo DupFlag
InExpr SimplEnv -- The argument, as yet unsimplified,
SimplCont -- and its environment
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
ppr (Select dup bndr alts se cont) = (ptext SLIT("Select") <+> ppr dup <+> ppr bndr) $$
(nest 4 (ppr alts)) $$ ppr cont
ppr (CoerceIt ty cont) = (ptext SLIT("CoerceIt") <+> ppr ty) $$ ppr cont
contIsDupable (ApplyTo OkToDup _ _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable (ApplyTo OkToDup _ _ _) = True
contIsDupable (Select OkToDup _ _ _ _) = True
contIsDupable (CoerceIt _ cont) = contIsDupable cont
contIsDupable other = False
-------------------
discardableCont :: SimplCont -> Bool
discardableCont (Stop _ _ _) = False
discardableCont (CoerceIt _ cont) = discardableCont cont
contIsDupable other = False
-------------------
discardableCont :: SimplCont -> Bool
discardableCont (Stop _ _ _) = False
discardableCont (CoerceIt _ cont) = discardableCont cont
discardableCont other = True
discardCont :: SimplCont -- A continuation, expecting
discardableCont other = True
discardCont :: SimplCont -- A continuation, expecting
contResultType (ArgOf _ _ to_ty _) = to_ty
contResultType (ApplyTo _ _ _ cont) = contResultType cont
contResultType (CoerceIt _ cont) = contResultType cont
contResultType (ArgOf _ _ to_ty _) = to_ty
contResultType (ApplyTo _ _ _ cont) = contResultType cont
contResultType (CoerceIt _ cont) = contResultType cont
getContArgs :: SwitchChecker
-> OutId -> SimplCont
-> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
getContArgs :: SwitchChecker
-> OutId -> SimplCont
-> ([(InExpr, SimplEnv, Bool)], -- Arguments; the Bool is true for strict args
-- getContArgs id k = (args, k', inl)
-- args are the leading ApplyTo items in k
-- (i.e. outermost comes first)
-- getContArgs id k = (args, k', inl)
-- args are the leading ApplyTo items in k
-- (i.e. outermost comes first)
- go acc ss inl (ApplyTo _ arg@(Type _) se cont)
- = go ((arg,se,False) : acc) ss inl cont
+ go acc ss (ApplyTo _ arg@(Type _) se cont)
+ = go ((arg,se,False) : acc) ss cont
- 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
+ go acc (s:ss) (ApplyTo _ arg se cont)
+ = go ((arg,se,s) : acc) ss 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
-- We're run out of arguments, or else we've run out of demands
-- The latter only happens if the result is guaranteed bottom
-- 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.
-- 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)
+ go acc ss cont
+ | null ss && discardableCont cont = (reverse acc, discardCont cont)
+ | otherwise = (reverse acc, cont)
----------------------------
vanilla_stricts, computed_stricts :: [Bool]
----------------------------
vanilla_stricts, computed_stricts :: [Bool]
interesting (Select _ _ _ _ _) = some_args
interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
-- Perhaps True is a bit over-keen, but I've
interesting (Select _ _ _ _ _) = some_args
interesting (ApplyTo _ _ _ _) = True -- Can happen if we have (coerce t (f x)) y
-- Perhaps True is a bit over-keen, but I've
returnSmpl (emptyFloats env, mkLams bndrs body')
{- Sept 01: I'm experimenting with getting the
returnSmpl (emptyFloats env, mkLams bndrs body')
{- Sept 01: I'm experimenting with getting the