Small refactor in desugar of pattern matching
[ghc.git] / compiler / deSugar / DsUtils.hs
index bce5186..f74be0b 100644 (file)
@@ -9,6 +9,8 @@ This module exports some utility functions of no great interest.
 -}
 
 {-# LANGUAGE CPP #-}
 -}
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 -- | Utility functions for constructing Core syntax, principally for desugaring
 module DsUtils (
 
 -- | Utility functions for constructing Core syntax, principally for desugaring
 module DsUtils (
@@ -35,20 +37,21 @@ module DsUtils (
         mkSelectorBinds,
 
         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
         mkSelectorBinds,
 
         selectSimpleMatchVarL, selectMatchVars, selectMatchVar,
-        mkOptTickBox, mkBinaryTickBox
+        mkOptTickBox, mkBinaryTickBox, decideBangHood, addBang
     ) where
 
 #include "HsVersions.h"
 
     ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}   Match ( matchSimply )
+import GhcPrelude
+
+import {-# SOURCE #-} Match  ( matchSimply )
+import {-# SOURCE #-} DsExpr ( dsLExpr )
 
 import HsSyn
 import TcHsSyn
 
 import HsSyn
 import TcHsSyn
-import Coercion( Coercion, isReflCo )
 import TcType( tcSplitTyConApp )
 import CoreSyn
 import DsMonad
 import TcType( tcSplitTyConApp )
 import CoreSyn
 import DsMonad
-import {-# SOURCE #-} DsExpr ( dsLExpr )
 
 import CoreUtils
 import MkCore
 
 import CoreUtils
 import MkCore
@@ -56,22 +59,25 @@ import MkId
 import Id
 import Literal
 import TyCon
 import Id
 import Literal
 import TyCon
-import ConLike
 import DataCon
 import PatSyn
 import Type
 import DataCon
 import PatSyn
 import Type
+import Coercion
 import TysPrim
 import TysWiredIn
 import BasicTypes
 import TysPrim
 import TysWiredIn
 import BasicTypes
+import ConLike
 import UniqSet
 import UniqSupply
 import Module
 import PrelNames
 import UniqSet
 import UniqSupply
 import Module
 import PrelNames
+import Name( isInternalName )
 import Outputable
 import SrcLoc
 import Util
 import DynFlags
 import FastString
 import Outputable
 import SrcLoc
 import Util
 import DynFlags
 import FastString
+import qualified GHC.LanguageExtensions as LangExt
 
 import TcEvidence
 
 
 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.
 -}
 
 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
 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
 
 --    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
 
 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...
 
                                   -- 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
 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.
 
 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.
 -}
 
 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]
 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)
 
 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 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
 
 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))
 
   = 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
 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,
             return (LitAlt lit, [], body)
 
 data CaseAlt a = MkCaseAlt{ alt_pat :: a,
-                            alt_bndrs :: [CoreBndr],
+                            alt_bndrs :: [Var],
                             alt_wrapper :: HsWrapper,
                             alt_result :: MatchResult }
 
 mkCoAlgCaseMatchResult
                             alt_wrapper :: HsWrapper,
                             alt_result :: MatchResult }
 
 mkCoAlgCaseMatchResult
-  :: DynFlags
-  -> Id                 -- Scrutinee
+  :: Id                 -- Scrutinee
   -> Type               -- Type of exp
   -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)
   -> MatchResult
   -> 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
 
   | 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
   | 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)
 
                                                 -- (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
 
 mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult
 mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt
 
@@ -340,10 +319,11 @@ sort_alts = sortWith (dataConTag . alt_pat)
 
 mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr
 mkPatSynCase var ty alt fail = do
 
 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
     let MatchResult _ mkCont = match_result
     cont <- mkCoreLams bndrs <$> mkCont fail
-    return $ mkCoreAppsDs matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
+    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
   where
     MkCaseAlt{ alt_pat = psyn,
                alt_bndrs = bndrs,
@@ -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
 
         = 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]
-
 {-
 ************************************************************************
 *                                                                      *
 {-
 ************************************************************************
 *                                                                      *
@@ -463,10 +401,10 @@ mkErrorAppDs err_id ty msg = do
     src_loc <- getSrcSpanDs
     dflags <- getDynFlags
     let
     src_loc <- getSrcSpanDs
     dflags <- getDynFlags
     let
-        full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg])
+        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
         core_msg = Lit (mkMachString full_msg)
         -- mkMachString returns a result of type String#
         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'.
 
 {-
 'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.
@@ -536,22 +474,25 @@ into
 which stupidly tries to bind the datacon 'True'.
 -}
 
 which stupidly tries to bind the datacon 'True'.
 -}
 
