diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2013-01-10 16:50:25 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2013-01-14 16:45:13 +0000 |
commit | deec5b74dee7f676b8a9f840ec7b5a813e7e0956 (patch) | |
tree | 1976ac7b4606aded369f5ff9c9b468fa5677f0a8 | |
parent | 343548da7274cd15aaeabe72c6b37bce78e9af9c (diff) | |
download | haskell-deec5b74dee7f676b8a9f840ec7b5a813e7e0956.tar.gz |
Be willing to parse {-# UNPACK #-} without '!'
This change gives a more helpful error message when the
user says data T = MkT {-# UNPACK #-} Int
which should have a strictness '!' as well. Rather than
just a parse error, we get
T7562.hs:3:14: Warning:
UNPACK pragma lacks '!' on the first argument of `MkT'
Fixes Trac #7562
-rw-r--r-- | compiler/basicTypes/DataCon.lhs | 40 | ||||
-rw-r--r-- | compiler/basicTypes/MkId.lhs | 29 | ||||
-rw-r--r-- | compiler/deSugar/DsMeta.hs | 4 | ||||
-rw-r--r-- | compiler/hsSyn/Convert.lhs | 4 | ||||
-rw-r--r-- | compiler/iface/MkIface.lhs | 2 | ||||
-rw-r--r-- | compiler/main/PprTyThing.hs | 4 | ||||
-rw-r--r-- | compiler/parser/Parser.y.pp | 10 | ||||
-rw-r--r-- | compiler/typecheck/TcSplice.lhs | 11 | ||||
-rw-r--r-- | compiler/typecheck/TcTyClsDecls.lhs | 13 |
9 files changed, 73 insertions, 44 deletions
diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index e55a6e4c18..47e37a9c0e 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -442,15 +442,19 @@ data DataConRep -- HsBang describes what the *programmer* wrote -- This info is retained in the DataCon.dcStrictMarks field data HsBang - = HsNoBang -- Lazy field + = HsUserBang -- The user's source-code request + (Maybe Bool) -- Just True {-# UNPACK #-} + -- Just False {-# NOUNPACK #-} + -- Nothing no pragma + Bool -- True <=> '!' specified - | HsBang Bool -- Source-language '!' bang - -- True <=> also an {-# UNPACK #-} pragma + | HsNoBang -- Lazy field + -- HsUserBang Nothing False means the same as HsNoBang | HsUnpack -- Definite commitment: this field is strict and unboxed (Maybe Coercion) -- co :: arg-ty ~ product-ty - | HsStrict -- Definite commitment: this field is strict but not unboxed + | HsStrict -- Definite commitment: this field is strict but not unboxed deriving (Data.Data, Data.Typeable) ------------------------- @@ -489,7 +493,9 @@ Note [Bangs on data constructor arguments] Consider data T = MkT !Int {-# UNPACK #-} !Int Bool Its dcArgBangs field records the *users* specifications, in this case - [HsBang False, HsBang True, HsNoBang] + [ HsUserBang Nothing True + , HsUserBang (Just True) True + , HsNoBang] See the declaration of HsBang in BasicTypes The dcr_bangs field of the dcRep field records the *actual, decided* @@ -538,12 +544,16 @@ instance Data.Data DataCon where dataTypeOf _ = mkNoRepType "DataCon" instance Outputable HsBang where - ppr HsNoBang = empty - ppr (HsBang True) = ptext (sLit "{-# UNPACK #-} !") - ppr (HsBang False) = char '!' - ppr (HsUnpack Nothing) = ptext (sLit "Unpk") - ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co) - ppr HsStrict = ptext (sLit "SrictNotUnpacked") + ppr HsNoBang = empty + ppr (HsUserBang prag bang) = pp_unpk prag <+> ppWhen bang (char '!') + ppr (HsUnpack Nothing) = ptext (sLit "Unpk") + ppr (HsUnpack (Just co)) = ptext (sLit "Unpk") <> parens (ppr co) + ppr HsStrict = ptext (sLit "SrictNotUnpacked") + +pp_unpk :: Maybe Bool -> SDoc +pp_unpk Nothing = empty +pp_unpk (Just True) = ptext (sLit "{-# UNPACK #-}") +pp_unpk (Just False) = ptext (sLit "{-# NOUNPACK #-}") instance Outputable StrictnessMark where ppr MarkedStrict = ptext (sLit "!") @@ -551,16 +561,16 @@ instance Outputable StrictnessMark where eqHsBang :: HsBang -> HsBang -> Bool -eqHsBang HsNoBang HsNoBang = True eqHsBang HsStrict HsStrict = True -eqHsBang (HsBang b1) (HsBang b2) = b1 == b2 +eqHsBang (HsUserBang u1 b1) (HsUserBang u2 b2) = u1==u2 && b1==b2 eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2)) = eqType (coercionType c1) (coercionType c2) eqHsBang _ _ = False isBanged :: HsBang -> Bool -isBanged HsNoBang = False -isBanged _ = True +isBanged HsNoBang = False +isBanged (HsUserBang Nothing bang) = bang +isBanged _ = True isMarkedStrict :: StrictnessMark -> Bool isMarkedStrict NotMarkedStrict = False diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 1d12f6f12f..375e731077 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -593,7 +593,11 @@ dataConArgRep dataConArgRep _ _ arg_ty HsNoBang = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) -dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag) +dataConArgRep _ _ arg_ty (HsUserBang _ False) -- No '!' + = (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer)) + +dataConArgRep dflags fam_envs arg_ty + (HsUserBang unpk_prag True) -- {-# UNPACK #-} ! | not (gopt Opt_OmitInterfacePragmas dflags) -- Don't unpack if -fomit-iface-pragmas -- Don't unpack if we aren't optimising; -- rather arbitrarily, we use -fomit-iface-pragmas @@ -602,10 +606,11 @@ dataConArgRep dflags fam_envs arg_ty (HsBang user_unpack_prag) arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty } , isUnpackableType fam_envs arg_ty' , (rep_tys, wrappers) <- dataConArgUnpack arg_ty' - , user_unpack_prag - || gopt Opt_UnboxStrictFields dflags - || (gopt Opt_UnboxSmallStrictFields dflags - && length rep_tys <= 1) -- See Note [Unpack one-wide fields] + , case unpk_prag of + Nothing -> gopt Opt_UnboxStrictFields dflags + || (gopt Opt_UnboxSmallStrictFields dflags + && length rep_tys <= 1) -- See Note [Unpack one-wide fields] + Just unpack_me -> unpack_me = case mb_co of Nothing -> (HsUnpack Nothing, rep_tys, wrappers) Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers) @@ -687,6 +692,10 @@ dataConArgUnpack arg_ty isUnpackableType :: FamInstEnvs -> Type -> Bool -- True if we can unpack the UNPACK fields of the constructor -- without involving the NameSet tycons +-- See Note [Recursive unboxing] +-- We look "deeply" inside rather than relying on the DataCons +-- we encounter on the way, because otherwise we might well +-- end up relying on ourselves! isUnpackableType fam_envs ty | Just (tc, _) <- splitTyConApp_maybe ty , Just con <- tyConSingleDataCon_maybe tc @@ -695,7 +704,7 @@ isUnpackableType fam_envs ty | otherwise = False where - ok_arg tcs (ty, bang) = no_unpack bang || ok_ty tcs norm_ty + ok_arg tcs (ty, bang) = not (attempt_unpack bang) || ok_ty tcs norm_ty where norm_ty = case topNormaliseType fam_envs ty of Just (_, ty) -> ty @@ -713,10 +722,12 @@ isUnpackableType fam_envs ty ok_con_args tcs con = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConStrictMarks con) + -- NB: dataConStrictMarks gives the *user* request; + -- We'd get a black hole if we used dataConRepBangs - no_unpack (HsBang True) = False - no_unpack (HsUnpack {}) = False - no_unpack _ = True + attempt_unpack (HsUnpack {}) = True + attempt_unpack (HsUserBang (Just unpk) _) = unpk + attempt_unpack _ = False \end{code} Note [Unpack one-wide fields] diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index fd57f4656a..04ffb766a0 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -557,8 +557,8 @@ repBangTy ty= do rep2 strictTypeName [s, t] where (str, ty') = case ty of - L _ (HsBangTy (HsBang True) ty) -> (unpackedName, ty) - L _ (HsBangTy _ ty) -> (isStrictName, ty) + L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName, ty) + L _ (HsBangTy (HsUserBang _ True) ty) -> (isStrictName, ty) _ -> (notStrictName, ty) ------------------------------------------------------- diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index c5a92f8b28..a21caf44db 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -364,8 +364,8 @@ cvtConstr (ForallC tvs ctxt con) cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) cvt_arg (NotStrict, ty) = cvtType ty -cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang False) ty' } -cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang True) ty' } +cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang Nothing True) ty' } +cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' } cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName) cvt_id_arg (i, str, ty) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index fed30f19e1..d5b302406e 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -1528,7 +1528,7 @@ toIfaceBang _ HsNoBang = IfNoBang toIfaceBang _ (HsUnpack Nothing) = IfUnpack toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (coToIfaceType (tidyCo env co)) toIfaceBang _ HsStrict = IfStrict -toIfaceBang _ (HsBang {}) = panic "toIfaceBang" +toIfaceBang _ (HsUserBang {}) = panic "toIfaceBang" classToIfaceDecl :: TidyEnv -> Class -> IfaceDecl classToIfaceDecl env clas diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 4447ad5f35..932b46c2f5 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -217,8 +217,8 @@ pprDataConDecl pefas ss gadt_style dataCon -- See Note [Printing bangs on data constructors] user_ify :: HsBang -> HsBang user_ify bang | opt_PprStyle_Debug = bang - user_ify HsStrict = HsBang False - user_ify (HsUnpack {}) = HsBang True + user_ify HsStrict = HsUserBang Nothing True + user_ify (HsUnpack {}) = HsUserBang (Just True) True user_ify bang = bang maybe_show_label (lbl,bty) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index b6139621d1..c552b6aec7 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1030,9 +1030,13 @@ infixtype :: { LHsType RdrName } | btype tyvarop type { LL $ mkHsOpTy $1 $2 $3 } strict_mark :: { Located HsBang } - : '!' { L1 (HsBang False) } - | '{-# UNPACK' '#-}' '!' { LL (HsBang True) } - | '{-# NOUNPACK' '#-}' '!' { LL HsStrict } + : '!' { L1 (HsUserBang Nothing True) } + | '{-# UNPACK' '#-}' { LL (HsUserBang (Just True) False) } + | '{-# NOUNPACK' '#-}' { LL (HsUserBang (Just False) True) } + | '{-# UNPACK' '#-}' '!' { LL (HsUserBang (Just True) True) } + | '{-# NOUNPACK' '#-}' '!' { LL (HsUserBang (Just False) True) } + -- Although UNPAACK with no '!' is illegal, we get a + -- better error message if we parse it here -- A ctype is a for-all type ctype :: { LHsType RdrName } diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 0a25a6c03b..959c0c1847 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -1487,11 +1487,12 @@ reifyFixity name conv_dir BasicTypes.InfixN = TH.InfixN reifyStrict :: DataCon.HsBang -> TH.Strict -reifyStrict HsNoBang = TH.NotStrict -reifyStrict (HsBang False) = TH.Unpacked -reifyStrict (HsBang True) = TH.Unpacked -reifyStrict HsStrict = TH.IsStrict -reifyStrict (HsUnpack {}) = TH.Unpacked +reifyStrict HsNoBang = TH.NotStrict +reifyStrict (HsUserBang _ False) = TH.NotStrict +reifyStrict (HsUserBang (Just True) True) = TH.Unpacked +reifyStrict (HsUserBang _ True) = TH.IsStrict +reifyStrict HsStrict = TH.IsStrict +reifyStrict (HsUnpack {}) = TH.Unpacked ------------------------------ noTH :: LitString -> SDoc -> TcM a diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 36fcc459c3..998450a0d6 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1399,19 +1399,22 @@ checkValidDataCon dflags existential_ok tc con } where ctxt = ConArgCtxt (dataConName con) - check_bang (HsBang want_unpack, rep_bang, n) + check_bang (HsUserBang (Just want_unpack) has_bang, rep_bang, n) + | want_unpack, not has_bang + = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'"))) | want_unpack , case rep_bang of { HsUnpack {} -> False; _ -> True } , not (gopt Opt_OmitInterfacePragmas dflags) -- If not optimising, se don't unpack, so don't complain! -- See MkId.dataConArgRep, the (HsBang True) case - = addWarnTc (cant_unbox_msg n) + = addWarnTc (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma"))) + check_bang _ = return () - cant_unbox_msg n = sep [ ptext (sLit "Ignoring unusable UNPACK pragma on the") - , speakNth n <+> ptext (sLit "argument of") <+> quotes (ppr con)] - + bad_bang n herald + = hang herald 2 (ptext (sLit "on the") <+> speakNth n + <+> ptext (sLit "argument of") <+> quotes (ppr con)) ------------------------------- checkNewDataCon :: DataCon -> TcM () -- Checks for the data constructor of a newtype |