Commit f842ad6c authored by Adam Sandberg Eriksson's avatar Adam Sandberg Eriksson Committed by Ben Gamari
Browse files

Implementation of StrictData language extension

This implements the `StrictData` language extension, which lets the
programmer default to strict data fields in datatype declarations on a
per-module basis.

Specification and motivation can be found at
https://ghc.haskell.org/trac/ghc/wiki/StrictPragma

This includes a tricky parser change due to conflicts regarding `~` in
the type level syntax: all ~'s are parsed as strictness annotations (see
`strict_mark` in Parser.y) and then turned into equality constraints at
the appropriate places using `RdrHsSyn.splitTilde`.

Updates haddock submodule.

Test Plan: Validate through Harbormaster.

Reviewers: goldfire, austin, hvr, simonpj, tibbe, bgamari

Reviewed By: simonpj, tibbe, bgamari

Subscribers: lelf, simonpj, alanz, goldfire, thomie, bgamari, mpickering

Differential Revision: https://phabricator.haskell.org/D1033

GHC Trac Issues: #8347
parent 474d4ccc
......@@ -10,7 +10,8 @@
module DataCon (
-- * Main data types
DataCon, DataConRep(..),
HsBang(..), HsSrcBang, HsImplBang,
HsBang(..), SrcStrictness(..), SrcUnpackedness(..),
HsSrcBang, HsImplBang,
StrictnessMark(..),
ConTag,
......@@ -39,7 +40,7 @@ module DataCon (
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
isBanged, isMarkedStrict, eqHsBang,
isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,
-- ** Promotion related functions
promoteKind, promoteDataCon, promoteDataCon_maybe
......@@ -348,12 +349,12 @@ data DataCon
-- Now the strictness annotations and field labels of the constructor
dcSrcBangs :: [HsBang],
-- See Note [Bangs on data constructor arguments]
-- For DataCons defined in this module:
-- For DataCons defined in this module:
-- the [HsSrcBang] as written by the programmer.
-- For DataCons imported from an interface file:
-- the [HsImplBang] determined when compiling the
-- defining module
--
--
-- Matches 1-1 with dcOrigArgTys
-- Hence length = dataConSourceArity dataCon
......@@ -447,38 +448,53 @@ data DataConRep
-- when we bring bits of unfoldings together.)
-------------------------
-- HsBang describes the strictness/unpack status of one
-- | 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
= HsNoBang -- Equivalent to (HsSrcBang Nothing False)
| HsSrcBang -- What the user wrote in the source code
-- | What the user wrote in the source code.
--
-- (HsSrcBang _ SrcUnpack SrcLazy) and (HsSrcBang _ SrcUnpack
-- NoSrcStrictness) (without StrictData) makes no sense, we emit a
-- warning (in checkValidDataCon) and treat it like (HsSrcBang _
-- NoSrcUnpack SrcLazy)
= HsSrcBang
(Maybe SourceText) -- Note [Pragma source text] in BasicTypes
(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)
SrcUnpackedness
SrcStrictness
-- 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
-- after consulting HsSrcBang, flags, etc
| HsLazy -- ^ Definite commitment: Lazy field
| HsStrict -- ^ Definite commitment: Strict but not unpacked field
| HsUnpack (Maybe Coercion) -- co :: arg-ty ~ product-ty
-- ^ Definite commitment: Strict and unpacked field
| HsStrict -- Definite commitment: this field is strict but not unboxed
deriving (Data.Data, Data.Typeable)
-- | What strictness annotation the user wrote
data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'
| SrcStrict -- ^ Strict, ie '!'
| NoSrcStrictness -- ^ no strictness annotation
deriving (Eq, Data.Data, Data.Typeable)
-- | What unpackedness the user requested
data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
| SrcNoUnpack -- ^ {-# NOUNPACK #-} specified
| NoSrcUnpack -- ^ no unpack pragma
deriving (Eq, Data.Data, Data.Typeable)
-- Two type-insecure, but useful, synonyms
type HsSrcBang = HsBang -- What the user wrote; hence always HsNoBang or HsSrcBang
type HsImplBang = HsBang -- A HsBang implementation decision,
-- as determined by the compiler
-- Never HsSrcBang
-- | What the user wrote; hence always HsSrcBang
type HsSrcBang = HsBang
-- | A HsBang implementation decision, as determined by the compiler.
-- Never HsSrcBang
type HsImplBang = HsBang
-------------------------
-- StrictnessMark is internal only, used to indicate strictness
......@@ -492,38 +508,40 @@ Consider
When compiling the module, GHC will decide how to represent
MkT, depending on the optimisation level, and settings of
flags like -funbox-small-strict-fields.
flags like -funbox-small-strict-fields.
Terminology:
* HsSrcBang: What the user wrote
Constructors: HsNoBang, HsUserBang
Constructors: HsSrcBang
* HsImplBang: What GHC decided
Constructors: HsNoBang, HsStrict, HsUnpack
Constructors: HsLazy, HsStrict, HsUnpack
* If T was defined in this module, MkT's dcSrcBangs field
* If T was defined in this module, MkT's dcSrcBangs field
records the [HsSrcBang] of what the user wrote; in the example
[ HsSrcBang Nothing True
, HsSrcBang (Just True) True
, HsNoBang]
[ HsSrcBang _ NoSrcUnpack SrcStrict
, HsSrcBang _ SrcUnpack SrcStrict
, HsSrcBang _ NoSrcUnpack NoSrcStrictness]
* However, if T was defined in an imported module, MkT's dcSrcBangs
field gives the [HsImplBang] recording the decisions of the
field gives the [HsImplBang] recording the decisions of the
defining module. The importing module must follow those decisions,
regardless of the flag settings in the importing module.
* The dcr_bangs field of the dcRep field records the [HsImplBang]
If T was defined in this module, Without -O the dcr_bangs might be
[HsStrict, HsStrict, HsNoBang]
[HsStrict, HsStrict, HsLazy]
With -O it might be
[HsStrict, HsUnpack, HsNoBang]
[HsStrict, HsUnpack _, HsLazy]
With -funbox-small-strict-fields it might be
[HsUnpack, HsUnpack, HsNoBang]
[HsUnpack, HsUnpack _, HsLazy]
With -XStrictData it might be
[HsStrict, HsUnpack _, HsStrict]
Note [Data con representation]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The dcRepType field contains the type of the representation of a contructor
This may differ from the type of the contructor *Id* (built
This may differ from the type of the constructor *Id* (built
by MkId.mkDataConId) for two reasons:
a) the constructor Id may be overloaded, but the dictionary isn't stored
e.g. data Eq a => T a = MkT a a
......@@ -578,35 +596,51 @@ instance Data.Data DataCon where
dataTypeOf _ = mkNoRepType "DataCon"
instance Outputable HsBang where
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
pp_unpk (Just True) = ptext (sLit "{-# UNPACK #-}")
pp_unpk (Just False) = ptext (sLit "{-# NOUNPACK #-}")
ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark
ppr HsLazy = ptext (sLit "Lazy")
ppr (HsUnpack Nothing) = ptext (sLit "Unpacked")
ppr (HsUnpack (Just co)) = ptext (sLit "Unpacked") <> parens (ppr co)
ppr HsStrict = ptext (sLit "StrictNotUnpacked")
instance Outputable SrcStrictness where
ppr SrcLazy = char '~'
ppr SrcStrict = char '!'
ppr NoSrcStrictness = empty
instance Outputable SrcUnpackedness where
ppr SrcUnpack = ptext (sLit "{-# UNPACK #-}")
ppr SrcNoUnpack = ptext (sLit "{-# NOUNPACK #-}")
ppr NoSrcUnpack = empty
instance Outputable StrictnessMark where
ppr MarkedStrict = ptext (sLit "!")
ppr NotMarkedStrict = empty
-- | Compare strictness annotations
eqHsBang :: HsBang -> HsBang -> Bool
eqHsBang HsNoBang HsNoBang = True
eqHsBang HsStrict HsStrict = True
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 (HsSrcBang _ _ bang) = bang
isBanged (HsUnpack {}) = True
isBanged (HsStrict {}) = True
eqHsBang (HsSrcBang _ u1 b1) (HsSrcBang _ u2 b2) = u1==u2 && b1==b2
eqHsBang HsLazy HsLazy = True
eqHsBang HsStrict HsStrict = True
eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True
eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))
= eqType (coercionType c1) (coercionType c2)
eqHsBang _ _ = False
isBanged :: HsImplBang -> Bool
isBanged (HsUnpack {}) = True
isBanged (HsStrict {}) = True
isBanged HsLazy = False
isBanged (HsSrcBang {})
= panic "DataCon.isBanged: Cannot check bangedness of HsSrcBang."
isSrcStrict :: SrcStrictness -> Bool
isSrcStrict SrcStrict = True
isSrcStrict _ = False
isSrcUnpacked :: SrcUnpackedness -> Bool
isSrcUnpacked SrcUnpack = True
isSrcUnpacked _ = False
isMarkedStrict :: StrictnessMark -> Bool
isMarkedStrict NotMarkedStrict = False
......@@ -622,22 +656,22 @@ isMarkedStrict _ = True -- All others are strict
-- | Build a new data constructor
mkDataCon :: Name
-> Bool -- ^ Is the constructor declared infix?
-> [HsBang] -- ^ Strictness/unpack annotations, from user;
-- or, for imported DataCons, from the interface file
-> [FieldLabel] -- ^ Field labels for the constructor, if it is a record,
-- otherwise empty
-> [TyVar] -- ^ Universally quantified type variables
-> [TyVar] -- ^ Existentially quantified type variables
-> [(TyVar,Type)] -- ^ GADT equalities
-> ThetaType -- ^ Theta-type occuring before the arguments proper
-> [Type] -- ^ Original argument types
-> Type -- ^ Original result type
-> TyCon -- ^ Representation type constructor
-> ThetaType -- ^ The "stupid theta", context of the data declaration
-- e.g. @data Eq a => T a ...@
-> Id -- ^ Worker Id
-> DataConRep -- ^ Representation
-> Bool -- ^ Is the constructor declared infix?
-> [HsBang] -- ^ Strictness/unpack annotations, from user; or,
-- for imported DataCons, from the interface file
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universally quantified type variables
-> [TyVar] -- ^ Existentially quantified type variables
-> [(TyVar,Type)] -- ^ GADT equalities
-> ThetaType -- ^ Theta-type occuring before the arguments proper
-> [Type] -- ^ Original argument types
-> Type -- ^ Original result type
-> TyCon -- ^ Representation type constructor
-> ThetaType -- ^ The "stupid theta", context of the data
-- declaration e.g. @data Eq a => T a ...@
-> Id -- ^ Worker Id
-> DataConRep -- ^ Representation
-> DataCon
-- Can get the tag from the TyCon
......@@ -835,7 +869,7 @@ dataConImplBangs :: DataCon -> [HsImplBang]
-- source program argument to the data constructor
dataConImplBangs dc
= case dcRep dc of
NoDataConRep -> replicate (dcSourceArity dc) HsNoBang
NoDataConRep -> replicate (dcSourceArity dc) HsLazy
DCR { dcr_bangs = bangs } -> bangs
dataConBoxer :: DataCon -> Maybe DataConBoxer
......
......@@ -490,7 +490,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
mk_dmd str | isBanged str = evalDmd
| otherwise = topDmd
| otherwise = topDmd
-- The Cpr info can be important inside INLINE rhss, where the
-- wrapper constructor isn't inlined.
-- And the argument strictness can be important too; we
......@@ -534,9 +534,9 @@ mkDataConRep dflags fam_envs wrap_name data_con
(rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker
&& (any isBanged orig_bangs -- Some forcing/unboxing
-- (includes eq_spec)
|| isFamInstTyCon tycon) -- Cast result
&& (any isBanged wrap_bangs -- Some forcing/unboxing
-- (includes eq_spec)
|| isFamInstTyCon tycon) -- Cast result
initial_wrap_app = Var (dataConWorkId data_con)
`mkTyApps` res_ty_args
......@@ -593,34 +593,42 @@ dataConArgRep
, [(Type, StrictnessMark)] -- Rep types
, (Unboxer, Boxer) )
dataConArgRep _ _ arg_ty HsNoBang
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep dflags fam_envs arg_ty (HsSrcBang ann unpk NoSrcStrictness)
| xopt Opt_StrictData dflags -- StrictData => strict field
= dataConArgRep dflags fam_envs arg_ty (HsSrcBang ann unpk SrcStrict)
dataConArgRep _ _ arg_ty (HsSrcBang _ _ False) -- No '!'
= (HsNoBang, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
| otherwise -- no StrictData => lazy field
= (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep _ _ arg_ty (HsSrcBang _ _ SrcLazy)
= (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep dflags fam_envs arg_ty
(HsSrcBang _ unpk_prag True) -- {-# UNPACK #-} !
(HsSrcBang _ unpk_prag SrcStrict)
| 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
, let mb_co = topNormaliseType_maybe fam_envs arg_ty
-- Unwrap type families and newtypes
arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
, isUnpackableType fam_envs arg_ty'
, isUnpackableType dflags fam_envs arg_ty'
, (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
, 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
NoSrcUnpack ->
gopt Opt_UnboxStrictFields dflags
|| (gopt Opt_UnboxSmallStrictFields dflags
&& length rep_tys <= 1) -- See Note [Unpack one-wide fields]
srcUnpack -> isSrcUnpacked srcUnpack
= case mb_co of
Nothing -> (HsUnpack Nothing, rep_tys, wrappers)
Just (co,rep_ty) -> (HsUnpack (Just co), rep_tys, wrapCo co rep_ty wrappers)
| otherwise -- Record the strict-but-no-unpack decision
| otherwise -- Record the strict-but-no-unpack decision
= strict_but_not_unpacked arg_ty
dataConArgRep _ _ arg_ty HsLazy
= (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep _ _ arg_ty HsStrict
= strict_but_not_unpacked arg_ty
......@@ -695,13 +703,13 @@ dataConArgUnpack arg_ty
= pprPanic "dataConArgUnpack" (ppr arg_ty)
-- An interface file specified Unpacked, but we couldn't unpack it
isUnpackableType :: FamInstEnvs -> Type -> Bool
isUnpackableType :: DynFlags -> FamInstEnvs -> Type -> Bool
-- True if we can unpack the UNPACK the argument type
-- 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
isUnpackableType dflags fam_envs ty
| Just (tc, _) <- splitTyConApp_maybe ty
, Just con <- tyConSingleAlgDataCon_maybe tc
, isVanillaDataCon con
......@@ -728,11 +736,21 @@ isUnpackableType fam_envs ty
-- NB: dataConSrcBangs gives the *user* request;
-- We'd get a black hole if we used dataConImplBangs
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
attempt_unpack (HsUnpack {})
= True
attempt_unpack HsStrict
= False
attempt_unpack HsLazy
= False
attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrictness)
= xopt Opt_StrictData dflags
attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
= True
attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict)
= True -- Be conservative
attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrictness)
= xopt Opt_StrictData dflags -- Be conservative
attempt_unpack _ = False
{-
Note [Unpack one-wide fields]
......@@ -797,10 +815,10 @@ 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 -> HsSrcBang
mk_pred_strict_mark :: PredType -> HsImplBang
mk_pred_strict_mark pred
| isEqPred pred = HsUnpack Nothing -- Note [Unpack equality predicates]
| otherwise = HsNoBang
| otherwise = HsLazy
{-
************************************************************************
......
......@@ -648,15 +648,17 @@ mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
repBangTy ty= do
repBangTy ty = do
MkC s <- rep2 str []
MkC t <- repLTy ty'
rep2 strictTypeName [s, t]
where
(str, ty') = case ty of
L _ (HsBangTy (HsSrcBang _ (Just True) True) ty) -> (unpackedName, ty)
L _ (HsBangTy (HsSrcBang _ _ True) ty) -> (isStrictName, ty)
_ -> (notStrictName, ty)
L _ (HsBangTy (HsSrcBang _ SrcUnpack SrcStrict) ty)
-> (unpackedName, ty)
L _ (HsBangTy (HsSrcBang _ _ SrcStrict) ty)
-> (isStrictName, ty)
_ -> (notStrictName, ty)
-------------------------------------------------------
-- Deriving clause
......@@ -2129,5 +2131,3 @@ notHandled what doc = failWithDs msg
where
msg = hang (text what <+> ptext (sLit "not (yet) handled by Template Haskell"))
2 doc
......@@ -438,10 +438,10 @@ 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 (HsSrcBang Nothing Nothing True) ty' }
; returnL $ HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcStrict) ty' }
cvt_arg (Unpacked, ty)
= do { ty' <- cvtType ty
; returnL $ HsBangTy (HsSrcBang Nothing (Just True) True) ty' }
; returnL $ HsBangTy (HsSrcBang Nothing SrcUnpack SrcStrict) ty' }
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (LConDeclField RdrName)
cvt_id_arg (i, str, ty)
......
......@@ -29,6 +29,7 @@ module HsTypes (
HsIPName(..), hsIPNameFS,
LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang,
SrcStrictness(..), SrcUnpackedness(..),
getBangType, getBangStrictness,
ConDeclField(..), LConDeclField, pprConDeclFields,
......@@ -62,7 +63,8 @@ import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..), HsSrcBang, HsImplBang )
import DataCon( HsBang(..), HsSrcBang, HsImplBang,
SrcStrictness(..), SrcUnpackedness(..) )
import TysPrim( funTyConName )
import Type
import HsDoc
......@@ -97,7 +99,7 @@ getBangType ty = ty
getBangStrictness :: LHsType a -> HsSrcBang
getBangStrictness (L _ (HsBangTy s _)) = s
getBangStrictness _ = HsNoBang
getBangStrictness _ = HsSrcBang Nothing NoSrcUnpack NoSrcStrictness
{-
************************************************************************
......
......@@ -272,7 +272,7 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")
datacon_name
False -- Not declared infix
(map (const HsNoBang) args)
(map (const HsLazy) args)
[{- No fields -}]
tvs [{- no existentials -}]
[{- No GADT equalities -}]
......
......@@ -1728,7 +1728,7 @@ tyConToIfaceDecl env tycon
to_eq_spec (tv,ty) = (toIfaceTyVar (tidyTyVar con_env2 tv), tidyToIfaceType con_env2 ty)
toIfaceBang :: TidyEnv -> HsImplBang -> IfaceBang
toIfaceBang _ HsNoBang = IfNoBang
toIfaceBang _ HsLazy = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
toIfaceBang _ HsStrict = IfStrict
......
......@@ -542,9 +542,9 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr name))
name is_infix
stricts -- Pass the HsImplBangs (i.e. final decisions
-- to buildDataCon; it'll use these to guide
-- the construction of a worker
stricts -- Pass the HsImplBangs (i.e. final decisions)
-- to buildDataCon; it'll use these to guide
-- the construction of a worker
lbl_names
tc_tyvars ex_tyvars
eq_spec theta
......@@ -554,7 +554,7 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
tc_strict :: IfaceBang -> IfL HsImplBang
tc_strict IfNoBang = return HsNoBang
tc_strict IfNoBang = return HsLazy
tc_strict IfStrict = return HsStrict
tc_strict IfUnpack = return (HsUnpack Nothing)
tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co
......
......@@ -653,6 +653,7 @@ data ExtensionFlag
| Opt_PartialTypeSignatures
| Opt_NamedWildCards
| Opt_StaticPointers
| Opt_StrictData
deriving (Eq, Enum, Show)
type SigOf = Map ModuleName Module
......@@ -3207,6 +3208,7 @@ xFlags = [
flagSpec "ScopedTypeVariables" Opt_ScopedTypeVariables,
flagSpec "StandaloneDeriving" Opt_StandaloneDeriving,
flagSpec "StaticPointers" Opt_StaticPointers,
flagSpec "StrictData" Opt_StrictData,
flagSpec' "TemplateHaskell" Opt_TemplateHaskell
setTemplateHaskellLoc,
flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax,
......
......@@ -1566,18 +1566,21 @@ sigtypes1 :: { (OrdList (LHsType RdrName)) } -- Always HsForAllTys
-- Types
strict_mark :: { Located ([AddAnn],HsBang) }
: '!' { sL1 $1 ([mj AnnBang $1]
,HsSrcBang Nothing Nothing True) }
| '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2]
,HsSrcBang (Just $ getUNPACK_PRAGs $1) (Just True) False) }
| '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1,mc $2]
,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) False) }
| '{-# UNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3]
,HsSrcBang (Just $ getUNPACK_PRAGs $1) (Just True) True) }
| '{-# NOUNPACK' '#-}' '!' { sLL $1 $> ([mo $1,mc $2,mj AnnBang $3]
,HsSrcBang (Just $ getNOUNPACK_PRAGs $1) (Just False) True) }
-- Although UNPACK with no '!' is illegal, we get a
-- better error message if we parse it here
: strictness { sL1 $1 (let (a, str) = unLoc $1 in (a, HsSrcBang Nothing NoSrcUnpack str)) }
| unpackedness { sL1 $1 (let (a, prag, unpk) = unLoc $1 in (a, HsSrcBang prag unpk NoSrcStrictness)) }
| unpackedness strictness { sLL $1 $> (let { (a, prag, unpk) = unLoc $1
; (a', str) = unLoc $2 }
in (a ++ a', HsSrcBang prag unpk str)) }
-- Although UNPACK with no '!' without StrictData and UNPACK with '~' are illegal,
-- we get a better error message if we parse them here
strictness :: { Located ([AddAnn], SrcStrictness) }
: '!' { sL1 $1 ([mj AnnBang $1], SrcStrict) }
| '~' { sL1 $1 ([mj AnnTilde $1], SrcLazy) }
unpackedness :: { Located ([AddAnn], Maybe SourceText, SrcUnpackedness) }
: '{-# UNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], Just $ getUNPACK_PRAGs $1, SrcUnpack) }
| '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], Just $ getNOUNPACK_PRAGs $1, SrcNoUnpack) }
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
......@@ -1626,47 +1629,39 @@ ctypedoc :: { LHsType RdrName }
-- to permit an individual equational constraint without parenthesis.
-- Thus for some reason we allow f :: a~b => blah
-- but not f :: ?x::Int => blah
-- See Note [Parsing ~]
context :: { LHsContext RdrName }
: btype '~' btype {% do { (anns,ctx) <- checkContext
(sLL $1 $> $ HsEqTy $1 $3)
; ams ctx (mj AnnTilde $2:anns) } }
| btype {% do { (anns,ctx) <- checkContext $1
; if null (unLoc ctx)
then addAnnotation (gl $1) AnnUnit (gl $1)
else return ()
; ams ctx anns
} }
: btype {% do { (anns,ctx) <- checkContext (splitTilde $1)
; if null (unLoc ctx)
then addAnnotation (gl $1) AnnUnit (gl $1)
else return ()
; ams ctx anns
} }
-- See Note [Parsing ~]
type :: { LHsType RdrName }
: btype { $1 }
: btype { splitTilde $1 }
| btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
| btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 }
| btype '->' ctype {% ams $1 [mj AnnRarrow $2]
>> ams (sLL $1 $> $ HsFunTy $1 $3)
>> ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3)
[mj AnnRarrow $2] }
| btype '~' btype {% ams (sLL $1 $> $ HsEqTy $1 $3)
[mj AnnTilde $2] }
-- see Note [Promotion]
| btype SIMPLEQUOTE qconop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
[mj AnnSimpleQuote $2] }
| btype SIMPLEQUOTE varop type {% ams (sLL $1 $> $ mkHsOpTy $1 $3 $4)
[mj AnnSimpleQuote $2] }