Fix and refactor strict pattern bindings
authorSimon Peyton Jones <simonpj@microsoft.com>
Thu, 25 Feb 2016 15:53:03 +0000 (15:53 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 26 Feb 2016 17:14:59 +0000 (17:14 +0000)
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

12 files changed:
compiler/coreSyn/CoreLint.hs
compiler/coreSyn/MkCore.hs
compiler/deSugar/DsBinds.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs
compiler/prelude/TysWiredIn.hs
docs/users_guide/glasgow_exts.rst
libraries/ghc-prim/GHC/Tuple.hs
testsuite/tests/deSugar/should_compile/T5455.stderr
testsuite/tests/deSugar/should_run/T11601.hs [new file with mode: 0644]
testsuite/tests/deSugar/should_run/T11601.stderr [new file with mode: 0644]
testsuite/tests/deSugar/should_run/all.T

index f5d0f84..90e68e8 100644 (file)
@@ -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
 
index 0eccccc..dbb3d45 100644 (file)
@@ -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)]
@@ -496,6 +520,29 @@ mkSmallTupleCase vars body scrut_var scrut
 {-
 ************************************************************************
 *                                                                      *
+                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)]
+
+{-
+************************************************************************
+*                                                                      *
 \subsection{Common list manipulation expressions}
 *                                                                      *
 ************************************************************************
index 420090d..72b74c7 100644 (file)
@@ -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) }
 
index ece50d8..2e76c93 100644 (file)
@@ -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
index be089e6..763b04f 100644 (file)
@@ -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
 
         ; result_expr <- handleWarnings $
                          matchEquations ctxt new_vars eqns_info rhs_ty
@@ -704,12 +702,12 @@ matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches
   where
     mk_eqn_info vars (L _ (Match _ pats _ grhss))
       = do { dflags <- getDynFlags
-           ; let upats = map (getMaybeStrictPat dflags) pats
+           ; let upats = map (unLoc . decideBangHood dflags) pats
                  dicts = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
            ; tm_cs <- genCaseTmCs2 mb_scr upats vars
-           ; match_result <- addDictsDs dicts $  -- See Note [Type and Term Equality Propagation]
-                               addTmCsDs tm_cs $ -- See Note [Type and Term Equality Propagation]
-                                 dsGRHSs ctxt upats grhss rhs_ty
+           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]
+                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]
+                             dsGRHSs ctxt upats grhss rhs_ty
            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
 
     handleWarnings = if isGenerated origin
@@ -763,23 +761,18 @@ matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
 matchSinglePat (Var var) ctx pat ty match_result
   = do { dflags <- getDynFlags
        ; locn   <- getSrcSpanDs
-       ; let pat' = getMaybeStrictPat dflags pat
-       -- pattern match check warnings
-       ; checkSingle dflags (DsMatchContext ctx locn) var pat'
+                    -- Pattern match check warnings
+       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)
 
