Commit faa8ff40 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Major refactoring of the way that UNPACK pragmas are handled

The situation was pretty dire.  The way in which data constructors
were handled, notably the mapping between their *source* argument types
and their *representation* argument types (after seq'ing and unpacking)
was scattered in three different places, and hard to keep in sync.

Now it is all in one place:

 * The dcRep field of a DataCon gives its representation,
   specified by a DataConRep

 * As well as having the wrapper, the DataConRep has a "boxer"
   of type DataConBoxer (defined in MkId for loopy reasons).
   The boxer used at a pattern match to reconstruct the source-level
   arguments from the rep-level bindings in the pattern match.

 * The unboxing in the wrapper and the boxing in the boxer are dual,
   and are now constructed together, by MkId.mkDataConRep. This is
   the key function of this change.

 * All the computeBoxingStrategy code in TcTyClsDcls disappears.

Much nicer.

There is a little bit of refactoring left to do; the strange
deepSplitProductType functions are now called only in WwLib, so
I moved them there, and I think they could be tidied up further.
parent 566920c7
......@@ -62,7 +62,7 @@ module BasicTypes(
EP(..),
HsBang(..), isBanged, isMarkedUnboxed,
HsBang(..), isBanged,
StrictnessMark(..), isMarkedStrict,
DefMethSpec(..),
......@@ -585,33 +585,26 @@ e.g. data T = MkT !Int !(Bool,Bool)
-------------------------
-- HsBang describes what the *programmer* wrote
-- This info is retained in the DataCon.dcStrictMarks field
data HsBang = HsNoBang
data HsBang = HsNoBang -- Lazy field
| HsStrict
| HsBang Bool -- Source-language '!' bang
-- True <=> also an {-# UNPACK #-} pragma
| HsUnpack -- {-# UNPACK #-} ! (GHC extension, meaning "unbox")
| HsUnpackFailed -- An UNPACK pragma that we could not make
-- use of, because the type isn't unboxable;
-- equivalant to HsStrict except for checkValidDataCon
| HsNoUnpack -- {-# NOUNPACK #-} ! (GHC extension, meaning "strict but not unboxed")
| HsUnpack -- Definite commitment: this field is strict and unboxed
| HsStrict -- Definite commitment: this field is strict but not unboxec
deriving (Eq, Data, Typeable)
instance Outputable HsBang where
ppr HsNoBang = empty
ppr HsStrict = char '!'
ppr HsUnpack = ptext (sLit "{-# UNPACK #-} !")
ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !")
ppr HsNoUnpack = ptext (sLit "{-# NOUNPACK #-} !")
ppr (HsBang True) = ptext (sLit "{-# UNPACK #-} !")
ppr (HsBang False) = char '!'
ppr HsUnpack = ptext (sLit "Unpacked")
ppr HsStrict = ptext (sLit "SrictNotUnpacked")
isBanged :: HsBang -> Bool
isBanged HsNoBang = False
isBanged _ = True
isMarkedUnboxed :: HsBang -> Bool
isMarkedUnboxed HsUnpack = True
isMarkedUnboxed _ = False
-------------------------
-- StrictnessMark is internal only, used to indicate strictness
-- of the DataCon *worker* fields
......
......@@ -14,7 +14,7 @@
module DataCon (
-- * Main data types
DataCon, DataConIds(..),
DataCon, DataConRep(..),
ConTag,
-- ** Type construction
......@@ -30,19 +30,18 @@ module DataCon (
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts,
dataConStrictMarks,
dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness,
dataConRepStrictness, dataConRepBangs, dataConBoxer,
-- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types
splitProductType_maybe, splitProductType, deepSplitProductType,
deepSplitProductType_maybe,
splitProductType_maybe, splitProductType,
-- ** Promotion related functions
isPromotableTyCon, promoteTyCon,
......@@ -51,12 +50,12 @@ module DataCon (
#include "HsVersions.h"
import {-# SOURCE #-} MkId( DataConBoxer )
import Type
import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey )
import Kind
import Unify
import Coercion
import TyCon
import Class
import Name
......@@ -342,24 +341,27 @@ data DataCon
-- The OrigResTy is T [a], but the dcRepTyCon might be :T123
-- Now the strictness annotations and field labels of the constructor
dcStrictMarks :: [HsBang],
dcArgBangs :: [HsBang],
-- Strictness annotations as decided by the compiler.
-- Does *not* include the existential dictionaries
-- length = dataConSourceArity dataCon
-- Matches 1-1 with dcOrigArgTys
-- Hence length = dataConSourceArity dataCon
dcFields :: [FieldLabel],
-- Field labels for this constructor, in the
-- same order as the dcOrigArgTys;
-- length = 0 (if not a record) or dataConSourceArity.
-- The curried worker function that corresponds to the constructor:
-- It doesn't have an unfolding; the code generator saturates these Ids
-- and allocates a real constructor when it finds one.
dcWorkId :: Id,
-- Constructor representation
dcRepArgTys :: [Type], -- Final, representation argument types,
-- after unboxing and flattening,
-- and *including* all existential evidence args
dcRep :: DataConRep,
dcRepStrictness :: [StrictnessMark],
-- One for each *representation* *value* argument
-- See also Note [Data-con worker strictness] in MkId.lhs
-- Cached
dcRepArity :: Arity, -- == length dataConRepArgTys
dcSourceArity :: Arity, -- == length dcOrigArgTys
-- Result type of constructor is T t1..tn
dcRepTyCon :: TyCon, -- Result tycon, T
......@@ -379,13 +381,6 @@ data DataCon
-- used in CoreLint.
-- The curried worker function that corresponds to the constructor:
-- It doesn't have an unfolding; the code generator saturates these Ids
-- and allocates a real constructor when it finds one.
--
-- An entirely separate wrapper function is built in TcTyDecls
dcIds :: DataConIds,
dcInfix :: Bool, -- True <=> declared infix
-- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere
......@@ -395,29 +390,49 @@ data DataCon
}
deriving Data.Typeable.Typeable
-- | Contains the Ids of the data constructor functions
data DataConIds
= DCIds (Maybe Id) Id -- Algebraic data types always have a worker, and
-- may or may not have a wrapper, depending on whether
-- the wrapper does anything. Newtypes just have a worker
-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
-- The wrapper takes dcOrigArgTys as its arguments
-- The worker takes dcRepArgTys as its arguments
-- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys
-- The 'Nothing' case of DCIds is important
-- Not only is this efficient,
-- but it also ensures that the wrapper is replaced
-- by the worker (because it *is* the worker)
-- even when there are no args. E.g. in
-- f (:) x
-- the (:) *is* the worker.
-- This is really important in rule matching,
-- (We could match on the wrappers,
-- but that makes it less likely that rules will match
-- when we bring bits of unfoldings together.)
data DataConRep
= NoDataConRep -- No wrapper
| DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens,
-- and constructs the representation
, dcr_boxer :: DataConBoxer
, dcr_arg_tys :: [Type] -- Final, representation argument types,
-- after unboxing and flattening,
-- and *including* all evidence args
, dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys
-- See also Note [Data-con worker strictness] in MkId.lhs
, dcr_bangs :: [HsBang] -- The actual decisions made (including failures)
-- 1-1 with orig_arg_tys
}
-- Algebraic data types always have a worker, and
-- may or may not have a wrapper, depending on whether
-- the wrapper does anything.
--
-- Data types have a worker with no unfolding
-- Newtypes just have a worker, which has a compulsory unfolding (just a cast)
-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments
-- The wrapper (if it exists) takes dcOrigArgTys as its arguments
-- The worker takes dataConRepArgTys as its arguments
-- If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys
-- The 'NoDataConRep' case is important
-- Not only is this efficient,
-- but it also ensures that the wrapper is replaced
-- by the worker (because it *is* the worker)
-- even when there are no args. E.g. in
-- f (:) x
-- the (:) *is* the worker.
-- This is really important in rule matching,
-- (We could match on the wrappers,
-- but that makes it less likely that rules will match
-- when we bring bits of unfoldings together.)
-- | Type of the tags associated with each constructor possibility
type ConTag = Int
......@@ -503,7 +518,8 @@ mkDataCon :: Name
-> TyCon -- ^ Representation type constructor
-> ThetaType -- ^ The "stupid theta", context of the data declaration
-- e.g. @data Eq a => T a ...@
-> DataConIds -- ^ The Ids of the actual builder functions
-> Id -- ^ Worker Id
-> DataConRep -- ^ Representation
-> DataCon
-- Can get the tag from the TyCon
......@@ -513,7 +529,7 @@ mkDataCon name declared_infix
univ_tvs ex_tvs
eq_spec theta
orig_arg_tys orig_res_ty rep_tycon
stupid_theta ids
stupid_theta work_id rep
-- Warning: mkDataCon is not a good place to check invariants.
-- If the programmer writes the wrong result type in the decl, thus:
-- data T a where { MkT :: S }
......@@ -533,37 +549,30 @@ mkDataCon name declared_infix
dcStupidTheta = stupid_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon,
dcRepArgTys = rep_arg_tys,
dcStrictMarks = arg_stricts,
dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = ty,
dcIds = ids,
dcArgBangs = arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = rep_ty,
dcWorkId = work_id,
dcRep = rep,
dcSourceArity = length orig_arg_tys,
dcRepArity = length rep_arg_tys,
dcPromoted = mb_promoted }
-- Strictness marks for source-args
-- *after unboxing choices*,
-- but *including existential dictionaries*
--
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
full_theta = eqSpecPreds eq_spec ++ theta
real_arg_tys = full_theta ++ orig_arg_tys
real_stricts = map mk_pred_strict_mark full_theta ++ arg_stricts
-- Representation arguments and demands
-- To do: eliminate duplication with MkId
(rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
rep_arg_tys = dataConRepArgTys con
rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted -- See Note [Promoted data constructors] in TyCon
| all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs)
-- No kind polymorphism, and all of kind *
, null full_theta -- No constraints
, null eq_spec -- No constraints
, null theta
, all isPromotableType orig_arg_tys
= Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
| otherwise
......@@ -573,11 +582,6 @@ mkDataCon name declared_infix
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
mk_pred_strict_mark :: PredType -> HsBang
mk_pred_strict_mark pred
| isEqPred pred = HsUnpack -- Note [Unpack equality predicates]
| otherwise = HsNoBang
\end{code}
Note [Unpack equality predicates]
......@@ -647,31 +651,32 @@ dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
-- be different from the obvious one written in the source program. Panics
-- if there is no such 'Id' for this 'DataCon'
dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of
DCIds _ wrk_id -> wrk_id
dataConWorkId dc = dcWorkId dc
-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual"
-- constructor so it has the type visible in the source program: c.f. 'dataConWorkId'.
-- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor
-- and also for a newtype (whose constructor is inlined compulsorily)
dataConWrapId_maybe :: DataCon -> Maybe Id
dataConWrapId_maybe dc = case dcIds dc of
DCIds mb_wrap _ -> mb_wrap
dataConWrapId_maybe dc = case dcRep dc of
NoDataConRep -> Nothing
DCR { dcr_wrap_id = wrap_id } -> Just wrap_id
-- | Returns an Id which looks like the Haskell-source constructor by using
-- the wrapper if it exists (see 'dataConWrapId_maybe') and failing over to
-- the worker (see 'dataConWorkId')
dataConWrapId :: DataCon -> Id
dataConWrapId dc = case dcIds dc of
DCIds (Just wrap) _ -> wrap
DCIds Nothing wrk -> wrk -- worker=wrapper
dataConWrapId dc = case dcRep dc of
NoDataConRep-> dcWorkId dc -- worker=wrapper
DCR { dcr_wrap_id = wrap_id } -> wrap_id
-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
-- the union of the 'dataConWorkId' and the 'dataConWrapId'
dataConImplicitIds :: DataCon -> [Id]
dataConImplicitIds dc = case dcIds dc of
DCIds (Just wrap) work -> [wrap,work]
DCIds Nothing work -> [work]
dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
= case rep of
NoDataConRep -> [work]
DCR { dcr_wrap_id = wrap } -> [wrap,work]
-- | The labels for the fields of this particular 'DataCon'
dataConFieldLabels :: DataCon -> [FieldLabel]
......@@ -687,22 +692,18 @@ dataConFieldType con label
-- | The strictness markings decided on by the compiler. Does not include those for
-- existential dictionaries. The list is in one-to-one correspondence with the arity of the 'DataCon'
dataConStrictMarks :: DataCon -> [HsBang]
dataConStrictMarks = dcStrictMarks
-- | Strictness of evidence arguments to the wrapper function
dataConExStricts :: DataCon -> [HsBang]
-- Usually empty, so we don't bother to cache this
dataConExStricts dc = map mk_pred_strict_mark (dataConTheta dc)
dataConStrictMarks = dcArgBangs
-- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity
dataConSourceArity dc = length (dcOrigArgTys dc)
dataConSourceArity (MkData { dcSourceArity = arity }) = arity
-- | Gives the number of actual fields in the /representation/ of the
-- data constructor. This may be more than appear in the source code;
-- the extra ones are the existentially quantified dictionaries
dataConRepArity :: DataCon -> Arity
dataConRepArity (MkData {dcRepArgTys = arg_tys}) = length arg_tys
dataConRepArity (MkData { dcRepArity = arity }) = arity
-- | The number of fields in the /representation/ of the constructor
-- AFTER taking into account the unpacking of any unboxed tuple fields
......@@ -715,12 +716,23 @@ isNullarySrcDataCon dc = null (dcOrigArgTys dc)
-- | Return whether there are any argument types for this 'DataCon's runtime representation type
isNullaryRepDataCon :: DataCon -> Bool
isNullaryRepDataCon dc = null (dcRepArgTys dc)
isNullaryRepDataCon dc = dataConRepArity dc == 0
dataConRepStrictness :: DataCon -> [StrictnessMark]
-- ^ Give the demands on the arguments of a
-- Core constructor application (Con dc args)
dataConRepStrictness dc = dcRepStrictness dc
dataConRepStrictness dc = case dcRep dc of
NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]
DCR { dcr_stricts = strs } -> strs
dataConRepBangs :: DataCon -> [HsBang]
dataConRepBangs dc = case dcRep dc of
NoDataConRep -> dcArgBangs dc
DCR { dcr_bangs = bangs } -> bangs
dataConBoxer :: DataCon -> Maybe DataConBoxer
dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer
dataConBoxer _ = Nothing
-- | The \"signature\" of the 'DataCon' returns, in order:
--
......@@ -798,13 +810,12 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality con
-- class dictionary, with superclasses)
-> [Type] -- ^ Instantiated at these types
-> [Type]
dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys,
dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
dcExTyVars = ex_tvs}) inst_tys
= ASSERT2 ( length univ_tvs == length inst_tys
, ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
ASSERT2 ( null ex_tvs && null eq_spec, ppr dc )
map (substTyWith univ_tvs inst_tys) rep_arg_tys
map (substTyWith univ_tvs inst_tys) (dataConRepArgTys dc)
-- | Returns just the instantiated /value/ argument types of a 'DataCon',
-- (excluding dictionary args)
......@@ -831,10 +842,16 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
dataConOrigArgTys :: DataCon -> [Type]
dataConOrigArgTys dc = dcOrigArgTys dc
-- | Returns the arg types of the worker, including all dictionaries, after any
-- | Returns the arg types of the worker, including *all* evidence, after any
-- flattening has been done and without substituting for any type variables
dataConRepArgTys :: DataCon -> [Type]
dataConRepArgTys dc = dcRepArgTys dc
dataConRepArgTys (MkData { dcRep = rep
, dcEqSpec = eq_spec
, dcOtherTheta = theta
, dcOrigArgTys = orig_arg_tys })
= case rep of
NoDataConRep -> ASSERT( null eq_spec ) theta ++ orig_arg_tys
DCR { dcr_arg_tys = arg_tys } -> arg_tys
\end{code}
\begin{code}
......@@ -940,47 +957,6 @@ splitProductType str ty
= case splitProductType_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
-- | As 'splitProductType_maybe', but in turn instantiates the 'TyCon' returned
-- and hence recursively tries to unpack it as far as it able to
deepSplitProductType_maybe :: Type -> Maybe (TyCon, [Type], DataCon, [Type])
deepSplitProductType_maybe ty
= do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty
; let {result
| Just (ty', _co) <- instNewTyCon_maybe tycon tycon_args
, not (isRecursiveTyCon tycon)
= deepSplitProductType_maybe ty' -- Ignore the coercion?
| isNewTyCon tycon = Nothing -- cannot unbox through recursive
-- newtypes nor through families
| otherwise = Just res}
; result
}
-- | As 'deepSplitProductType_maybe', but panics if the 'Type' is not a product type
deepSplitProductType :: String -> Type -> (TyCon, [Type], DataCon, [Type])
deepSplitProductType str ty
= case deepSplitProductType_maybe ty of
Just stuff -> stuff
Nothing -> pprPanic (str ++ ": not a product") (pprType ty)
-- | Compute the representation type strictness and type suitable for a 'DataCon'
computeRep :: [HsBang] -- ^ Original argument strictness
-> [Type] -- ^ Original argument types
-> ([StrictnessMark], -- Representation arg strictness
[Type]) -- And type
computeRep stricts tys
= unzip $ concat $ zipWithEqual "computeRep" unbox stricts tys
where
unbox HsNoBang ty = [(NotMarkedStrict, ty)]
unbox HsStrict ty = [(MarkedStrict, ty)]
unbox HsNoUnpack ty = [(MarkedStrict, ty)]
unbox HsUnpackFailed ty = [(MarkedStrict, ty)]
unbox HsUnpack ty = zipEqual "computeRep" (dataConRepStrictness arg_dc) arg_tys
where
(_tycon, _tycon_args, arg_dc, arg_tys)
= deepSplitProductType "unbox_strict_arg_ty" ty
\end{code}
......
......@@ -2,11 +2,10 @@
module DataCon where
import Name( Name )
import {-# SOURCE #-} TyCon( TyCon )
import {-# SOURCE #-} TypeRep (Type)
data DataCon
data DataConRep
dataConName :: DataCon -> Name
dataConRepArgTys :: DataCon -> [Type]
dataConTyCon :: DataCon -> TyCon
isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon
......
This diff is collapsed.
\begin{code}
module MkId where
import Name( Name )
import DataCon( DataCon, DataConIds )
import Var( Id )
import {-# SOURCE #-} DataCon( DataCon )
import {-# SOURCE #-} PrimOp( PrimOp )
import Id( Id )
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkPrimOpId :: PrimOp -> Id
data DataConBoxer
mkDataConWorkId :: Name -> DataCon -> Id
mkPrimOpId :: PrimOp -> Id
\end{code}
......@@ -519,9 +519,9 @@ repBangTy ty= do
rep2 strictTypeName [s, t]
where
(str, ty') = case ty of
L _ (HsBangTy HsUnpack ty) -> (unpackedName, ty)
L _ (HsBangTy _ ty) -> (isStrictName, ty)
_ -> (notStrictName, ty)
L _ (HsBangTy (HsBang True) ty) -> (unpackedName, ty)
L _ (HsBangTy _ ty) -> (isStrictName, ty)
_ -> (notStrictName, ty)
-------------------------------------------------------
-- Deriving clause
......
......@@ -316,10 +316,14 @@ mkCoAlgCaseMatchResult dflags var ty match_alts
mk_case fail = do alts <- mapM (mk_alt fail) sorted_alts
return (mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts))
mk_alt fail (con, args, MatchResult _ body_fn) = do
body <- body_fn fail
us <- newUniqueSupply
return (mkReboxingAlt (uniqsFromSupply us) con args body)
mk_alt fail (con, args, MatchResult _ body_fn)
= do { body <- body_fn fail
; case dataConBoxer con of {
Nothing -> return (DataAlt con, args, body) ;
Just (DCB boxer) ->
do { us <- newUniqueSupply
; let (rep_ids, binds) = initUs_ us (boxer ty_args args)
; return (DataAlt con, rep_ids, mkLets binds body) } } }
mk_default fail | exhaustive_case = []
| otherwise = [(DEFAULT, [], fail)]
......
......@@ -351,9 +351,9 @@ cvtConstr (ForallC tvs ctxt con)
, con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } }
cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName)
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
cvt_arg (NotStrict, ty) = cvtType ty
cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsUnpack ty' }
cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang False) ty' }
cvt_arg (Unpacked, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy (HsBang True) ty' }
cvt_id_arg :: (TH.Name, TH.Strict, TH.Type) -> CvtM (ConDeclField RdrName)
cvt_id_arg (i, str, ty)
......
......@@ -749,19 +749,20 @@ instance Binary InlineSpec where
_ -> return NoInline
instance Binary HsBang where
put_ bh HsNoBang = putByte bh 0
put_ bh HsStrict = putByte bh 1
put_ bh HsUnpack = putByte bh 2
put_ bh HsUnpackFailed = putByte bh 3
put_ bh HsNoUnpack = putByte bh 4
put_ bh HsNoBang = putByte bh 0
put_ bh (HsBang False) = putByte bh 1
put_ bh (HsBang True) = putByte bh 2
put_ bh HsUnpack = putByte bh 3
put_ bh HsStrict = putByte bh 4
get bh = do
h <- getByte bh
case h of
0 -> do return HsNoBang
1 -> do return HsStrict
2 -> do return HsUnpack
3 -> do return HsUnpackFailed
_ -> do return HsNoUnpack
1 -> do return (HsBang False)
2 -> do return (HsBang True)
3 -> do return HsUnpack
_ -> do return HsStrict
instance Binary TupleSort where
put_ bh BoxedTuple = putByte bh 0
......
......@@ -39,6 +39,7 @@ import Coercion
import DynFlags
import TcRnMonad
import UniqSupply
import Util
import Outputable
\end{code}
......@@ -155,14 +156,17 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
-- code, which (for Haskell source anyway) will be in the DataName name
-- space, and puts it into the VarName name space
; us <- newUniqueSupply
; dflags <- getDynFlags
; let
stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
data_con = mkDataCon src_name declared_infix
arg_stricts field_lbls
univ_tvs ex_tvs eq_spec ctxt
arg_tys res_ty rep_tycon
stupid_ctxt dc_ids
dc_ids = mkDataConIds wrap_name work_name data_con
stupid_ctxt dc_wrk dc_rep
dc_wrk = mkDataConWorkId work_name data_con
dc_rep = initUs_ us (mkDataConRep dflags wrap_name data_con)
; return data_con }
......
......@@ -1506,7 +1506,7 @@ tyConToIfaceDecl env tycon
ifConArgTys = map (tidyToIfaceType env2) arg_tys,
ifConFields = map getOccName
(dataConFieldLabels data_con),
ifConStricts = dataConStrictMarks data_con }
ifConStricts = dataConRepBangs data_con }
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
......
......@@ -2360,7 +2360,7 @@ fFlags = [
( "do-eta-reduction", Opt_DoEtaReduction, nop ),
( "case-merge", Opt_CaseMerge, nop ),
( "unbox-strict-fields", Opt_UnboxStrictFields, nop ),
( "unbox-strict-primitive-fields", Opt_UnboxStrictPrimitiveFields, nop ),
( "unbox-small-strict-fields", Opt_UnboxSmallStrictFields, nop ),
( "dicts-cheap", Opt_DictsCheap, nop ),
( "excess-precision", Opt_ExcessPrecision, nop ),
( "eager-blackholing", Opt_EagerBlackHoling, nop ),
......
......@@ -1007,7 +1007,7 @@ infixtype :: { LHsType RdrName }
strict_mark :: { Located HsBang }
: '!' { L1 HsStrict }
| '{-# UNPACK' '#-}' '!' { LL HsUnpack }
| '{-# NOUNPACK' '#-}' '!' { LL HsNoUnpack }
| '{-# NOUNPACK' '#-}' '!' { LL HsStrict }
-- A ctype is a for-all type
ctype :: { LHsType RdrName }
......
......@@ -76,7 +76,7 @@ module TysWiredIn (
#include "HsVersions.h"
import {-# SOURCE #-} MkId( mkDataConIds )
import {-# SOURCE #-} MkId( mkDataConWorkId )
-- friends:
import PrelNames
......@@ -277,16 +277,14 @@ pcDataConWithFixity' declared_infix dc_name wrk_key tyvars arg_tys tycon
arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))
tycon
[] -- No stupid theta
(mkDataConIds bogus_wrap_name wrk_name data_con)
(mkDataConWorkId wrk_name data_con)
NoDataConRep -- Wired-in types are too simple to need wrappers
modu = ASSERT( isExternalName dc_name )
nameModule dc_name
wrk_occ = mkDataConWorkerOcc (nameOccName dc_name)