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
......
......@@ -22,12 +22,13 @@ have a standard form, namely:
module MkId (
mkDictFunId, mkDictFunTy, mkDictSelId,
mkDataConIds, mkPrimOpId, mkFCallId,
mkPrimOpId, mkFCallId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
wrapNewTypeBody, unwrapNewTypeBody,
wrapFamInstBody, unwrapFamInstScrut,
wrapTypeFamInstBody, unwrapTypeFamInstScrut,
mkUnpackCase, mkProductBox,
DataConBoxer(..), mkDataConRep, mkDataConWorkId,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
......@@ -46,7 +47,7 @@ import TysPrim
import TysWiredIn
import PrelRules
import Type
import Coercion
import Coercion ( mkReflCo, mkAxInstCo, mkSymCo, coercionKind, mkUnsafeCo )
import TcType
import MkCore
import CoreUtils ( exprType, mkCast )
......@@ -65,6 +66,7 @@ import IdInfo
import Demand
import CoreSyn
import Unique
import UniqSupply
import PrelNames
import BasicTypes hiding ( SuccessFlag(..) )
import Util
......@@ -74,6 +76,7 @@ import Outputable
import FastString
import ListSetOps
import Data.List ( unzip4 )
import Data.Maybe ( maybeToList )
\end{code}
......@@ -224,173 +227,6 @@ Hence we translate to
-- Coercion from family type to representation type
Co7T a :: T [a] ~ :R7T a
\begin{code}
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon -- Newtype, only has a worker
= DCIds Nothing nt_work_id
| any isBanged all_strict_marks -- Algebraic, needs wrapper
|| not (null eq_spec) -- NB: LoadIface.ifaceDeclImplicitBndrs
|| isFamInstTyCon tycon -- depends on this test
= DCIds (Just alg_wrap_id) wrk_id
| otherwise -- Algebraic, no wrapper
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
tycon = dataConTyCon data_con -- The representation TyCon (not family)
----------- Worker (algebraic data types only) --------------
-- The *worker* for the data constructor is the function that
-- takes the representation arguments and builds the constructor.
wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
(dataConRepType data_con) wkr_info
wkr_arity = dataConRepArity data_con
wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setStrictnessInfo` Just wkr_sig
`setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
-- even if arity = 0
wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
-- Note [Data-con worker strictness]
-- Notice that we do *not* say the worker is strict
-- even if the data constructor is declared strict
-- e.g. data T = MkT !(Int,Int)
-- Why? Because the *wrapper* is strict (and its unfolding has case
-- expresssions that do the evals) but the *worker* itself is not.
-- If we pretend it is strict then when we see
-- case x of y -> $wMkT y
-- the simplifier thinks that y is "sure to be evaluated" (because
-- $wMkT is strict) and drops the case. No, $wMkT is not strict.
--
-- When the simplifer sees a pattern
-- case e of MkT x -> ...
-- it uses the dataConRepStrictness of MkT to mark x as evaluated;
-- but that's fine... dataConRepStrictness comes from the data con
-- not from the worker Id.
cpr_info | isProductTyCon tycon &&
isDataTyCon tycon &&
wkr_arity > 0 &&
wkr_arity <= mAX_CPR_SIZE = retCPR
| otherwise = TopRes
-- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
----------- Workers for newtypes --------------
nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` newtype_unf
id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
newtype_unf = ASSERT2( isVanillaDataCon data_con &&
isSingleton orig_arg_tys, ppr data_con )
-- Note [Newtype datacons]
mkCompulsoryUnfolding $
mkLams wrap_tvs $ Lam id_arg1 $
wrapNewTypeBody tycon res_ty_args (Var id_arg1)
----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
-- but now we don't. Instead the type checker just injects these
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
ev_tys = other_theta
wrap_ty = mkForAllTys wrap_tvs $
mkFunTys ev_tys $
mkFunTys orig_arg_tys $ res_ty
----------- Wrappers for algebraic data types --------------
alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
alg_wrap_info = noCafIdInfo
`setArityInfo` wrap_arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
`setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` wrap_unf
`setStrictnessInfo` Just wrap_sig
-- We need to get the CAF info right here because TidyPgm
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
wrap_stricts = dropList eq_spec all_strict_marks
wrap_arg_dmds = map mk_dmd wrap_stricts
mk_dmd str | isBanged str = evalDmd
| otherwise = lazyDmd
-- 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
-- may not inline a contructor when it is partially applied.
-- For example:
-- data W = C !Int !Int !Int
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
wrap_rhs = mkLams wrap_tvs $
mkLams ev_args $
mkLams id_args $
foldr mk_case con_app
(zip (ev_args ++ id_args) wrap_stricts)
i3 []
-- The ev_args is the evidence arguments *other than* the eq_spec
-- Because we are going to apply the eq_spec args manually in the
-- wrapper
con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
Var wrk_id `mkTyApps` res_ty_args
`mkVarApps` ex_tvs
`mkCoApps` map (mkReflCo . snd) eq_spec
`mkVarApps` reverse rep_ids
-- Dont box the eq_spec coercions since they are
-- marked as HsUnpack by mk_dict_strict_mark
(ev_args,i2) = mkLocals 1 ev_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
wrap_arity = i3-1
mk_case