Use NoGen plan for unboxed-tuple bindings

There was a small mixup here, exposed by Trac #8762.
Now clarified with better function names and comments.

compiler/deSugar/DsExpr.lhs

@@ -165,9 +165,9 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
 strictMatchOnly :: HsBind Id -> Bool
 strictMatchOnly (AbsBinds { abs_binds = binds })
   = anyBag (strictMatchOnly . unLoc . snd) binds
-strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty })
-  =  isUnLiftedType ty 
-  || isBangLPat lpat   
+strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
+  =  isUnLiftedType rhs_ty
+  || isStrictLPat lpat
   || any (isUnLiftedType . idType) (collectPatBinders lpat)
 strictMatchOnly (FunBind { fun_id = L _ id })
   = isUnLiftedType (idType id)

compiler/hsSyn/HsPat.lhs

@@ -16,8 +16,8 @@ module HsPat (
 
         mkPrefixConPat, mkCharLitPat, mkNilPat,
 
-        isBangHsBind, isLiftedPatBind,
-        isBangLPat, hsPatNeedsParens,
+        isStrictHsBind, looksLazyPatBind,
+        isStrictLPat, hsPatNeedsParens,
         isIrrefutableHsPat,
 
         pprParendLPat
@@ -358,34 +358,34 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-isBangLPat :: LPat id -> Bool
-isBangLPat (L _ (BangPat {})) = True
-isBangLPat (L _ (ParPat p))   = isBangLPat p
-isBangLPat _                  = False
-
-isBangHsBind :: HsBind id -> Bool
--- A pattern binding with an outermost bang
+isStrictLPat :: LPat id -> Bool
+isStrictLPat (L _ (ParPat p))             = isStrictLPat p
+isStrictLPat (L _ (BangPat {}))           = True
+isStrictLPat (L _ (TuplePat _ Unboxed _)) = True
+isStrictLPat _                            = False
+
+isStrictHsBind :: HsBind id -> Bool
+-- A pattern binding with an outermost bang or unboxed tuple must be matched strictly
 -- Defined in this module because HsPat is above HsBinds in the import graph
-isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p
-isBangHsBind _                         = False
-
-isLiftedPatBind :: HsBind id -> Bool
--- A pattern binding with a compound pattern, not just a variable
---    (I# x)       yes
---    (# a, b #)   no, even if a::Int#
---    x            no, even if x::Int#
--- We want to warn about a missing bang-pattern on the yes's
-isLiftedPatBind (PatBind { pat_lhs = p }) = isLiftedLPat p
-isLiftedPatBind _                         = False
-
-isLiftedLPat :: LPat id -> Bool
-isLiftedLPat (L _ (ParPat p))   = isLiftedLPat p
-isLiftedLPat (L _ (BangPat p))  = isLiftedLPat p
-isLiftedLPat (L _ (AsPat _ p))  = isLiftedLPat p
-isLiftedLPat (L _ (TuplePat _ Unboxed _)) = False
-isLiftedLPat (L _ (VarPat {}))            = False
-isLiftedLPat (L _ (WildPat {}))           = False
-isLiftedLPat _                            = True
+isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p
+isStrictHsBind _                         = False
+
+looksLazyPatBind :: HsBind id -> Bool
+-- Returns True of anything *except*
+--     a StrictHsBind (as above) or 
+--     a VarPat
+-- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
+looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p
+looksLazyPatBind _                         = False
+
+looksLazyLPat :: LPat id -> Bool
+looksLazyLPat (L _ (ParPat p))             = looksLazyLPat p
+looksLazyLPat (L _ (AsPat _ p))            = looksLazyLPat p
+looksLazyLPat (L _ (BangPat {}))           = False
+looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False
+looksLazyLPat (L _ (VarPat {}))            = False
+looksLazyLPat (L _ (WildPat {}))           = False
+looksLazyLPat _                            = True
 
 isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,

compiler/typecheck/TcBinds.lhs

@@ -1280,13 +1280,13 @@ instTcTySig hs_ty@(L loc _) sigma_ty name
 
     mk_scoped :: [Name] -> [TyVar] -> [Maybe Name]
     mk_scoped []     tvs      = [Nothing | _ <- tvs]
-    mk_scoped (n:ns) (tv:tvs) 
+    mk_scoped (n:ns) (tv:tvs)
            | n == tyVarName tv = Just n  : mk_scoped ns     tvs
            | otherwise         = Nothing : mk_scoped (n:ns) tvs
     mk_scoped (n:ns) [] = pprPanic "mk_scoped" (ppr name $$ ppr (n:ns) $$ ppr hs_ty $$ ppr sigma_ty)
 
 -------------------------------
-data GeneralisationPlan 
+data GeneralisationPlan
   = NoGen               -- No generalisation, no AbsBinds
 
   | InferGen            -- Implicit generalisation; there is an AbsBinds
@@ -1306,25 +1306,25 @@ instance Outputable GeneralisationPlan where
   ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c
   ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
 
-decideGeneralisationPlan 
+decideGeneralisationPlan
    :: DynFlags -> TcTypeEnv -> [Name]
    -> [(Origin, LHsBind Name)] -> TcSigFun -> GeneralisationPlan
 decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
-  | bang_pat_binds                                  = NoGen
+  | strict_pat_binds                                 = NoGen
   | Just (lbind, sig) <- one_funbind_with_sig lbinds = CheckGen lbind sig
-  | mono_local_binds                                = NoGen
-  | otherwise                                       = InferGen mono_restriction closed_flag
+  | mono_local_binds                                 = NoGen
+  | otherwise                                        = InferGen mono_restriction closed_flag
 
   where
     bndr_set = mkNameSet bndr_names
     binds = map (unLoc . snd) lbinds
 
-    bang_pat_binds = any isBangHsBind binds
-       -- Bang patterns must not be polymorphic,
-       -- because we are going to force them
-       -- See Trac #4498
+    strict_pat_binds = any isStrictHsBind binds
+       -- Strict patterns (top level bang or unboxed tuple) must not
+       -- be polymorphic, because we are going to force them
+       -- See Trac #4498, #8762
 
-    mono_restriction  = xopt Opt_MonomorphismRestriction dflags 
+    mono_restriction  = xopt Opt_MonomorphismRestriction dflags
                      && any restricted binds
 
     is_closed_ns :: NameSet -> Bool -> Bool
@@ -1333,7 +1333,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
 
     is_closed_id :: Name -> Bool
     -- See Note [Bindings with closed types] in TcRnTypes
-    is_closed_id name 
+    is_closed_id name
       | name `elemNameSet` bndr_set
       = True              -- Ignore binders in this groups, of course
       | Just thing <- lookupNameEnv type_env name
@@ -1346,12 +1346,12 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
       = WARN( isInternalName name, ppr name ) True
         -- The free-var set for a top level binding mentions
         -- imported things too, so that we can report unused imports
-        -- These won't be in the local type env.  
+        -- These won't be in the local type env.
         -- Ditto class method etc from the current module
-    
+
     closed_flag = foldr (is_closed_ns . bind_fvs) True binds
 
-    mono_local_binds = xopt Opt_MonoLocalBinds dflags 
+    mono_local_binds = xopt Opt_MonoLocalBinds dflags
                     && not closed_flag
 
     no_sig n = isNothing (sig_fn n)
@@ -1385,45 +1385,42 @@ checkStrictBinds :: TopLevelFlag -> RecFlag
                  -> TcM ()
 -- Check that non-overloaded unlifted bindings are
 --      a) non-recursive,
---      b) not top level, 
+--      b) not top level,
 --      c) not a multiple-binding group (more or less implied by (a))
 
 checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
