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

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
This diff is collapsed.
......@@ -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] }
-- 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
......
......@@ -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
--
......
......@@ -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
......
......@@ -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
{-
************************************************************************
......
......@@ -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)
......
......@@ -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
......
......@@ -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") ]
......
......@@ -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])
-}
......@@ -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>
......@@ -1344,6 +1344,12 @@
<entry><option>-XNoStandaloneDeriving</option></entry>
<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>
......
......@@ -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"/>):