Commit 47f473b0 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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.
parent 2931d19e
...@@ -165,9 +165,9 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ...@@ -165,9 +165,9 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
strictMatchOnly :: HsBind Id -> Bool strictMatchOnly :: HsBind Id -> Bool
strictMatchOnly (AbsBinds { abs_binds = binds }) strictMatchOnly (AbsBinds { abs_binds = binds })
= anyBag (strictMatchOnly . unLoc . snd) binds = anyBag (strictMatchOnly . unLoc . snd) binds
strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = ty }) strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
= isUnLiftedType ty = isUnLiftedType rhs_ty
|| isBangLPat lpat || isStrictLPat lpat
|| any (isUnLiftedType . idType) (collectPatBinders lpat) || any (isUnLiftedType . idType) (collectPatBinders lpat)
strictMatchOnly (FunBind { fun_id = L _ id }) strictMatchOnly (FunBind { fun_id = L _ id })
= isUnLiftedType (idType id) = isUnLiftedType (idType id)
......
...@@ -16,8 +16,8 @@ module HsPat ( ...@@ -16,8 +16,8 @@ module HsPat (
mkPrefixConPat, mkCharLitPat, mkNilPat, mkPrefixConPat, mkCharLitPat, mkNilPat,
isBangHsBind, isLiftedPatBind, isStrictHsBind, looksLazyPatBind,
isBangLPat, hsPatNeedsParens, isStrictLPat, hsPatNeedsParens,
isIrrefutableHsPat, isIrrefutableHsPat,
pprParendLPat pprParendLPat
...@@ -358,34 +358,34 @@ patterns are treated specially, of course. ...@@ -358,34 +358,34 @@ patterns are treated specially, of course.
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
\begin{code} \begin{code}
isBangLPat :: LPat id -> Bool isStrictLPat :: LPat id -> Bool
isBangLPat (L _ (BangPat {})) = True isStrictLPat (L _ (ParPat p)) = isStrictLPat p
isBangLPat (L _ (ParPat p)) = isBangLPat p isStrictLPat (L _ (BangPat {})) = True
isBangLPat _ = False isStrictLPat (L _ (TuplePat _ Unboxed _)) = True
isStrictLPat _ = False
isBangHsBind :: HsBind id -> Bool
-- A pattern binding with an outermost bang 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 -- Defined in this module because HsPat is above HsBinds in the import graph
isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p isStrictHsBind (PatBind { pat_lhs = p }) = isStrictLPat p
isBangHsBind _ = False isStrictHsBind _ = False
isLiftedPatBind :: HsBind id -> Bool looksLazyPatBind :: HsBind id -> Bool
-- A pattern binding with a compound pattern, not just a variable -- Returns True of anything *except*
-- (I# x) yes -- a StrictHsBind (as above) or
-- (# a, b #) no, even if a::Int# -- a VarPat
-- x no, even if x::Int# -- In particular, returns True of a pattern binding with a compound pattern, like (I# x)
-- We want to warn about a missing bang-pattern on the yes's looksLazyPatBind (PatBind { pat_lhs = p }) = looksLazyLPat p
isLiftedPatBind (PatBind { pat_lhs = p }) = isLiftedLPat p looksLazyPatBind _ = False
isLiftedPatBind _ = False
looksLazyLPat :: LPat id -> Bool
isLiftedLPat :: LPat id -> Bool looksLazyLPat (L _ (ParPat p)) = looksLazyLPat p
isLiftedLPat (L _ (ParPat p)) = isLiftedLPat p looksLazyLPat (L _ (AsPat _ p)) = looksLazyLPat p
isLiftedLPat (L _ (BangPat p)) = isLiftedLPat p looksLazyLPat (L _ (BangPat {})) = False
isLiftedLPat (L _ (AsPat _ p)) = isLiftedLPat p looksLazyLPat (L _ (TuplePat _ Unboxed _)) = False
isLiftedLPat (L _ (TuplePat _ Unboxed _)) = False looksLazyLPat (L _ (VarPat {})) = False
isLiftedLPat (L _ (VarPat {})) = False looksLazyLPat (L _ (WildPat {})) = False
isLiftedLPat (L _ (WildPat {})) = False looksLazyLPat _ = True
isLiftedLPat _ = True
isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool
-- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- (isIrrefutableHsPat p) is true if matching against p cannot fail,
......
...@@ -1280,13 +1280,13 @@ instTcTySig hs_ty@(L loc _) sigma_ty name ...@@ -1280,13 +1280,13 @@ instTcTySig hs_ty@(L loc _) sigma_ty name
mk_scoped :: [Name] -> [TyVar] -> [Maybe Name] mk_scoped :: [Name] -> [TyVar] -> [Maybe Name]
mk_scoped [] tvs = [Nothing | _ <- tvs] 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 | n == tyVarName tv = Just n : mk_scoped ns tvs
| otherwise = Nothing : mk_scoped (n: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) 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 = NoGen -- No generalisation, no AbsBinds
| InferGen -- Implicit generalisation; there is an AbsBinds | InferGen -- Implicit generalisation; there is an AbsBinds
...@@ -1306,25 +1306,25 @@ instance Outputable GeneralisationPlan where ...@@ -1306,25 +1306,25 @@ instance Outputable GeneralisationPlan where
ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c ppr (InferGen b c) = ptext (sLit "InferGen") <+> ppr b <+> ppr c
ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s ppr (CheckGen _ s) = ptext (sLit "CheckGen") <+> ppr s
decideGeneralisationPlan decideGeneralisationPlan
:: DynFlags -> TcTypeEnv -> [Name] :: DynFlags -> TcTypeEnv -> [Name]
-> [(Origin, LHsBind Name)] -> TcSigFun -> GeneralisationPlan -> [(Origin, LHsBind Name)] -> TcSigFun -> GeneralisationPlan
decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn 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 | Just (lbind, sig) <- one_funbind_with_sig lbinds = CheckGen lbind sig
| mono_local_binds = NoGen | mono_local_binds = NoGen
| otherwise = InferGen mono_restriction closed_flag | otherwise = InferGen mono_restriction closed_flag
where where
bndr_set = mkNameSet bndr_names bndr_set = mkNameSet bndr_names
binds = map (unLoc . snd) lbinds binds = map (unLoc . snd) lbinds
bang_pat_binds = any isBangHsBind binds strict_pat_binds = any isStrictHsBind binds
-- Bang patterns must not be polymorphic, -- Strict patterns (top level bang or unboxed tuple) must not
-- because we are going to force them -- be polymorphic, because we are going to force them
-- See Trac #4498 -- See Trac #4498, #8762
mono_restriction = xopt Opt_MonomorphismRestriction dflags mono_restriction = xopt Opt_MonomorphismRestriction dflags
&& any restricted binds && any restricted binds
is_closed_ns :: NameSet -> Bool -> Bool is_closed_ns :: NameSet -> Bool -> Bool
...@@ -1333,7 +1333,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn ...@@ -1333,7 +1333,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
is_closed_id :: Name -> Bool is_closed_id :: Name -> Bool
-- See Note [Bindings with closed types] in TcRnTypes -- See Note [Bindings with closed types] in TcRnTypes
is_closed_id name is_closed_id name
| name `elemNameSet` bndr_set | name `elemNameSet` bndr_set
= True -- Ignore binders in this groups, of course = True -- Ignore binders in this groups, of course
| Just thing <- lookupNameEnv type_env name | Just thing <- lookupNameEnv type_env name
...@@ -1346,12 +1346,12 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn ...@@ -1346,12 +1346,12 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
= WARN( isInternalName name, ppr name ) True = WARN( isInternalName name, ppr name ) True
-- The free-var set for a top level binding mentions -- The free-var set for a top level binding mentions
-- imported things too, so that we can report unused imports -- 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 -- Ditto class method etc from the current module
closed_flag = foldr (is_closed_ns . bind_fvs) True binds 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 && not closed_flag
no_sig n = isNothing (sig_fn n) no_sig n = isNothing (sig_fn n)
...@@ -1385,45 +1385,42 @@ checkStrictBinds :: TopLevelFlag -> RecFlag ...@@ -1385,45 +1385,42 @@ checkStrictBinds :: TopLevelFlag -> RecFlag
-> TcM () -> TcM ()
-- Check that non-overloaded unlifted bindings are -- Check that non-overloaded unlifted bindings are
-- a) non-recursive, -- a) non-recursive,
-- b) not top level, -- b) not top level,
-- c) not a multiple-binding group (more or less implied by (a)) -- c) not a multiple-binding group (more or less implied by (a))
checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids 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) = do { checkTc (isNotTopLevel top_lvl)
(strictBindErr "Top-level" unlifted orig_binds) (strictBindErr "Top-level" unlifted_bndrs orig_binds)
; checkTc (isNonRec rec_group) ; checkTc (isNonRec rec_group)
(strictBindErr "Recursive" unlifted orig_binds) (strictBindErr "Recursive" unlifted_bndrs orig_binds)
; checkTc (all is_monomorphic (bagToList tc_binds)) ; checkTc (all is_monomorphic (bagToList tc_binds))
(polyBindErr orig_binds) (polyBindErr orig_binds)
-- data Ptr a = Ptr Addr# -- data Ptr a = Ptr Addr#
-- f x = let p@(Ptr y) = ... in ... -- 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 -- not mix with an unlifted binding for 'y'. You should
-- use a bang pattern. Trac #6078. -- use a bang pattern. Trac #6078.
; checkTc (isSingleton orig_binds) ; checkTc (isSingleton orig_binds)
(strictBindErr "Multiple" unlifted orig_binds) (strictBindErr "Multiple" unlifted_bndrs orig_binds)
-- Ensure that unlifted bindings which look lazy, like: -- Complain about a binding that looks lazy
-- f x = let I# y = x -- e.g. let I# y = x in ...
-- cause an error. -- Remember, in checkStrictBinds we are going to do strict
; when lifted_pat $ -- matching, so (for software engineering reasons) we insist
checkTc bang_pat -- that the strictness is manifest on each binding
-- No outer bang, but it's a compound pattern -- However, lone (unboxed) variables are ok
-- E.g (I# x#) = blah ; checkTc (not any_pat_looks_lazy)
-- Warn about this, but not about (unliftedMustBeBang orig_binds) }
-- x# = 4# +# 1#
-- (# a, b #) = ...
(unliftedMustBeBang orig_binds) }
| otherwise | otherwise
= traceTc "csb2" (ppr poly_ids) >> = traceTc "csb2" (ppr poly_ids) >>
return () return ()
where where
unlifted = any is_unlifted poly_ids unlifted_bndrs = any is_unlifted poly_ids
bang_pat = any (isBangHsBind . unLoc . snd) orig_binds any_strict_pat = any (isStrictHsBind . unLoc . snd) orig_binds
lifted_pat = any (isLiftedPatBind . unLoc . snd) orig_binds any_pat_looks_lazy = any (looksLazyPatBind . unLoc . snd) orig_binds
is_unlifted id = case tcSplitForAllTys (idType id) of is_unlifted id = case tcSplitForAllTys (idType id) of
(_, rho) -> isUnLiftedType rho (_, rho) -> isUnLiftedType rho
...@@ -1444,12 +1441,12 @@ polyBindErr binds ...@@ -1444,12 +1441,12 @@ polyBindErr binds
ptext (sLit "Probable fix: use a bang pattern")]) ptext (sLit "Probable fix: use a bang pattern")])
strictBindErr :: String -> Bool -> [(Origin, LHsBind Name)] -> SDoc 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:")) = hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
2 (vcat (map (ppr . snd) binds)) 2 (vcat (map (ppr . snd) binds))
where where
msg | unlifted = ptext (sLit "bindings for unlifted types") msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types")
| otherwise = ptext (sLit "bang-pattern bindings") | otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings")
\end{code} \end{code}
......
{-# LANGUAGE UnboxedTuples #-}
module T8762 where
type Ty a = Int
bug :: Ty a -> (# Ty a, () #)
bug ty = (# ty, () #)
foo = let (# a, b #) = bug undefined
in ()
...@@ -415,3 +415,4 @@ test('T8474', normal, compile, ['']) ...@@ -415,3 +415,4 @@ test('T8474', normal, compile, [''])
test('T8563', normal, compile, ['']) test('T8563', normal, compile, [''])
test('T8565', normal, compile, ['']) test('T8565', normal, compile, [''])
test('T8644', normal, compile, ['']) test('T8644', normal, compile, [''])
test('T8762', normal, compile, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment