summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/DataCon.hs105
-rw-r--r--compiler/basicTypes/MkId.hs30
-rw-r--r--compiler/deSugar/DsMeta.hs6
-rw-r--r--compiler/hsSyn/Convert.hs4
-rw-r--r--compiler/hsSyn/HsTypes.hs10
-rw-r--r--compiler/iface/BuildTyCl.hs2
-rw-r--r--compiler/iface/MkIface.hs6
-rw-r--r--compiler/main/GHC.hs2
-rw-r--r--compiler/parser/Parser.y10
-rw-r--r--compiler/typecheck/TcExpr.hs2
-rw-r--r--compiler/typecheck/TcRnDriver.hs2
-rw-r--r--compiler/typecheck/TcSplice.hs16
-rw-r--r--compiler/typecheck/TcTyClsDecls.hs10
-rw-r--r--compiler/vectorise/Vectorise/Type/TyConDecl.hs2
m---------utils/haddock0
15 files changed, 118 insertions, 89 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 4323d6d147..e77af96af1 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -9,7 +9,9 @@
module DataCon (
-- * Main data types
- DataCon, DataConRep(..), HsBang(..), StrictnessMark(..),
+ DataCon, DataConRep(..),
+ HsBang(..), HsSrcBang, HsImplBang,
+ StrictnessMark(..),
ConTag,
-- ** Type construction
@@ -26,11 +28,11 @@ module DataCon (
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
- dataConStrictMarks,
+ dataConSrcBangs,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
- dataConRepStrictness, dataConRepBangs, dataConBoxer,
+ dataConRepStrictness, dataConImplBangs, dataConBoxer,
splitDataProductType_maybe,
@@ -342,8 +344,8 @@ data DataCon
-- Now the strictness annotations and field labels of the constructor
-- See Note [Bangs on data constructor arguments]
- dcArgBangs :: [HsBang],
- -- Strictness annotations as decided by the compiler.
+ dcSrcBangs :: [HsSrcBang],
+ -- Strictness annotations as written by the programmer.
-- Matches 1-1 with dcOrigArgTys
-- Hence length = dataConSourceArity dataCon
@@ -406,9 +408,9 @@ data DataConRep
, dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys
-- See also Note [Data-con worker strictness] in MkId.lhs
- , dcr_bangs :: [HsBang] -- The actual decisions made (including failures)
- -- 1-1 with orig_arg_tys
- -- See Note [Bangs on data constructor arguments]
+ , dcr_bangs :: [HsImplBang] -- The actual decisions made (including failures)
+ -- about the original arguments; 1-1 with orig_arg_tys
+ -- See Note [Bangs on data constructor arguments]
}
-- Algebraic data types always have a worker, and
@@ -437,30 +439,55 @@ data DataConRep
-- when we bring bits of unfoldings together.)
-------------------------
--- HsBang describes what the *programmer* wrote
--- This info is retained in the DataCon.dcStrictMarks field
+-- HsBang describes the strictness/unpack status of one
+-- of the original data constructor arguments (i.e. *not*
+-- of the representation data constructor which may have
+-- more arguments after the originals have been unpacked)
+-- See Note [Bangs on data constructor arguments]
data HsBang
- = HsUserBang -- The user's source-code request
+ = HsNoBang -- Equivalent to (HsSrcBang Nothing False)
+
+ | HsSrcBang -- What the user wrote in the source code
(Maybe Bool) -- Just True {-# UNPACK #-}
-- Just False {-# NOUNPACK #-}
-- Nothing no pragma
Bool -- True <=> '!' specified
+ -- (HsSrcBang (Just True) False) makes no sense
+ -- We emit a warning (in checkValidDataCon) and treat it
+ -- just like (HsSrcBang Nothing False)
- | HsNoBang -- Lazy field
- -- HsUserBang Nothing False means the same as HsNoBang
-
+ -- Definite implementation commitments, generated by the compiler
+ -- after consulting HsSrcBang (if any), flags, etc
| 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
deriving (Data.Data, Data.Typeable)
+-- Two type-insecure, but useful, synonyms
+type HsSrcBang = HsBang -- What the user wrote; hence always HsNoBang or HsSrcBang
+ -- But see Note [HsSrcBang exceptions]
+
+type HsImplBang = HsBang -- A HsBang implementation decision,
+ -- as determined by the compiler
+ -- Never HsSrcBang
+
-------------------------
-- StrictnessMark is internal only, used to indicate strictness
-- of the DataCon *worker* fields
data StrictnessMark = MarkedStrict | NotMarkedStrict
-{-
+{- Note [HsSrcBang exceptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Exceptions to rule that HsSrcBang is always HsSrcBang or HsNoBang:
+
+* When we build a DataCon from an interface file we don't
+ know what the user wrote, so we use HsUnpack/HsStrict
+
+* In MkId.mkDataConRep we want to say "always unpack an equality
+ predicate for equality arguments so we use HsUnpack
+ see MkId.mk_pred_strict_mark
+
Note [Data con representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The dcRepType field contains the type of the representation of a contructor
@@ -483,11 +510,10 @@ Note [Bangs on data constructor arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = MkT !Int {-# UNPACK #-} !Int Bool
-Its dcArgBangs field records the *users* specifications, in this case
- [ HsUserBang Nothing True
- , HsUserBang (Just True) True
+Its dcSrcBangs field records the *users* specifications, in this case
+ [ HsSrcBang Nothing True
+ , HsSrcBang (Just True) True
, HsNoBang]
-See the declaration of HsBang in BasicTypes
The dcr_bangs field of the dcRep field records the *actual, decided*
representation of the data constructor. Without -O this might be
@@ -497,7 +523,7 @@ With -O it might be
With -funbox-small-strict-fields it might be
[HsUnpack, HsUnpack, HsNoBang]
-For imported data types, the dcArgBangs field is just the same as the
+For imported data types, the dcSrcBangs field is just the same as the
dcr_bangs field; we don't know what the user originally said.
@@ -539,11 +565,11 @@ instance Data.Data DataCon where
dataTypeOf _ = mkNoRepType "DataCon"
instance Outputable HsBang where
- 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")
+ ppr HsNoBang = empty
+ ppr (HsSrcBang 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
@@ -558,15 +584,16 @@ instance Outputable StrictnessMark where
eqHsBang :: HsBang -> HsBang -> Bool
eqHsBang HsNoBang HsNoBang = True
eqHsBang HsStrict HsStrict = True
-eqHsBang (HsUserBang u1 b1) (HsUserBang u2 b2) = u1==u2 && b1==b2
+eqHsBang (HsSrcBang u1 b1) (HsSrcBang 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 (HsUserBang Nothing bang) = bang
-isBanged _ = True
+isBanged HsNoBang = False
+isBanged (HsSrcBang _ bang) = bang
+isBanged (HsUnpack {}) = True
+isBanged (HsStrict {}) = True
isMarkedStrict :: StrictnessMark -> Bool
isMarkedStrict NotMarkedStrict = False
@@ -583,7 +610,7 @@ isMarkedStrict _ = True -- All others are strict
-- | Build a new data constructor
mkDataCon :: Name
-> Bool -- ^ Is the constructor declared infix?
- -> [HsBang] -- ^ Strictness annotations written in the source file
+ -> [HsSrcBang] -- ^ User-supplied strictness/unpack annotations
-> [FieldLabel] -- ^ Field labels for the constructor, if it is a record,
-- otherwise empty
-> [TyVar] -- ^ Universally quantified type variables
@@ -626,7 +653,7 @@ mkDataCon name declared_infix
dcStupidTheta = stupid_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon,
- dcArgBangs = arg_stricts,
+ dcSrcBangs = arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = rep_ty,
dcWorkId = work_id,
dcRep = rep,
@@ -764,10 +791,10 @@ dataConFieldType con label
Just ty -> ty
Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
--- | The strictness markings decided on by the compiler. Does not include those for
--- existential dictionaries. The list is in one-to-one correspondence with the arity of the 'DataCon'
-dataConStrictMarks :: DataCon -> [HsBang]
-dataConStrictMarks = dcArgBangs
+-- | The strictness markings written by the porgrammer.
+-- The list is in one-to-one correspondence with the arity of the 'DataCon'
+dataConSrcBangs :: DataCon -> [HsSrcBang]
+dataConSrcBangs = dcSrcBangs
-- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity
@@ -800,9 +827,11 @@ dataConRepStrictness dc = case dcRep dc of
NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
DCR { dcr_stricts = strs } -> strs
-dataConRepBangs :: DataCon -> [HsBang]
-dataConRepBangs dc = case dcRep dc of
- NoDataConRep -> dcArgBangs dc
+dataConImplBangs :: DataCon -> [HsImplBang]
+-- The implementation decisions about the strictness/unpack of each
+-- source program argument to the data constructor
+dataConImplBangs dc = case dcRep dc of
+ NoDataConRep -> dcSrcBangs dc
DCR { dcr_bangs = bangs } -> bangs
dataConBoxer :: DataCon -> Maybe DataConBoxer
diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index cfdc7385a5..0899997f3b 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -519,7 +519,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
wrap_ty = dataConUserType data_con
ev_tys = eqSpecPreds eq_spec ++ theta
all_arg_tys = ev_tys ++ orig_arg_tys
- orig_bangs = map mk_pred_strict_mark ev_tys ++ dataConStrictMarks data_con
+ orig_bangs = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con
wrap_arg_tys = theta ++ orig_arg_tys
wrap_arity = length wrap_arg_tys
@@ -580,19 +580,19 @@ newLocal ty = do { uniq <- getUniqueM
dataConArgRep
:: DynFlags
-> FamInstEnvs
- -> Type -> HsBang
- -> ( HsBang -- Like input but with HsUnpackFailed if necy
+ -> Type -> HsSrcBang
+ -> ( HsImplBang -- Implementation decision about unpack strategy
, [(Type, StrictnessMark)] -- Rep types
, (Unboxer, Boxer) )
dataConArgRep _ _ arg_ty HsNoBang
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
-dataConArgRep _ _ arg_ty (HsUserBang _ False) -- No '!'
+dataConArgRep _ _ arg_ty (HsSrcBang _ False) -- No '!'
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep dflags fam_envs arg_ty
- (HsUserBang unpk_prag True) -- {-# UNPACK #-} !
+ (HsSrcBang 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 as the indication
@@ -625,7 +625,7 @@ dataConArgRep _ _ _ (HsUnpack (Just co))
, (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
= (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
-strict_but_not_unpacked :: Type -> (HsBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
+strict_but_not_unpacked :: Type -> (HsImplBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
strict_but_not_unpacked arg_ty
= (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
@@ -716,15 +716,15 @@ isUnpackableType fam_envs ty
= True
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
+ = all (ok_arg tcs) (dataConOrigArgTys con `zip` dataConSrcBangs con)
+ -- NB: dataConSrcBangs gives the *user* request;
+ -- We'd get a black hole if we used dataConImplBangs
- attempt_unpack (HsUnpack {}) = True
- attempt_unpack (HsUserBang (Just unpk) bang) = bang && unpk
- attempt_unpack (HsUserBang Nothing bang) = bang -- Be conservative
- attempt_unpack HsStrict = False
- attempt_unpack HsNoBang = False
+ attempt_unpack (HsUnpack {}) = True
+ attempt_unpack (HsSrcBang (Just unpk) bang) = bang && unpk
+ attempt_unpack (HsSrcBang Nothing bang) = bang -- Be conservative
+ attempt_unpack HsStrict = False
+ attempt_unpack HsNoBang = False
{-
Note [Unpack one-wide fields]
@@ -789,7 +789,7 @@ heavy lifting. This one line makes every GADT take a word less
space for each equality predicate, so it's pretty important!
-}
-mk_pred_strict_mark :: PredType -> HsBang
+mk_pred_strict_mark :: PredType -> HsSrcBang
mk_pred_strict_mark pred
| isEqPred pred = HsUnpack Nothing -- Note [Unpack equality predicates]
| otherwise = HsNoBang
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index a94d996e7d..b7445a8e2b 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -651,9 +651,9 @@ repBangTy ty= do
rep2 strictTypeName [s, t]
where
(str, ty') = case ty of
- L _ (HsBangTy (HsUserBang (Just True) True) ty) -> (unpackedName, ty)
- L _ (HsBangTy (HsUserBang _ True) ty) -> (isStrictName, ty)
- _ -> (notStrictName, ty)
+ L _ (HsBangTy (HsSrcBang (Just True) True) ty) -> (unpackedName, ty)
+ L _ (HsBangTy (HsSrcBang _ True) ty) -> (isStrictName, ty)
+ _ -> (notStrictName, ty)
-------------------------------------------------------
-- Deriving clause
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 3c2b5e7fdb..92af65170f 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -436,8 +436,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 (HsUserBang Nothing True) ty' }
-cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsUserBang (Just True) True) ty' }
+cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang Nothing True) ty' }
+cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsSrcBang (Just True) True) ty' }
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
cvt_id_arg (i, str, ty)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index badcbe700a..41142bb053 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -28,7 +28,7 @@ module HsTypes (
HsTyLit(..),
HsIPName(..), hsIPNameFS,
- LBangType, BangType, HsBang(..),
+ LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang,
getBangType, getBangStrictness,
ConDeclField(..), LConDeclField, pprConDeclFields,
@@ -55,7 +55,7 @@ import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
import Name( Name )
import RdrName( RdrName )
-import DataCon( HsBang(..) )
+import DataCon( HsBang(..), HsSrcBang, HsImplBang )
import TysPrim( funTyConName )
import Type
import HsDoc
@@ -106,7 +106,7 @@ getBangType :: LHsType a -> LHsType a
getBangType (L _ (HsBangTy _ ty)) = ty
getBangType ty = ty
-getBangStrictness :: LHsType a -> HsBang
+getBangStrictness :: LHsType a -> HsSrcBang
getBangStrictness (L _ (HsBangTy s _)) = s
getBangStrictness _ = HsNoBang
@@ -292,8 +292,8 @@ data HsType name
| HsDocTy (LHsType name) LHsDocString -- A documented type
- | HsBangTy HsBang (LHsType name) -- Bang-style type annotations
- | HsRecTy [LConDeclField name] -- Only in data type declarations
+ | HsBangTy HsSrcBang (LHsType name) -- Bang-style type annotations
+ | HsRecTy [LConDeclField name] -- Only in data type declarations
| HsCoreTy Type -- An escape hatch for tunnelling a *closed*
-- Core Type through HsSyn.
diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index 6e14700cfa..48f5d99efe 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -128,7 +128,7 @@ mkNewTyConRhs tycon_name tycon con
------------------------------------------------------
buildDataCon :: FamInstEnvs
-> Name -> Bool
- -> [HsBang]
+ -> [HsSrcBang]
-> [Name] -- Field labels
-> [TyVar] -> [TyVar] -- Univ and ext
-> [(TyVar,Type)] -- Equality spec
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index 7226cb01f8..e7cc3adc19 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -1684,7 +1684,7 @@ tyConToIfaceDecl env tycon
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
ifConFields = map getOccName
(dataConFieldLabels data_con),
- ifConStricts = map (toIfaceBang con_env2) (dataConRepBangs data_con) }
+ ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con) }
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
@@ -1701,12 +1701,12 @@ tyConToIfaceDecl env tycon
(con_env2, ex_tvs') = tidyTyVarBndrs con_env1 ex_tvs
to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
-toIfaceBang :: TidyEnv -> HsBang -> IfaceBang
+toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
toIfaceBang _ HsNoBang = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
toIfaceBang _ HsStrict = IfStrict
-toIfaceBang _ (HsUserBang {}) = panic "toIfaceBang"
+toIfaceBang _ (HsSrcBang {}) = panic "toIfaceBang"
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 539961be90..2557ec4fee 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -172,7 +172,7 @@ module GHC (
DataCon,
dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
dataConIsInfix, isVanillaDataCon, dataConUserType,
- dataConStrictMarks,
+ dataConSrcBangs,
StrictnessMark(..), isMarkedStrict,
-- ** Classes
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 7739d973f0..4958e0c6a3 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1351,11 +1351,11 @@ sigtypes1 :: { (OrdList (LHsType RdrName)) } -- Always HsForAllTys
-- Types
strict_mark :: { Located ([AddAnn],HsBang) }
- : '!' { sL1 $1 ([], HsUserBang Nothing True) }
- | '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2], HsUserBang (Just True) False) }
- | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2], HsUserBang (Just False) False) }
- | '{-# UNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2], HsUserBang (Just True) True) }
- | '{-# NOUNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2], HsUserBang (Just False) True) }
+ : '!' { sL1 $1 ([], HsSrcBang Nothing True) }
+ | '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True) False) }
+ | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) False) }
+ | '{-# UNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just True) True) }
+ | '{-# NOUNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2], HsSrcBang (Just False) True) }
-- Although UNPACK with no '!' is illegal, we get a
-- better error message if we parse it here
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index f5da0b2014..a3a9be3f80 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1416,7 +1416,7 @@ checkMissingFields data_con rbinds
field_labels
field_strs
- field_strs = dataConStrictMarks data_con
+ field_strs = dataConSrcBangs data_con
{-
************************************************************************
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index b78b69d8be..dfe69055cf 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1006,7 +1006,7 @@ checkBootTyCon tc1 tc2
(text "The fixities of" <+> pname1 <+>
text "differ") `andThenCheck`
check (eqListBy eqHsBang
- (dataConStrictMarks c1) (dataConStrictMarks c2))
+ (dataConSrcBangs c1) (dataConSrcBangs c2))
(text "The strictness annotations for" <+> pname1 <+>
text "differ") `andThenCheck`
check (dataConFieldLabels c1 == dataConFieldLabels c2)
diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index 617a6fc28d..020722c594 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1268,7 +1268,7 @@ reifyDataCon tys dc
(subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs)
theta' = substTheta subst' theta
arg_tys' = substTys subst' arg_tys
- stricts = map reifyStrict (dataConStrictMarks dc)
+ stricts = map reifyStrict (dataConSrcBangs dc)
fields = dataConFieldLabels dc
name = reifyName dc
@@ -1620,13 +1620,13 @@ reifyFixity name
conv_dir BasicTypes.InfixL = TH.InfixL
conv_dir BasicTypes.InfixN = TH.InfixN
-reifyStrict :: DataCon.HsBang -> TH.Strict
-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
+reifyStrict :: DataCon.HsSrcBang -> TH.Strict
+reifyStrict HsNoBang = TH.NotStrict
+reifyStrict (HsSrcBang _ False) = TH.NotStrict
+reifyStrict (HsSrcBang (Just True) True) = TH.Unpacked
+reifyStrict (HsSrcBang _ True) = TH.IsStrict
+reifyStrict HsStrict = TH.IsStrict
+reifyStrict (HsUnpack {}) = TH.Unpacked
------------------------------
lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index d187b091f4..27e2d45a03 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -1227,7 +1227,7 @@ tcConIsInfix con details (ResTyGADT _)
tcConArgs :: NewOrData -> HsConDeclDetails Name
- -> TcM ([Name], [(TcType, HsBang)])
+ -> TcM ([Name], [(TcType, HsSrcBang)])
tcConArgs new_or_data (PrefixCon btys)
= do { btys' <- mapM (tcConArg new_or_data) btys
; return ([], btys') }
@@ -1245,7 +1245,7 @@ tcConArgs new_or_data (RecCon fields)
exploded = concatMap explode combined
(field_names,btys) = unzip exploded
-tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang)
+tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsSrcBang)
tcConArg new_or_data bty
= do { traceTc "tcConArg 1" (ppr bty)
; arg_ty <- tcHsConArgType new_or_data bty
@@ -1572,7 +1572,7 @@ checkValidDataCon dflags existential_ok tc con
-- Check that UNPACK pragmas and bangs work out
-- E.g. reject data T = MkT {-# UNPACK #-} Int -- No "!"
-- data T = MkT {-# UNPACK #-} !a -- Can't unpack
- ; mapM_ check_bang (zip3 (dataConStrictMarks con) (dataConRepBangs con) [1..])
+ ; mapM_ check_bang (zip3 (dataConSrcBangs con) (dataConImplBangs con) [1..])
-- Check that existentials are allowed if they are used
; checkTc (existential_ok || isVanillaDataCon con)
@@ -1589,7 +1589,7 @@ checkValidDataCon dflags existential_ok tc con
}
where
ctxt = ConArgCtxt (dataConName con)
- check_bang (HsUserBang (Just want_unpack) has_bang, rep_bang, n)
+ check_bang (HsSrcBang (Just want_unpack) has_bang, rep_bang, n)
| want_unpack, not has_bang
= addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'")))
| want_unpack
@@ -1623,7 +1623,7 @@ checkNewDataCon con
ptext (sLit "A newtype constructor cannot have existential type variables")
-- No existentials
- ; checkTc (not (any isBanged (dataConStrictMarks con)))
+ ; checkTc (not (any isBanged (dataConSrcBangs con)))
(newtypeStrictError con)
-- No strictness
}
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 37a07f710d..7b4d5aaad0 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -177,7 +177,7 @@ vectDataCon dc
; liftDs $ buildDataCon fam_envs
name'
(dataConIsInfix dc) -- infix if the original is
- (dataConStrictMarks dc) -- strictness as original constructor
+ (dataConSrcBangs dc) -- strictness as original constructor
[] -- no labelled fields for now
univ_tvs -- universally quantified vars
[] -- no existential tvs for now
diff --git a/utils/haddock b/utils/haddock
-Subproject 8b1d44fbdde141cf883f5ddcd337bbbab843322
+Subproject 04cf63d0195837ed52075ed7d2676e71831e8a0
View Lorry Controller Status