Commit 9564bb8c authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve HsBang

Provoked by questions from Johan

 - Improve comments, fix misleading stuff
 - Add commented synonyms for HsSrcBang, HsImplBang, and use them throughout
 - Rename HsUserBang to HsSrcBang
 - Rename dataConStrictMarks to dataConSrcBangs
          dataConRepBangs    to dataConImplBangs

This renaming affects Haddock in a trivial way, hence submodule update
parent 43e5a221
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -172,7 +172,7 @@ module GHC (
DataCon,
dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
dataConIsInfix, isVanillaDataCon, dataConUserType,
dataConStrictMarks,
dataConSrcBangs,
StrictnessMark(..), isMarkedStrict,
-- ** Classes
......
......@@ -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
......
......@@ -1416,7 +1416,7 @@ checkMissingFields data_con rbinds
field_labels
field_strs
field_strs = dataConStrictMarks data_con
field_strs = dataConSrcBangs data_con
{-
************************************************************************
......
......@@ -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)
......
......@@ -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
......
......@@ -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
}
......
......@@ -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
......
Subproject commit 8b1d44fbdde141cf883f5ddcd337bbbab8433228
Subproject commit 04cf63d0195837ed52075ed7d2676e71831e8a0b
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