Small refactor in desugar of pattern matching
[ghc.git] / compiler / deSugar / DsUtils.hs
index 98f7f0f..f74be0b 100644 (file)
@@ -9,6 +9,8 @@ This module exports some utility functions of no great interest.
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Utility functions for constructing Core syntax, principally for desugaring
 module DsUtils (
@@ -35,20 +37,21 @@ module DsUtils (
         mkSelectorBinds,
 
         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox, getUnBangedLPat
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}   Match ( matchSimply )
+import GhcPrelude
+
+import {-# SOURCE #-} Match  ( matchSimply )
+import {-# SOURCE #-} DsExpr ( dsLExpr )
 
 import HsSyn
 import TcHsSyn
-import Coercion( Coercion, isReflCo )
 import TcType( tcSplitTyConApp )
 import CoreSyn
 import DsMonad
-import {-# SOURCE #-} DsExpr ( dsLExpr )
 
 import CoreUtils
 import MkCore
@@ -56,22 +59,25 @@ import MkId
 import Id
 import Literal
 import TyCon
-import ConLike
 import DataCon
 import PatSyn
 import Type
+import Coercion
 import TysPrim
 import TysWiredIn
 import BasicTypes
+import ConLike
 import UniqSet
 import UniqSupply
 import Module
 import PrelNames
+import Name( isInternalName )
 import Outputable
 import SrcLoc
 import Util
 import DynFlags
 import FastString
+import qualified GHC.LanguageExtensions as LangExt
 
 import TcEvidence
 
@@ -90,7 +96,8 @@ hand, which should indeed be bound to the pattern as a whole, then use it;
 otherwise, make one up.
 -}
 
-selectSimpleMatchVarL :: LPat Id -> DsM Id
+selectSimpleMatchVarL :: LPat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
 selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
 
 -- (selectMatchVars ps tys) chooses variables of type tys
@@ -109,21 +116,23 @@ selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)
 --    Then we must not choose (x::Int) as the matching variable!
 -- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
 
-selectMatchVars :: [Pat Id] -> DsM [Id]
+selectMatchVars :: [Pat GhcTc] -> DsM [Id]
+-- Postcondition: the returned Ids have Internal Names
 selectMatchVars ps = mapM selectMatchVar ps
 
-selectMatchVar :: Pat Id -> DsM Id
-selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
-selectMatchVar (ParPat pat)  = selectMatchVar (unLoc pat)
-selectMatchVar (VarPat var)  = return (localiseId var)  -- Note [Localise pattern binders]
-selectMatchVar (AsPat var _) = return (unLoc var)
-selectMatchVar other_pat     = newSysLocalDs (hsPatType other_pat)
+selectMatchVar :: Pat GhcTc -> DsM Id
+-- Postcondition: the returned Id has an Internal Name
+selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)
+selectMatchVar (ParPat _ pat)  = selectMatchVar (unLoc pat)
+selectMatchVar (VarPat _ var)  = return (localiseId (unLoc var))
+                                  -- Note [Localise pattern binders]
+selectMatchVar (AsPat _ var _) = return (unLoc var)
+selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)
                                   -- OK, better make up one...
 
