import Id
import Var
import VarSet
-import PrelInfo
import DataCon
import TysWiredIn
import BasicTypes
-------------------------
dsIPBinds :: HsIPBinds Id -> CoreExpr -> DsM CoreExpr
-dsIPBinds (IPBinds ip_binds dict_binds) body
- = do { prs <- dsLHsBinds dict_binds
- ; let inner = Let (Rec prs) body
+dsIPBinds (IPBinds ip_binds ev_binds) body
+ = do { ds_ev_binds <- dsTcEvBinds ev_binds
+ ; let inner = wrapDsEvBinds ds_ev_binds body
-- The dict bindings may not be in
-- dependency order; hence Rec
; foldrM ds_ip_bind inner ip_binds }
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
ds_val_bind (NonRecursive, hsbinds) body
- | [L _ (AbsBinds [] [] exports binds)] <- bagToList hsbinds,
- (L loc bind : null_binds) <- bagToList binds,
- isBangHsBind bind
- || isUnboxedTupleBind bind
- || or [isUnLiftedType (idType g) | (_, g, _, _) <- exports]
- = let
- body_w_exports = foldr bind_export body exports
- bind_export (tvs, g, l, _) body = ASSERT( null tvs )
- bindNonRec g (Var l) body
- in
- ASSERT (null null_binds)
+ | [L loc bind] <- bagToList hsbinds,
-- Non-recursive, non-overloaded bindings only come in ones
-- ToDo: in some bizarre case it's conceivable that there
-- could be dict binds in the 'binds'. (See the notes
-- below. Then pattern-match would fail. Urk.)
- putSrcSpanDs loc $
- case bind of
- FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn,
- fun_tick = tick, fun_infix = inf }
- -> do (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
- MASSERT( null args ) -- Functions aren't lifted
- MASSERT( isIdHsWrapper co_fn )
- rhs' <- mkOptTickBox tick rhs
- return (bindNonRec fun rhs' body_w_exports)
-
- PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }
- -> -- let C x# y# = rhs in body
- -- ==> case rhs of C x# y# -> body
- putSrcSpanDs loc $
- do { rhs <- dsGuarded grhss ty
- ; let upat = unLoc pat
- eqn = EqnInfo { eqn_pats = [upat],
- eqn_rhs = cantFailMatchResult body_w_exports }
- ; var <- selectMatchVar upat
- ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
- ; return (scrungleMatch var rhs result) }
-
- _ -> pprPanic "dsLet: unlifted" (pprLHsBinds hsbinds $$ ppr body)
-
+ strictMatchOnly bind
+ = putSrcSpanDs loc (dsStrictBind bind body)
-- Ordinary case for bindings; none should be unlifted
ds_val_bind (_is_rec, binds) body
= do { prs <- dsLHsBinds binds
- ; ASSERT( not (any (isUnLiftedType . idType . fst) prs) )
+ ; ASSERT2( not (any (isUnLiftedType . idType . fst) prs), ppr _is_rec $$ ppr binds )
case prs of
[] -> return body
_ -> return (Let (Rec prs) body) }
-- NB The previous case dealt with unlifted bindings, so we
-- only have to deal with lifted ones now; so Rec is ok
-isUnboxedTupleBind :: HsBind Id -> Bool
-isUnboxedTupleBind (PatBind { pat_rhs_ty = ty }) = isUnboxedTupleType ty
-isUnboxedTupleBind _ = False
+------------------
+dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
+dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
+ , abs_exports = exports
+ , abs_ev_binds = ev_binds
+ , abs_binds = binds }) body
+ = do { ds_ev_binds <- dsTcEvBinds ev_binds
+ ; let body1 = foldr bind_export body exports
+ bind_export (_, g, l, _) b = bindNonRec g (Var l) b
+ ; body2 <- foldlBagM (\body bind -> dsStrictBind (unLoc bind) body)
+ body1 binds
+ ; return (wrapDsEvBinds ds_ev_binds body2) }
+
+dsStrictBind (FunBind { fun_id = L _ fun, fun_matches = matches, fun_co_fn = co_fn
+ , fun_tick = tick, fun_infix = inf }) body
+ -- Can't be a bang pattern (that looks like a PatBind)
+ -- so must be simply unboxed
+ = do { (args, rhs) <- matchWrapper (FunRhs (idName fun ) inf) matches
+ ; MASSERT( null args ) -- Functions aren't lifted
+ ; MASSERT( isIdHsWrapper co_fn )
+ ; rhs' <- mkOptTickBox tick rhs
+ ; return (bindNonRec fun rhs' body) }
+
+dsStrictBind (PatBind {pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty }) body
+ = -- let C x# y# = rhs in body
+ -- ==> case rhs of C x# y# -> body
+ do { rhs <- dsGuarded grhss ty
+ ; let upat = unLoc pat
+ eqn = EqnInfo { eqn_pats = [upat],
+ eqn_rhs = cantFailMatchResult body }
+ ; var <- selectMatchVar upat
+ ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
+ ; return (scrungleMatch var rhs result) }
+
+dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
+
+----------------------
+strictMatchOnly :: HsBind Id -> Bool
+strictMatchOnly (AbsBinds { abs_binds = binds })
+ = anyBag (strictMatchOnly . unLoc) binds
+strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
+ = isUnboxedTupleType ty
+ || isBangLPat lpat
+ || any (isUnLiftedType . idType) (collectPatBinders lpat)
+strictMatchOnly (FunBind { fun_id = L _ id })
+ = isUnLiftedType (idType id)
+strictMatchOnly _ = False -- I hope! Checked immediately by caller in fact
scrungleMatch :: Id -> CoreExpr -> CoreExpr -> CoreExpr
-- Returns something like (let var = scrut in body)
dsExpr (HsIPVar ip) = return (Var (ipNameName ip))
dsExpr (HsLit lit) = dsLit lit
dsExpr (HsOverLit lit) = dsOverLit lit
-dsExpr (HsWrap co_fn e) = do { co_fn' <- dsCoercion co_fn
+dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn
; e' <- dsExpr e
; return (co_fn' e') }
mod_name <- getModuleDs
Note (SCC (mkUserCC cc mod_name)) <$> dsLExpr expr
-
--- hdaume: core annotation
-
dsExpr (HsCoreAnn fs expr)
= Note (CoreNote $ unpackFS fs) <$> dsLExpr expr
dsExpr (HsDo GhciStmt stmts body result_ty)
= dsDo stmts body result_ty
-dsExpr (HsDo (MDoExpr tbl) stmts body result_ty)
- = dsMDo tbl stmts body result_ty
+dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty)
+ = do { (meth_binds, tbl') <- dsSyntaxTable tbl
+ ; core_expr <- dsMDo ctxt tbl' stmts body result_ty
+ ; return (mkLets meth_binds core_expr) }
dsExpr (HsDo PArrComp stmts body result_ty)
= -- Special case for array comprehensions
where
[elt_ty] = tcTyConAppArgs result_ty
-dsExpr (HsIf guard_expr then_expr else_expr)
- = mkIfThenElse <$> dsLExpr guard_expr <*> dsLExpr then_expr <*> dsLExpr else_expr
+dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
+ = do { pred <- dsLExpr guard_expr
+ ; b1 <- dsLExpr then_expr
+ ; b2 <- dsLExpr else_expr
+ ; case mb_fun of
+ Just fun -> do { core_fun <- dsExpr fun
+ ; return (mkCoreApps core_fun [pred,b1,b2]) }
+ Nothing -> return $ mkIfThenElse pred b1 b2 }
\end{code}
= nlHsVar (lookupNameEnv upd_fld_env field_name `orElse` pat_arg_id)
inst_con = noLoc $ HsWrap wrap (HsVar (dataConWrapId con))
-- Reconstruct with the WrapId so that unpacking happens
- wrap = mkWpApps theta_vars `WpCompose`
- mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
+ wrap = mkWpEvVarApps theta_vars `WpCompose`
+ mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose`
mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
, isNothing (lookupTyVar wrap_subst tv) ]
rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
, pat_dicts = eqs_vars ++ theta_vars
- , pat_binds = emptyLHsBinds
+ , pat_binds = emptyTcEvBinds
, pat_args = PrefixCon $ map nlVarPat arg_ids
, pat_ty = in_ty }
; return (mkSimpleMatch [pat] wrapped_rhs) }
go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
, recS_rec_ids = rec_ids, recS_ret_fn = return_op
, recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
- , recS_rec_rets = rec_rets, recS_dicts = binds }) stmts
+ , recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts
= ASSERT( length rec_ids > 0 )
- goL (new_bind_stmt : let_stmt : stmts)
+ ASSERT( isEmptyTcEvBinds _ev_binds ) -- No method binds
+ goL (new_bind_stmt : stmts)
where
-- returnE <- dsExpr return_id
-- mfixE <- dsExpr mfix_id
bind_op
noSyntaxExpr -- Tuple cannot fail
- let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-
tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
rec_tup_pats = map nlVarPat tup_ids
later_pats = rec_tup_pats
return (v1,..vn))
\begin{code}
-dsMDo :: PostTcTable
+dsMDo :: HsStmtContext Name
+ -> [(Name,Id)]
-> [LStmt Id]
-> LHsExpr Id
-> Type -- Type of the whole expression
-> DsM CoreExpr
-dsMDo tbl stmts body result_ty
+dsMDo ctxt tbl stmts body result_ty
= goL stmts
where
goL [] = dsLExpr body
bind_id = lookupEvidence tbl bindMName
then_id = lookupEvidence tbl thenMName
fail_id = lookupEvidence tbl failMName
- ctxt = MDoExpr tbl
go _ (LetStmt binds) stmts
= do { rest <- goL stmts
; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty,
rhs', Lam var match_code]) }
- go loc (RecStmt rec_stmts later_ids rec_ids _ _ _ rec_rets binds) stmts
+ go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
+ , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets
+ , recS_dicts = _ev_binds }) stmts
= ASSERT( length rec_ids > 0 )
ASSERT( length rec_ids == length rec_rets )
+ ASSERT( isEmptyTcEvBinds _ev_binds )
pprTrace "dsMDo" (ppr later_ids) $
- goL (new_bind_stmt : let_stmt : stmts)
+ goL (new_bind_stmt : stmts)
where
new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app
- let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(Recursive, binds)] []))
-
-- Remove the later_ids that appear (without fancy coercions)
-- in rec_rets, because there's no need to knot-tie them separately