+
+%************************************************************************
+%* *
+\subsection{Attaching notes}
+%* *
+%************************************************************************
+
+mkNote removes redundant coercions, and SCCs where possible
+
+\begin{code}
+mkNote :: Note -> CoreExpr -> CoreExpr
+mkNote (Coerce to_ty from_ty) expr = mkCoerce to_ty from_ty expr
+mkNote (SCC cc) expr = mkSCC cc expr
+mkNote InlineMe expr = mkInlineMe expr
+mkNote note expr = Note note expr
+
+-- Slide InlineCall in around the function
+-- No longer necessary I think (SLPJ Apr 99)
+-- mkNote InlineCall (App f a) = App (mkNote InlineCall f) a
+-- mkNote InlineCall (Var v) = Note InlineCall (Var v)
+-- mkNote InlineCall expr = expr
+\end{code}
+
+Drop trivial InlineMe's. This is somewhat important, because if we have an unfolding
+that looks like (Note InlineMe (Var v)), the InlineMe doesn't go away because it may
+not be *applied* to anything.
+
+We don't use exprIsTrivial here, though, because we sometimes generate worker/wrapper
+bindings like
+ fw = ...
+ f = inline_me (coerce t fw)
+As usual, the inline_me prevents the worker from getting inlined back into the wrapper.
+We want the split, so that the coerces can cancel at the call site.
+
+However, we can get left with tiresome type applications. Notably, consider
+ f = /\ a -> let t = e in (t, w)
+Then lifting the let out of the big lambda gives
+ t' = /\a -> e
+ f = /\ a -> let t = inline_me (t' a) in (t, w)
+The inline_me is to stop the simplifier inlining t' right back
+into t's RHS. In the next phase we'll substitute for t (since
+its rhs is trivial) and *then* we could get rid of the inline_me.
+But it hardly seems worth it, so I don't bother.
+
+\begin{code}
+mkInlineMe (Var v) = Var v
+mkInlineMe e = Note InlineMe e
+\end{code}
+
+
+
+\begin{code}
+mkCoerce :: Type -> Type -> CoreExpr -> CoreExpr
+
+mkCoerce to_ty from_ty (Note (Coerce to_ty2 from_ty2) expr)
+ = ASSERT( from_ty == to_ty2 )
+ mkCoerce to_ty from_ty2 expr
+
+mkCoerce to_ty from_ty expr
+ | to_ty == from_ty = expr
+ | otherwise = ASSERT( from_ty == exprType expr )
+ Note (Coerce to_ty from_ty) expr
+\end{code}
+
+\begin{code}
+mkSCC :: CostCentre -> Expr b -> Expr b
+ -- Note: Nested SCC's *are* preserved for the benefit of
+ -- cost centre stack profiling (Durham)
+
+mkSCC cc (Lit lit) = Lit lit
+mkSCC cc (Lam x e) = Lam x (mkSCC cc e) -- Move _scc_ inside lambda
+mkSCC cc expr = Note (SCC cc) expr
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Other expression construction}
+%* *
+%************************************************************************
+
+\begin{code}
+bindNonRec :: Id -> CoreExpr -> CoreExpr -> CoreExpr
+-- (bindNonRec x r b) produces either
+-- let x = r in b
+-- or
+-- case r of x { _DEFAULT_ -> b }
+--
+-- depending on whether x is unlifted or not
+-- It's used by the desugarer to avoid building bindings
+-- that give Core Lint a heart attack. Actually the simplifier
+-- deals with them perfectly well.
+bindNonRec bndr rhs body
+ | isUnLiftedType (idType bndr) = Case rhs bndr [(DEFAULT,[],body)]
+ | otherwise = Let (NonRec bndr rhs) body
+\end{code}
+
+\begin{code}
+mkAltExpr :: AltCon -> [CoreBndr] -> [Type] -> CoreExpr
+ -- This guy constructs the value that the scrutinee must have
+ -- when you are in one particular branch of a case
+mkAltExpr (DataAlt con) args inst_tys
+ = mkConApp con (map Type inst_tys ++ map varToCoreExpr args)
+mkAltExpr (LitAlt lit) [] []
+ = Lit lit
+
+mkIfThenElse :: CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+mkIfThenElse guard then_expr else_expr
+ = Case guard (mkWildId boolTy)
+ [ (DataAlt trueDataCon, [], then_expr),
+ (DataAlt falseDataCon, [], else_expr) ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Taking expressions apart}
+%* *
+%************************************************************************
+
+
+\begin{code}
+findDefault :: [CoreAlt] -> ([CoreAlt], Maybe CoreExpr)
+findDefault [] = ([], Nothing)
+findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null alts && null args )
+ ([], Just rhs)
+findDefault (alt : alts) = case findDefault alts of
+ (alts', deflt) -> (alt : alts', deflt)
+
+findAlt :: AltCon -> [CoreAlt] -> CoreAlt
+findAlt con alts
+ = go alts
+ where
+ go [] = pprPanic "Missing alternative" (ppr con $$ vcat (map ppr alts))
+ go (alt : alts) | matches alt = alt
+ | otherwise = go alts
+
+ matches (DEFAULT, _, _) = True
+ matches (con1, _, _) = con == con1
+\end{code}
+
+