-{-
-Note [Localise pattern binders]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{- Note [Localise pattern binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider     module M where
                [Just a] = e
 After renaming it looks like
@@ -159,6 +168,7 @@ In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr
 runs on the output of the desugarer, so all is well by the end of
 the desugaring pass.
 
+See also Note [MatchIds] in Match.hs
 
 ************************************************************************
 *                                                                      *
@@ -171,7 +181,7 @@ The ``equation info'' used by @match@ is relatively complicated and
 worthy of a type synonym and a few handy functions.
 -}
 
-firstPat :: EquationInfo -> Pat Id
+firstPat :: EquationInfo -> Pat GhcTc
 firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)
 
 shiftEqns :: [EquationInfo] -> [EquationInfo]
@@ -237,11 +247,11 @@ seqVar var body = Case (Var var) var (exprType body)
 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
 
--- (mkViewMatchResult var' viewExpr var mr) makes the expression
--- let var' = viewExpr var in mr
-mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
-mkViewMatchResult var' viewExpr var =
-    adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs (text "mkView" <+> ppr var') viewExpr (Var var))))
+-- (mkViewMatchResult var' viewExpr mr) makes the expression
+-- let var' = viewExpr in mr
+mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
+mkViewMatchResult var' viewExpr =
+    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
 
 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
 mkEvalMatchResult var ty
@@ -252,10 +262,10 @@ mkGuardedMatchResult pred_expr (MatchResult _ body_fn)
   = MatchResult CanFail (\fail -> do body <- body_fn fail
                                      return (mkIfThenElse pred_expr body fail))
 
-mkCoPrimCaseMatchResult :: Id                           -- Scrutinee
-                    -> Type                             -- Type of the case
-                    -> [(Literal, MatchResult)]         -- Alternatives
-                    -> MatchResult                      -- Literals are all unlifted
+mkCoPrimCaseMatchResult :: Id                  -- Scrutinee
+                        -> Type                      -- Type of the case
+                        -> [(Literal, MatchResult)]  -- Alternatives
+                        -> MatchResult               -- Literals are all unlifted
 mkCoPrimCaseMatchResult var ty match_alts
   = MatchResult CanFail mk_case
   where
@@ -270,23 +280,20 @@ mkCoPrimCaseMatchResult var ty match_alts
             return (LitAlt lit, [], body)
 
 data CaseAlt a = MkCaseAlt{ alt_pat :: a,
-                            alt_bndrs :: [CoreBndr],
+                            alt_bndrs :: [Var],
                             alt_wrapper :: HsWrapper,
                             alt_result :: MatchResult }
 
 mkCoAlgCaseMatchResult
-  :: DynFlags
-  -> Id                 -- Scrutinee
+  :: Id                 -- Scrutinee
   -> Type               -- Type of exp
   -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
   -> MatchResult
-mkCoAlgCaseMatchResult dflags var ty match_alts
+mkCoAlgCaseMatchResult var ty match_alts
   | isNewtype  -- Newtype case; use a let
   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
 
-  | isPArrFakeAlts match_alts
-  = MatchResult CanFail $ mkPArrCase dflags var ty (sort_alts match_alts)
   | otherwise
   = mkDataConCase var ty match_alts
   where
@@ -304,34 +311,6 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
                                                 -- (not that splitTyConApp does, these days)
     newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)
 
-        --- Stuff for parallel arrays
-        --
-        -- Concerning `isPArrFakeAlts':
-        --
-        --  * it is *not* sufficient to just check the type of the type
-        --   constructor, as we have to be careful not to confuse the real
-        --   representation of parallel arrays with the fake constructors;
-        --   moreover, a list of alternatives must not mix fake and real
-        --   constructors (this is checked earlier on)
-        --
-        -- FIXME: We actually go through the whole list and make sure that
-        --        either all or none of the constructors are fake parallel
-        --        array constructors.  This is to spot equations that mix fake
-        --        constructors with the real representation defined in
-        --        `PrelPArr'.  It would be nicer to spot this situation
-        --        earlier and raise a proper error message, but it can really
-        --        only happen in `PrelPArr' anyway.
-        --
-
-    isPArrFakeAlts :: [CaseAlt DataCon] -> Bool
-    isPArrFakeAlts [alt] = isPArrFakeCon (alt_pat alt)
-    isPArrFakeAlts (alt:alts) =
-      case (isPArrFakeCon (alt_pat alt), isPArrFakeAlts alts) of
-        (True , True ) -> True
-        (False, False) -> False
-        _              -> panic "DsUtils: you may not mix `[:...:]' with `PArr' patterns"
-    isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives"
-
 mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
 mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
 
@@ -340,7 +319,8 @@ sort_alts = sortWith (dataConTag . alt_pat)
 
 mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
 mkPatSynCase var ty alt fail = do
-    matcher <- dsLExpr $ mkLHsWrap wrapper $ nlHsTyApp matcher [ty]
+    matcher <- dsLExpr $ mkLHsWrap wrapper $
+                         nlHsTyApp matcher [getRuntimeRep ty, ty]
     let MatchResult _ mkCont = match_result
     cont <- mkCoreLams bndrs <$> mkCont fail
     return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
@@ -404,48 +384,6 @@ mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case
         = mkUniqSet data_cons `minusUniqSet` mentioned_constructors
     exhaustive_case = isEmptyUniqSet un_mentioned_constructors
 
---- Stuff for parallel arrays
---
---  * the following is to desugar cases over fake constructors for
---   parallel arrays, which are introduced by `tidy1' in the `PArrPat'
---   case
---
-mkPArrCase :: DynFlags -> Id -> Type -> [CaseAlt DataCon] -> CoreExpr -> DsM CoreExpr
-mkPArrCase dflags var ty sorted_alts fail = do
-    lengthP <- dsDPHBuiltin lengthPVar
-    alt <- unboxAlt
-    return (mkWildCase (len lengthP) intTy ty [alt])
-  where
-    elemTy      = case splitTyConApp (idType var) of
-        (_, [elemTy]) -> elemTy
-        _             -> panic panicMsg
-    panicMsg    = "DsUtils.mkCoAlgCaseMatchResult: not a parallel array?"
-    len lengthP = mkApps (Var lengthP) [Type elemTy, Var var]
-    --
-    unboxAlt = do
-        l      <- newSysLocalDs intPrimTy
-        indexP <- dsDPHBuiltin indexPVar
-        alts   <- mapM (mkAlt indexP) sorted_alts
-        return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts))
-      where
-        dft  = (DEFAULT, [], fail)
-
-    --
-    -- each alternative matches one array length (corresponding to one
-    -- fake array constructor), so the match is on a literal; each
-    -- alternative's body is extended by a local binding for each
-    -- constructor argument, which are bound to array elements starting
-    -- with the first
-    --
-    mkAlt indexP alt@MkCaseAlt{alt_result = MatchResult _ bodyFun} = do
-        body <- bodyFun fail
-        return (LitAlt lit, [], mkCoreLets binds body)
-      where
-        lit   = MachInt $ toInteger (dataConSourceArity (alt_pat alt))
-        binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] (alt_bndrs alt)]
-        --
-        indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr dflags i]
-
 {-
 ************************************************************************
 *                                                                      *
@@ -466,7 +404,7 @@ mkErrorAppDs err_id ty msg = do
         full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
         core_msg = Lit (mkMachString full_msg)
         -- mkMachString returns a result of type String#
-    return (mkApps (Var err_id) [Type ty, core_msg])
+    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])
 
 {-
 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
@@ -536,22 +474,25 @@ into
 which stupidly tries to bind the datacon 'True'.
 -}
 