-       ; match [var] ty
-               [EqnInfo { eqn_pats = [pat'], eqn_rhs  = match_result }] }
+       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]
+                                , eqn_rhs  = match_result }
+       ; match [var] ty [eqn_info] }
 
 matchSinglePat scrut hs_ctx pat ty match_result
   = do { var <- selectSimpleMatchVarL pat
        ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result
        ; return (adjustMatchResult (bindNonRec var scrut) match_result') }
 
-getMaybeStrictPat :: DynFlags -> LPat Id -> Pat Id
-getMaybeStrictPat dflags pat =
-  let (is_strict, pat') = getUnBangedLPat dflags pat
-  in if is_strict then BangPat pat' else unLoc pat'
-
 
 {-
 ************************************************************************
index 6f0fc56..c58bf32 100644 (file)
@@ -513,6 +513,32 @@ Note [How tuples work]  See also Note [Known-key names] in PrelNames
   we get the right wired-in name.  This guy can't tell the difference
   between BoxedTuple and ConstraintTuple (same OccName!), so tuples
   are not serialised into interface files using OccNames at all.
+
+Note [One-tuples]
+~~~~~~~~~~~~~~~~~
+GHC supports both boxed and unboxed one-tuples:
+ - Unboxed one-tuples are sometimes useful when returning a
+   single value after CPR analysis
+ - A boxed one-tuple is used by DsUtils.mkSelectorBinds, when
+   there is just one binder
+Basically it keeps everythig uniform.
+
+However the /naming/ of the type/data constructors for one-tuples is a
+bit odd:
+  3-tuples:  (,,)   (,,)#
+  2-tuples:  (,)    (,)#
+  1-tuples:  ??
+  0-tuples:  ()     ()#
+
+Zero-tuples have used up the logical name. So we use 'Unit' and 'Unit#'
+for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:
+  data ()     = ()
+  data Unit a = Unit a
+  data (a,b)  = (a,b)
+
+NB (Feb 16): for /constraint/ one-tuples I have 'Unit%' but no class
+decl in GHC.Classes, so I think this part may not work properly. But
+it's unused I think.
 -}
 
 isBuiltInOcc_maybe :: OccName -> Maybe Name
@@ -550,20 +576,30 @@ isBuiltInOcc_maybe occ
       | otherwise             = pprPanic "tup_name" (ppr occ)
 
 mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName
-mkTupleOcc ns sort ar = mkOccName ns str
-  where
-    -- No need to cache these, the caching is done in mk_tuple
-    str = case sort of
-                Unboxed    -> '(' : '#' : commas ++ "#)"
-                Boxed      -> '(' : commas ++ ")"
-
-    commas = take (ar-1) (repeat ',')
+-- No need to cache these, the caching is done in mk_tuple
+mkTupleOcc ns Boxed   ar = mkOccName ns (mkBoxedTupleStr   ar)
+mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar)
 
 mkCTupleOcc :: NameSpace -> Arity -> OccName
-mkCTupleOcc ns ar = mkOccName ns str
-  where
-    str    = "(%" ++ commas ++ "%)"
-    commas = take (ar-1) (repeat ',')
+mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)
+
+mkBoxedTupleStr :: Arity -> String
+mkBoxedTupleStr 0  = "()"
+mkBoxedTupleStr 1  = "Unit"   -- See Note [One-tuples]
+mkBoxedTupleStr ar = '(' : commas ar ++ ")"
+
+mkUnboxedTupleStr :: Arity -> String
+mkUnboxedTupleStr 0  = "(##)"
+mkUnboxedTupleStr 1  = "Unit#"  -- See Note [One-tuples]
+mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)"
+
+mkConstraintTupleStr :: Arity -> String
+mkConstraintTupleStr 0  = "(%%)"
+mkConstraintTupleStr 1  = "Unit%"   -- See Note [One-tuples]
+mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)"
+
+commas :: Arity -> String
+commas ar = take (ar-1) (repeat ',')
 
 cTupleTyConName :: Arity -> Name
 cTupleTyConName arity
index 59e8b62..454c73e 100644 (file)
@@ -10816,13 +10816,13 @@ add a new case (t): ::
 That leaves let expressions, whose translation is given in `Section
 3.12 <http://www.haskell.org/onlinereport/exps.html#sect3.12>`__ of the
 Haskell Report.
-Replace these rules with the following ones, where ``v`` stands for a
-variable:
+Replace the "Translation" there with the following one.  Given
+``let { bind1 ... bindn } in body``:
 
 .. admonition:: FORCE
 
-    Replace any binding ``!p = e`` with ``v = e; p = v`` and replace
-    ``e0`` with ``v seq e0``, where ``v`` is fresh. This translation works fine if
+    Replace any binding ``!p = e`` with ``v = case e of p -> (x1, ..., xn); (x1, ..., xn) = v`` and replace
+    ``body`` with ``v seq body``, where ``v`` is fresh. This translation works fine if
     ``p`` is already a variable ``x``, but can obviously be optimised by not
     introducing a fresh variable ``v``.
 
@@ -10865,41 +10865,43 @@ Here is a simple non-recursive case: ::
 
 Same again, only with a pattern binding: ::
 
-    let !(x,y) = if blob then (factorial p, factorial q) else (0,0)
-    in body
+    let !(Just x, Left y) = e in body
 
     ===> (FORCE)