-mkCoreAppDs  :: CoreExpr -> CoreExpr -> CoreExpr
-mkCoreAppDs (Var f `App` Type ty1 `App` Type ty2 `App` arg1) arg2
+-- 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
   | 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 fun arg = mkCoreApp fun arg  -- The rest is done in MkCore
+mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore
 
 
-mkCoreAppsDs :: CoreExpr -> [CoreExpr] -> CoreExpr
-mkCoreAppsDs fun args = foldl mkCoreAppDs fun args
+-- 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
 
 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
 -- because in the immediate output of the desugarer, we can have
 -- apparently-mis-matched coercions:  E.g.
 --     let a = b
@@ -587,147 +528,251 @@ expressions.
 
 Note [mkSelectorBinds]
 ~~~~~~~~~~~~~~~~~~~~~~
 
 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 :: [[Tickish Id]] -- ticks to add, possibly
-                -> LPat Id      -- The pattern
-                -> CoreExpr     -- Expression to which the pattern is bound
-                -> DsM [(Id,CoreExpr)]
-
-mkSelectorBinds ticks (L _ (VarPat v)) val_expr
-  = return [(v, case ticks of
-                  [t] -> mkOptTickBox t val_expr
-                  _   -> val_expr)]
+mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly
+                -> LPat GhcTc     -- ^ The pattern
+                -> CoreExpr       -- ^ Expression to which the pattern is bound
+                -> 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 pat val_expr
 
 mkSelectorBinds ticks pat val_expr
-  | null binders
-  = return []
-
-  | 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 ( (val_var, val_expr) :
-                  (err_var, Lam alphaTyVar err_app) :
-                  binds ) }
-
-  | otherwise
-  = do { error_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID   tuple_ty (ppr pat)
-       ; tuple_expr <- matchSimply val_expr PatBindRhs pat local_tuple error_expr
-       ; tuple_var <- newSysLocalDs tuple_ty
+  | 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
        ; let mk_tup_bind tick binder
-              = (binder, mkOptTickBox tick $
-                            mkTupleSelector local_binders binder
-                                            tuple_var (Var tuple_var))
-       ; return ( (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
   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_binders = map localiseId binders      -- See Note [Localise pattern binders]
-    local_tuple   = mkBigCoreVarTup binders
+    local_tuple   = mkBigCoreVarTup1 binders
     tuple_ty      = exprType local_tuple
 
     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
+
+is_flat_prod_lpat :: LPat a -> Bool
+is_flat_prod_lpat p = is_flat_prod_pat (unLoc p)
+
+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 Id] -> LPat Id
+{- *********************************************************************
+*                                                                      *
+  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
 
 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)
 
 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
 -- 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
 
 -- The Big equivalents for the source tuple expressions
-mkBigLHsVarTupId :: [Id] -> LHsExpr Id
+mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
 mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)
 
 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
 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)
 
 mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)
 
-mkBigLHsPatTupId :: [LPat Id] -> LPat Id
+mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc
 mkBigLHsPatTupId = mkChunkified mkLHsPatTup
 
 {-
 mkBigLHsPatTupId = mkChunkified mkLHsPatTup
 
 {-
@@ -784,6 +829,15 @@ for the primitive case:
 \end{verbatim}
 
 Now @fail.33@ is a function, so it can be let-bound.
 \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
 -}
 
 mkFailurePair :: CoreExpr       -- Result type of the whole case expression
@@ -803,6 +857,11 @@ mkFailurePair expr
 {-
 Note [Failure thunks and CPR]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 {-
 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:
 
 When we make a failure point we ensure that it
 does not look like a thunk. Example:
 
@@ -842,3 +901,68 @@ mkBinaryTickBox ixT ixF e = do
                        [ (DataAlt falseDataCon, [], falseBox)
                        , (DataAlt trueDataCon,  [], trueBox)
                        ]
                        [ (DataAlt falseDataCon, [], falseBox)
                        , (DataAlt trueDataCon,  [], trueBox)
                        ]
+
+
+
+-- *******************************************************************
+
+{- 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
+-}
+
+
+-- | 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)