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

Replace HsBang type with HsSrcBang and HsImplBang

Updates haddock submodule.

Reviewers: tibbe, goldfire, simonpj, austin, bgamari

Reviewed By: simonpj, bgamari

Subscribers: goldfire, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1069
parent a40ec755
......@@ -10,8 +10,8 @@
module DataCon (
-- * Main data types
DataCon, DataConRep(..),
HsBang(..), SrcStrictness(..), SrcUnpackedness(..),
HsSrcBang, HsImplBang,
SrcStrictness(..), SrcUnpackedness(..),
HsSrcBang(..), HsImplBang(..),
StrictnessMark(..),
ConTag,
......@@ -68,6 +68,7 @@ import BasicTypes
import FastString
import Module
import VarEnv
import Binary
import qualified Data.Data as Data
import qualified Data.Typeable
......@@ -347,13 +348,10 @@ data DataCon
-- The OrigResTy is T [a], but the dcRepTyCon might be :T123
-- Now the strictness annotations and field labels of the constructor
dcSrcBangs :: [HsBang],
dcSrcBangs :: [HsSrcBang],
-- See Note [Bangs on data constructor arguments]
-- 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
--
-- The [HsSrcBang] as written by the programmer.
--
-- Matches 1-1 with dcOrigArgTys
-- Hence length = dataConSourceArity dataCon
......@@ -448,36 +446,34 @@ data DataConRep
-- when we bring bits of unfoldings together.)
-------------------------
-- | 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
-- | 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
SrcUnpackedness
SrcStrictness
-- Definite implementation commitments, generated by the compiler
-- 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
-- | Bangs on data constructor arguments as the user wrote them in the
-- source code.
--
-- (HsSrcBang _ SrcUnpack SrcLazy) and
-- (HsSrcBang _ SrcUnpack NoSrcStrict) (without StrictData) makes no sense, we
-- emit a warning (in checkValidDataCon) and treat it like
-- (HsSrcBang _ NoSrcUnpack SrcLazy)
data HsSrcBang =
HsSrcBang (Maybe SourceText) -- Note [Pragma source text] in BasicTypes
SrcUnpackedness
SrcStrictness
deriving (Data.Data, Data.Typeable)
-- | Bangs of data constructor arguments as generated by the compiler
-- after consulting HsSrcBang, flags, etc.
data HsImplBang
= HsLazy -- ^ Lazy field
| HsStrict -- ^ Strict but not unpacked field
| HsUnpack (Maybe Coercion)
-- ^ Strict and unpacked field
-- co :: arg-ty ~ product-ty HsBang
deriving (Data.Data, Data.Typeable)
-- | What strictness annotation the user wrote
data SrcStrictness = SrcLazy -- ^ Lazy, ie '~'
| SrcStrict -- ^ Strict, ie '!'
| NoSrcStrictness -- ^ no strictness annotation
| NoSrcStrict -- ^ no strictness annotation
deriving (Eq, Data.Data, Data.Typeable)
-- | What unpackedness the user requested
......@@ -487,14 +483,6 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
deriving (Eq, Data.Data, Data.Typeable)
-- Two type-insecure, but useful, synonyms
-- | 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
......@@ -523,10 +511,10 @@ Terminology:
, 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
defining module. The importing module must follow those decisions,
regardless of the flag settings in the importing module.
* However, if T was defined in an imported module, the importing module
must follow the decisions made in the original module, regardless of
the flag settings in the importing module.
Also see Note [Bangs on imported data constructors] in MkId
* 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
......@@ -595,17 +583,19 @@ instance Data.Data DataCon where
gunfold _ _ = error "gunfold"
dataTypeOf _ = mkNoRepType "DataCon"
instance Outputable HsBang where
instance Outputable HsSrcBang where
ppr (HsSrcBang _ prag mark) = ppr prag <+> ppr mark
instance Outputable HsImplBang where
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
ppr SrcLazy = char '~'
ppr SrcStrict = char '!'
ppr NoSrcStrict = empty
instance Outputable SrcUnpackedness where
ppr SrcUnpack = ptext (sLit "{-# UNPACK #-}")
......@@ -613,13 +603,35 @@ instance Outputable SrcUnpackedness where
ppr NoSrcUnpack = empty
instance Outputable StrictnessMark where
ppr MarkedStrict = ptext (sLit "!")
ppr NotMarkedStrict = empty
ppr MarkedStrict = ptext (sLit "!")
ppr NotMarkedStrict = empty
instance Binary SrcStrictness where
put_ bh SrcLazy = putByte bh 0
put_ bh SrcStrict = putByte bh 1
put_ bh NoSrcStrict = putByte bh 2
get bh =
do h <- getByte bh
case h of
0 -> return SrcLazy
1 -> return SrcLazy
_ -> return NoSrcStrict
instance Binary SrcUnpackedness where
put_ bh SrcNoUnpack = putByte bh 0
put_ bh SrcUnpack = putByte bh 1
put_ bh NoSrcUnpack = putByte bh 2
get bh =
do h <- getByte bh
case h of
0 -> return SrcNoUnpack
1 -> return SrcUnpack
_ -> return NoSrcUnpack
-- | Compare strictness annotations
eqHsBang :: HsBang -> HsBang -> Bool
eqHsBang (HsSrcBang _ u1 b1) (HsSrcBang _ u2 b2) = u1==u2 && b1==b2
eqHsBang :: HsImplBang -> HsImplBang -> Bool
eqHsBang HsLazy HsLazy = True
eqHsBang HsStrict HsStrict = True
eqHsBang (HsUnpack Nothing) (HsUnpack Nothing) = True
......@@ -631,8 +643,6 @@ 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
......@@ -657,8 +667,7 @@ 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
-> [HsSrcBang] -- ^ Strictness/unpack annotations, from user
-> [FieldLabel] -- ^ Field labels for the constructor,
-- if it is a record, otherwise empty
-> [TyVar] -- ^ Universally quantified type variables
......@@ -828,8 +837,10 @@ dataConFieldType con label
Just ty -> ty
Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
-- | The strictness markings written by the porgrammer.
-- | Strictness/unpack annotations, from user; or, for imported
-- DataCons, from the interface file
-- The list is in one-to-one correspondence with the arity of the 'DataCon'
dataConSrcBangs :: DataCon -> [HsSrcBang]
dataConSrcBangs = dcSrcBangs
......
......@@ -465,8 +465,14 @@ newtype DataConBoxer = DCB ([Type] -> [Var] -> UniqSM ([Var], [CoreBind]))
-- Bind these src-level vars, returning the
-- rep-level vars to bind in the pattern
mkDataConRep :: DynFlags -> FamInstEnvs -> Name -> DataCon -> UniqSM DataConRep
mkDataConRep dflags fam_envs wrap_name data_con
mkDataConRep :: DynFlags
-> FamInstEnvs
-> Name
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors]
-> DataCon
-> UniqSM DataConRep
mkDataConRep dflags fam_envs wrap_name mb_bangs data_con
| not wrapper_reqd
= return NoDataConRep
......@@ -488,7 +494,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
-- so it not make sure that the CAF info is sane
wrap_sig = mkClosedStrictSig wrap_arg_dmds (dataConCPR data_con)
wrap_arg_dmds = map mk_dmd (dropList eq_spec wrap_bangs)
wrap_arg_dmds = map mk_dmd arg_ibangs
mk_dmd str | isBanged str = evalDmd
| otherwise = topDmd
-- The Cpr info can be important inside INLINE rhss, where the
......@@ -511,7 +517,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
, dcr_boxer = mk_boxer boxers
, dcr_arg_tys = rep_tys
, dcr_stricts = rep_strs
, dcr_bangs = dropList ev_tys wrap_bangs }) }
, dcr_bangs = arg_ibangs }) }
where
(univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys, _) = dataConFullSig data_con
......@@ -519,8 +525,9 @@ mkDataConRep dflags fam_envs wrap_name data_con
tycon = dataConTyCon data_con -- The representation TyCon (not family)
wrap_ty = dataConUserType data_con
ev_tys = eqSpecPreds eq_spec ++ theta
all_arg_tys = ev_tys ++ orig_arg_tys
orig_bangs = map mk_pred_strict_mark ev_tys ++ dataConSrcBangs data_con
all_arg_tys = ev_tys ++ orig_arg_tys
ev_ibangs = map mk_pred_strict_mark ev_tys
orig_bangs = dataConSrcBangs data_con
wrap_arg_tys = theta ++ orig_arg_tys
wrap_arity = length wrap_arg_tys
......@@ -528,14 +535,21 @@ mkDataConRep dflags fam_envs wrap_name data_con
-- Because we are going to apply the eq_spec args manually in the
-- wrapper
(wrap_bangs, rep_tys_w_strs, wrappers)
= unzip3 (zipWith (dataConArgRep dflags fam_envs) all_arg_tys orig_bangs)
arg_ibangs =
case mb_bangs of
Nothing -> zipWith (dataConSrcToImplBang dflags fam_envs)
orig_arg_tys orig_bangs
Just bangs -> bangs
(rep_tys_w_strs, wrappers)
= unzip (zipWith dataConArgRep all_arg_tys (ev_ibangs ++ arg_ibangs))
(unboxers, boxers) = unzip wrappers
(rep_tys, rep_strs) = unzip (concat rep_tys_w_strs)
wrapper_reqd = not (isNewTyCon tycon) -- Newtypes have only a worker
&& (any isBanged wrap_bangs -- Some forcing/unboxing
-- (includes eq_spec)
&& (any isBanged (ev_ibangs ++ arg_ibangs)
-- Some forcing/unboxing (includes eq_spec)
|| isFamInstTyCon tycon) -- Cast result
initial_wrap_app = Var (dataConWorkId data_con)
......@@ -572,38 +586,52 @@ mkDataConRep dflags fam_envs wrap_name data_con
; expr <- mk_rep_app prs (mkVarApps con_app rep_ids)
; return (unbox_fn expr) }
{-
Note [Bangs on imported data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We pass Maybe [HsImplBang] to mkDataConRep to make use of HsImplBangs
from imported modules.
- Nothing <=> use HsSrcBangs
- Just bangs <=> use HsImplBangs
For imported types we can't work it all out from the HsSrcBangs,
because we want to be very sure to follow what the original module
(where the data type was declared) decided, and that depends on what
flags were enabled when it was compiled. So we record the decisions in
the interface file.
The HsImplBangs passed are in 1-1 correspondence with the
dataConOrigArgTys of the DataCon.
-}
-------------------------
newLocal :: Type -> UniqSM Var
newLocal ty = do { uniq <- getUniqueM
; return (mkSysLocal (fsLit "dt") uniq ty) }
-------------------------
dataConArgRep
-- | Unpack/Strictness decisions from source module
dataConSrcToImplBang
:: DynFlags
-> FamInstEnvs
-> Type
-> HsSrcBang -- For DataCons defined in this module, this is the
-- bang/unpack annotation that the programmer wrote
-- For DataCons imported from an interface file, this
-- is the HsImplBang implementation decision taken
-- by the compiler in the defining module; just follow
-- it slavishly, so that we make the same decision as
-- in the defining module
-> ( HsImplBang -- Implementation decision about unpack strategy
, [(Type, StrictnessMark)] -- Rep types
, (Unboxer, Boxer) )
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)
-> HsSrcBang
-> HsImplBang
| otherwise -- no StrictData => lazy field
= (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConSrcToImplBang dflags fam_envs arg_ty
(HsSrcBang ann unpk NoSrcStrict)
| xopt Opt_StrictData dflags -- StrictData => strict field
= dataConSrcToImplBang dflags fam_envs arg_ty
(HsSrcBang ann unpk SrcStrict)
| otherwise -- no StrictData => lazy field
= HsLazy
dataConArgRep _ _ arg_ty (HsSrcBang _ _ SrcLazy)
= (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConSrcToImplBang _ _ _ (HsSrcBang _ _ SrcLazy)
= HsLazy
dataConArgRep dflags fam_envs arg_ty
dataConSrcToImplBang dflags fam_envs arg_ty
(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,
......@@ -612,7 +640,7 @@ dataConArgRep dflags fam_envs arg_ty
-- Unwrap type families and newtypes
arg_ty' = case mb_co of { Just (_,ty) -> ty; Nothing -> arg_ty }
, isUnpackableType dflags fam_envs arg_ty'
, (rep_tys, wrappers) <- dataConArgUnpack arg_ty'
, (rep_tys, _) <- dataConArgUnpack arg_ty'
, case unpk_prag of
NoSrcUnpack ->
gopt Opt_UnboxStrictFields dflags
......@@ -620,30 +648,36 @@ dataConArgRep dflags fam_envs arg_ty
&& 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)
Nothing -> HsUnpack Nothing
Just (co,_) -> HsUnpack (Just co)
| otherwise -- Record the strict-but-no-unpack decision
= strict_but_not_unpacked arg_ty
= HsStrict
dataConArgRep _ _ arg_ty HsLazy
= (HsLazy, [(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep _ _ arg_ty HsStrict
= strict_but_not_unpacked arg_ty
-- | Wrappers/Workser and representation following Unpack/Strictness
-- decisions
dataConArgRep
:: Type
-> HsImplBang
-> ([(Type,StrictnessMark)] -- Rep types
,(Unboxer,Boxer))
dataConArgRep arg_ty HsLazy
= ([(arg_ty, NotMarkedStrict)], (unitUnboxer, unitBoxer))
dataConArgRep _ _ arg_ty (HsUnpack Nothing)
dataConArgRep arg_ty HsStrict
= ([(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
dataConArgRep arg_ty (HsUnpack Nothing)
| (rep_tys, wrappers) <- dataConArgUnpack arg_ty
= (HsUnpack Nothing, rep_tys, wrappers)
= (rep_tys, wrappers)
dataConArgRep _ _ _ (HsUnpack (Just co))
dataConArgRep _ (HsUnpack (Just co))
| let co_rep_ty = pSnd (coercionKind co)
, (rep_tys, wrappers) <- dataConArgUnpack co_rep_ty
= (HsUnpack (Just co), rep_tys, wrapCo co co_rep_ty wrappers)
= (rep_tys, wrapCo co co_rep_ty wrappers)
strict_but_not_unpacked :: Type -> (HsImplBang, [(Type,StrictnessMark)], (Unboxer, Boxer))
strict_but_not_unpacked arg_ty
= (HsStrict, [(arg_ty, MarkedStrict)], (seqUnboxer, unitBoxer))
-------------------------
wrapCo :: Coercion -> Type -> (Unboxer, Boxer) -> (Unboxer, Boxer)
......@@ -736,19 +770,13 @@ isUnpackableType dflags 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 HsStrict
= False
attempt_unpack HsLazy
= False
attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrictness)
attempt_unpack (HsSrcBang _ SrcUnpack NoSrcStrict)
= xopt Opt_StrictData dflags
attempt_unpack (HsSrcBang _ SrcUnpack SrcStrict)
= True
attempt_unpack (HsSrcBang _ NoSrcUnpack SrcStrict)
= True -- Be conservative
attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrictness)
attempt_unpack (HsSrcBang _ NoSrcUnpack NoSrcStrict)
= xopt Opt_StrictData dflags -- Be conservative
attempt_unpack _ = False
......@@ -817,7 +845,8 @@ space for each equality predicate, so it's pretty important!
mk_pred_strict_mark :: PredType -> HsImplBang
mk_pred_strict_mark pred
| isEqPred pred = HsUnpack Nothing -- Note [Unpack equality predicates]
| isEqPred pred = HsUnpack Nothing
-- Note [Unpack equality predicates]
| otherwise = HsLazy
{-
......
......@@ -28,7 +28,8 @@ module HsTypes (
HsTyLit(..),
HsIPName(..), hsIPNameFS,
LBangType, BangType, HsBang(..), HsSrcBang, HsImplBang,
LBangType, BangType,
HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..),
getBangType, getBangStrictness,
......@@ -63,7 +64,7 @@ import PlaceHolder ( PostTc,PostRn,DataId,PlaceHolder(..) )
import Name( Name )
import RdrName( RdrName )
import DataCon( HsBang(..), HsSrcBang, HsImplBang,
import DataCon( HsSrcBang(..), HsImplBang(..),
SrcStrictness(..), SrcUnpackedness(..) )
import TysPrim( funTyConName )
import Type
......@@ -99,7 +100,7 @@ getBangType ty = ty
getBangStrictness :: LHsType a -> HsSrcBang
getBangStrictness (L _ (HsBangTy s _)) = s
getBangStrictness _ = HsSrcBang Nothing NoSrcUnpack NoSrcStrictness
getBangStrictness _ = (HsSrcBang Nothing NoSrcUnpack NoSrcStrict)
{-
************************************************************************
......
......@@ -129,20 +129,22 @@ mkNewTyConRhs tycon_name tycon con
------------------------------------------------------
buildDataCon :: FamInstEnvs
-> Name -> Bool
-> [HsBang]
-> [Name] -- Field labels
-> [TyVar] -> [TyVar] -- Univ and ext
-> [(TyVar,Type)] -- Equality spec
-> ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
-> [Type] -> Type -- Argument and result types
-> TyCon -- Rep tycon
-> TcRnIf m n DataCon
-> [HsSrcBang]
-> Maybe [HsImplBang]
-- See Note [Bangs on imported data constructors] in MkId
-> [Name] -- Field labels
-> [TyVar] -> [TyVar] -- Univ and ext
-> [(TyVar,Type)] -- Equality spec
-> ThetaType -- Does not include the "stupid theta"
-- or the GADT equalities
-> [Type] -> Type -- Argument and result types
-> TyCon -- Rep tycon
-> TcRnIf m n DataCon
-- A wrapper for DataCon.mkDataCon that
-- a) makes the worker Id
-- b) makes the wrapper Id if necessary, including
-- allocating its unique (hence monadic)
buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
buildDataCon fam_envs src_name declared_infix src_bangs impl_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
= do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
......@@ -155,12 +157,13 @@ buildDataCon fam_envs src_name declared_infix arg_stricts field_lbls
; let
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix
arg_stricts field_lbls
src_bangs field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty rep_tycon
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name data_con)
dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name
impl_bangs data_con)
; return data_con }
......@@ -272,7 +275,8 @@ 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 HsLazy) args)
(map (const no_bang) args)
(Just (map (const HsLazy) args))
[{- No fields -}]
tvs [{- no existentials -}]
[{- No GADT equalities -}]
......@@ -308,6 +312,8 @@ buildClass tycon_name tvs roles sc_theta fds at_items sig_stuff mindef tc_isrec
; traceIf (text "buildClass" <+> ppr tycon)
; return result }
where
no_bang = HsSrcBang Nothing NoSrcUnpack NoSrcStrict
mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem
mk_op_item rec_clas (op_name, dm_spec, _)
= do { dm_info <- case dm_spec of
......
......@@ -15,7 +15,9 @@ module IfaceSyn (
IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..),
IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,
IfaceClsInst(..), IfaceFamInst(..), IfaceTickish(..),
IfaceBang(..), IfaceAxBranch(..),
IfaceBang(..),
IfaceSrcBang(..), SrcUnpackedness(..), SrcStrictness(..),
IfaceAxBranch(..),
IfaceTyConParent(..),
-- Misc
......@@ -57,6 +59,7 @@ import TyCon (Role (..))
import StaticFlags (opt_PprStyle_Debug)
import Util( filterOut )
import InstEnv
import DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Control.Monad
import System.IO.Unsafe
......@@ -196,20 +199,28 @@ data IfaceConDecl
-- but it's not so easy for the original TyCon/DataCon
-- So this guarantee holds for IfaceConDecl, but *not* for DataCon
ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
ifConEqSpec :: IfaceEqSpec, -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [IfaceTopBndr], -- ...ditto... (field labels)
ifConStricts :: [IfaceBang]} -- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
ifConExTvs :: [IfaceTvBndr], -- Existential tyvars
ifConEqSpec :: IfaceEqSpec, -- Equality constraints
ifConCtxt :: IfaceContext, -- Non-stupid context
ifConArgTys :: [IfaceType], -- Arg types
ifConFields :: [IfaceTopBndr], -- ...ditto... (field labels)
ifConStricts :: [IfaceBang],
-- Empty (meaning all lazy),
-- or 1-1 corresp with arg tys
-- See Note [Bangs on imported data constructors] in MkId
ifConSrcStricts :: [IfaceSrcBang] } -- empty meaning no src stricts
type IfaceEqSpec = [(IfLclName,IfaceType)]
data IfaceBang -- This corresponds to an HsImplBang; that is, the final
-- implementation decision about the data constructor arg
-- | This corresponds to an HsImplBang; that is, the final
-- implementation decision about the data constructor arg
data IfaceBang
= IfNoBang | IfStrict | IfUnpack | IfUnpackCo IfaceCoercion
-- | This corresponds to HsSrcBang
data IfaceSrcBang
= IfSrcBang SrcUnpackedness SrcStrictness
data IfaceClsInst
= IfaceClsInst { ifInstCls :: IfExtName, -- See comments with
ifInstTys :: [Maybe IfaceTyCon], -- the defn of ClsInst
......@@ -1506,7 +1517,7 @@ instance Binary IfaceConDecls where
_ -> liftM IfNewTyCon $ get bh
instance Binary IfaceConDecl where
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
put_ bh a1
put_ bh a2
put_ bh a3
......@@ -1516,6 +1527,7 @@ instance Binary IfaceConDecl where
put_ bh a7
put_ bh a8
put_ bh a9
put_ bh a10
get bh = do
a1 <- get bh
a2 <- get bh
......@@ -1526,7 +1538,8 @@ instance Binary IfaceConDecl where
a7 <- get bh
a8 <- get bh
a9 <- get bh
return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
a10 <- get bh
return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
instance Binary IfaceBang where
put_ bh IfNoBang = putByte bh 0
......@@ -1542,6 +1555,16 @@ instance Binary IfaceBang where
2 -> do return IfUnpack
_ -> do { a <- get bh; return (IfUnpackCo a) }
instance Binary IfaceSrcBang where
put_ bh (IfSrcBang a1 a2) =
do put_ bh a1
put_ bh a2
get bh =
do a1 <- get bh
a2 <- get bh
return (IfSrcBang a1 a2)
instance Binary IfaceClsInst where
put_ bh (IfaceClsInst cls tys dfun flag orph) = do
put_ bh cls
......@@ -1609,7 +1632,7 @@ instance Binary IfaceIdDetails where
case h of
0 -> return IfVanillaId
1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
_ -> return IfDFunId
_ -> return IfDFunId
instance Binary IfaceIdInfo where
put_ bh NoInfo = putByte bh 0
......
......@@ -1710,7 +1710,10 @@ tyConToIfaceDecl env tycon
ifConArgTys = map (tidyToIfaceType con_env2) arg_tys,
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = map (toIfaceBang con_env2) (dataConImplBangs data_con) }
ifConStricts = map (toIfaceBang con_env2)
(dataConImplBangs data_con),
ifConSrcStricts = map toIfaceSrcBang
(dataConSrcBangs data_con)}
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
......@@ -1732,7 +1735,9 @@ toIfaceBang _ HsLazy = IfNoBang
toIfaceBang _ (HsUnpack Nothing) = IfUnpack
toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))
toIfaceBang _ HsStrict = IfStrict
toIfaceBang _ (HsSrcBang {}) = panic "toIfaceBang"
toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang
toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang
classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)
classToIfaceDecl env clas
......
......@@ -515,7 +515,8 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
ifConExTvs = ex_tvs,
ifConOcc = occ, ifConCtxt = ctxt, ifConEqSpec = spec,
ifConArgTys = args, ifConFields = field_lbls,
ifConStricts = if_stricts})
ifConStricts = if_stricts,
ifConSrcStricts = if_src_stricts})
= -- Universally-quantified tyvars are shared with
-- parent TyCon, and are alrady in scope
bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
......@@ -542,25 +543,32 @@ tcIfaceDataCons tycon_name tycon tc_tyvars if_cons
(substTyVars (mkTopTvSubst eq_spec) tc_tyvars)
; 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
lbl_names
tc_tyvars ex_tyvars
eq_spec theta
arg_tys orig_res_ty tycon
name is_infix
(map src_strict if_src_stricts)
(Just stricts)
-- Pass the HsImplBangs (i.e. final
-- decisions) to buildDataCon; it'll use
-- these to guide the construction of a
-- worker.
-- See Note [Bangs on imported data constructors] in MkId
lbl_names
tc_tyvars ex_tyvars
eq_spec theta
arg_tys orig_res_ty tycon