-  | unlifted || bang_pat
+  | unlifted_bndrs || any_strict_pat   -- This binding group must be matched strictly
   = do  { checkTc (isNotTopLevel top_lvl)
-                  (strictBindErr "Top-level" unlifted orig_binds)
+                  (strictBindErr "Top-level" unlifted_bndrs orig_binds)
         ; checkTc (isNonRec rec_group)
-                  (strictBindErr "Recursive" unlifted orig_binds)
+                  (strictBindErr "Recursive" unlifted_bndrs orig_binds)
 
         ; checkTc (all is_monomorphic (bagToList tc_binds))
                   (polyBindErr orig_binds)
             -- data Ptr a = Ptr Addr#
             -- f x = let p@(Ptr y) = ... in ...
-            -- Here the binding for 'p' is polymorphic, but does 
+            -- Here the binding for 'p' is polymorphic, but does
             -- not mix with an unlifted binding for 'y'.  You should
             -- use a bang pattern.  Trac #6078.
-        
+
         ; checkTc (isSingleton orig_binds)
-                  (strictBindErr "Multiple" unlifted orig_binds)
-
-        -- Ensure that unlifted bindings which look lazy, like:
-        --   f x = let I# y = x
-        -- cause an error.
-        ; when lifted_pat $
-            checkTc bang_pat
-                 -- No outer bang, but it's a compound pattern
-                 -- E.g   (I# x#) = blah
-                 -- Warn about this, but not about
-                 --      x# = 4# +# 1#
-                 --      (# a, b #) = ...
-                 (unliftedMustBeBang orig_binds) }
+                  (strictBindErr "Multiple" unlifted_bndrs orig_binds)
+
+        -- Complain about a binding that looks lazy
+        --    e.g.    let I# y = x in ...
+        -- Remember, in checkStrictBinds we are going to do strict
+        -- matching, so (for software engineering reasons) we insist
+        -- that the strictness is manifest on each binding
+        -- However, lone (unboxed) variables are ok
+        ; checkTc (not any_pat_looks_lazy)
+                  (unliftedMustBeBang orig_binds) }
   | otherwise
   = traceTc "csb2" (ppr poly_ids) >>
     return ()
   where
-    unlifted    = any is_unlifted poly_ids
-    bang_pat    = any (isBangHsBind    . unLoc . snd) orig_binds
-    lifted_pat  = any (isLiftedPatBind . unLoc . snd) orig_binds
+    unlifted_bndrs     = any is_unlifted poly_ids
+    any_strict_pat     = any (isStrictHsBind   . unLoc . snd) orig_binds
+    any_pat_looks_lazy = any (looksLazyPatBind . unLoc . snd) orig_binds
 
     is_unlifted id = case tcSplitForAllTys (idType id) of
                        (_, rho) -> isUnLiftedType rho
@@ -1444,12 +1441,12 @@ polyBindErr binds
                 ptext (sLit "Probable fix: use a bang pattern")])
 
 strictBindErr :: String -> Bool -> [(Origin, LHsBind Name)] -> SDoc
-strictBindErr flavour unlifted binds
+strictBindErr flavour unlifted_bndrs binds
   = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:")) 
        2 (vcat (map (ppr . snd) binds))
   where
-    msg | unlifted  = ptext (sLit "bindings for unlifted types")
-        | otherwise = ptext (sLit "bang-pattern bindings")
+    msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types")
+        | otherwise      = ptext (sLit "bang-pattern or unboxed-tuple bindings")
 \end{code}
 
 

testsuite/tests/typecheck/should_compile/T8762.hs

+{-# LANGUAGE UnboxedTuples #-}
+module T8762 where
+
+type Ty a = Int
+
+bug :: Ty a -> (# Ty a, () #)
+bug ty = (# ty, () #)
+
+foo = let (# a, b #) = bug undefined
+      in ()

testsuite/tests/typecheck/should_compile/all.T

@@ -415,3 +415,4 @@ test('T8474', normal, compile, [''])
 test('T8563', normal, compile, [''])
 test('T8565', normal, compile, [''])
 test('T8644', normal, compile, [''])
+test('T8762', normal, compile, [''])