-        let v = if blob then (factorial p, factorial q) else (0,0)
+        let v = case e of (Just x, Left y) -> (x,y)
             (x,y) = v
         in v `seq` body
 
     ===> (SPLIT)
-        let v = if blob then (factorial p, factorial q) else (0,0)
+        let v = case e of (Just x, Left y) -> (x,y)
             x = case v of (x,y) -> x
             y = case v of (x,y) -> y
         in v `seq` body
 
     ===> (inline seq, float x,y bindings inwards)
-        let v = if blob then (factorial p, factorial q) else (0,0)
+        let v = case e of (Just x, Left y) -> (x,y)
         in case v of v -> let x = case v of (x,y) -> x
-                                y = case v of (x,y) -> y
-                            in body
+                              y = case v of (x,y) -> y
+                          in body
 
     ===> (fluff up v's pattern; this is a standard Core optimisation)
-        let v = if blob then (factorial p, factorial q) else (0,0)
+        let v = case e of (Just x, Left y) -> (x,y)
         in case v of v@(p,q) -> let x = case v of (x,y) -> x
                                     y = case v of (x,y) -> y
                                 in body
 
     ===> (case of known constructor)
-        let v = if blob then (factorial p, factorial q) else (0,0)
+        let v = case e of (Just x, Left y) -> (x,y)
         in case v of v@(p,q) -> let x = p
                                     y = q
                                 in body
 
-    ===> (inline x,y)
-        let v = if blob then (factorial p, factorial q) else (0,0)
-        in case v of (p,q) -> body[p/x, q/y]
+    ===> (inline x,y, v)
+        case (case e of (Just x, Left y) -> (x,y) of
+            (p,q) -> body[p/x, q/y]
+
+    ===> (case of case)
+        case e of (Just x, Left y) -> body[p/x, q/y]
 
 The final form is just what we want: a simple case expression.
 
index b08d0b4..05d6fbf 100644 (file)
@@ -26,6 +26,11 @@ default () -- Double and Integer aren't available yet
 -- constructor @()@.
 data () = ()
 
+-- The desugarer uses 1-tuples,
+-- but "()" is already used up for 0-tuples
+-- See Note [One-tuples] in TysWiredIn
+data Unit a = Unit a
+
 data (a,b) = (a,b)
 data (a,b,c) = (a,b,c)
 data (a,b,c,d) = (a,b,c,d)
index 9ff56b5..e4214ae 100644 (file)
@@ -1,4 +1,8 @@
 
-T5455.hs:13:13:
-    Warning: Pattern match(es) are non-exhaustive
-             In a pattern binding: Patterns not matched: []
+T5455.hs:8:11: warning:
+    Pattern match(es) are non-exhaustive
+    In a pattern binding: Patterns not matched: []
+
+T5455.hs:13:13: warning:
+    Pattern match(es) are non-exhaustive
+    In a pattern binding: Patterns not matched: []
diff --git a/testsuite/tests/deSugar/should_run/T11601.hs b/testsuite/tests/deSugar/should_run/T11601.hs
new file mode 100644 (file)
index 0000000..f12c060
--- /dev/null
@@ -0,0 +1,8 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Main where
+
+-- This should fail evern though y is unused
+f x = let !(Just (Just y)) = Just undefined in True
+
+main = print (f False)
diff --git a/testsuite/tests/deSugar/should_run/T11601.stderr b/testsuite/tests/deSugar/should_run/T11601.stderr
new file mode 100644 (file)
index 0000000..6db78c0
--- /dev/null
@@ -0,0 +1,5 @@
+T11601: Prelude.undefined
+CallStack (from HasCallStack):
+  error, called at libraries/base/GHC/Err.hs:79:14 in base:GHC.Err
+  undefined, called at T11601.hs:6:35 in main:Main
+  f, called at T11601.hs:8:15 in main:Main
index 265580a..c8a9c93 100644 (file)
@@ -51,3 +51,4 @@ test('DsStrict', normal, compile_and_run, [''])
 test('DsStrictLet', normal, compile_and_run, ['-O'])
 test('T11193', exit_code(1), compile_and_run, [''])
 test('T11572', exit_code(1), compile_and_run, [''])
+test('T11601', exit_code(1), compile_and_run, [''])