From 47f473b0f7ddf21b2cde825166d092cb6e72329d Mon Sep 17 00:00:00 2001 From: Simon Peyton Jones Date: Tue, 18 Feb 2014 08:37:21 +0000 Subject: [PATCH] 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 | 6 +- compiler/hsSyn/HsPat.lhs | 58 +++++++------- compiler/typecheck/TcBinds.lhs | 77 +++++++++---------- .../tests/typecheck/should_compile/T8762.hs | 10 +++ .../tests/typecheck/should_compile/all.T | 1 + 5 files changed, 80 insertions(+), 72 deletions(-) create mode 100644 testsuite/tests/typecheck/should_compile/T8762.hs diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 546a198ca8..d1ef24070c 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/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) diff --git a/compiler/hsSyn/HsPat.lhs b/compiler/hsSyn/HsPat.lhs index 9d458b79c4..ef888fe5a8 100644 --- a/compiler/hsSyn/HsPat.lhs +++ b/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, diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 1e619ed493..1305437786 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/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} diff --git a/testsuite/tests/typecheck/should_compile/T8762.hs b/testsuite/tests/typecheck/should_compile/T8762.hs new file mode 100644 index 0000000000..8eb13a73eb --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/T8762.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE UnboxedTuples #-} +module T8762 where + +type Ty a = Int + +bug :: Ty a -> (# Ty a, () #) +bug ty = (# ty, () #) + +foo = let (# a, b #) = bug undefined + in () diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index 0fe6968bf7..a5f853cac0 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/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, ['']) -- GitLab