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)
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)
......
......@@ -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,
......
......@@ -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}
......
{-# 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, [''])
test('T8563', normal, compile, [''])
test('T8565', 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