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( ...@@ -62,7 +62,7 @@ module BasicTypes(
EP(..), EP(..),
HsBang(..), isBanged, isMarkedUnboxed, HsBang(..), isBanged,
StrictnessMark(..), isMarkedStrict, StrictnessMark(..), isMarkedStrict,
DefMethSpec(..), DefMethSpec(..),
...@@ -585,33 +585,26 @@ e.g. data T = MkT !Int !(Bool,Bool) ...@@ -585,33 +585,26 @@ e.g. data T = MkT !Int !(Bool,Bool)
------------------------- -------------------------
-- HsBang describes what the *programmer* wrote -- HsBang describes what the *programmer* wrote
-- This info is retained in the DataCon.dcStrictMarks field -- 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") | HsUnpack -- Definite commitment: this field is strict and unboxed
| HsStrict -- Definite commitment: this field is strict but not unboxec
| 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")
deriving (Eq, Data, Typeable) deriving (Eq, Data, Typeable)
instance Outputable HsBang where instance Outputable HsBang where
ppr HsNoBang = empty ppr HsNoBang = empty
ppr HsStrict = char '!' ppr (HsBang True) = ptext (sLit "{-# UNPACK #-} !")
ppr HsUnpack = ptext (sLit "{-# UNPACK #-} !") ppr (HsBang False) = char '!'
ppr HsUnpackFailed = ptext (sLit "{-# UNPACK (failed) #-} !") ppr HsUnpack = ptext (sLit "Unpacked")
ppr HsNoUnpack = ptext (sLit "{-# NOUNPACK #-} !") ppr HsStrict = ptext (sLit "SrictNotUnpacked")
isBanged :: HsBang -> Bool isBanged :: HsBang -> Bool
isBanged HsNoBang = False isBanged HsNoBang = False
isBanged _ = True isBanged _ = True
isMarkedUnboxed :: HsBang -> Bool
isMarkedUnboxed HsUnpack = True
isMarkedUnboxed _ = False
------------------------- -------------------------
-- StrictnessMark is internal only, used to indicate strictness -- StrictnessMark is internal only, used to indicate strictness
-- of the DataCon *worker* fields -- of the DataCon *worker* fields
......
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
module DataCon ( module DataCon (
-- * Main data types -- * Main data types
DataCon, DataConIds(..), DataCon, DataConRep(..),
ConTag, ConTag,
-- ** Type construction -- ** Type construction
...@@ -30,19 +30,18 @@ module DataCon ( ...@@ -30,19 +30,18 @@ module DataCon (
dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
dataConInstOrigArgTys, dataConRepArgTys, dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType, dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts, dataConStrictMarks,
dataConSourceArity, dataConRepArity, dataConRepRepArity, dataConSourceArity, dataConRepArity, dataConRepRepArity,
dataConIsInfix, dataConIsInfix,
dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds, dataConWorkId, dataConWrapId, dataConWrapId_maybe, dataConImplicitIds,
dataConRepStrictness, dataConRepStrictness, dataConRepBangs, dataConBoxer,
-- ** Predicates on DataCons -- ** Predicates on DataCons
isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon, isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,
isVanillaDataCon, classDataCon, dataConCannotMatch, isVanillaDataCon, classDataCon, dataConCannotMatch,
-- * Splitting product types -- * Splitting product types
splitProductType_maybe, splitProductType, deepSplitProductType, splitProductType_maybe, splitProductType,
deepSplitProductType_maybe,
-- ** Promotion related functions -- ** Promotion related functions
isPromotableTyCon, promoteTyCon, isPromotableTyCon, promoteTyCon,
...@@ -51,12 +50,12 @@ module DataCon ( ...@@ -51,12 +50,12 @@ module DataCon (
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} MkId( DataConBoxer )
import Type import Type
import TypeRep( Type(..) ) -- Used in promoteType import TypeRep( Type(..) ) -- Used in promoteType
import PrelNames( liftedTypeKindTyConKey ) import PrelNames( liftedTypeKindTyConKey )
import Kind import Kind
import Unify import Unify
import Coercion
import TyCon import TyCon
import Class import Class
import Name import Name
...@@ -342,24 +341,27 @@ data DataCon ...@@ -342,24 +341,27 @@ data DataCon
-- The OrigResTy is T [a], but the dcRepTyCon might be :T123 -- The OrigResTy is T [a], but the dcRepTyCon might be :T123
-- Now the strictness annotations and field labels of the constructor -- Now the strictness annotations and field labels of the constructor
dcStrictMarks :: [HsBang], dcArgBangs :: [HsBang],
-- Strictness annotations as decided by the compiler. -- Strictness annotations as decided by the compiler.
-- Does *not* include the existential dictionaries -- Matches 1-1 with dcOrigArgTys
-- length = dataConSourceArity dataCon -- Hence length = dataConSourceArity dataCon
dcFields :: [FieldLabel], dcFields :: [FieldLabel],
-- Field labels for this constructor, in the -- Field labels for this constructor, in the
-- same order as the dcOrigArgTys; -- same order as the dcOrigArgTys;
-- length = 0 (if not a record) or dataConSourceArity. -- 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 -- Constructor representation
dcRepArgTys :: [Type], -- Final, representation argument types, dcRep :: DataConRep,
-- after unboxing and flattening,
-- and *including* all existential evidence args
dcRepStrictness :: [StrictnessMark], -- Cached
-- One for each *representation* *value* argument dcRepArity :: Arity, -- == length dataConRepArgTys
-- See also Note [Data-con worker strictness] in MkId.lhs dcSourceArity :: Arity, -- == length dcOrigArgTys
-- Result type of constructor is T t1..tn -- Result type of constructor is T t1..tn
dcRepTyCon :: TyCon, -- Result tycon, T dcRepTyCon :: TyCon, -- Result tycon, T
...@@ -379,13 +381,6 @@ data DataCon ...@@ -379,13 +381,6 @@ data DataCon
-- used in CoreLint. -- 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 dcInfix :: Bool, -- True <=> declared infix
-- Used for Template Haskell and 'deriving' only -- Used for Template Haskell and 'deriving' only
-- The actual fixity is stored elsewhere -- The actual fixity is stored elsewhere
...@@ -395,29 +390,49 @@ data DataCon ...@@ -395,29 +390,49 @@ data DataCon
} }
deriving Data.Typeable.Typeable deriving Data.Typeable.Typeable
-- | Contains the Ids of the data constructor functions data DataConRep
data DataConIds = NoDataConRep -- No wrapper
= DCIds (Maybe Id) Id -- Algebraic data types always have a worker, and
-- may or may not have a wrapper, depending on whether | DCR { dcr_wrap_id :: Id -- Takes src args, unboxes/flattens,
-- the wrapper does anything. Newtypes just have a worker -- and constructs the representation
-- _Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments , dcr_boxer :: DataConBoxer
-- The wrapper takes dcOrigArgTys as its arguments , dcr_arg_tys :: [Type] -- Final, representation argument types,
-- The worker takes dcRepArgTys as its arguments -- after unboxing and flattening,
-- If the worker is absent, dcRepArgTys is the same as dcOrigArgTys -- and *including* all evidence args
-- The 'Nothing' case of DCIds is important , dcr_stricts :: [StrictnessMark] -- 1-1 with dcr_arg_tys
-- Not only is this efficient, -- See also Note [Data-con worker strictness] in MkId.lhs
-- but it also ensures that the wrapper is replaced
-- by the worker (because it *is* the worker) , dcr_bangs :: [HsBang] -- The actual decisions made (including failures)
-- even when there are no args. E.g. in -- 1-1 with orig_arg_tys
-- f (:) x }
-- the (:) *is* the worker. -- Algebraic data types always have a worker, and
-- This is really important in rule matching, -- may or may not have a wrapper, depending on whether
-- (We could match on the wrappers, -- the wrapper does anything.
-- but that makes it less likely that rules will match --
-- when we bring bits of unfoldings together.) -- 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 of the tags associated with each constructor possibility
type ConTag = Int type ConTag = Int
...@@ -503,7 +518,8 @@ mkDataCon :: Name ...@@ -503,7 +518,8 @@ mkDataCon :: Name
-> TyCon -- ^ Representation type constructor -> TyCon -- ^ Representation type constructor
-> ThetaType -- ^ The "stupid theta", context of the data declaration -> ThetaType -- ^ The "stupid theta", context of the data declaration
-- e.g. @data Eq a => T a ...@ -- e.g. @data Eq a => T a ...@
-> DataConIds -- ^ The Ids of the actual builder functions -> Id -- ^ Worker Id
-> DataConRep -- ^ Representation
-> DataCon -> DataCon
-- Can get the tag from the TyCon -- Can get the tag from the TyCon
...@@ -513,7 +529,7 @@ mkDataCon name declared_infix ...@@ -513,7 +529,7 @@ mkDataCon name declared_infix
univ_tvs ex_tvs univ_tvs ex_tvs
eq_spec theta eq_spec theta
orig_arg_tys orig_res_ty rep_tycon 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. -- Warning: mkDataCon is not a good place to check invariants.
-- If the programmer writes the wrong result type in the decl, thus: -- If the programmer writes the wrong result type in the decl, thus:
-- data T a where { MkT :: S } -- data T a where { MkT :: S }
...@@ -533,37 +549,30 @@ mkDataCon name declared_infix ...@@ -533,37 +549,30 @@ mkDataCon name declared_infix
dcStupidTheta = stupid_theta, dcStupidTheta = stupid_theta,
dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
dcRepTyCon = rep_tycon, dcRepTyCon = rep_tycon,
dcRepArgTys = rep_arg_tys, dcArgBangs = arg_stricts,
dcStrictMarks = arg_stricts, dcFields = fields, dcTag = tag, dcRepType = rep_ty,
dcRepStrictness = rep_arg_stricts, dcWorkId = work_id,
dcFields = fields, dcTag = tag, dcRepType = ty, dcRep = rep,
dcIds = ids, dcSourceArity = length orig_arg_tys,
dcRepArity = length rep_arg_tys,
dcPromoted = mb_promoted } 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 -- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the -- source-language arguments. We add extra ones for the
-- dictionary arguments right here. -- 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 tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ rep_arg_tys = dataConRepArgTys con
mkFunTys rep_arg_tys $ rep_ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs) mkFunTys rep_arg_tys $
mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
mb_promoted -- See Note [Promoted data constructors] in TyCon mb_promoted -- See Note [Promoted data constructors] in TyCon
| all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs) | all (isLiftedTypeKind . tyVarKind) (univ_tvs ++ ex_tvs)
-- No kind polymorphism, and all of kind * -- No kind polymorphism, and all of kind *
, null full_theta -- No constraints , null eq_spec -- No constraints
, null theta
, all isPromotableType orig_arg_tys , all isPromotableType orig_arg_tys
= Just (mkPromotedDataCon con name (getUnique name) prom_kind arity) = Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
| otherwise | otherwise
...@@ -573,11 +582,6 @@ mkDataCon name declared_infix ...@@ -573,11 +582,6 @@ mkDataCon name declared_infix
eqSpecPreds :: [(TyVar,Type)] -> ThetaType eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ] 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} \end{code}
Note [Unpack equality predicates] Note [Unpack equality predicates]
...@@ -647,31 +651,32 @@ dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) ...@@ -647,31 +651,32 @@ dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })
-- be different from the obvious one written in the source program. Panics -- be different from the obvious one written in the source program. Panics
-- if there is no such 'Id' for this 'DataCon' -- if there is no such 'Id' for this 'DataCon'
dataConWorkId :: DataCon -> Id dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of dataConWorkId dc = dcWorkId dc
DCIds _ wrk_id -> wrk_id
-- | Get the Id of the 'DataCon' wrapper: a function that wraps the "actual" -- | 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'. -- 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 -- Returns Nothing if there is no wrapper, which occurs for an algebraic data constructor
-- and also for a newtype (whose constructor is inlined compulsorily) -- and also for a newtype (whose constructor is inlined compulsorily)
dataConWrapId_maybe :: DataCon -> Maybe Id dataConWrapId_maybe :: DataCon -> Maybe Id
dataConWrapId_maybe dc = case dcIds dc of dataConWrapId_maybe dc = case dcRep dc of
DCIds mb_wrap _ -> mb_wrap NoDataConRep -> Nothing
DCR { dcr_wrap_id = wrap_id } -> Just wrap_id
-- | Returns an Id which looks like the Haskell-source constructor by using -- | 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 wrapper if it exists (see 'dataConWrapId_maybe') and failing over to
-- the worker (see 'dataConWorkId') -- the worker (see 'dataConWorkId')
dataConWrapId :: DataCon -> Id dataConWrapId :: DataCon -> Id
dataConWrapId dc = case dcIds dc of dataConWrapId dc = case dcRep dc of
DCIds (Just wrap) _ -> wrap NoDataConRep-> dcWorkId dc -- worker=wrapper
DCIds Nothing wrk -> wrk -- worker=wrapper DCR { dcr_wrap_id = wrap_id } -> wrap_id
-- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently, -- | Find all the 'Id's implicitly brought into scope by the data constructor. Currently,
-- the union of the 'dataConWorkId' and the 'dataConWrapId' -- the union of the 'dataConWorkId' and the 'dataConWrapId'
dataConImplicitIds :: DataCon -> [Id] dataConImplicitIds :: DataCon -> [Id]
dataConImplicitIds dc = case dcIds dc of dataConImplicitIds (MkData { dcWorkId = work, dcRep = rep})
DCIds (Just wrap) work -> [wrap,work] = case rep of
DCIds Nothing work -> [work] NoDataConRep -> [work]
DCR { dcr_wrap_id = wrap } -> [wrap,work]
-- | The labels for the fields of this particular 'DataCon' -- | The labels for the fields of this particular 'DataCon'
dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels :: DataCon -> [FieldLabel]
...@@ -687,22 +692,18 @@ dataConFieldType con label ...@@ -687,22 +692,18 @@ dataConFieldType con label
-- | The strictness markings decided on by the compiler. Does not include those for -- | 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' -- existential dictionaries. The list is in one-to-one correspondence with the arity of the 'DataCon'
dataConStrictMarks :: DataCon -> [HsBang] dataConStrictMarks :: DataCon -> [HsBang]
dataConStrictMarks = dcStrictMarks dataConStrictMarks = dcArgBangs
-- | 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)
-- | Source-level arity of the data constructor -- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity dataConSourceArity :: DataCon -> Arity
dataConSourceArity dc = length (dcOrigArgTys dc) dataConSourceArity (MkData { dcSourceArity = arity }) = arity
-- | Gives the number of actual fields in the /representation/ of the -- | Gives the number of actual fields in the /representation/ of the
-- data constructor. This may be more than appear in the source code; -- data constructor. This may be more than appear in the source code;
-- the extra ones are the existentially quantified dictionaries -- the extra ones are the existentially quantified dictionaries
dataConRepArity :: DataCon -> Arity 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 -- | The number of fields in the /representation/ of the constructor
-- AFTER taking into account the unpacking of any unboxed tuple fields -- AFTER taking into account the unpacking of any unboxed tuple fields
...@@ -715,12 +716,23 @@ isNullarySrcDataCon dc = null (dcOrigArgTys dc) ...@@ -715,12 +716,23 @@ isNullarySrcDataCon dc = null (dcOrigArgTys dc)
-- | Return whether there are any argument types for this 'DataCon's runtime representation type -- | Return whether there are any argument types for this 'DataCon's runtime representation type
isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon :: DataCon -> Bool
isNullaryRepDataCon dc = null (dcRepArgTys dc) isNullaryRepDataCon dc = dataConRepArity dc == 0
dataConRepStrictness :: DataCon -> [StrictnessMark] dataConRepStrictness :: DataCon -> [StrictnessMark]
-- ^ Give the demands on the arguments of a -- ^ Give the demands on the arguments of a
-- Core constructor application (Con dc args) -- 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: -- | The \"signature\" of the 'DataCon' returns, in order:
-- --
...@@ -798,13 +810,12 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality con ...@@ -798,13 +810,12 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality con
-- class dictionary, with superclasses) -- class dictionary, with superclasses)
-> [Type] -- ^ Instantiated at these types -> [Type] -- ^ Instantiated at these types
-> [Type] -> [Type]
dataConInstArgTys dc@(MkData {dcRepArgTys = rep_arg_tys, dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
dcUnivTyVars = univ_tvs, dcEqSpec = eq_spec,
dcExTyVars = ex_tvs}) inst_tys dcExTyVars = ex_tvs}) inst_tys
= ASSERT2 ( length univ_tvs == length inst_tys = ASSERT2 ( length univ_tvs == length inst_tys
, ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys) , ptext (sLit "dataConInstArgTys") <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
ASSERT2 ( null ex_tvs && null eq_spec, ppr dc ) 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', -- | Returns just the instantiated /value/ argument types of a 'DataCon',
-- (excluding dictionary args) -- (excluding dictionary args)
...@@ -831,10 +842,16 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, ...@@ -831,10 +842,16 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
dataConOrigArgTys :: DataCon -> [Type] dataConOrigArgTys :: DataCon -> [Type]
dataConOrigArgTys dc = dcOrigArgTys dc 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 -- flattening has been done and without substituting for any type variables
dataConRepArgTys :: DataCon -> [Type] 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} \end{code}
\begin{code} \begin{code}
...@@ -940,47 +957,6 @@ splitProductType str ty ...@@ -940,47 +957,6 @@ splitProductType str ty
= case splitProductType_maybe ty of = case splitProductType_maybe ty of
Just stuff -> stuff Just stuff -> stuff
Nothing -> pprPanic (str ++ ": not a product") (pprType ty) 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} \end{code}
......
...@@ -2,11 +2,10 @@ ...@@ -2,11 +2,10 @@
module DataCon where module DataCon where
import Name( Name ) import Name( Name )
import {-# SOURCE #-} TyCon( TyCon ) import {-# SOURCE #-} TyCon( TyCon )
import {-# SOURCE #-} TypeRep (Type)
data DataCon data DataCon
data DataConRep
dataConName :: DataCon -> Name dataConName :: DataCon -> Name
dataConRepArgTys :: DataCon -> [Type]
dataConTyCon :: DataCon -> TyCon dataConTyCon :: DataCon -> TyCon
isVanillaDataCon :: DataCon -> Bool isVanillaDataCon :: DataCon -> Bool
instance Eq DataCon instance Eq DataCon
......
This diff is collapsed.
\begin{code} \begin{code}
module MkId where module MkId where
import Name( Name ) import Name( Name )
import DataCon( DataCon, DataConIds ) import Var( Id )
import {-# SOURCE #-} DataCon( DataCon )
import {-# SOURCE #-} PrimOp( PrimOp ) import {-# SOURCE #-} PrimOp( PrimOp )
import Id( Id )
mkDataConIds :: Name -> Name -> DataCon -> DataConIds data DataConBoxer
mkPrimOpId :: PrimOp -> Id
mkDataConWorkId :: Name -> DataCon -> Id
mkPrimOpId :: PrimOp -> Id
\end{code} \end{code}
...@@ -519,9 +519,9 @@ repBangTy ty= do ...@@ -519,9 +519,9 @@ repBangTy ty= do
rep2 strictTypeName [s, t] rep2 strictTypeName [s, t]
where where
(str, ty') = case ty of