-Expressions
-~~~~~~~~~~~
-\begin{code}
-tidyCoreExpr (Var v) = lookupId v `thenTM` \ v' ->
- returnTM (Var v')
-
-tidyCoreExpr (Lit lit)
- = litToRep lit `thenTM` \ (_, lit_expr) ->
- returnTM lit_expr
-
-tidyCoreExpr (App fun arg)
- = tidyCoreExpr fun `thenTM` \ fun' ->
- tidyCoreArg arg `thenTM` \ arg' ->
- returnTM (App fun' arg')
-
-tidyCoreExpr (Con con args)
- = mapTM tidyCoreArg args `thenTM` \ args' ->
- returnTM (Con con args')
-
-tidyCoreExpr (Prim prim args)
- = tidyPrimOp prim `thenTM` \ prim' ->
- mapTM tidyCoreArg args `thenTM` \ args' ->
- returnTM (Prim prim' args')
-
-tidyCoreExpr (Lam (ValBinder v) body)
- = newId v $ \ v' ->
- tidyCoreExpr body `thenTM` \ body' ->
- returnTM (Lam (ValBinder v') body')
-
-tidyCoreExpr (Lam (TyBinder tv) body)
- = newTyVar tv $ \ tv' ->
- tidyCoreExpr body `thenTM` \ body' ->
- returnTM (Lam (TyBinder tv') body')
-
- -- Try for let-to-case (see notes in Simplify.lhs for why
- -- some let-to-case stuff is deferred to now).
-tidyCoreExpr (Let (NonRec bndr rhs) body)
- | willBeDemanded (getIdDemandInfo bndr) &&
- not rhs_is_whnf && -- Don't do it if RHS is already in WHNF
- typeOkForCase (idType bndr)
- = ASSERT( not (isUnpointedType (idType bndr)) )
- tidyCoreExpr (Case rhs (AlgAlts [] (BindDefault bndr body)))
- where
- rhs_is_whnf = case mkFormSummary rhs of
- VarForm -> True
- ValueForm -> True
- other -> False
-
-tidyCoreExpr (Let (NonRec bndr rhs) body)
- = tidyCoreExpr rhs `thenTM` \ rhs' ->
- newId bndr $ \ bndr' ->
- tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (Let (NonRec bndr' rhs') body')
-
-tidyCoreExpr (Let (Rec pairs) body)
- = newIds bndrs $ \ bndrs' ->
- mapTM tidyCoreExpr rhss `thenTM` \ rhss' ->
- tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (Let (Rec (bndrs' `zip` rhss')) body')
- where
- (bndrs, rhss) = unzip pairs
-
-tidyCoreExpr (SCC cc body)
- = tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (SCC cc body')
-
-tidyCoreExpr (Coerce coercion ty body)
- = tidyCoreExprEta body `thenTM` \ body' ->
- tidyTy ty `thenTM` \ ty' ->
- returnTM (Coerce coercion ty' body')
-
--- Wierd case for par, seq, fork etc. See notes above.
-tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
- | funnyParallelOp op
- = tidyCoreExpr scrut `thenTM` \ scrut' ->
- newId binder $ \ binder' ->
- tidyCoreExprEta rhs `thenTM` \ rhs' ->
- returnTM (Case scrut' (PrimAlts [] (BindDefault binder' rhs')))
-
--- Eliminate polymorphic case, for which we can't generate code just yet
-tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
- | not (typeOkForCase (idType deflt_bndr))
- = pprTrace "Warning: discarding polymorphic case:" (ppr scrut) $
- case scrut of
- Var v -> lookupId v `thenTM` \ v' ->
- extendEnvTM deflt_bndr v' (tidyCoreExpr rhs)
- other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
-
-tidyCoreExpr (Case scrut alts)
- = tidyCoreExpr scrut `thenTM` \ scrut' ->
- tidy_alts scrut' alts `thenTM` \ alts' ->
- returnTM (Case scrut' alts')
- where
- tidy_alts scrut (AlgAlts alts deflt)
- = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
- tidy_deflt scrut deflt `thenTM` \ deflt' ->
- returnTM (AlgAlts alts' deflt')
-
- tidy_alts scrut (PrimAlts alts deflt)
- = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
- tidy_deflt scrut deflt `thenTM` \ deflt' ->
- returnTM (PrimAlts alts' deflt')
-
- tidy_alg_alt (con,bndrs,rhs) = newIds bndrs $ \ bndrs' ->
- tidyCoreExprEta rhs `thenTM` \ rhs' ->
- returnTM (con, bndrs', rhs')
-
- tidy_prim_alt (lit,rhs) = tidyCoreExprEta rhs `thenTM` \ rhs' ->
- returnTM (lit,rhs')
-
- -- We convert case x of {...; x' -> ...x'...}
- -- to
- -- case x of {...; _ -> ...x... }
- --
- -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
- -- It's quite easily done: simply extend the environment to bind the
- -- default binder to the scrutinee.
-
- tidy_deflt scrut NoDefault = returnTM NoDefault
- tidy_deflt scrut (BindDefault bndr rhs)
- = newId bndr $ \ bndr' ->
- extend_env (tidyCoreExprEta rhs) `thenTM` \ rhs' ->
- returnTM (BindDefault bndr' rhs')
- where
- extend_env = case scrut of
- Var v -> extendEnvTM bndr v
- other -> \x -> x
-
-tidyCoreExprEta e = tidyCoreExpr e `thenTM` \ e' ->
- returnTM (etaCoreExpr e')
-\end{code}