summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/deSugar/Desugar.lhs2
-rw-r--r--compiler/deSugar/DsBinds.lhs77
-rw-r--r--compiler/deSugar/DsExpr.lhs8
-rw-r--r--compiler/deSugar/Match.lhs2
-rw-r--r--compiler/deSugar/MatchCon.lhs15
5 files changed, 58 insertions, 46 deletions
diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index cb482eaf89..cb23075134 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -120,7 +120,7 @@ deSugar hsc_env
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
- do { let ds_ev_binds = dsEvBinds ev_binds
+ do { ds_ev_binds <- dsEvBinds ev_binds
; core_prs <- dsTopLHsBinds binds_cvr
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
; (ds_fords, foreign_prs) <- dsForeigns fords
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index 9753d3ebb4..b6e0969562 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -32,6 +32,7 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
+import HscTypes(MonadThings)
import CoreSubst
import MkCore
import CoreUtils
@@ -66,6 +67,7 @@ import Util
import MonadUtils
import Data.Word(Word)
+import Control.Monad(liftM)
\end{code}
%************************************************************************
@@ -109,7 +111,7 @@ dsHsBind (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_infix = inf })
= do { (args, body) <- matchWrapper (FunRhs (idName fun) inf) matches
; let body' = mkOptTickBox tick body
- rhs = dsHsWrapper co_fn (mkLams args body')
+ ; rhs <- dsHsWrapper co_fn (mkLams args body')
; {- pprTrace "dsHsBind" (ppr fun <+> ppr (idInlinePragma fun)) $ -}
return (unitOL (makeCorePair fun False 0 rhs)) }
@@ -133,9 +135,10 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abe_mono = local, abe_prags = prags } <- export
= do { bind_prs <- ds_lhs_binds binds
; let core_bind = Rec (fromOL bind_prs)
- rhs = dsHsWrapper wrap $ -- Usually the identity
+ ; ds_binds <- dsTcEvBinds ev_binds
+ ; rhs <- dsHsWrapper wrap $ -- Usually the identity
mkLams tyvars $ mkLams dicts $
- mkCoreLets (dsTcEvBinds ev_binds) $
+ mkCoreLets ds_binds $
Let core_bind $
Var local
@@ -151,13 +154,14 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
, abs_exports = exports, abs_ev_binds = ev_binds
, abs_binds = binds })
= do { bind_prs <- ds_lhs_binds binds
+ ; ds_binds <- dsTcEvBinds ev_binds
; let core_bind = Rec (fromOL bind_prs)
-- Monomorphic recursion possible, hence Rec
tup_expr = mkBigCoreVarTup locals
tup_ty = exprType tup_expr
poly_tup_rhs = mkLams tyvars $ mkLams dicts $
- mkCoreLets (dsTcEvBinds ev_binds) $
+ mkCoreLets ds_binds $
Let core_bind $
tup_expr
locals = map abe_mono exports
@@ -167,11 +171,11 @@ dsHsBind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts
; let mk_bind (ABE { abe_wrap = wrap, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
= do { tup_id <- newSysLocalDs tup_ty
- ; let rhs = dsHsWrapper wrap $
+ ; rhs <- dsHsWrapper wrap $
mkLams tyvars $ mkLams dicts $
mkTupleSelector locals local tup_id $
mkVarApps (Var poly_tup_id) (tyvars ++ dicts)
- rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
+ ; let rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs
; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags
; let global' = addIdSpecialisations global rules
; return ((global', rhs) `consOL` spec_binds) }
@@ -400,8 +404,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
= putSrcSpanDs loc $
do { let poly_name = idName poly_id
; spec_name <- newLocalName poly_name
- ; let (bndrs, ds_lhs) = collectBinders (dsHsWrapper spec_co (Var poly_id))
- spec_ty = mkPiTypes bndrs (exprType ds_lhs)
+ ; (bndrs, ds_lhs) <- liftM collectBinders
+ (dsHsWrapper spec_co (Var poly_id))
+ ; let spec_ty = mkPiTypes bndrs (exprType ds_lhs)
; case decomposeRuleLhs bndrs ds_lhs of {
Left msg -> do { warnDs msg; return Nothing } ;
Right (final_bndrs, _fn, args) -> do
@@ -439,8 +444,8 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
final_bndrs args
(mkVarApps (Var spec_id) bndrs)
- spec_rhs = dsHsWrapper spec_co poly_rhs
- spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
+ ; spec_rhs <- dsHsWrapper spec_co poly_rhs
+ ; let spec_pair = makeCorePair spec_id False (dictArity bndrs) spec_rhs
; return (Just (spec_pair `consOL` unf_pairs, rule))
} } }
@@ -645,28 +650,29 @@ as the old one, but with an Internal name and no IdInfo.
\begin{code}
-dsHsWrapper :: HsWrapper -> CoreExpr -> CoreExpr
-dsHsWrapper WpHole e = e
-dsHsWrapper (WpTyApp ty) e = App e (Type ty)
-dsHsWrapper (WpLet ev_binds) e = mkCoreLets (dsTcEvBinds ev_binds) e
-dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 (dsHsWrapper c2 e)
-dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e)
-dsHsWrapper (WpEvLam ev) e = Lam ev e
-dsHsWrapper (WpTyLam tv) e = Lam tv e
-dsHsWrapper (WpEvApp evtrm) e = App e (dsEvTerm evtrm)
+dsHsWrapper :: MonadThings m => HsWrapper -> CoreExpr -> m CoreExpr
+dsHsWrapper WpHole e = return e
+dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
+dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
+ return (mkCoreLets bs e)
+dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
+dsHsWrapper (WpCast co) e = return $ dsTcCoercion co (mkCast e)
+dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
+dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
+dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm)
--------------------------------------
-dsTcEvBinds :: TcEvBinds -> [CoreBind]
-dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
+dsTcEvBinds :: MonadThings m => TcEvBinds -> m [CoreBind]
+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
dsTcEvBinds (EvBinds bs) = dsEvBinds bs
-dsEvBinds :: Bag EvBind -> [CoreBind]
-dsEvBinds bs = map ds_scc (sccEvBinds bs)
+dsEvBinds :: MonadThings m => Bag EvBind -> m [CoreBind]
+dsEvBinds bs = mapM ds_scc (sccEvBinds bs)
where
- ds_scc (AcyclicSCC (EvBind v r)) = NonRec v (dsEvTerm r)
- ds_scc (CyclicSCC bs) = Rec (map ds_pair bs)
+ ds_scc (AcyclicSCC (EvBind v r)) = liftM (NonRec v) (dsEvTerm r)
+ ds_scc (CyclicSCC bs) = liftM Rec (mapM ds_pair bs)
- ds_pair (EvBind v r) = (v, dsEvTerm r)
+ ds_pair (EvBind v r) = liftM ((,) v) (dsEvTerm r)
sccEvBinds :: Bag EvBind -> [SCC EvBind]
sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
@@ -679,19 +685,20 @@ sccEvBinds bs = stronglyConnCompFromEdgedVertices edges
---------------------------------------
-dsEvTerm :: EvTerm -> CoreExpr
-dsEvTerm (EvId v) = Var v
+dsEvTerm :: MonadThings m => EvTerm -> m CoreExpr
+dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast v co)
- = dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
+ = return $ dsTcCoercion co $ mkCast (Var v) -- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
dsEvTerm (EvKindCast v co)
- = dsTcCoercion co $ (\_ -> Var v)
+ = return $ dsTcCoercion co $ (\_ -> Var v)
-dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
+dsEvTerm (EvDFunApp df tys vars) = return (Var df `mkTyApps` tys `mkVarApps` vars)
+dsEvTerm (EvCoercion co) = return $ dsTcCoercion co mkEqBox
dsEvTerm (EvTupleSel v n)
= ASSERT( isTupleTyCon tc )
+ return $
Case (Var v) (mkWildValBinder (varType v)) (tys !! n) [(DataAlt dc, xs, Var v')]
where
(tc, tys) = splitTyConApp (evVarPred v)
@@ -699,11 +706,11 @@ dsEvTerm (EvTupleSel v n)
v' = v `setVarType` ty_want
xs = map mkWildValBinder tys_before ++ v' : map mkWildValBinder tys_after
(tys_before, ty_want:tys_after) = splitAt n tys
-dsEvTerm (EvTupleMk vs) = Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
+dsEvTerm (EvTupleMk vs) = return $ Var (dataConWorkId dc) `mkTyApps` tys `mkVarApps` vs
where dc = tupleCon ConstraintTuple (length vs)
tys = map varType vs
dsEvTerm (EvSuperClass d n)
- = Var sc_sel_id `mkTyApps` tys `App` Var d
+ = return $ Var sc_sel_id `mkTyApps` tys `App` Var d
where
sc_sel_id = classSCSelId cls n -- Zero-indexed
(cls, tys) = getClassPredTys (evVarPred d)
@@ -714,7 +721,7 @@ dsEvTerm (EvSuperClass d n)
-- leave this for a later day.
dsEvTerm (EvInteger n)
| n > fromIntegral (maxBound :: Word) = panic "dsEvTerm: Integer too big!"
- | otherwise = mkWordExprWord (fromInteger n)
+ | otherwise = return $ mkWordExprWord (fromInteger n)
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> CoreExpr
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index a47e617a7c..65134ed85f 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -79,7 +79,8 @@ dsValBinds (ValBindsIn _ _) _ = panic "dsValBinds ValBindsIn"
-------------------------
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
dsIPBinds (IPBinds ip_binds ev_binds) body
- = do { let inner = mkCoreLets (dsTcEvBinds ev_binds) body
+ = do { ds_binds <- dsTcEvBinds ev_binds
+ ; let inner = mkCoreLets ds_binds body
-- The dict bindings may not be in
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
@@ -131,7 +132,8 @@ dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
body1 binds
- ; return (mkCoreLets (dsTcEvBinds ev_binds) body2) }
+ ; ds_binds <- dsTcEvBinds ev_binds
+ ; return (mkCoreLets ds_binds body2) }
dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
, fun_tick = tick, fun_infix = inf }) body
@@ -216,7 +218,7 @@ dsExpr (HsOverLit lit) = dsOverLit lit
dsExpr (HsWrap co_fn e)
= do { e' <- dsExpr e
- ; let wrapped_e = dsHsWrapper co_fn e'
+ ; wrapped_e <- dsHsWrapper co_fn e'
; warn_id <- woptDs Opt_WarnIdentities
; when warn_id $ warnAboutIdentities e' wrapped_e
; return wrapped_e }
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index cd0153e3ac..f2e3be8bb8 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -356,7 +356,7 @@ matchCoercion (var:vars) ty (eqns@(eqn1:_))
; var' <- newUniqueId var (hsPatType pat)
; match_result <- match (var':vars) ty $
map (decomposeFirstPat getCoPat) eqns
- ; let rhs' = dsHsWrapper co (Var var)
+ ; rhs' <- dsHsWrapper co (Var var)
; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
matchCoercion _ _ _ = panic "matchCoercion"
diff --git a/compiler/deSugar/MatchCon.lhs b/compiler/deSugar/MatchCon.lhs
index f3b613fdbb..29c10bdb48 100644
--- a/compiler/deSugar/MatchCon.lhs
+++ b/compiler/deSugar/MatchCon.lhs
@@ -32,6 +32,7 @@ import Id
import NameEnv
import SrcLoc
import Outputable
+import Control.Monad(liftM)
\end{code}
We are confronted with the first column of patterns in a set of
@@ -131,18 +132,20 @@ matchOneCon vars ty (eqn1 : eqns) -- All eqns for a single constructor
match_group :: [Id] -> [(ConArgPats, EquationInfo)] -> DsM MatchResult
-- All members of the group have compatible ConArgPats
match_group arg_vars arg_eqn_prs
- = do { let (wraps, eqns') = unzip (map shift arg_eqn_prs)
- group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
+ = do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)
+ ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs
; match_result <- match (group_arg_vars ++ vars) ty eqns'
; return (adjustMatchResult (foldr1 (.) wraps) match_result) }
shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,
pat_binds = bind, pat_args = args
} : pats }))
- = ( wrapBinds (tvs `zip` tvs1)
- . wrapBinds (ds `zip` dicts1)
- . mkCoreLets (dsTcEvBinds bind)
- , eqn { eqn_pats = conArgPats arg_tys args ++ pats })
+ = do ds_bind <- dsTcEvBinds bind
+ return ( wrapBinds (tvs `zip` tvs1)
+ . wrapBinds (ds `zip` dicts1)
+ . mkCoreLets ds_bind
+ , eqn { eqn_pats = conArgPats arg_tys args ++ pats }
+ )
shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)
-- Choose the right arg_vars in the right order for this group
View Lorry Controller Status