+%************************************************************************
+%* *
+\subsection{The continuation data type}
+%* *
+%************************************************************************
+
+\begin{code}
+data SimplCont -- Strict contexts
+ = Stop OutType -- Type of the result
+ LetRhsFlag
+ Bool -- True <=> This is the RHS of a thunk whose type suggests
+ -- that update-in-place would be possible
+ -- (This makes the inliner a little keener.)
+
+ | CoerceIt OutType -- The To-type, simplified
+ SimplCont
+
+ | InlinePlease -- This continuation makes a function very
+ SimplCont -- keen to inline itelf
+
+ | ApplyTo DupFlag
+ InExpr SimplEnv -- The argument, as yet unsimplified,
+ SimplCont -- and its environment
+
+ | Select DupFlag
+ InId [InAlt] SimplEnv -- The case binder, alts, and subst-env
+ SimplCont
+
+ | ArgOf LetRhsFlag -- An arbitrary strict context: the argument
+ -- of a strict function, or a primitive-arg fn
+ -- or a PrimOp
+ -- No DupFlag because we never duplicate it
+ OutType -- arg_ty: type of the argument itself
+ OutType -- cont_ty: the type of the expression being sought by the context
+ -- f (error "foo") ==> coerce t (error "foo")
+ -- when f is strict
+ -- We need to know the type t, to which to coerce.
+
+ (SimplEnv -> OutExpr -> SimplM FloatsWithExpr) -- What to do with the result
+ -- The result expression in the OutExprStuff has type cont_ty
+
+data LetRhsFlag = AnArg -- It's just an argument not a let RHS
+ | AnRhs -- It's the RHS of a let (so please float lets out of big lambdas)
+
+instance Outputable LetRhsFlag where
+ ppr AnArg = ptext SLIT("arg")
+ ppr AnRhs = ptext SLIT("rhs")
+
+instance Outputable SimplCont where
+ ppr (Stop _ is_rhs _) = ptext SLIT("Stop") <> brackets (ppr is_rhs)
+ ppr (ApplyTo dup arg se cont) = (ptext SLIT("ApplyTo") <+> ppr dup <+> ppr arg) $$ ppr cont
+ ppr (ArgOf _ _ _ _) = ptext SLIT("ArgOf...")
+ 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 (InlinePlease cont) = ptext SLIT("InlinePlease") $$ ppr cont
+
+data DupFlag = OkToDup | NoDup
+
+instance Outputable DupFlag where
+ ppr OkToDup = ptext SLIT("ok")
+ ppr NoDup = ptext SLIT("nodup")
+
+
+-------------------
+mkBoringStop :: OutType -> SimplCont
+mkBoringStop ty = Stop ty AnArg (canUpdateInPlace ty)
+
+mkStop :: OutType -> LetRhsFlag -> SimplCont
+mkStop ty is_rhs = Stop ty is_rhs (canUpdateInPlace ty)
+
+contIsRhs :: SimplCont -> Bool
+contIsRhs (Stop _ AnRhs _) = True
+contIsRhs (ArgOf AnRhs _ _ _) = True
+contIsRhs other = False
+
+contIsRhsOrArg (Stop _ _ _) = True
+contIsRhsOrArg (ArgOf _ _ _ _) = True
+contIsRhsOrArg other = False
+
+-------------------
+contIsDupable :: SimplCont -> Bool
+contIsDupable (Stop _ _ _) = True
+contIsDupable (ApplyTo OkToDup _ _ _) = True
+contIsDupable (Select OkToDup _ _ _ _) = True
+contIsDupable (CoerceIt _ cont) = contIsDupable cont
+contIsDupable (InlinePlease cont) = contIsDupable cont
+contIsDupable other = False
+
+-------------------
+discardableCont :: SimplCont -> Bool
+discardableCont (Stop _ _ _) = False
+discardableCont (CoerceIt _ cont) = discardableCont cont
+discardableCont (InlinePlease cont) = discardableCont cont
+discardableCont other = True
+
+discardCont :: SimplCont -- A continuation, expecting
+ -> SimplCont -- Replace the continuation with a suitable coerce
+discardCont cont = case cont of
+ Stop to_ty is_rhs _ -> cont
+ other -> CoerceIt to_ty (mkBoringStop to_ty)
+ where
+ to_ty = contResultType cont
+
+-------------------
+contResultType :: SimplCont -> OutType
+contResultType (Stop to_ty _ _) = to_ty
+contResultType (ArgOf _ _ to_ty _) = to_ty
+contResultType (ApplyTo _ _ _ cont) = contResultType cont
+contResultType (CoerceIt _ cont) = contResultType cont
+contResultType (InlinePlease cont) = contResultType cont
+contResultType (Select _ _ _ _ cont) = contResultType cont
+
+-------------------
+countValArgs :: SimplCont -> Int
+countValArgs (ApplyTo _ (Type ty) se cont) = countValArgs cont
+countValArgs (ApplyTo _ val_arg se cont) = 1 + countValArgs cont
+countValArgs other = 0
+
+countArgs :: SimplCont -> Int
+countArgs (ApplyTo _ arg se cont) = 1 + countArgs cont
+countArgs other = 0
+
+-------------------
+pushContArgs :: SimplEnv -> [OutArg] -> SimplCont -> SimplCont
+-- Pushes args with the specified environment
+pushContArgs env [] cont = cont
+pushContArgs env (arg : args) cont = ApplyTo NoDup arg env (pushContArgs env args cont)
+\end{code}
+