Commit 9429d794 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Merge branch 'master' of http://darcs.haskell.org/ghc

parents be5cc2e3 3394d49a
...@@ -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 unboxed
| 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,28 @@ data DataCon ...@@ -342,24 +341,28 @@ 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], -- See Note [Bangs on data constructor arguments]
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 +382,6 @@ data DataCon ...@@ -379,13 +382,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 +391,51 @@ data DataCon ...@@ -395,29 +391,51 @@ 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 -- See Note [Bangs on data constructor arguments]
-- the (:) *is* the worker.
-- This is really important in rule matching, }
-- (We could match on the wrappers, -- Algebraic data types always have a worker, and
-- but that makes it less likely that rules will match -- may or may not have a wrapper, depending on whether
-- when we bring bits of unfoldings together.) -- 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 of the tags associated with each constructor possibility
type ConTag = Int type ConTag = Int
...@@ -445,6 +463,25 @@ but the rep type is ...@@ -445,6 +463,25 @@ but the rep type is
Trep :: Int# -> a -> T a Trep :: Int# -> a -> T a
Actually, the unboxed part isn't implemented yet! Actually, the unboxed part isn't implemented yet!
Note [Bangs on data constructor arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider
data T = MkT !Int {-# UNPACK #-} !Int Bool
Its dcArgBangs field records the *users* specifications, in this case
[HsBang False, HsBang True, HsNoBang]
See the declaration of HsBang in BasicTypes
The dcr_bangs field of the dcRep field records the *actual, decided*
representation of the data constructor. Without -O this might be
[HsStrict, HsStrict, HsNoBang]
With -O it might be
[HsStrict, HsUnpack, HsNoBang]
With -funbox-small-strict-fields it might be
[HsUnpack, HsUnpack, HsNoBang]
For imported data types, the dcArgBangs field is just the same as the
dcr_bangs field; we don't know what the user originally said.
%************************************************************************ %************************************************************************
%* * %* *
...@@ -503,7 +540,8 @@ mkDataCon :: Name ...@@ -503,7 +540,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 +551,7 @@ mkDataCon name declared_infix ...@@ -513,7 +551,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 +571,30 @@ mkDataCon name declared_infix ...@@ -533,37 +571,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 +604,6 @@ mkDataCon name declared_infix ...@@ -573,11 +604,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 +673,32 @@ dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) ...@@ -647,31 +673,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 +714,18 @@ dataConFieldType con label ...@@ -687,22 +714,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 +738,23 @@ isNullarySrcDataCon dc = null (dcOrigArgTys dc) ...@@ -715,12 +738,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 +832,12 @@ dataConInstArgTys :: DataCon -- ^ A datacon with no existentials or equality con ...@@ -798,13 +832,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 +864,16 @@ dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys, ...@@ -831,10 +864,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}
...@@ -872,7 +911,7 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of ...@@ -872,7 +911,7 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
dataConCannotMatch :: [Type] -> DataCon -> Bool dataConCannotMatch :: [Type] -> DataCon -> Bool
-- Returns True iff the data con *definitely cannot* match a -- Returns True iff the data con *definitely cannot* match a
-- scrutinee of type (T tys) -- scrutinee of type (T tys)
-- where T is the type constructor for the data con -- where T is the dcRepTyCon for the data con
-- NB: look at *all* equality constraints, not only those -- NB: look at *all* equality constraints, not only those
-- in dataConEqSpec; see Trac #5168 -- in dataConEqSpec; see Trac #5168
dataConCannotMatch tys con dataConCannotMatch tys con
...@@ -884,7 +923,8 @@ dataConCannotMatch tys con ...@@ -884,7 +923,8 @@ dataConCannotMatch tys con
where where
dc_tvs = dataConUnivTyVars con dc_tvs = dataConUnivTyVars con
theta = dataConTheta con theta = dataConTheta con
subst = zipTopTvSubst dc_tvs tys subst = ASSERT2( length dc_tvs == length tys, ppr con $$ ppr dc_tvs $$ ppr tys )
zipTopTvSubst dc_tvs tys
-- TODO: could gather equalities from superclasses too -- TODO: could gather equalities from superclasses too
predEqs pred = case classifyPredType pred of predEqs pred = case classifyPredType pred of
...@@ -940,47 +980,6 @@ splitProductType str ty ...@@ -940,47 +980,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)]