diff options
24 files changed, 395 insertions, 197 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index a70bcbdd3d..51b8d785d2 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -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 diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index 4edf26831f..bdcaf72864 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -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 {- ************************************************************************ diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index d4a811ff1b..c222b33ed9 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 - - diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 4a0e013cf9..d4a0b54c2a 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 9526a8cce3..e123277851 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -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 {- ************************************************************************ diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs index b6db5dc9ee..28a5f68f47 100644 --- a/compiler/iface/BuildTyCl.hs +++ b/compiler/iface/BuildTyCl.hs @@ -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 -}] diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 753c81a8a0..2b8a21272e 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -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 diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index a7c340f780..3e977474b1 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 74e9bf303d..35e5dc5fc5 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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, diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 99abf162d1..815c8cb798 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -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] } - +-- See Note [Parsing ~] typedoc :: { LHsType RdrName } - : btype { $1 } - | btype docprev { sLL $1 $> $ HsDocTy $1 $2 } + : btype { splitTilde $1 } + | btype docprev { sLL $1 $> $ HsDocTy (splitTilde $1) $2 } | btype qtyconop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } | btype qtyconop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 } | btype tyvarop type { sLL $1 $> $ mkHsOpTy $1 $2 $3 } | btype tyvarop type docprev { sLL $1 $> $ HsDocTy (L (comb3 $1 $2 $3) (mkHsOpTy $1 $2 $3)) $4 } - | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy $1 $3) + | btype '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (splitTilde $1) $3) [mj AnnRarrow $2] } - | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (L (comb2 $1 $2) + | btype docprev '->' ctypedoc {% ams (sLL $1 $> $ HsFunTy (L (comb2 (splitTilde $1) $2) (HsDocTy $1 $2)) $4) [mj AnnRarrow $3] } - | 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) @@ -1791,6 +1786,23 @@ varids0 :: { Located [Located RdrName] } : {- empty -} { noLoc [] } | varids0 tyvar { sLL $1 $> ($2 : unLoc $1) } +{- +Note [Parsing ~] +~~~~~~~~~~~~~~~~ + +Due to parsing conflicts between lazyness annotations in data type +declarations (see strict_mark) and equality types ~'s are always +parsed as lazyness annotations, and turned into HsEqTy's in the +correct places using RdrHsSyn.splitTilde. + +Since strict_mark is parsed as part of atype which is part of type, +typedoc and context (where HsEqTy previously appeared) it made most +sense and was simplest to parse ~ as part of strict_mark and later +turn them into HsEqTy's. + +-} + + ----------------------------------------------------------------------------- -- Kinds diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index aa0b8cf16f..357512be33 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -52,6 +52,7 @@ module RdrHsSyn ( checkDoAndIfThenElse, checkRecordSyntax, parseErrorSDoc, + splitTilde, -- Help with processing exports ImpExpSubSpec(..), @@ -1059,6 +1060,21 @@ isFunLhs e = go e [] [] go _ _ _ = return Nothing +-- | Transform btype with strict_mark's into HsEqTy's +-- (((~a) ~b) c) ~d ==> ((~a) ~ (b c)) ~ d +splitTilde :: LHsType RdrName -> LHsType RdrName +splitTilde t = go t + where go (L loc (HsAppTy t1 t2)) + | L _ (HsBangTy (HsSrcBang Nothing NoSrcUnpack SrcLazy) t2') <- t2 + = L loc (HsEqTy (go t1) t2') + | otherwise + = case go t1 of + (L _ (HsEqTy tl tr)) -> + L loc (HsEqTy tl (L (combineLocs tr t2) (HsAppTy tr t2))) + t -> L loc (HsAppTy t t2) + + go t = t + --------------------------------------------------------------------------- -- Check for monad comprehensions -- diff --git a/compiler/prelude/TysWiredIn.hs b/compiler/prelude/TysWiredIn.hs index f7d08ff1c4..83599682e9 100644 --- a/compiler/prelude/TysWiredIn.hs +++ b/compiler/prelude/TysWiredIn.hs @@ -285,7 +285,7 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon = data_con where data_con = mkDataCon dc_name declared_infix - (map (const HsNoBang) arg_tys) + (map (const HsLazy) arg_tys) [] -- No labelled fields tyvars [] -- No existential type variables diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index cc09d23554..605ba57089 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -1371,7 +1371,7 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd) = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl) ; return Nothing } -checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () +checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields @@ -1408,7 +1408,7 @@ checkMissingFields data_con rbinds field_labels field_strs - field_strs = dataConSrcBangs data_con + field_strs = dataConImplBangs data_con {- ************************************************************************ diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index c46a2174d5..010a67940f 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -838,8 +838,8 @@ checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig) -> TyThing -> TyThing -> TcM () checkBootDeclM is_boot boot_thing real_thing = whenIsJust (checkBootDecl boot_thing real_thing) $ \ err -> - addErrAt (nameSrcSpan (getName boot_thing)) - (bootMisMatch is_boot err real_thing boot_thing) + addErrAt (nameSrcSpan (getName boot_thing)) + (bootMisMatch is_boot err real_thing boot_thing) -- | Compares the two things for equivalence between boot-file and normal -- code. Returns @Nothing@ on success or @Just "some helpful info for user"@ @@ -1017,8 +1017,7 @@ checkBootTyCon tc1 tc2 check (dataConIsInfix c1 == dataConIsInfix c2) (text "The fixities of" <+> pname1 <+> text "differ") `andThenCheck` - check (eqListBy eqHsBang - (dataConSrcBangs c1) (dataConSrcBangs c2)) + check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs 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 d8dde3346e..4a414a2d43 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1490,12 +1490,13 @@ reifyFixity name conv_dir BasicTypes.InfixN = TH.InfixN 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 +reifyStrict HsLazy = TH.NotStrict +reifyStrict (HsSrcBang _ _ SrcLazy) = TH.NotStrict +reifyStrict (HsSrcBang _ _ NoSrcStrictness) = TH.NotStrict +reifyStrict (HsSrcBang _ SrcUnpack SrcStrict) = TH.Unpacked +reifyStrict (HsSrcBang _ _ SrcStrict) = 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 9c14055c08..b7a959e207 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1613,15 +1613,24 @@ checkValidDataCon dflags existential_ok tc con } where ctxt = ConArgCtxt (dataConName con) - check_bang (HsSrcBang _ (Just want_unpack) has_bang, rep_bang, n) - | want_unpack, not has_bang + + check_bang (HsSrcBang _ _ SrcLazy, _, n) + | not (xopt Opt_StrictData dflags) + = addErrTc + (bad_bang n (ptext (sLit "Lazy annotation (~) without StrictData"))) + check_bang (HsSrcBang _ want_unpack strict_mark, rep_bang, n) + | isSrcUnpacked want_unpack, not is_strict = addWarnTc (bad_bang n (ptext (sLit "UNPACK pragma lacks '!'"))) - | want_unpack + | isSrcUnpacked 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 (bad_bang n (ptext (sLit "Ignoring unusable UNPACK pragma"))) + where + is_strict = case strict_mark of + NoSrcStrictness -> xopt Opt_StrictData dflags + bang -> isSrcStrict bang check_bang _ = return () @@ -1634,7 +1643,7 @@ checkNewDataCon :: DataCon -> TcM () -- Further checks for the data constructor of a newtype checkNewDataCon con = do { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys)) - -- One argument + -- One argument ; check_con (null eq_spec) $ ptext (sLit "A newtype constructor must have a return type of form T a1 ... an") @@ -1647,15 +1656,20 @@ checkNewDataCon con ptext (sLit "A newtype constructor cannot have existential type variables") -- No existentials - ; checkTc (not (any isBanged (dataConSrcBangs con))) + ; checkTc (all ok_bang (dataConSrcBangs con)) (newtypeStrictError con) - -- No strictness + -- No strictness annotations } where (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con + check_con what msg = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con)) + ok_bang (HsSrcBang _ _ SrcStrict) = False + ok_bang (HsSrcBang _ _ SrcLazy) = False + ok_bang _ = True + ------------------------------- checkValidClass :: Class -> TcM () checkValidClass cls @@ -1704,7 +1718,7 @@ checkValidClass cls -- Here, MonadState has a fundep m->b, so newBoard is fine ; unless constrained_class_methods $ - mapM_ check_constraint (tail (theta1 ++ theta2)) + mapM_ check_constraint (tail (theta1 ++ theta2)) ; case dm of GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name @@ -2164,7 +2178,7 @@ classFunDepsErr cls badMethPred :: Id -> TcPredType -> SDoc badMethPred sel_id pred - = vcat [ hang (ptext (sLit "Constraint") <+> quotes (ppr pred) + = vcat [ hang (ptext (sLit "Constraint") <+> quotes (ppr pred) <+> ptext (sLit "in the type of") <+> quotes (ppr sel_id)) 2 (ptext (sLit "constrains only the class type variables")) , ptext (sLit "Use ConstrainedClassMethods to allow it") ] diff --git a/compiler/vectorise/Vectorise/Generic/PData.hs b/compiler/vectorise/Vectorise/Generic/PData.hs index ed127b449f..e9a1133348 100644 --- a/compiler/vectorise/Vectorise/Generic/PData.hs +++ b/compiler/vectorise/Vectorise/Generic/PData.hs @@ -5,7 +5,7 @@ -- We should be able to factor out the common parts. module Vectorise.Generic.PData ( buildPDataTyCon - , buildPDatasTyCon ) + , buildPDatasTyCon ) where import Vectorise.Monad @@ -31,7 +31,7 @@ import Control.Monad -- buildPDataTyCon ------------------------------------------------------------ -- | Build the PData instance tycon for a given type constructor. buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst -buildPDataTyCon orig_tc vect_tc repr +buildPDataTyCon orig_tc vect_tc repr = fixV $ \fam_inst -> do let repr_tc = dataFamInstRepTyCon fam_inst name' <- mkLocalisedName mkPDataTyConOcc orig_name @@ -79,7 +79,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr fam_envs <- readGEnv global_fam_inst_env liftDs $ buildDataCon fam_envs dc_name False -- not infix - (map (const HsNoBang) comp_tys) + (map (const HsLazy) comp_tys) [] -- no field labels tvs [] -- no existentials @@ -93,7 +93,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr -- buildPDatasTyCon ----------------------------------------------------------- -- | Build the PDatas instance tycon for a given type constructor. buildPDatasTyCon :: TyCon -> TyCon -> SumRepr -> VM FamInst -buildPDatasTyCon orig_tc vect_tc repr +buildPDatasTyCon orig_tc vect_tc repr = fixV $ \fam_inst -> do let repr_tc = dataFamInstRepTyCon fam_inst name' <- mkLocalisedName mkPDatasTyConOcc orig_name @@ -118,7 +118,7 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr fam_envs <- readGEnv global_fam_inst_env liftDs $ buildDataCon fam_envs dc_name False -- not infix - (map (const HsNoBang) comp_tys) + (map (const HsLazy) comp_tys) [] -- no field labels tvs [] -- no existentials @@ -131,7 +131,7 @@ buildPDatasDataCon orig_name vect_tc repr_tc repr -- Utils ---------------------------------------------------------------------- -- | Flatten a SumRepr into a list of data constructor types. -mkSumTys +mkSumTys :: (SumRepr -> Type) -> (Type -> VM Type) -> SumRepr @@ -158,4 +158,3 @@ mk_fam_inst :: TyCon -> TyCon -> (TyCon, [Type]) mk_fam_inst fam_tc arg_tc = (fam_tc, [mkTyConApp arg_tc . mkTyVarTys $ tyConTyVars arg_tc]) -} - diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml index c9186006d6..39b48722c1 100644 --- a/docs/users_guide/flags.xml +++ b/docs/users_guide/flags.xml @@ -720,7 +720,7 @@ <tbody> <row> <entry><option>-fconstraint-solver-iterations=</option><replaceable>n</replaceable></entry> - <entry>Set the iteration limit for the type-constraint solver. + <entry>Set the iteration limit for the type-constraint solver. The default limit is 4. Typically one iteration suffices; so please yell if you find you need to set it higher than the default. Zero means infinity. </entry> @@ -729,7 +729,7 @@ </row> <row> <entry><option>-freduction-depth=</option><replaceable>n</replaceable></entry> - <entry>Set the <link linkend="undecidable-instances">limit for type simplification</link>. + <entry>Set the <link linkend="undecidable-instances">limit for type simplification</link>. Default is 200; zero means infinity.</entry> <entry>dynamic</entry> <entry></entry> @@ -1309,7 +1309,7 @@ </row> <row> <entry><option>-XRelaxedPolyRec</option></entry> - <entry><emphasis>(deprecated)</emphasis> Relaxed checking for + <entry><emphasis>(deprecated)</emphasis> Relaxed checking for <link linkend="typing-binds">mutually-recursive polymorphic functions</link>.</entry> <entry>dynamic</entry> <entry><option>-XNoRelaxedPolyRec</option></entry> @@ -1345,6 +1345,12 @@ <entry>6.8.1</entry> </row> <row> + <entry><option>-XStrictData</option></entry> + <entry>Enable <link linkend="strict-data">default strict datatype fields</link>.</entry> + <entry>dynamic</entry> + <entry><option>-XNoStrictData</option></entry> + </row> + <row> <entry><option>-XTemplateHaskell</option></entry> <entry>Enable <link linkend="template-haskell">Template Haskell</link>.</entry> <entry>dynamic</entry> diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 9685b1d29a..e3368f2129 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -1114,7 +1114,7 @@ on <literal>MkT</literal>. But the same pattern match also <emphasis>provides</e </para> <para> Exactly the same reasoning applies to <literal>ExNumPat</literal>: -matching against <literal>ExNumPat</literal> <emphasis>requires</emphasis> +matching against <literal>ExNumPat</literal> <emphasis>requires</emphasis> the constraints <literal>(Num a, Eq a)</literal>, and <emphasis>provides</emphasis> the constraint <literal>(Show b)</literal>. </para> @@ -4707,7 +4707,7 @@ class type variable (in this case <literal>a</literal>). </para> <para> GHC lifts this restriction with language extension <option>-XConstrainedClassMethods</option>. -The restriction is a pretty stupid one in the first place, +The restriction is a pretty stupid one in the first place, so <option>-XConstrainedClassMethods</option> is implied by <option>-XMultiParamTypeClasses</option>. </para> </sect3> @@ -5235,7 +5235,7 @@ termination: see <xref linkend="instance-termination"/>. <para> Regardless of <option>-XFlexibleInstances</option> and <option>-XFlexibleContexts</option>, instance declarations must conform to some rules that ensure that instance resolution -will terminate. The restrictions can be lifted with <option>-XUndecidableInstances</option> +will terminate. The restrictions can be lifted with <option>-XUndecidableInstances</option> (see <xref linkend="undecidable-instances"/>). </para> <para> @@ -6908,8 +6908,8 @@ T :: (k -> *) -> k -> * </para></listitem> <listitem><para> -GHC does not usually print explicit <literal>forall</literal>s, including kind <literal>forall</literal>s. -You can make GHC show them explicitly with <option>-fprint-explicit-foralls</option> +GHC does not usually print explicit <literal>forall</literal>s, including kind <literal>forall</literal>s. +You can make GHC show them explicitly with <option>-fprint-explicit-foralls</option> (see <xref linkend="options-help"/>): <programlisting> ghci> :set -XPolyKinds @@ -6981,7 +6981,7 @@ very convenient, and it is not clear what the syntax for explicit quantification Generally speaking, when <option>-XPolyKinds</option> is on, GHC tries to infer the most general kind for a declaration. For example: <programlisting> -data T f a = MkT (f a) -- GHC infers: +data T f a = MkT (f a) -- GHC infers: -- T :: forall k. (k->*) -> k -> * </programlisting> In this case the definition has a right-hand side to inform kind inference. @@ -6990,9 +6990,9 @@ But that is not always the case. Consider type family F a </programlisting> Type family declarations have no right-hand side, but GHC must still infer a kind -for <literal>F</literal>. Since there are no constraints, it could infer -<literal>F :: forall k1 k2. k1 -> k2</literal>, but that seems <emphasis>too</emphasis> -polymorphic. So GHC defaults those entirely-unconstrained kind variables to <literal>*</literal> and +for <literal>F</literal>. Since there are no constraints, it could infer +<literal>F :: forall k1 k2. k1 -> k2</literal>, but that seems <emphasis>too</emphasis> +polymorphic. So GHC defaults those entirely-unconstrained kind variables to <literal>*</literal> and we get <literal>F :: * -> *</literal>. You can still declare <literal>F</literal> to be kind-polymorphic using kind signatures: <programlisting> @@ -7014,23 +7014,23 @@ by the class method signatures. </para></listitem> <listitem><para> <emphasis>When there is no right hand side, GHC defaults argument and result kinds to <literal>*</literal>, -except when directed otherwise by a kind signature</emphasis>. +except when directed otherwise by a kind signature</emphasis>. Examples: data and type family declarations. </para></listitem> </itemizedlist> -This rule has occasionally-surprising consequences +This rule has occasionally-surprising consequences (see <ulink url="https://ghc.haskell.org/trac/ghc/ticket/10132">Trac 10132</ulink>). <programlisting> class C a where -- Class declarations are generalised -- so C :: forall k. k -> Constraint - data D1 a -- No right hand side for these two family + data D1 a -- No right hand side for these two family type F1 a -- declarations, but the class forces (a :: k) -- so D1, F1 :: forall k. k -> * data D2 a -- No right-hand side so D2 :: * -> * type F2 a -- No right-hand side so F2 :: * -> * </programlisting> -The kind-polymorphism from the class declaration makes <literal>D1</literal> +The kind-polymorphism from the class declaration makes <literal>D1</literal> kind-polymorphic, but not so <literal>D2</literal>; and similarly <literal>F1</literal>, <literal>F1</literal>. </para> </sect2> @@ -8500,7 +8500,7 @@ for rank-2 types. <title>Impredicative polymorphism </title> <para>In general, GHC will only instantiate a polymorphic function at -a monomorphic type (one with no foralls). For example, +a monomorphic type (one with no foralls). For example, <programlisting> runST :: (forall s. ST s a) -> a id :: forall b. b -> b @@ -13303,10 +13303,48 @@ Here are some examples:</para> </sect1> +<sect1 id="strict-haskell"> + <title>Strict Haskell</title> + <indexterm><primary>strict haskell</primary></indexterm> + + <para>High-performance Haskell code (e.g. numeric code) can + sometimes be littered with bang patterns, making it harder to + read. The reason is that lazy evaluation isn't the right default in + this particular code but the programmer has no way to say that + except by repeatedly adding bang patterns. Below + <option>-XStrictData</option> is detailed that allows the programmer + to switch the default behavior on a per-module basis.</para> + + <sect2 id="strict-data"> + <title>Strict-by-default data types</title> + + <para>Informally the <literal>StrictData</literal> language + extension switches data type declarations to be strict by default + allowing fields to be lazy by adding a <literal>~</literal> in + front of the field.</para> + + <para>When the user writes</para> + + <programlisting> + data T = C a + data T' = C' ~a + </programlisting> + + <para>we interpret it as if she had written</para> + + <programlisting> + data T = C !a + data T' = C' a + </programlisting> + + <para>The extension only affects definitions in this module.</para> + </sect2> + +</sect1> + <!-- Emacs stuff: ;;; Local Variables: *** ;;; sgml-parent-document: ("users_guide.xml" "book" "chapter" "sect1") *** ;;; ispell-local-dictionary: "british" *** ;;; End: *** --> - diff --git a/testsuite/tests/deSugar/should_run/DsStrictData.hs b/testsuite/tests/deSugar/should_run/DsStrictData.hs new file mode 100644 index 0000000000..f1898a5f6a --- /dev/null +++ b/testsuite/tests/deSugar/should_run/DsStrictData.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE ScopedTypeVariables, StrictData, GADTs #-} + +-- | Tests the StrictData LANGUAGE pragma. +module Main where + +import qualified Control.Exception as E +import System.IO.Unsafe (unsafePerformIO) + +data Strict a = S a +data Strict2 b = S2 !b +data Strict3 c where + S3 :: c -> Strict3 c + +data UStrict = US {-# UNPACK #-} Int + +data Lazy d = L ~d +data Lazy2 e where + L2 :: ~e -> Lazy2 e + +main :: IO () +main = + do print (isBottom (S bottom)) + print (isBottom (S2 bottom)) + print (isBottom (US bottom)) + print (isBottom (S3 bottom)) + putStrLn "" + print (not (isBottom (L bottom))) + print (not (isBottom (L2 bottom))) + print (not (isBottom (Just bottom))) -- sanity check + +------------------------------------------------------------------------ +-- Support for testing for bottom + +bottom :: a +bottom = error "_|_" + +isBottom :: a -> Bool +isBottom f = unsafePerformIO $ + (E.evaluate f >> return False) `E.catches` + [ E.Handler (\(_ :: E.ArrayException) -> return True) + , E.Handler (\(_ :: E.ErrorCall) -> return True) + , E.Handler (\(_ :: E.NoMethodError) -> return True) + , E.Handler (\(_ :: E.NonTermination) -> return True) + , E.Handler (\(_ :: E.PatternMatchFail) -> return True) + , E.Handler (\(_ :: E.RecConError) -> return True) + , E.Handler (\(_ :: E.RecSelError) -> return True) + , E.Handler (\(_ :: E.RecUpdError) -> return True) + ] diff --git a/testsuite/tests/deSugar/should_run/DsStrictData.stdout b/testsuite/tests/deSugar/should_run/DsStrictData.stdout new file mode 100644 index 0000000000..b34f35dcee --- /dev/null +++ b/testsuite/tests/deSugar/should_run/DsStrictData.stdout @@ -0,0 +1,8 @@ +True +True +True +True + +True +True +True diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T index 57878161a3..228b90dd0f 100644 --- a/testsuite/tests/deSugar/should_run/all.T +++ b/testsuite/tests/deSugar/should_run/all.T @@ -47,3 +47,4 @@ test('DsStaticPointers', compile_and_run, ['']) test('T8952', normal, compile_and_run, ['']) test('T9844', normal, compile_and_run, ['']) +test('DsStrictData', normal, compile_and_run, ['']) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index dde6da7b16..3c6de35402 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -33,7 +33,8 @@ expectedGhcOnlyExtensions :: [String] expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", - "StaticPointers"] + "StaticPointers", + "StrictData"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", @@ -47,4 +48,3 @@ expectedCabalOnlyExtensions = ["Generics", "Safe", "Unsafe", "Trustworthy"] - diff --git a/utils/haddock b/utils/haddock -Subproject 553c719236972f3a1d445146352ec94614979b6 +Subproject 5eb0785cde60997f072c3bdfefaf8c389c96d42 |