Commit deec5b74 authored by Simon Peyton Jones's avatar Simon Peyton Jones

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
parent 343548da
......@@ -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
......
......@@ -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]
......
......@@ -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)
-------------------------------------------------------
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
......
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