+-- NB: Make sure the argument is not levity polymorphic
 mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr
 mkCoreAppDs _ (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
   | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]
   = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]
   where
     case_bndr = case arg1 of
-                   Var v1 | isLocalId v1 -> v1        -- Note [Desugaring seq (2) and (3)]
-                   _                     -> mkWildValBinder ty1
+                   Var v1 | isInternalName (idName v1)
+                          -> v1        -- Note [Desugaring seq (2) and (3)]
+                   _      -> mkWildValBinder ty1
 
 mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
 
+-- NB: No argument can be levity polymorphic
 mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr
 mkCoreAppsDs s fun args = foldl (mkCoreAppDs s) fun args
 
 mkCastDs :: CoreExpr -> Coercion -> CoreExpr
--- We define a desugarer-specific verison of CoreUtils.mkCast,
+-- We define a desugarer-specific version of CoreUtils.mkCast,
 -- because in the immediate output of the desugarer, we can have
 -- apparently-mis-matched coercions:  E.g.
 --     let a = b
@@ -587,163 +528,251 @@ 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
- * Matching the pattern is cheap so we don't mind
-   doing it twice.
- * Or if the pattern binds only one variable (so we'll only
-   match once)
- * AND the pattern can't fail (else we tiresomely get two inexhaustive
-   pattern warning messages)
-
-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.
+
+------ Special case (A) -------
+  For a pattern that is just a variable,
+     let !x = e in body
+  ==>
+     let x = e in x `seq` body
+  So we return the binding, with 'x' as the variable to seq.
+
+------ 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
+
+------ General case (C) -------
+  In the general case we generate these bindings:
+       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) -> y }
+       in t `seq` body
+
+  Note that we return 't' as the variable to force if the pattern
+  is strict (i.e. with -XStrict or an outermost-bang-pattern)
+
+  Note that (A) /includes/ the situation where
+
+   * The pattern binds exactly one variable
+        let !(Just (Just x) = e in body
+     ==>
+       let { t = case e of Just (Just v) -> Unit v
+           ; v = case t of Unit v -> v }
+       in t `seq` body
+    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn
+    Note that forcing 't' makes the pattern match happen,
+    but does not force 'v'.
+
+  * The pattern binds no variables
+        let !(True,False) = e in body
+    ==>
+        let t = case e of (True,False) -> ()
+        in t `seq` body
+
+
+------ 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
-                -> LPat Id        -- ^ The pattern
+mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
+                -> LPat GhcTc     -- ^ 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 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
-    -- See Note [mkSelectorBinds]
-  = do { val_var <- newSysLocalDs (hsLPatType pat)
-        -- 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 (mkForAllTy 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
-  = do { val_var <- newSysLocalDs (hsLPatType pat)
-       ; error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (ppr pat)
-       ; tuple_expr
-           <- matchSimply (Var val_var) PatBindRhs pat local_tuple error_expr
-       ; tuple_var <- newSysLocalDs tuple_ty
+mkSelectorBinds ticks pat val_expr
+  | L _ (VarPat _ (L _ v)) <- pat'     -- Special case (A)
+  = return (v, [(v, val_expr)])
+
+  | is_flat_prod_lpat pat'           -- Special case (B)
+  = do { let pat_ty = hsLPatType pat'
+       ; val_var <- newSysLocalDsNoLP pat_ty
+
+       ; let mk_bind tick bndr_var
+               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }
+               -- Remember, 'pat' binds 'bv'
+               = do { rhs_expr <- matchSimply (Var val_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 ticks' binders
+       ; return ( val_var, (val_var, val_expr) : binds) }
+
+  | otherwise                          -- General case (C)
+  = do { tuple_var  <- newSysLocalDs tuple_ty
+       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr 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))
-         -- if strict and no binders we want to force the case
-         -- expression to force an error if the pattern match
-         -- failed. See Note [Desugar Strict binds] in DsBinds.
-       ; let force_var = if null binders && is_strict
-                         then tuple_var
-                         else val_var
-       ; return (Just force_var
-                ,(val_var,val_expr) :
-                 (tuple_var, tuple_expr) :
-                 zipWith mk_tup_bind ticks' binders) }
+               = (binder, mkOptTickBox tick $
+                          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 []
+    pat' = strip_bangs pat
+           -- Strip the bangs before looking for case (A) or (B)
+           -- The incoming pattern may well have a bang on it
+
+    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 p = is_simple_pat (unLoc p)
-
-    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_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
+strip_bangs :: LPat a -> LPat a
+-- Remove outermost bangs and parens
+strip_bangs (L _ (ParPat _ p))  = strip_bangs p
+strip_bangs (L _ (BangPat _ p)) = strip_bangs p
+strip_bangs lp                  = lp
 
-{-
-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.
--}
+is_flat_prod_lpat :: LPat a -> Bool
+is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
 
-mkLHsPatTup :: [LPat Id] -> LPat Id
+is_flat_prod_pat :: Pat a -> Bool
+is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p
+is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps
+is_flat_prod_pat (ConPatOut { pat_con  = L _ pcon, pat_args = ps})
+  | RealDataCon con <- pcon
+  , isProductTyCon (dataConTyCon con)
+  = all is_triv_lpat (hsConPatArgs ps)
+is_flat_prod_pat _ = False
+
+is_triv_lpat :: LPat a -> Bool
+is_triv_lpat p = is_triv_pat (unLoc p)
+
+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.
+*                                                                      *
+********************************************************************* -}
+
+mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc
 mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed
 mkLHsPatTup [lpat] = lpat
 mkLHsPatTup lpats  = L (getLoc (head lpats)) $
                      mkVanillaTuplePat lpats Boxed
 
-mkLHsVarPatTup :: [Id] -> LPat Id
+mkLHsVarPatTup :: [Id] -> LPat GhcTc
 mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)
 
-mkVanillaTuplePat :: [OutPat Id] -> Boxity -> Pat Id
+mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
 -- A vanilla tuple pattern simply gets its type from its sub-patterns
-mkVanillaTuplePat pats box = TuplePat pats box (map hsLPatType pats)
+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
 
 -- The Big equivalents for the source tuple expressions
-mkBigLHsVarTupId :: [Id] -> LHsExpr Id
+mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
 mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
 
-mkBigLHsTupId :: [LHsExpr Id] -> LHsExpr Id
+mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc
 mkBigLHsTupId = mkChunkified mkLHsTupleExpr
 
 -- The Big equivalents for the source tuple patterns
-mkBigLHsVarPatTupId :: [Id] -> LPat Id
+mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc
 mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
 
-mkBigLHsPatTupId :: [LPat Id] -> LPat Id
+mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
 mkBigLHsPatTupId = mkChunkified mkLHsPatTup
 
 {-
@@ -800,6 +829,15 @@ for the primitive case:
 \end{verbatim}
 
 Now @fail.33@ is a function, so it can be let-bound.
+
+We would *like* to use join points here; in fact, these "fail variables" are
+paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as
+CPS functions - i.e. they take "join points" as parameters. It's not impossible
+to imagine extending our type system to allow passing join points around (very
+carefully), but we certainly don't support it now.
+
+99.99% of the time, the fail variables wind up as join points in short order
+anyway, and the Void# doesn't do much harm.
 -}
 
 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
@@ -819,6 +857,11 @@ mkFailurePair expr
 {-
 Note [Failure thunks and CPR]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+(This note predates join points as formal entities (hence the quotation marks).
+We can't use actual join points here (see above); if we did, this would also
+solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR
+join points] in WorkWrap.)
+
 When we make a failure point we ensure that it
 does not look like a thunk. Example:
 
@@ -863,26 +906,63 @@ mkBinaryTickBox ixT ixF e = do
 
 -- *******************************************************************
 
+{- Note [decideBangHood]
+~~~~~~~~~~~~~~~~~~~~~~~~
+With -XStrict we may make /outermost/ patterns more strict.
+E.g.
+       let (Just x) = e in ...
+          ==>
+       let !(Just x) = e in ...
+and
+       f x = e
+          ==>
+       f !x = e
+
+This adjustment is done by decideBangHood,
+
+  * Just before constructing an EqnInfo, in Match
+      (matchWrapper and matchSinglePat)
+
+  * When desugaring a pattern-binding in DsBinds.dsHsBind
+
+Note that it is /not/ done recursively.  See the -XStrict
+spec in the user manual.
+
+Specifically:
+   ~pat    => pat    -- when -XStrict (even if pat = ~pat')
+   !pat    => !pat   -- always
+   pat     => !pat   -- when -XStrict
+   pat     => pat    -- otherwise
+-}
+
 
--- | Remove any bang from a pattern and say if it is a strict bind,
--- also make irrefutable patterns ordinary patterns if -XStrict.
---
--- Example:
--- ~pat    => False, pat -- when -XStrict
--- ~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 Opt_Strict dflags
-  = (False,p)
-getUnBangedLPat dflags p
-  = (xopt Opt_Strict dflags,p)
+-- | Use -XStrict to add a ! or remove a ~
+-- See Note [decideBangHood]
+decideBangHood :: DynFlags
+               -> LPat GhcTc  -- ^ Original pattern
+               -> LPat GhcTc  -- Pattern with bang if necessary
+decideBangHood dflags lpat
+  | not (xopt LangExt.Strict dflags)
+  = lpat
+  | otherwise   --  -XStrict
+  = go lpat
+  where
+    go lp@(L l p)
+      = case p of
+           ParPat x p    -> L l (ParPat x (go p))
+           LazyPat _ lp' -> lp'
+           BangPat _ _   -> lp
+           _             -> L l (BangPat noExt lp)
+
+-- | Unconditionally make a 'Pat' strict.
+addBang :: LPat GhcTc -- ^ Original pattern
+        -> LPat GhcTc -- ^ Banged pattern
+addBang = go
+  where
+    go lp@(L l p)
+      = case p of
+           ParPat x p    -> L l (ParPat x (go p))
+           LazyPat _ lp' -> L l (BangPat noExt lp')
+                                  -- Should we bring the extension value over?
+           BangPat _ _   -> lp
+           _             -> L l (BangPat noExt lp)