Commit e3f341f3 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Fix and refactor strict pattern bindings

This patch was triggered by Trac #11601, where I discovered that
-XStrict was really not doing the right thing. In particular,

  f y = let !(Just x) = blah[y] in body[y,x]

This was evaluating 'blah' but not pattern matching it
against Just until x was demanded.  This is wrong.

The patch implements a new semantics which ensures that strict
patterns (i.e. ones with an explicit bang, or with -XStrict)
are evaluated fully when bound.

* There are extensive notes in DsUtils:
  Note [mkSelectorBinds]

* To do this I found I need one-tuples;
  see Note [One-tuples] in TysWiredIn

I updated the user manual to give the new semantics
parent a0261121
......@@ -591,10 +591,7 @@ lintCoreExpr :: CoreExpr -> LintM OutType
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
lintCoreExpr (Var var)
= do { checkL (not (var == oneTupleDataConId))
(text "Illegal one-tuple")
; checkL (isId var && not (isCoVar var))
= do { checkL (isId var && not (isCoVar var))
(text "Non term variable" <+> ppr var)
; checkDeadIdOcc var
......@@ -1720,10 +1717,6 @@ lookupIdInScope id
where
out_of_scope = pprBndr LetBind id <+> text "is out of scope"
oneTupleDataConId :: Id -- Should not happen
oneTupleDataConId = dataConWorkId (tupleDataCon Boxed 1)
lintTyCoVarInScope :: Var -> LintM ()
lintTyCoVarInScope v = lintInScope (text "is out of scope") v
......
......@@ -24,14 +24,15 @@ module MkCore (
mkCoreTupBoxity,
-- * Constructing big tuples
mkBigCoreVarTup, mkBigCoreVarTupTy,
mkBigCoreTup, mkBigCoreTupTy,
mkBigCoreVarTup, mkBigCoreVarTup1,
mkBigCoreVarTupTy, mkBigCoreTupTy,
mkBigCoreTup,
-- * Deconstructing small tuples
mkSmallTupleSelector, mkSmallTupleCase,
-- * Deconstructing big tuples
mkTupleSelector, mkTupleCase,
mkTupleSelector, mkTupleSelector1, mkTupleCase,
-- * Constructing list expressions
mkNilExpr, mkConsExpr, mkListExpr,
......@@ -303,17 +304,36 @@ Creating tuples and their types for Core expressions
* If there are more elements than a big tuple can have, it nests
the tuples.
Note [Flattening one-tuples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
This family of functions creates a tuple of variables/expressions/types.
mkCoreTup [e1,e2,e3] = (e1,e2,e3)
What if there is just one variable/expression/type in the agument?
We could do one of two things:
* Flatten it out, so that
mkCoreTup [e1] = e1
* Built a one-tuple (see Note [One-tuples] in TysWiredIn)
mkCoreTup1 [e1] = Unit e1
We use a suffix "1" to indicate this.
Usually we want the former, but occasionally the latter.
-}
-- | Build a small tuple holding the specified variables
-- One-tuples are flattened; see Note [Flattening of one-tuples]
mkCoreVarTup :: [Id] -> CoreExpr
mkCoreVarTup ids = mkCoreTup (map Var ids)
-- | Bulid the type of a small tuple that holds the specified variables
-- One-tuples are flattened; see Note [Flattening of one-tuples]
mkCoreVarTupTy :: [Id] -> Type
mkCoreVarTupTy ids = mkBoxedTupleTy (map idType ids)
-- | Build a small tuple holding the specified expressions
-- One-tuples are flattened; see NOte [Flattening of one-tuples]
mkCoreTup :: [CoreExpr] -> CoreExpr
mkCoreTup [] = Var unitDataConId
mkCoreTup [c] = c
......@@ -324,6 +344,7 @@ mkCoreTup cs = mkCoreConApps (tupleDataCon Boxed (length cs))
-- with the given types. The types must be the types of the expressions.
-- Do not include the RuntimeRep specifiers; this function calculates them
-- for you.
-- Does /not/ flatten one-tuples; see Note [Flattening one-tuples]
mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr
mkCoreUbxTup tys exps
= ASSERT( tys `equalLength` exps)
......@@ -336,43 +357,32 @@ mkCoreTupBoxity Boxed exps = mkCoreTup exps
mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps
-- | Build a big tuple holding the specified variables
-- One-tuples are flattened; see Note [Flattening of one-tuples]
mkBigCoreVarTup :: [Id] -> CoreExpr
mkBigCoreVarTup ids = mkBigCoreTup (map Var ids)
mkBigCoreVarTup1 :: [Id] -> CoreExpr
-- Same as mkBigCoreVarTup, but one-tuples are NOT flattened
-- see Note [Flattening one-tuples]
mkBigCoreVarTup1 [id] = mkCoreConApps (tupleDataCon Boxed 1)
[Type (idType id), Var id]
mkBigCoreVarTup1 ids = mkBigCoreTup (map Var ids)
-- | Build the type of a big tuple that holds the specified variables
-- One-tuples are flattened; see Note [Flattening of one-tuples]
mkBigCoreVarTupTy :: [Id] -> Type
mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)
-- | Build a big tuple holding the specified expressions
-- One-tuples are flattened; see Note [Flattening of one-tuples]
mkBigCoreTup :: [CoreExpr] -> CoreExpr
mkBigCoreTup = mkChunkified mkCoreTup
-- | Build the type of a big tuple that holds the specified type of thing
-- One-tuples are flattened; see Note [Flattening of one-tuples]
mkBigCoreTupTy :: [Type] -> Type
mkBigCoreTupTy = mkChunkified mkBoxedTupleTy
{-
************************************************************************
* *
Floats
* *
************************************************************************
-}
data FloatBind
= FloatLet CoreBind
| FloatCase CoreExpr Id AltCon [Var]
-- case e of y { C ys -> ... }
-- See Note [Floating cases] in SetLevels
instance Outputable FloatBind where
ppr (FloatLet b) = text "LET" <+> ppr b
ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b)
2 (ppr c <+> ppr bs)
wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet defns) body = Let defns body
wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
{-
************************************************************************
......@@ -392,11 +402,12 @@ wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body
-- just the identity.
--
-- If necessary, we pattern match on a \"big\" tuple.
mkTupleSelector :: [Id] -- ^ The 'Id's to pattern match the tuple against
-> Id -- ^ The 'Id' to select
-> Id -- ^ A variable of the same type as the scrutinee
-> CoreExpr -- ^ Scrutinee
-> CoreExpr -- ^ Selector expression
mkTupleSelector, mkTupleSelector1
:: [Id] -- ^ The 'Id's to pattern match the tuple against
-> Id -- ^ The 'Id' to select
-> Id -- ^ A variable of the same type as the scrutinee
-> CoreExpr -- ^ Scrutinee
-> CoreExpr -- ^ Selector expression
-- mkTupleSelector [a,b,c,d] b v e
-- = case e of v {
......@@ -420,21 +431,34 @@ mkTupleSelector vars the_var scrut_var scrut
tpl_vs = mkTemplateLocals tpl_tys
[(tpl_v, group)] = [(tpl,gp) | (tpl,gp) <- zipEqual "mkTupleSelector" tpl_vs vars_s,
the_var `elem` gp ]
-- ^ 'mkTupleSelector1' is like 'mkTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkTupleSelector1 vars the_var scrut_var scrut
| [_] <- vars
= mkSmallTupleSelector1 vars the_var scrut_var scrut
| otherwise
= mkTupleSelector vars the_var scrut_var scrut
-- | Like 'mkTupleSelector' but for tuples that are guaranteed
-- never to be \"big\".
--
-- > mkSmallTupleSelector [x] x v e = [| e |]
-- > mkSmallTupleSelector [x,y,z] x v e = [| case e of v { (x,y,z) -> x } |]
mkSmallTupleSelector :: [Id] -- The tuple args
-> Id -- The selected one
-> Id -- A variable of the same type as the scrutinee
-> CoreExpr -- Scrutinee
mkSmallTupleSelector, mkSmallTupleSelector1
:: [Id] -- The tuple args
-> Id -- The selected one
-> Id -- A variable of the same type as the scrutinee
-> CoreExpr -- Scrutinee
-> CoreExpr
mkSmallTupleSelector [var] should_be_the_same_var _ scrut
= ASSERT(var == should_be_the_same_var)
scrut
scrut -- Special case for 1-tuples
mkSmallTupleSelector vars the_var scrut_var scrut
= mkSmallTupleSelector1 vars the_var scrut_var scrut
-- ^ 'mkSmallTupleSelector1' is like 'mkSmallTupleSelector'
-- but one-tuples are NOT flattened (see Note [Flattening one-tuples])
mkSmallTupleSelector1 vars the_var scrut_var scrut
= ASSERT( notNull vars )
Case scrut scrut_var (idType the_var)
[(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]
......@@ -493,6 +517,29 @@ mkSmallTupleCase vars body scrut_var scrut
= Case scrut scrut_var (exprType body)
[(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]
{-
************************************************************************
* *
Floats
* *
************************************************************************
-}
data FloatBind
= FloatLet CoreBind
| FloatCase CoreExpr Id AltCon [Var]
-- case e of y { C ys -> ... }
-- See Note [Floating cases] in SetLevels
instance Outputable FloatBind where
ppr (FloatLet b) = text "LET" <+> ppr b
ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> ptext (sLit "of") <+> ppr b)
2 (ppr c <+> ppr bs)
wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet defns) body = Let defns body
wrapFloat (FloatCase e b con bs) body = Case e b (exprType body) [(con, bs, body)]
{-
************************************************************************
* *
......
......@@ -142,13 +142,13 @@ dsHsBind dflags
, pat_ticks = (rhs_tick, var_ticks) })
= do { body_expr <- dsGuarded grhss ty
; let body' = mkOptTickBox rhs_tick body_expr
(is_strict,pat') = getUnBangedLPat dflags pat
pat' = decideBangHood dflags pat
; (force_var,sel_binds) <-
mkSelectorBinds is_strict var_ticks pat' body'
mkSelectorBinds var_ticks pat body'
-- We silently ignore inline pragmas; no makeCorePair
-- Not so cool, but really doesn't matter
; let force_var' = if is_strict
then maybe [] (\v -> [v]) force_var
; let force_var' = if isBangedLPat pat'
then [force_var]
else []
; return (force_var', sel_binds) }
......
......@@ -35,7 +35,7 @@ module DsUtils (
mkSelectorBinds,
selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
mkOptTickBox, mkBinaryTickBox, getUnBangedLPat
mkOptTickBox, mkBinaryTickBox, decideBangHood
) where
#include "HsVersions.h"
......@@ -55,7 +55,7 @@ import MkId
import Id
import Literal
import TyCon
import ConLike
-- import ConLike
import DataCon
import PatSyn
import Type
......@@ -63,6 +63,7 @@ import Coercion
import TysPrim
import TysWiredIn
import BasicTypes
import ConLike
import UniqSet
import UniqSupply
import Module
......@@ -590,135 +591,196 @@ expressions.
Note [mkSelectorBinds]
~~~~~~~~~~~~~~~~~~~~~~
Given p = e, where p binds x,y
we are going to make EITHER
EITHER (A) v = e (where v is fresh)
x = case v of p -> x
y = case v of p -> y
OR (B) t = case e of p -> (x,y)
x = case t of (x,_) -> x
y = case t of (_,y) -> y
We do (A) when (test: isSingleton binders)
* The pattern binds only one variable (so we'll only match once)
OR when (test: is_simple_lpat)
* Matching the pattern is cheap so we don't mind doing it twice.
* AND the pattern can't fail (else we tiresomely get one
inexhaustive pattern warning message for each binder
Otherwise we do (B). Really (A) is just an optimisation for very common
cases like
Just x = e
(p,q) = e
mkSelectorBinds is used to desugar a pattern binding {p = e},
in a binding group:
let { ...; p = e; ... } in body
where p binds x,y (this list of binders can be empty).
There are two cases.
General case (A).
In the general case we generate these bindings (A)
{ t = case e of p -> (x,y)
; x = case t of (x,y) -> x
; y = case t of (x,y) -> y }
and we return 't' as the variable to force if the pattern
is strict. So with -XStrict or an outermost-bang-pattern, the binding
let p = e in body
would turn into
let { t = case e of p -> (x,y)
; x = case t of (x,y) -> x
; y = case t of (x,y) -> y }
in t `seq` t
Special case (B).
For a pattern that is essentially just a tuple:
* A product type, so cannot fail
* Only one level, so that
- generating multiple matches is fine
- seq'ing it evaluates the same as matching it
Then instead we generate
{ v = e
; x = case v of p -> x
; y = case v of p -> y }
with 'v' as the variable to force
Examples:
* !(_, (_, a)) = e
==>
t = case e of (_, (_, a)) -> Unit a
a = case t of Unit a -> a
Note that
- Forcing 't' will force the pattern to match fully;
e.g. will diverge if (snd e) is bottom
- But 'a' itself is not forced; it is wrapped in a one-tuple
(see Note [One-tuples] in TysWiredIn)
* !(Just x) = e
==>
t = case e of Just x -> Unit x
x = case t of Unit x -> x
Again, forcing 't' will fail if 'e' yields Nothing.
Note that even though this is rather general, the special cases
work out well:
* One binder, not -XStrict:
let Just (Just v) = e in body
==>
let t = case e of Just (Just v) -> Unit v
v = case t of Unit v -> v
in body
==>
let v = case (case e of Just (Just v) -> Unit v) of
Unit v -> v
in body
==>
let v = case e of Just (Just v) -> v
in body
* Non-recursive, -XStrict
let p = e in body
==>
let { t = case e of p -> (x,y)
; x = case t of (x,y) -> x
; y = case t of (x,y) -> x }
in t `seq` body
==> {inline seq, float x,y bindings inwards}
let t = case e of p -> (x,y) in
case t of t' ->
let { x = case t' of (x,y) -> x
; y = case t' of (x,y) -> x } in
body
==> {inline t, do case of case}
case e of p ->
let t = (x,y) in
let { x = case t' of (x,y) -> x
; y = case t' of (x,y) -> x } in
body
==> {case-cancellation, drop dead code}
case e of p -> body
* Special case (B) is there to avoid fruitlessly taking the tuple
apart and rebuilding it. For example, consider
{ K x y = e }
where K is a product constructor. Then general case (A) does:
{ t = case e of K x y -> (x,y)
; x = case t of (x,y) -> x
; y = case t of (x,y) -> y }
In the lazy case we can't optimise out this fruitless taking apart
and rebuilding. Instead (B) builds
{ v = e
; x = case v of K x y -> x
; y = case v of K x y -> y }
which is better.
-}
mkSelectorBinds :: Bool -- ^ is strict
-> [[Tickish Id]] -- ^ ticks to add, possibly
mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
-> LPat Id -- ^ The pattern
-> CoreExpr -- ^ Expression to which the pattern is bound
-> DsM (Maybe Id,[(Id,CoreExpr)])
-> DsM (Id,[(Id,CoreExpr)])
-- ^ Id the rhs is bound to, for desugaring strict
-- binds (see Note [Desugar Strict binds] in DsBinds)
-- and all the desugared binds
mkSelectorBinds _ ticks (L _ (VarPat (L _ v))) val_expr
= return (Just v
,[(v, case ticks of
[t] -> mkOptTickBox t val_expr
_ -> val_expr)])
mkSelectorBinds is_strict ticks pat val_expr
| null binders, not is_strict
= return (Nothing, [])
| isSingleton binders || is_simple_lpat pat -- Case (A)
-- See Note [mkSelectorBinds]
mkSelectorBinds ticks pat val_expr
| is_simple_lpat pat -- Special case (B)
= do { let pat_ty = hsLPatType pat
; val_var <- newSysLocalDs pat_ty
-- Make up 'v' in Note [mkSelectorBinds]
-- NB: give it the type of *pattern* p, not the type of the *rhs* e.
-- This does not matter after desugaring, but there's a subtle
-- issue with implicit parameters. Consider
-- (x,y) = ?i
-- Then, ?i is given type {?i :: Int}, a PredType, which is opaque
-- to the desugarer. (Why opaque? Because newtypes have to be. Why
-- does it get that type? So that when we abstract over it we get the
-- right top-level type (?i::Int) => ...)
--
-- So to get the type of 'v', use the pattern not the rhs. Often more
-- efficient too.
-- For the error message we make one error-app, to avoid duplication.
-- But we need it at different types, so we make it polymorphic:
-- err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah"
; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat)
; err_var <- newSysLocalDs (mkInvForAllTys [alphaTyVar] alphaTy)
; binds <- zipWithM (mk_bind val_var err_var) ticks' binders
; return (Just val_var
,(val_var, val_expr) :
(err_var, Lam alphaTyVar err_app) :
binds) }
| otherwise -- Case (B)
= do { val_var <- newSysLocalDs (hsLPatType pat)
; tuple_var <- newSysLocalDs tuple_ty
; let mk_bind scrut_var tick bndr_var
-- (mk_bind sv bv) generates bv = case sv of { pat -> bv }
-- Remember, 'pat' binds 'bv'
= do { rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
(Var bndr_var)
(Var bndr_var) -- Neat hack
-- Neat hack: since 'pat' can't fail, the
-- "fail-expr" passed to matchSimply is not
-- used. But it /is/ used for its type, and for
-- that bndr_var is just the ticket.
; return (bndr_var, mkOptTickBox tick rhs_expr) }
; binds <- zipWithM (mk_bind val_var) ticks' binders
; return ( val_var, (val_var, val_expr) : binds) }
| otherwise
= do { tuple_var <- newSysLocalDs tuple_ty
; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
; tuple_expr <- matchSimply (Var val_var) PatBindRhs pat
; tuple_expr <- matchSimply val_expr PatBindRhs pat
local_tuple error_expr
; let mk_tup_bind tick binder
= (binder, mkOptTickBox tick $
mkTupleSelector local_binders binder
tuple_var (Var tuple_var))
tup_binds
| null binders = []
| otherwise = (tuple_var, tuple_expr)
: zipWith mk_tup_bind ticks' binders
; return ( Just val_var
, (val_var,val_expr) : tup_binds ) }
mkTupleSelector1 local_binders binder
tuple_var (Var tuple_var))
tup_binds = zipWith mk_tup_bind ticks' binders
; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }
where
binders = collectPatBinders pat
ticks' = ticks ++ repeat []
binders = collectPatBinders pat
ticks' = ticks ++ repeat []
local_binders = map localiseId binders -- See Note [Localise pattern binders]
local_tuple = mkBigCoreVarTup binders
local_tuple = mkBigCoreVarTup1 binders
tuple_ty = exprType local_tuple
mk_bind scrut_var err_var tick bndr_var = do
-- (mk_bind sv err_var) generates
-- bv = case sv of { pat -> bv; other -> err_var @ type-of-bv }
-- Remember, pat binds bv
rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
(Var bndr_var) error_expr
return (bndr_var, mkOptTickBox tick rhs_expr)
where
error_expr = Var err_var `App` Type (idType bndr_var)
is_simple_lpat :: LPat a -> Bool
is_simple_lpat p = is_simple_pat (unLoc p)
is_simple_lpat p = is_simple_pat (unLoc p)
is_simple_pat :: Pat a -> Bool
is_simple_pat (VarPat _) = True
is_simple_pat (ParPat p) = is_simple_lpat p
is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
is_simple_pat (ConPatOut { pat_con = con
, pat_args = ps}) = is_simple_con_pat con ps
is_simple_pat _ = False
is_simple_pat (TuplePat ps Boxed _) = all is_triv_lpat ps
is_simple_pat pat@(ConPatOut{}) = case unLoc (pat_con pat) of
RealDataCon con -> isProductTyCon (dataConTyCon con)
&& all is_triv_lpat (hsConPatArgs (pat_args pat))
PatSynCon _ -> False
is_simple_pat (VarPat _) = True
is_simple_pat (ParPat p) = is_simple_lpat p
is_simple_pat _ = False
is_simple_con_pat :: Located ConLike -> HsConPatDetails a -> Bool
is_simple_con_pat con args
= case con of
L _ (RealDataCon con) -> isProductTyCon (dataConTyCon con)
&& all is_triv_lpat (hsConPatArgs args)
L _ (PatSynCon {}) -> False
is_triv_lpat p = is_triv_pat (unLoc p)
is_triv_lpat :: LPat a -> Bool
is_triv_lpat p = is_triv_pat (unLoc p)
is_triv_pat (VarPat _) = True
is_triv_pat (WildPat _) = True
is_triv_pat (ParPat p) = is_triv_lpat p
is_triv_pat _ = False
is_triv_pat :: Pat a -> Bool
is_triv_pat (VarPat _) = True
is_triv_pat (WildPat _) = True
is_triv_pat (ParPat p) = is_triv_lpat p
is_triv_pat _ = False
{-
Creating big tuples and their types for full Haskell expressions.
They work over *Ids*, and create tuples replete with their types,
which is whey they are not in HsUtils.
-}
{- *********************************************************************
* *
Creating big tuples and their types for full Haskell expressions.
They work over *Ids*, and create tuples replete with their types,
which is whey they are not in HsUtils.
* *
********************************************************************* -}
mkLHsPatTup :: [LPat Id] -> LPat Id
mkLHsPatTup [] = noLoc $ mkVanillaTuplePat [] Boxed
......@@ -864,26 +926,28 @@ mkBinaryTickBox ixT ixF e = do
-- *******************************************************************
-- | Remove any bang from a pattern and say if it is a strict bind,
-- also make irrefutable patterns ordinary patterns if -XStrict.
--
-- Example:
-- Examples:
-- ~pat => False, pat -- when -XStrict
-- -- even if pat = ~pat'
-- ~pat => False, ~pat -- without -XStrict
-- ~(~pat) => False, ~pat -- when -XStrict
-- pat => True, pat -- when -XStrict
-- !pat => True, pat -- always
getUnBangedLPat :: DynFlags
-> LPat id -- ^ Original pattern
-> (Bool, LPat id) -- is bind strict?, pattern without bangs
getUnBangedLPat dflags (L l (ParPat p))
= let (is_strict, p') = getUnBangedLPat dflags p
in (is_strict, L l (ParPat p'))
getUnBangedLPat _ (L _ (BangPat p))
= (True,p)
getUnBangedLPat dflags (L _ (LazyPat p))
| xopt LangExt.Strict dflags
= (False,p)
getUnBangedLPat dflags p
= (xopt LangExt.Strict dflags,p)
decideBangHood :: DynFlags
-> LPat id -- ^ Original pattern
-> LPat id -- Pattern with bang if necessary
decideBangHood dflags lpat
= go lpat
where
xstrict = xopt LangExt.Strict dflags
go lp@(L l p)
= case p of
ParPat p -> L l (ParPat (go p))
LazyPat lp' | xstrict -> lp'
BangPat _ -> lp
_ | xstrict -> L l (BangPat lp)
| otherwise -> lp
......@@ -429,7 +429,7 @@ tidy1 v (AsPat (L _ var) pat)
-}
tidy1 v (LazyPat pat)
= do { (_,sel_prs) <- mkSelectorBinds False [] pat (Var v)
= do { (_,sel_prs) <- mkSelectorBinds [] pat (Var v)
; let sel_binds = [NonRec b rhs | (b,rhs) <- sel_prs]
; return (mkCoreLets sel_binds, WildPat (idType v)) }
......@@ -690,13 +690,11 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
; eqns_info <- mapM (mk_eqn_info new_vars) matches
-- pattern match check warnings
; unless (isGenerated origin) $ do
when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $ do
; unless (isGenerated origin) $
when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $
addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
-- See Note [Type and Term Equality Propagation]
addTmCsDs (genCaseTmCs1 mb_scr new_vars) $
checkMatches dflags (DsMatchContext ctxt locn) new_vars matches
checkMatches dflags (DsMatchContext ctxt locn) new_vars matches