import Literal ( Literal(..) )
import TyCon ( tyConDataCons )
import Name ( NamedThing(..) )
-import DataCon ( dataConWrapId )
import Maybes ( catMaybes )
import PrimOp ( primOpNeedsWrapper )
import MachOp ( MachOp(..) )
ptext SLIT("CLOSURE_TBL") <>
lparen <> pprCLabel (mkClosureTblLabel tycon) <> rparen :
punctuate comma (
- map (pp_closure_lbl . mkClosureLabel . getName . dataConWrapId) (tyConDataCons tycon)
+ map (pp_closure_lbl . mkClosureLabel . getName) (tyConDataCons tycon)
)
) $$ ptext SLIT("};")
module DataCon where
data DataCon
-dataConRepType :: DataCon -> TypeRep.Type
isExistentialDataCon :: DataCon -> GHC.Base.Bool
dataConRepArgTys, dataConTheta,
dataConFieldLabels, dataConStrictMarks,
dataConSourceArity, dataConRepArity,
- dataConNumInstArgs, dataConWorkId, dataConWrapId, dataConRepStrictness,
+ dataConNumInstArgs,
+ dataConWorkId, dataConWrapId, dataConWrapId_maybe,
+ dataConRepStrictness,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
isExistentialDataCon, classDataCon, dataConExistentialTyVars,
import Outputable
import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
-import Maybe
+import Maybes ( orElse )
import ListSetOps ( assoc )
import Util ( zipEqual, zipWithEqual, equalLength, notNull )
\end{code}
-Stuff about data constructors
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Every constructor, C, comes with a
+Data constructor representation
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the following Haskell data type declaration
- *wrapper*, called C, whose type is exactly what it looks like
- in the source program. It is an ordinary function,
- and it gets a top-level binding like any other function
+ data T = T !Int ![Int]
+
+Using the strictness annotations, GHC will represent this as
+
+ data T = T Int# [Int]
+
+That is, the Int has been unboxed. Furthermore, the Haskell source construction
+
+ T e1 e2
+
+is translated to
+
+ case e1 of { I# x ->
+ case e2 of { r ->
+ T x r }}
+
+That is, the first argument is unboxed, and the second is evaluated. Finally,
+pattern matching is translated too:
+
+ case e of { T a b -> ... }
+
+becomes
+
+ case e of { T a' b -> let a = I# a' in ... }
+
+To keep ourselves sane, we name the different versions of the data constructor
+differently, as follows.
+
+
+Note [Data Constructor Naming]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Each data constructor C has two, and possibly three, Names associated with it:
- *worker*, called $wC, which is the actual data constructor.
- Its type may be different to C, because:
+ OccName Name space Used for
+ ---------------------------------------------------------------------------
+ * The "source data con" C DataName The DataCon itself
+ * The "real data con" C VarName Its worker Id
+ * The "wrapper data con" $wC VarName Wrapper Id (optional)
+
+Each of these three has a distinct Unique. The "source data con" name
+appears in the output of the renamer, and names the Haskell-source
+data constructor. The type checker translates it into either the wrapper Id
+(if it exists) or worker Id (otherwise).
+
+The data con has one or two Ids associated with it:
+
+ The "worker Id", is the actual data constructor.
+ Its type may be different to the Haskell source constructor
+ because:
- useless dict args are dropped
- strict args may be flattened
- It does not have a binding.
+ The worker is very like a primop, in that it has no binding.
+
+ Newtypes currently do get a worker-Id, but it is never used.
+
+
+ The "wrapper Id", $wC, whose type is exactly what it looks like
+ in the source program. It is an ordinary function,
+ and it gets a top-level binding like any other function.
+
+ The wrapper Id isn't generated for a data type if the worker
+ and wrapper are identical. It's always generated for a newtype.
- The worker is very like a primop, in that it has no binding,
A note about the stupid context
data DataCon
= MkData { -- Used for data constructors only;
-- there *is* no constructor for a newtype
- dcName :: Name,
+ dcName :: Name,
+
dcUnique :: Unique, -- Cached from Name
dcTag :: ConTag,
-- "Stupid", because the dictionaries aren't used for anything.
--
-- Indeed, [as of March 02] they are no
- -- longer in the type of the dataConWrapId, because
+ -- longer in the type of the dcWrapId, because
-- that makes it harder to use the wrap-id to rebuild
-- values after record selection or in generics.
dcWorkId :: Id, -- The corresponding worker Id
-- Takes dcRepArgTys as its arguments
+ -- Perhaps this should be a 'Maybe'; not reqd for newtype constructors
- dcWrapId :: Id -- The wrapper Id
+ dcWrapId :: Maybe Id -- The wrapper Id, if it's necessary
+ -- It's deemed unnecessary if it performs the
+ -- identity function
}
type ConTag = Int
%************************************************************************
\begin{code}
-mkDataCon :: Name
+mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType
-> [TyVar] -> ThetaType
-> [Type] -> TyCon
- -> Id -> Id
+ -> Id -> Maybe Id -- Worker and possible wrapper
-> DataCon
-- Can get the tag from the TyCon
-mkDataCon name arg_stricts fields
+mkDataCon name
+ arg_stricts -- Use [] to mean 'all non-strict'
+ fields
tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
work_id wrap_id
- = ASSERT(equalLength arg_stricts orig_arg_tys)
- -- The 'stricts' passed to mkDataCon are simply those for the
- -- source-language arguments. We add extra ones for the
- -- dictionary arguments right here.
- con
+ = con
where
- con = MkData {dcName = name, dcUnique = nameUnique name,
+ con = MkData {dcName = name,
+ dcUnique = nameUnique name,
dcTyVars = tyvars, dcStupidTheta = theta,
dcOrigArgTys = orig_arg_tys,
dcRepArgTys = rep_arg_tys,
-- 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.
ex_dict_tys = mkPredTys ex_theta
- real_stricts = (map mk_dict_strict_mark ex_dict_tys) ++
- zipWithEqual "mkDataCon1" (chooseBoxingStrategy tycon)
- orig_arg_tys arg_stricts
+ real_stricts = map mk_dict_strict_mark ex_dict_tys ++
+ zipWith (chooseBoxingStrategy tycon)
+ orig_arg_tys
+ (arg_stricts ++ repeat NotMarkedStrict)
real_arg_tys = ex_dict_tys ++ orig_arg_tys
-- Representation arguments and demands
dataConWorkId :: DataCon -> Id
dataConWorkId = dcWorkId
+dataConWrapId_maybe :: DataCon -> Maybe Id
+dataConWrapId_maybe = dcWrapId
+
dataConWrapId :: DataCon -> Id
-dataConWrapId = dcWrapId
+-- Returns an Id which looks like the Haskell-source constructor
+-- If there is no dcWrapId it's because there is no need for a
+-- wrapper, so the worker is the Right Thing
+dataConWrapId dc = dcWrapId dc `orElse` dcWorkId dc
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels = dcFields
isRecordSelector,
isPrimOpId, isPrimOpId_maybe,
isFCallId, isFCallId_maybe,
- isDataConId, isDataConId_maybe,
+ isDataConWorkId, isDataConWorkId_maybe,
isDataConWrapId, isDataConWrapId_maybe,
isBottomingId,
hasNoBinding,
FCallId call -> Just call
other -> Nothing
-isDataConId id = case globalIdDetails id of
- DataConId _ -> True
- other -> False
+isDataConWorkId id = case globalIdDetails id of
+ DataConWorkId _ -> True
+ other -> False
-isDataConId_maybe id = case globalIdDetails id of
- DataConId con -> Just con
- other -> Nothing
+isDataConWorkId_maybe id = case globalIdDetails id of
+ DataConWorkId con -> Just con
+ other -> Nothing
isDataConWrapId_maybe id = case globalIdDetails id of
DataConWrapId con -> Just con
RecordSelId _ -> True -- Includes dictionary selectors
FCallId _ -> True
PrimOpId _ -> True
- DataConId _ -> True
+ DataConWorkId _ -> True
DataConWrapId _ -> True
-- These are are implied by their type or class decl;
-- remember that all type and class decls appear in the interface file.
= VanillaGlobal -- Imported from elsewhere, a default method Id.
| RecordSelId FieldLabel -- The Id for a record selector
- | DataConId DataCon -- The Id for a data constructor *worker*
+ | DataConWorkId DataCon -- The Id for a data constructor *worker*
| DataConWrapId DataCon -- The Id for a data constructor *wrapper*
-- [the only reasons we need to know is so that
-- a) we can suppress printing a definition in the interface file
instance Outputable GlobalIdDetails where
ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]")
ppr VanillaGlobal = ptext SLIT("[GlobalId]")
- ppr (DataConId _) = ptext SLIT("[DataCon]")
+ ppr (DataConWorkId _) = ptext SLIT("[DataCon]")
ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
ppr (FCallId _) = ptext SLIT("[ForeignCall]")
module MkId where
-mkDataConId :: Name.Name -> DataCon.DataCon -> Var.Id
-mkDataConWrapId :: DataCon.DataCon -> Var.Id
+mkDataConWorkId :: Name.Name -> DataCon.DataCon -> Var.Id
mkDictFunId, mkDefaultMethodId,
mkDictSelId,
- mkDataConId, mkDataConWrapId,
+ mkDataConWorkId, mkDataConWrapId,
mkRecordSelId,
mkPrimOpId, mkFCallId,
dataConFieldLabels, dataConRepArity, dataConTyCon,
dataConArgTys, dataConRepType,
dataConOrigArgTys,
- dataConName, dataConTheta,
+ dataConTheta,
dataConSig, dataConStrictMarks, dataConWorkId,
splitProductType
)
%************************************************************************
\begin{code}
-mkDataConId :: Name -> DataCon -> Id
+mkDataConWorkId :: Name -> DataCon -> Id
-- Makes the *worker* for the data constructor; that is, the function
-- that takes the reprsentation arguments and builds the constructor.
-mkDataConId work_name data_con
- = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
+mkDataConWorkId wkr_name data_con
+ = mkGlobalId (DataConWorkId data_con) wkr_name
+ (dataConRepType data_con) info
where
info = noCafIdInfo
`setArityInfo` arity
`setAllStrictnessInfo` Just strict_sig
arity = dataConRepArity data_con
-
strict_sig = mkStrictSig (mkTopDmdType (replicate arity topDmd) cpr_info)
-- Notice that we do *not* say the worker is strict
-- even if the data constructor is declared strict
it in the (common) case where the constructor arg is already evaluated.
\begin{code}
-mkDataConWrapId data_con
- = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
+mkDataConWrapId :: Name -> DataCon -> Maybe Id
+-- Only make a wrapper Id if necessary
+
+mkDataConWrapId wrap_name data_con
+ | is_newtype || any isMarkedStrict strict_marks
+ = -- We need a wrapper function
+ Just (mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty info)
+
+ | otherwise
+ = Nothing -- The common case, where there is no point in
+ -- having a wrapper function. Not only is this efficient,
+ -- but it also ensures that the wrapper is replaced
+ -- by the worker (becuase it *is* the wroker)
+ -- 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.)
where
- work_id = dataConWorkId data_con
+ (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
+ is_newtype = isNewTyCon tycon
+ all_tyvars = tyvars ++ ex_tyvars
+ work_id = dataConWorkId data_con
- info = noCafIdInfo
- `setUnfoldingInfo` wrap_unf
- -- The NoCaf-ness is set by noCafIdInfo
- `setArityInfo` arity
+ common_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
+ `setArityInfo` arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
- `setAllStrictnessInfo` Just wrap_sig
+
+ info | is_newtype = common_info `setUnfoldingInfo` newtype_unf
+ | otherwise = common_info `setUnfoldingInfo` data_unf
+ `setAllStrictnessInfo` Just wrap_sig
wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
res_info = strictSigResInfo (idNewStrictness work_id)
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
- wrap_unf | isNewTyCon tycon
- = ASSERT( null ex_tyvars && null ex_dict_args && isSingleton orig_arg_tys )
- -- No existentials on a newtype, but it can have a context
- -- e.g. newtype Eq a => T a = MkT (...)
- mkTopUnfolding $ Note InlineMe $
- mkLams tyvars $ Lam id_arg1 $
- mkNewTypeBody tycon result_ty (Var id_arg1)
-
- | not (any isMarkedStrict strict_marks)
- = mkCompulsoryUnfolding (Var work_id)
- -- The common case. Not only is this efficient,
- -- but it also ensures that the wrapper is replaced
- -- by the worker even when there are no args.
- -- f (:) x
- -- becomes
- -- f $w: x
- -- 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.)
- --
- -- NB: because of this special case, (map (:) ys) turns into
- -- (map $w: ys). The top-level defn for (:) is never used.
- -- This is somewhat of a bore, but I'm currently leaving it
- -- as is, so that there still is a top level curried (:) for
- -- the interpreter to call.
-
- | otherwise
- = mkTopUnfolding $ Note InlineMe $
+ newtype_unf = ASSERT( null ex_tyvars && null ex_dict_args &&
+ isSingleton orig_arg_tys )
+ -- No existentials on a newtype, but it can have a context
+ -- e.g. newtype Eq a => T a = MkT (...)
+ mkTopUnfolding $ Note InlineMe $
+ mkLams tyvars $ Lam id_arg1 $
+ mkNewTypeBody tycon result_ty (Var id_arg1)
+
+ data_unf = mkTopUnfolding $ Note InlineMe $
mkLams all_tyvars $
mkLams ex_dict_args $ mkLams id_args $
foldr mk_case con_app
con_app i rep_ids = mkApps (Var work_id)
(map varToCoreExpr (all_tyvars ++ reverse rep_ids))
- (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
- all_tyvars = tyvars ++ ex_tyvars
-
ex_dict_tys = mkPredTys ex_theta
all_arg_tys = ex_dict_tys ++ orig_arg_tys
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
pprExternal sty name uniq mod occ
| codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
-
- | debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <>
- text "{-" <> pprUnique uniq <> text "-}"
-
+ | debugStyle sty = ppr (moduleName mod) <> dot <> ppr_debug_occ uniq occ
| unqualStyle sty name = pprOccName occ
| otherwise = ppr (moduleName mod) <> dot <> pprOccName occ
pprInternal sty uniq occ
| codeStyle sty = pprUnique uniq
- | debugStyle sty = pprOccName occ <>
- text "{-" <> pprUnique uniq <> text "-}"
+ | debugStyle sty = ppr_debug_occ uniq occ
| otherwise = pprOccName occ -- User style
-- Like Internal, except that we only omit the unique in Iface style
-- If the tidy phase hasn't run, the OccName
-- is unlikely to be informative (like 's'),
-- so print the unique
+
+ppr_debug_occ uniq occ = hsep [pprOccName occ, text "{-",
+ text (briefOccNameFlavour occ),
+ pprUnique uniq, text "-}"]
\end{code}
%************************************************************************
module OccName (
-- The NameSpace type; abstact
NameSpace, tcName, clsName, tcClsName, dataName, varName,
- tvName, nameSpaceString,
+ tvName, srcDataName, nameSpaceString,
-- The OccName type
OccName, -- Abstract, instance of Outputable
mkSuperDictSelOcc, mkDFunOcc, mkForeignExportOcc,
mkDictOcc, mkIPOcc, mkWorkerOcc, mkMethodOcc, mkDefaultMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkSpecOcc,
- mkGenOcc1, mkGenOcc2, mkLocalOcc,
+ mkGenOcc1, mkGenOcc2, mkLocalOcc,
+ mkDataConWrapperOcc, mkDataConWorkerOcc,
isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,
reportIfUnused,
- occNameFS, occNameString, occNameUserString, occNameSpace, occNameFlavour,
+ occNameFS, occNameString, occNameUserString, occNameSpace,
+ occNameFlavour, briefOccNameFlavour,
setOccNameSpace,
-- Tidying up
%************************************************************************
\begin{code}
-data NameSpace = VarName -- Variables
- | DataName -- Data constructors
+data NameSpace = VarName -- Variables, including "source" data constructors
+ | DataName -- "Real" data constructors
| TvName -- Type variables
| TcClsName -- Type constructors and classes; Haskell has them
-- in the same name space for now.
deriving( Eq, Ord )
{-! derive: Binary !-}
+-- Note [Data Constructors]
+-- see also: Note [Data Constructor Naming] in DataCon.lhs
+--
+-- "Source" data constructors are the data constructors mentioned
+-- in Haskell source code
+--
+-- "Real" data constructors are the data constructors of the
+-- representation type, which may not be the same as the source
+-- type
+
+-- Example:
+-- data T = T !(Int,Int)
+--
+-- The source datacon has type (Int,Int) -> T
+-- The real datacon has type Int -> Int -> T
+-- GHC chooses a representation based on the strictness etc.
+
+
-- Though type constructors and classes are in the same name space now,
-- the NameSpace type is abstract, so we can easily separate them later
tcName = TcClsName -- Type constructors
clsName = TcClsName -- Classes
tcClsName = TcClsName -- Not sure which!
-dataName = DataName
-tvName = TvName
-varName = VarName
+dataName = DataName
+srcDataName = DataName -- Haskell-source data constructors should be
+ -- in the Data name space
+tvName = TvName
+varName = VarName
nameSpaceString :: NameSpace -> String
nameSpaceString DataName = "Data constructor"
occNameSpace :: OccName -> NameSpace
occNameSpace (OccName sp _) = sp
-setOccNameSpace :: OccName -> NameSpace -> OccName
-setOccNameSpace (OccName _ occ) sp = OccName sp occ
+setOccNameSpace :: NameSpace -> OccName -> OccName
+setOccNameSpace sp (OccName _ occ) = OccName sp occ
-- occNameFlavour is used only to generate good error messages
occNameFlavour :: OccName -> String
-occNameFlavour (OccName sp _) = nameSpaceString sp
+occNameFlavour (OccName DataName _) = "Real data constructor"
+occNameFlavour (OccName TvName _) = "Type variable"
+occNameFlavour (OccName TcClsName _) = "Type constructor or class"
+occNameFlavour (OccName VarName s) = "Variable"
+
+-- briefOccNameFlavour is used in debug-printing of names
+briefOccNameFlavour :: OccName -> String
+briefOccNameFlavour (OccName DataName _) = "d"
+briefOccNameFlavour (OccName VarName _) = "v"
+briefOccNameFlavour (OccName TvName _) = "tv"
+briefOccNameFlavour (OccName TcClsName _) = "tc"
\end{code}
\begin{code}
-- Data constructor operator (starts with ':', or '[]')
-- Pretty inefficient!
isDataSymOcc (OccName DataName s) = isLexConSym (decodeFS s)
+isDataSymOcc (OccName VarName s) = isLexConSym (decodeFS s)
isDataSymOcc other = False
isDataOcc (OccName DataName _) = True
+isDataOcc (OccName VarName s) = isLexCon (decodeFS s)
isDataOcc other = False
-- Any operator (data constructor or variable)
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
+mkDataConWrapperOcc = mk_simple_deriv varName "$W"
mkWorkerOcc = mk_simple_deriv varName "$w"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies
mkClassTyConOcc = mk_simple_deriv tcName ":T" -- as a tycon/datacon
-mkClassDataConOcc = mk_simple_deriv dataName ":D" --
+mkClassDataConOcc = mk_simple_deriv dataName ":D" -- We go straight to the "real" data con
+ -- for datacons from classes
mkDictOcc = mk_simple_deriv varName "$d"
mkIPOcc = mk_simple_deriv varName "$i"
mkSpecOcc = mk_simple_deriv varName "$s"
mkGenOcc1 = mk_simple_deriv varName "$gfrom" -- Generics
mkGenOcc2 = mk_simple_deriv varName "$gto" -- Generics
mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
+
+
+-- Data constructor workers are made by setting the name space
+-- of the data constructor OccName (which should be a DataName)
+-- to DataName
+mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ
\end{code}
\begin{code}
-- The original-name case *can* occur when parsing
-- data [] a = [] | a : [a]
-- For the orig-name case we return an unqualified name.
-setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace occ ns)
-setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace occ ns)
-setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace occ ns)
-setRdrNameSpace (Exact n) ns = Unqual (setOccNameSpace (nameOccName n) ns)
+setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
+setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
+setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
+setRdrNameSpace (Exact n) ns = Unqual (setOccNameSpace ns (nameOccName n))
\end{code}
\begin{code}
currentCCS )
import DataCon ( DataCon, dataConTag,
isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
- dataConWrapId, dataConRepArity
+ dataConName, dataConRepArity
)
import Id ( Id, idName, idPrimRep )
import Literal ( Literal(..) )
\begin{code}
buildDynCon binder cc con []
= returnFC (stableAmodeIdInfo binder
- (CLbl (mkClosureLabel (idName (dataConWrapId con))) PtrRep)
+ (CLbl (mkClosureLabel (dataConName con)) PtrRep)
(mkConLFInfo con))
\end{code}
import CoreSyn
import Type ( Type, applyTy, splitFunTy_maybe,
isUnLiftedType, isUnboxedTupleType, seqType )
+import TcType ( TyThing( AnId ) )
import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) )
import Var ( Var, Id, setVarUnique )
import VarSet
import VarEnv
import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
- isFCallId, isGlobalId,
+ isFCallId, isGlobalId, isImplicitId,
isLocalId, hasNoBinding, idNewStrictness,
- isDataConId_maybe, idUnfolding
+ idUnfolding, isDataConWorkId_maybe
)
-import HscTypes ( ModGuts(..), ModGuts, implicitTyThingIds, typeEnvElts )
+import HscTypes ( ModGuts(..), ModGuts, typeEnvElts )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
\begin{code}
mkImplicitBinds type_env
= [ NonRec id (get_unfolding id)
- | id <- implicitTyThingIds (typeEnvElts type_env) ]
+ | AnId id <- typeEnvElts type_env, isImplicitId id ]
+ -- The type environment already contains all the implicit Ids,
+ -- so we just filter them out
+ --
-- The etaExpand is so that the manifest arity of the
-- binding matches its claimed arity, which is an
-- invariant of top level bindings going into the code gen
get_unfolding id -- See notes above
- | Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
- | otherwise = unfoldingTemplate (idUnfolding id)
+ | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works
+ -- CorePrep will eta-expand it
+ | otherwise = unfoldingTemplate (idUnfolding id)
\end{code}
| fun `hasKey` augmentIdKey = augmentSize
| otherwise
= case globalIdDetails fun of
- DataConId dc -> conSizeN dc (valArgCount args)
+ DataConWorkId dc -> conSizeN dc (valArgCount args)
FCallId fc -> sizeN opt_UF_DearOp
PrimOpId op -> primOpSize op (valArgCount args)
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
- isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId
+ isDataConWorkId_maybe, mkSysLocal, isDataConWorkId, isBottomingId
)
import IdInfo ( GlobalIdDetails(..),
megaSeqIdInfo )
-- a variable (f t1 t2 t3)
-- counts as WHNF
| otherwise = case globalIdDetails id of
- DataConId _ -> True
- RecordSelId _ -> True -- I'm experimenting with making record selection
- -- look cheap, so we will substitute it inside a
- -- lambda. Particularly for dictionary field selection
+ DataConWorkId _ -> True
+ RecordSelId _ -> True -- I'm experimenting with making record selection
+ -- look cheap, so we will substitute it inside a
+ -- lambda. Particularly for dictionary field selection
PrimOpId op -> primOpIsCheap op -- In principle we should worry about primops
-- that return a type variable, since the result
other -> False
where
- spec_ok (DataConId _) args
+ spec_ok (DataConWorkId _) args
= True -- The strictness of the constructor has already
-- been expressed by its "wrapper", so we don't need
-- to take the arguments into account
\begin{code}
exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP
exprIsValue (Var v) -- NB: There are no value args at this point
- = isDataConId v -- Catches nullary constructors,
+ = isDataConWorkId v -- Catches nullary constructors,
-- so that [] and () are values, for example
|| idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings
|| isEvaldUnfolding (idUnfolding v)
-- There is at least one value argument
app_is_value (Var fun) args
- | isDataConId fun -- Constructor apps are values
+ | isDataConWorkId fun -- Constructor apps are values
|| idArity fun > valArgCount args -- Under-applied function
= check_args (idType fun) args
app_is_value (App f a) as = app_is_value f (a:as)
exprIsConApp_maybe expr = analyse (collectArgs expr)
where
analyse (Var fun, args)
- | Just con <- isDataConId_maybe fun,
+ | Just con <- isDataConWorkId_maybe fun,
args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
= Just (con,args)
import Class
import TypeRep
import Type
-import DataCon
+import DataCon ( DataCon, dataConExistentialTyVars, dataConRepArgTys,
+ dataConName, dataConWrapId_maybe )
import CoreSyn
import Var
import IdInfo
-import Id( idUnfolding )
-import CoreTidy( tidyExpr )
-import VarEnv( emptyTidyEnv )
+import Id ( idUnfolding )
+import CoreTidy ( tidyExpr )
+import VarEnv ( emptyTidyEnv )
import Literal
import Name
import CostCentre
import ForeignCall
import PprExternalCore
import CmdLineOpts
-import Maybes( orElse )
+import Maybes ( orElse, catMaybes )
import IO
import FastString
other_implicit_binds = map get_defn (concatMap other_implicit_ids (typeEnvElts type_env))
implicit_con_ids :: TyThing -> [Id]
-implicit_con_ids (ATyCon tc) = map dataConWrapId (tyConDataCons_maybe tc `orElse` [])
-implicit_con_ids other = []
+implicit_con_ids (ATyCon tc) | isAlgTyCon tc = catMaybes (map dataConWrapId_maybe (tyConDataCons tc))
+implicit_con_ids other = []
other_implicit_ids :: TyThing -> [Id]
other_implicit_ids (ATyCon tc) = tyConSelIds tc ++ tyConGenIds tc
import CoreSyn
import CostCentre ( pprCostCentreCore )
import Var ( Var )
-import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
+import Id ( Id, idType, isDataConWorkId_maybe, idLBVarInfo, idArity,
idInfo, idInlinePragma, idOccInfo,
#ifdef OLD_STRICTNESS
idDemandInfo,
pp_tup_args = sep (punctuate comma (map pprArg val_args))
in
case fun of
- Var f -> case isDataConId_maybe f of
+ Var f -> case isDataConWorkId_maybe f of
-- Notice that we print the *worker*
-- for tuples in paren'd format.
Just dc | saturated && isTupleTyCon tc
import OccName ( mkOccFS )
import NameEnv
import NameSet
-import Type ( Type, TyThing(..), mkGenTyConApp )
-import TcType ( tcTyConAppArgs )
+import Type ( Type, mkGenTyConApp )
+import TcType ( TyThing(..), tcTyConAppArgs )
import TyCon ( DataConDetails(..) )
import TysWiredIn ( stringTy )
import CoreSyn
isTyVarTy )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isUnboxedTupleCon, isNullaryDataCon,
- dataConRepArity, dataConWorkId )
+ dataConRepArity )
import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons,
isFunTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
schemeTopBind (id, rhs)
- | Just data_con <- isDataConId_maybe id,
+ | Just data_con <- isDataConWorkId_maybe id,
isNullaryDataCon data_con
= -- Special case for the worker of a nullary data con.
-- It'll look like this: $wNil = /\a -> $wNil a
schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))
| (AnnVar v, args_r_to_l) <- splitApp rhs,
- Just data_con <- isDataConId_maybe v,
+ Just data_con <- isDataConWorkId_maybe v,
dataConRepArity data_con == length args_r_to_l
= -- Special case for a non-recursive let whose RHS is a
-- saturatred constructor application.
-- saturated. Otherwise, we'll call the constructor wrapper.
n_args = length args_r_to_l
maybe_saturated_dcon
- = case isDataConId_maybe fn of
+ = case isDataConWorkId_maybe fn of
Just con | dataConRepArity con == n_args -> Just con
_ -> Nothing
mkConAppCode orig_d s p con [] -- Nullary constructor
= ASSERT( isNullaryDataCon con )
- returnBc (unitOL (PUSH_G (getName (dataConWorkId con))))
+ returnBc (unitOL (PUSH_G (getName con)))
-- Instead of doing a PACK, which would allocate a fresh
-- copy of this constructor, use the single shared version.
- -- The name of the constructor is the name of its wrapper function
mkConAppCode orig_d s p con args_r_to_l
= ASSERT( dataConRepArity con == length args_r_to_l )
{-# OPTIONS -#include "Linker.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.142 2002/12/27 12:20:06 panne Exp $
+-- $Id: InteractiveUI.hs,v 1.143 2003/02/12 15:01:35 simonpj Exp $
--
-- GHC Interactive User Interface
--
import Linker ( initLinker, showLinkerState, linkLibraries,
linkPackages )
import Util
-import Id ( isRecordSelector, recordSelectorFieldLabel,
- isDataConWrapId, isDataConId, idName )
+import Id ( isRecordSelector, isImplicitId, recordSelectorFieldLabel, idName )
import Class ( className )
import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) )
+import DataCon ( dataConName )
import FieldLabel ( fieldLabelTyCon )
import SrcLoc ( isGoodSrcLoc )
import Module ( showModMsg, lookupModuleEnv )
showTyThing (AClass cl)
= hcat [ppr cl, text " is a class", showSrcLoc (className cl)]
+ showTyThing (ADataCon dc)
+ = hcat [ppr dc, text " is a data constructor", showSrcLoc (dataConName dc)]
showTyThing (ATyCon ty)
| isPrimTyCon ty
= hcat [ppr ty, text " is a primitive type constructor"]
recordSelectorFieldLabel id)) of
Nothing -> text "record selector"
Just c -> text "method in class " <> ppr c
- | isDataConWrapId id = text "data constructor"
| otherwise = text "variable"
-- also print out the source location for home things
things' = filter wantToSee things
- wantToSee (AnId id) = not (isDataConId id || isDataConWrapId id)
- wantToSee _ = True
+ wantToSee (AnId id) = not (isImplicitId id)
+ wantToSee (ADataCon _) = False -- They'll come via their TyCon
+ wantToSee _ = True
thing_names = map getName things
where
mk_con (Constr c tys)
= ConDecl (cName c) noExistentials noContext
- (PrefixCon (map mk_arg tys)) loc0
+ (PrefixCon (map mk_arg tys)) loc0
mk_arg ty = BangType NotMarkedStrict (cvtType ty)
convertToHsExpr :: Meta.Exp -> HsExpr RdrName
convertToHsExpr = cvt
-cvt (Var s) = HsVar(vName s)
-cvt (Con s) = HsVar(cName s)
+cvt (Var s) = HsVar (vName s)
+cvt (Con s) = HsVar (cName s)
cvt (Lit l)
| overloadedLit l = HsOverLit (cvtOverLit l)
| otherwise = HsLit (cvtLit l)
vName :: String -> RdrName
vName = mkName varName
--- Constructor function names
+-- Constructor function names; this is Haskell source, hence srcDataName
cName :: String -> RdrName
-cName = mkName dataName
+cName = mkName srcDataName
-- Type variable names
tName :: String -> RdrName
)
-- others:
-import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe )
+import Id ( idArity, idType, isDataConWorkId_maybe, isFCallId_maybe )
import Var ( varType, isId )
import IdInfo ( InlinePragInfo )
import Name ( Name, NamedThing(..), eqNameByOcc )
---------------------
toUfApp (App f a) as = toUfApp f (a:as)
toUfApp (Var v) as
- = case isDataConId_maybe v of
+ = case isDataConWorkId_maybe v of
-- We convert the *worker* for tuples into UfTuples
Just dc | isTupleTyCon tc && saturated
-> UfTuple (mk_hs_tup_con tc dc) tup_args
import Java
import Literal ( Literal(..) )
-import Id ( Id, isDataConId_maybe, isId, idName, isDeadBinder, idPrimRep
+import Id ( Id, isDataConWorkId_maybe, isId, idName, isDeadBinder, idPrimRep
, isPrimOpId_maybe )
import Name ( NamedThing(..), getOccString, isExternalName, isInternalName
, nameModule )
| isValArg a = javaApp r f (a:as)
| otherwise = javaApp r f as
javaApp r (CoreSyn.Var f) as
- = case isDataConId_maybe f of {
+ = case isDataConWorkId_maybe f of {
Just dc | as `lengthIs` dataConRepArity dc
-- NOTE: Saturated constructors never returning a primitive at this point
--
VersionInfo(..), initialVersionInfo, lookupVersion,
FixityEnv, lookupFixity, collectFixities, emptyFixityEnv,
- TyThing(..), isTyClThing, implicitTyThingIds,
+ TyThing(..), implicitTyThings,
TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv,
extendTypeEnvList, extendTypeEnvWithIds,
import InstEnv ( InstEnv, ClsInstEnv, DFunId )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
-import Id ( Id )
-import Class ( Class, classSelIds )
-import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe )
-import Type ( TyThing(..), isTyClThing )
-import DataCon ( dataConWorkId, dataConWrapId )
+import Id ( Id, idName )
+import Class ( Class, classSelIds, classTyCon )
+import TyCon ( TyCon, tyConName, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons )
+import TcType ( TyThing(..) )
+import DataCon ( dataConWorkId, dataConWrapId, dataConWrapId_maybe )
import Packages ( PackageName, basePackage )
import CmdLineOpts ( DynFlags )
typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
typeEnvIds env = [id | AnId id <- typeEnvElts env]
-
-implicitTyThingIds :: [TyThing] -> [Id]
--- Add the implicit data cons and selectors etc
-implicitTyThingIds things
- = concat (map go things)
- where
- go (AnId f) = []
- go (AClass cl) = classSelIds cl
- go (ATyCon tc) = tyConGenIds tc ++
- tyConSelIds tc ++
- [ n | dc <- tyConDataCons_maybe tc `orElse` [],
- n <- implicitConIds tc dc]
- -- Synonyms return empty list of constructors and selectors
-
- implicitConIds tc dc -- Newtypes have a constructor wrapper,
- -- but no worker
- | isNewTyCon tc = [dataConWrapId dc]
- | otherwise = [dataConWorkId dc, dataConWrapId dc]
\end{code}
mkTypeEnv things = extendTypeEnvList emptyTypeEnv things
extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
+-- Extend the type environment
extendTypeEnvList env things
- = extendNameEnvList env [(getName thing, thing) | thing <- things]
+ = foldl extend env things
+ where
+ extend env thing = extendNameEnv env (getName thing) thing
+
+implicitTyThings :: [TyThing] -> [TyThing]
+implicitTyThings things
+ = concatMap extras things
+ where
+ extras_plus thing = thing : extras thing
+
+ extras (AnId id) = []
+
+ -- For type constructors, add the data cons (and their extras),
+ -- and the selectors and generic-programming Ids too
+ --
+ -- Newtypes don't have a worker Id, so don't generate that
+ extras (ATyCon tc) = map AnId (tyConGenIds tc ++ tyConSelIds tc) ++ data_con_stuff
+ where
+ data_con_stuff | isNewTyCon tc = [ADataCon dc1, AnId (dataConWrapId dc1)]
+ | otherwise = concatMap (extras_plus . ADataCon) dcs
+ dcs = tyConDataCons tc
+ dc1 = head dcs
+
+ -- For classes, add the class TyCon too (and its extras)
+ -- and the class selector Ids
+ extras (AClass cl) = map AnId (classSelIds cl) ++
+ extras_plus (ATyCon (classTyCon cl))
+
+
+ -- For data cons add the worker and wrapper (if any)
+ extras (ADataCon dc)
+ = AnId (dataConWorkId dc) : wrap_id_stuff
+ where
+ -- May or may not have a wrapper
+ wrap_id_stuff = case dataConWrapId_maybe dc of
+ Just id -> [AnId id]
+ Nothing -> []
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds env ids
import CmdLineOpts
import Id ( idType, idInfo, isImplicitId, idCgInfo )
-import DataCon ( dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import CoreSyn ( CoreRule(..), IdCoreRule )
import CoreFVs ( ruleLhsFreeNames )
\begin{code}
ifaceTyThing_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl]
+ifaceTyThing_acc (ADataCon dc) so_far = so_far
ifaceTyThing_acc (AnId id) so_far | isImplicitId id = so_far
ifaceTyThing_acc (ATyCon id) so_far | isClassTyCon id = so_far
ifaceTyThing_acc other so_far = ifaceTyThing other : so_far
ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
ifaceConDecl data_con
- = ConDecl (getName data_con)
+ = ConDecl (dataConName data_con)
(toHsTyVars ex_tyvars)
(toHsContext ex_theta)
details noSrcLoc
import Panic ( panic )
import TyCon ( tyConDataCons )
import Constants ( wORD_SIZE, bITMAP_BITS_SHIFT )
-import DataCon ( dataConWrapId )
import Name ( NamedThing(..) )
import CmdLineOpts ( opt_Static, opt_EnsureSplittableC )
import Outputable ( assertPanic )
gentopcode stmt@(CClosureTbl tycon)
= returnUs [ StSegment TextSegment
, StLabel (mkClosureTblLabel tycon)
- , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName . dataConWrapId)
+ , StData DataPtrRep (map (StCLbl . mkClosureLabel . getName)
(tyConDataCons tycon) )
]
{- -*-haskell-*-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.114 2002/12/10 16:28:48 igloo Exp $
+$Id: Parser.y,v 1.115 2003/02/12 15:01:37 simonpj Exp $
Haskell grammar.
import Lex
import RdrName
import PrelNames ( mAIN_Name, funTyConName, listTyConName,
- parrTyConName, consDataConName, nilDataConName )
-import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon )
+ parrTyConName, consDataConName )
+import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon )
import ForeignCall ( Safety(..), CExportSpec(..),
CCallConv(..), CCallTarget(..), defaultCCallConv,
)
import OccName ( UserFS, varName, tcName, dataName, tcClsName, tvName )
import TyCon ( DataConDetails(..) )
+import DataCon ( DataCon, dataConName )
import SrcLoc ( SrcLoc )
import Module
import CmdLineOpts ( opt_SccProfilingOn, opt_InPackage )
| tycon { $1 }
gcon :: { RdrName } -- Data constructor namespace
- : sysdcon { $1 }
+ : sysdcon { nameRdrName (dataConName $1) }
| qcon { $1 }
-- the case of '[:' ':]' is part of the production `parr'
-sysdcon :: { RdrName } -- Data constructor namespace
- : '(' ')' { getRdrName unitDataCon }
- | '(' commas ')' { getRdrName (tupleCon Boxed $2) }
- | '[' ']' { nameRdrName nilDataConName }
+sysdcon :: { DataCon } -- Wired in data constructors
+ : '(' ')' { unitDataCon }
+ | '(' commas ')' { tupleCon Boxed $2 }
+ | '[' ']' { nilDataCon }
var :: { RdrName }
: varid { $1 }
consym :: { RdrName }
: CONSYM { mkUnqual dataName $1 }
- | ':' { nameRdrName consDataConName }
+
-- ':' means only list cons
+ | ':' { nameRdrName consDataConName }
+ -- NB: SrcName because we are reading source
-----------------------------------------------------------------------------
| con ';' cons1 { $1:$3 }
con :: { ConDecl RdrName }
- : q_d_name attbinds atys
+ : q_d_patt attbinds atys
{ ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc}
atys :: { [ RdrNameHsType] }
| alt ';' alts1 { $1:$3 }
alt :: { UfAlt RdrName }
- : q_d_name attbinds vbinds '->' exp
- { {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
+ : q_d_patt attbinds vbinds '->' exp
+ { (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) }
| lit '->' exp
{ (UfLitAlt $1, [], $3) }
| '%_' '->' exp
lit :: { Literal }
: '(' INTEGER '::' aty ')' { convIntLit $2 $4 }
- | '(' RATIONAL '::' aty ')' { MachDouble $2 }
+ | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 }
| '(' CHAR '::' aty ')' { MachChar (fromEnum $2) }
| '(' STRING '::' aty ')' { MachStr (mkFastString $2) }
qname :: { RdrName } -- Includes data constructors
: name { $1 }
| mname '.' NAME { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
- | q_d_name { $1 }
+ | q_d_occ { $1 }
-- Type constructor
: mname '.' cname
{ mkIfaceOrig tcName (mkFastString $1) (mkFastString $3) }
--- Data constructor
-q_d_name :: { RdrName }
+-- Data constructor in a pattern or data type declaration; use the dataName,
+-- because that's what we expect in Core case patterns
+q_d_patt :: { RdrName }
: mname '.' cname
{ mkIfaceOrig dataName (mkFastString $1) (mkFastString $3) }
+-- Data constructor occurrence in an expression;
+-- use the varName because that's the worker Id
+q_d_occ :: { RdrName }
+ : mname '.' cname
+ { mkIfaceOrig varName (mkFastString $1) (mkFastString $3) }
+
{
convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName)
| n == intPrimRdrName = MachInt i
| n == wordPrimRdrName = MachWord i
convIntLit i aty
- = pprPanic "Unknown literal type" (ppr aty $$ ppr intPrimRdrName)
+ = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName)
+
+convRatLit :: Rational -> RdrNameHsType -> Literal
+convRatLit r (HsTyVar n)
+ | n == floatPrimRdrName = MachFloat r
+ | n == doublePrimRdrName = MachDouble r
+convRatLit i aty
+ = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName)
-wordPrimRdrName :: RdrName
-wordPrimRdrName = nameRdrName wordPrimTyConName
-intPrimRdrName :: RdrName
-intPrimRdrName = nameRdrName intPrimTyConName
+wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName :: RdrName
+wordPrimRdrName = nameRdrName wordPrimTyConName
+intPrimRdrName = nameRdrName intPrimTyConName
+floatPrimRdrName = nameRdrName floatPrimTyConName
+doublePrimRdrName = nameRdrName doublePrimTyConName
happyError :: P a
happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..))
-import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString,
+import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString,
mkDefaultMethodOcc, mkVarOcc )
import SrcLoc
import CStrings ( CLabelString )
tyConToDataCon :: RdrName -> P RdrName
tyConToDataCon tc
| isTcOcc (rdrNameOcc tc)
- = returnP (setRdrNameSpace tc dataName)
+ = returnP (setRdrNameSpace tc srcDataName)
| otherwise
= parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc)))
import TysPrim ( primTyCons )
import TysWiredIn ( wiredInTyCons )
import RdrHsSyn ( mkClassDecl )
-import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv,
+import HscTypes ( TyThing(..), implicitTyThings, TypeEnv, mkTypeEnv,
GenAvailInfo(..), RdrAvailInfo )
import Class ( Class, classKey, className )
import Type ( funTyCon, openTypeKind, liftedTypeKind )
= concat
[ -- Wired in TyCons and their implicit Ids
tycon_things
- , map AnId (implicitTyThingIds tycon_things)
+ , implicitTyThings tycon_things
-- Wired in Ids
, map AnId wiredInIds
\begin{code}
varQual = mk_known_key_name varName
-dataQual = mk_known_key_name dataName
+dataQual = mk_known_key_name dataName -- All the constructor names here are for the DataCon
+ -- itself, which lives in the VarName name space
tcQual = mk_known_key_name tcName
clsQual = mk_known_key_name clsName
wDataQual = mk_wired_in_name dataName
wTcQual = mk_wired_in_name tcName
-varQual_RDR mod str = mkOrig mod (mkOccFS varName str) -- note use of local alias vName
+varQual_RDR mod str = mkOrig mod (mkOccFS varName str) -- The RDR analogues
+dataQual_RDR mod str = mkOrig mod (mkOccFS dataName str)
tcQual_RDR mod str = mkOrig mod (mkOccFS tcName str)
clsQual_RDR mod str = mkOrig mod (mkOccFS clsName str)
-dataQual_RDR mod str = mkOrig mod (mkOccFS dataName str)
mk_known_key_name space mod str uniq
= mkKnownKeyExternalName (mkBasePkgModule mod) (mkOccFS space str) uniq
#include "HsVersions.h"
-import {-# SOURCE #-} MkId( mkDataConId, mkDataConWrapId )
+import {-# SOURCE #-} MkId( mkDataConWorkId )
import {-# SOURCE #-} Generics( mkTyConGenInfo )
-- friends:
import Module ( mkBasePkgModule )
import Name ( Name, nameUnique, nameOccName,
nameModule, mkWiredInName )
-import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
+import OccName ( mkOccFS, tcName, dataName, mkDataConWorkerOcc, mkGenOcc1, mkGenOcc2 )
import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons,
name2 = mkWiredInName mod occ_name2 fn2_key
pcDataCon :: Name -> [TyVar] -> ThetaType -> [Type] -> TyCon -> DataCon
+-- The Name should be in the DataName name space; it's the name
+-- of the DataCon itself.
+--
-- The unique is the first of two free uniques;
--- the first is used for the datacon itself and the worker;
--- the second is used for the wrapper.
+-- the first is used for the datacon itself,
+-- the second is used for the "worker name"
-pcDataCon name tyvars context arg_tys tycon
+pcDataCon dc_name tyvars context arg_tys tycon
= data_con
where
- data_con = mkDataCon name
- [ NotMarkedStrict | a <- arg_tys ]
- [ {- no labelled fields -} ]
- tyvars context [] [] arg_tys tycon work_id wrap_id
-
- wrap_occ = nameOccName name
-
- mod = nameModule name
- wrap_id = mkDataConWrapId data_con
-
- work_occ = mkWorkerOcc wrap_occ
- work_key = incrUnique (nameUnique name)
- work_name = mkWiredInName mod work_occ work_key
- work_id = mkDataConId work_name data_con
+ data_con = mkDataCon dc_name
+ [{- No strictness -}]
+ [{- No labelled fields -}]
+ tyvars context [] [] arg_tys tycon work_id
+ Nothing {- No wrapper for wired-in things
+ (they are too simple to need one) -}
+
+ mod = nameModule dc_name
+ wrk_occ = mkDataConWorkerOcc (nameOccName dc_name)
+ wrk_key = incrUnique (nameUnique dc_name)
+ wrk_name = mkWiredInName mod wrk_occ wrk_key
+ work_id = mkDataConWorkId wrk_name data_con
\end{code}
)
import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName )
import OccName ( OccName, mkWorkerOcc, mkClassTyConOcc, mkClassDataConOcc,
- mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2 )
+ mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2,
+ mkDataConWrapperOcc, mkDataConWorkerOcc )
import TyCon ( DataConDetails(..) )
import SrcLoc ( noSrcLoc, mkSrcLoc )
import Maybes ( maybeToBool )
-- on RdrNames, returning OccNames
getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc})
- = sequenceM [new_sys_bndr mod n loc | n <- sys_occs]
+ = mapM (new_sys_bndr mod loc) sys_occs
where
-- C.f. TcClassDcl.tcClassDecl1
- sys_occs = tc_occ : data_occ : dw_occ : sc_sel_occs
+ sys_occs = tc_occ : data_occ : dwrap_occ : dwork_occ : sc_sel_occs
cls_occ = rdrNameOcc cname
data_occ = mkClassDataConOcc cls_occ
- dw_occ = mkWorkerOcc data_occ
+ dwrap_occ = mkDataConWrapperOcc data_occ
+ dwork_occ = mkDataConWorkerOcc data_occ
tc_occ = mkClassTyConOcc cls_occ
sc_sel_occs = [mkSuperDictSelOcc n cls_occ | n <- [1..length cxt]]
tcdGeneric = Just want_generic, tcdLoc = loc})
-- The 'Just' is because this is an interface-file decl
-- so it will say whether to derive generic stuff for it or not
- = sequenceM ([new_sys_bndr mod n loc | n <- gen_occs] ++
- map con_sys_occ cons)
+ = mapM (new_sys_bndr mod loc) (gen_occs ++ concatMap mk_con_occs cons)
where
+ new = new_sys_bndr
-- c.f. TcTyDecls.tcTyDecl
tc_occ = rdrNameOcc tc_name
gen_occs | want_generic = [mkGenOcc1 tc_occ, mkGenOcc2 tc_occ]
| otherwise = []
- con_sys_occ (ConDecl name _ _ _ loc)
- = new_sys_bndr mod (mkWorkerOcc (rdrNameOcc name)) loc
+ mk_con_occs (ConDecl name _ _ _ _)
+ = [mkDataConWrapperOcc con_occ, mkDataConWorkerOcc con_occ]
+ where
+ con_occ = rdrNameOcc name -- The "source name"
getSysBinders mod decl = returnM []
-new_sys_bndr mod occ loc = newTopBinder mod (mkRdrUnqual occ) loc
+new_sys_bndr mod loc occ = newTopBinder mod (mkRdrUnqual occ) loc
-----------------------------------------------------
import IdInfo ( GlobalIdDetails(..) )
import TcType ( tyClsNamesOfType, classNamesOfTheta )
import FieldLabel ( fieldLabelTyCon )
-import DataCon ( dataConTyCon )
+import DataCon ( dataConTyCon, dataConWrapId )
import TyCon ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName )
import Class ( className, classSCTheta )
import Name ( Name {-instance NamedThing-}, isWiredInName, nameIsLocalOrFrom,
-- Tiresomely, we must get the "main" name for the
-- thing, because that's what VSlurp contains, and what
-- is recorded in the usage information
-get_main_name (AClass cl) = className cl
+get_main_name (AClass cl) = className cl
+get_main_name (ADataCon dc) = tyConName (dataConTyCon dc)
get_main_name (ATyCon tc)
| Just clas <- tyConClass_maybe tc = get_main_name (AClass clas)
| otherwise = tyConName tc
get_main_name (AnId id)
= case globalIdDetails id of
- DataConId dc -> get_main_name (ATyCon (dataConTyCon dc))
+ DataConWorkId dc -> get_main_name (ATyCon (dataConTyCon dc))
DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc))
RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl))
other -> idName id
super_classes = classNamesOfTheta (classSCTheta cl)
getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id)
+getWiredInGates (ADataCon dc) = tyClsNamesOfType (idType (dataConWrapId dc))
getWiredInGates (ATyCon tc)
| isSynTyCon tc = tyClsNamesOfType ty
| otherwise = unitFV (getName tc)
import Name ( Name, nameSrcLoc, nameOccName, nameModule, isExternalName )
import NameSet
import NameEnv
-import OccName ( OccName, dataName, isTcOcc )
+import OccName ( OccName, srcDataName, isTcOcc )
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails,
IsBootInterface,
avails -> returnM [(a, []) | a <- avails]
-- The 'explicits' list is irrelevant when hiding
where
- data_n = setRdrNameSpace n dataName
+ data_n = setRdrNameSpace n srcDataName
get_item item
= case check_item item of
import CoreSyn
import CoreFVs ( idRuleVars )
import CoreUtils ( exprIsTrivial )
-import Id ( isDataConId, isOneShotLambda, setOneShotLambda,
+import Id ( isDataConWorkId, isOneShotLambda, setOneShotLambda,
idOccInfo, setIdOccInfo,
isExportedId, modifyIdInfo, idInfo, idArity,
idSpecialisation, isLocalId,
-- This is the *whole point* of the isRhsEnv predicate
final_args_uds
| isRhsEnv env,
- isDataConId fun || valArgCount args < idArity fun
+ isDataConWorkId fun || valArgCount args < idArity fun
= mapVarEnv markMany args_uds
| otherwise = args_uds
in
findDefault, exprOkForSpeculation, exprIsValue
)
import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr )
-import Id ( Id, idType, idInfo, isDataConId,
+import Id ( Id, idType, idInfo, isDataConWorkId,
mkSysLocal, isDeadBinder, idNewDemandInfo,
idUnfolding, idNewStrictness
)
interestingArg (Var v) = hasSomeUnfolding (idUnfolding v)
-- Was: isValueUnfolding (idUnfolding v')
-- But that seems over-pessimistic
- || isDataConId v
+ || isDataConWorkId v
-- This accounts for an argument like
-- () or [], which is definitely interesting
interestingArg (Type _) = False
)
import Var ( mustHaveLocalBinding )
import VarEnv
-import Id ( Id, idType, idInfo, idArity, isDataConId,
+import Id ( Id, idType, idInfo, idArity, isDataConWorkId,
setIdUnfolding, isDeadBinder,
idNewDemandInfo, setIdInfo,
setIdOccInfo, zapLamIdInfo, setOneShotLambda,
-- if the strict-binding flag is on
mkAtomicArgs is_strict ok_float_unlifted rhs
- | (Var fun, args) <- collectArgs rhs, -- It's an application
- isDataConId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
+ | (Var fun, args) <- collectArgs rhs, -- It's an application
+ isDataConWorkId fun || valArgCount args < idArity fun -- And it's a constructor or PAP
= go fun nilOL [] args -- Have a go
| otherwise = bale_out -- Give up
import DataCon ( dataConRepArity )
import Type ( tyConAppArgs )
import Id ( Id, idName, idType,
- isDataConId_maybe,
+ isDataConWorkId_maybe,
mkUserLocal, mkSysLocal )
import Var ( Var )
import VarEnv
is_con_app_maybe env expr
= case collectArgs expr of
- (Var fun, args) | Just con <- isDataConId_maybe fun,
+ (Var fun, args) | Just con <- isDataConWorkId_maybe fun,
args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
-> Just (DataAlt con,args)
import CostCentre ( noCCS )
import VarSet
import VarEnv
-import DataCon ( dataConWrapId )
import Maybes ( maybeToBool )
import Name ( getOccName, isExternalName, isDllName )
import OccName ( occNameUserString )
res_ty = exprType (mkApps (Var f) args)
app = case globalIdDetails f of
- DataConId dc | saturated -> StgConApp dc args'
- PrimOpId op -> ASSERT( saturated )
- StgOpApp (StgPrimOp op) args' res_ty
- FCallId call -> ASSERT( saturated )
- StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
- _other -> StgApp f args'
+ DataConWorkId dc | saturated -> StgConApp dc args'
+ PrimOpId op -> ASSERT( saturated )
+ StgOpApp (StgPrimOp op) args' res_ty
+ FCallId call -> ASSERT( saturated )
+ StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+ _other -> StgApp f args'
in
returnLne (
idAppIsNonUpd :: IdEnv HowBound -> Id -> Int -> [CoreExpr] -> Bool
idAppIsNonUpd p id n_val_args args
- | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args)
+ | Just con <- isDataConWorkId_maybe id = not (isCrossDllConApp con args)
| otherwise = False -- SDM: disbled. See comment with isPAP above.
-- n_val_args < stgArity id (lookupBinding p id)
import DataCon ( dataConTyCon )
import TyCon ( isProductTyCon, isRecursiveTyCon )
import Id ( Id, idType, idInlinePragma,
- isDataConId, isGlobalId, idArity,
+ isDataConWorkId, isGlobalId, idArity,
#ifdef OLD_STRICTNESS
idDemandInfo, idStrictness, idCprInfo, idName,
#endif
dmdTransform sigs var dmd
------ DATA CONSTRUCTOR
- | isDataConId var -- Data constructor
+ | isDataConWorkId var -- Data constructor
= let
StrictSig dmd_ty = idNewStrictness var -- It must have a strictness sig
DmdType _ _ con_res = dmd_ty
import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict )
import CoreSyn
import CoreUnfold ( maybeUnfoldingTemplate )
-import Id ( Id, idType, idUnfolding, isDataConId_maybe,
+import Id ( Id, idType, idUnfolding, isDataConWorkId_maybe,
idStrictness,
)
import DataCon ( dataConTyCon, splitProductType_maybe, dataConRepArgTys )
absId anal var env
= case (lookupAbsValEnv env var,
- isDataConId_maybe var,
+ isDataConWorkId_maybe var,
idStrictness var,
maybeUnfoldingTemplate (idUnfolding var)) of
tcLookupClass, tcExtendTyVarEnv2,
tcExtendTyVarEnv
)
+import TcTyDecls ( tcMkDataCon )
import TcBinds ( tcMonoBinds )
import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
import TcSimplify ( tcSimplifyCheck )
Class, ClassOpItem, DefMeth (..) )
import TyCon ( tyConGenInfo )
import Subst ( substTyWith )
-import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
-import DataCon ( mkDataCon )
+import MkId ( mkDictSelId, mkDefaultMethodId )
import Id ( Id, idType, idName, mkUserLocal, setIdLocalExported, setInlinePragma )
import Name ( Name, NamedThing(..) )
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
mappM (tcClassSig clas tyvars mb_dm_env) op_sigs `thenM` \ sig_stuff ->
-- MAKE THE CLASS DETAILS
- lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name ->
- lookupSysName datacon_name mkWorkerOcc `thenM` \ datacon_wkr_name ->
+ lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name ->
+ lookupSysName class_name mkClassDataConOcc `thenM` \ datacon_name ->
mapM (lookupSysName class_name . mkSuperDictSelOcc)
[1..length context] `thenM` \ sc_sel_names ->
-- We number off the superclass selectors, 1, 2, 3 etc so that we
-- D_sc1, D_sc2
-- (We used to call them D_C, but now we can have two different
-- superclasses both called C!)
- lookupSysName class_name mkClassTyConOcc `thenM` \ tycon_name ->
let
(op_tys, op_items) = unzip sig_stuff
sc_tys = mkPredTys sc_theta
dict_component_tys = sc_tys ++ op_tys
sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
-
- dict_con = mkDataCon datacon_name
- [NotMarkedStrict | _ <- dict_component_tys]
- [{- No labelled fields -}]
- tyvars
- [{-No context-}]
- [{-No existential tyvars-}] [{-Or context-}]
- dict_component_tys
- (classTyCon clas)
- dict_con_id dict_wrap_id
-
- dict_con_id = mkDataConId datacon_wkr_name dict_con
- dict_wrap_id = mkDataConWrapId dict_con
in
+ tcMkDataCon datacon_name
+ [{- No strictness -}]
+ [{- No labelled fields -}]
+ tyvars [{-No context-}]
+ [{-No existential tyvars-}] [{-Or context-}]
+ dict_component_tys
+ (classTyCon clas) `thenM` \ dict_con ->
+
returnM (class_name, ClassDetails sc_theta sc_sel_ids op_items dict_con tycon_name)
\end{code}
import VarSet
import VarEnv
import CoreSyn ( IdCoreRule )
-import DataCon ( DataCon )
+import DataCon ( DataCon, dataConWrapId )
import TyCon ( TyCon, DataConDetails )
import Class ( Class, ClassOpItem )
import Name ( Name, NamedThing(..),
tcLookupGlobalId name
= tcLookupGlobal_maybe name `thenM` \ maybe_thing ->
case maybe_thing of
- Just (AnId id) -> returnM id
- other -> notFound "tcLookupGlobal" name
+ Just (AnId id) -> returnM id
+
+ -- When typechecking Haskell source, occurrences of
+ -- data constructors use the "source name", which maps
+ -- to ADataCon; we want the wrapper instead
+ Just (ADataCon dc) -> returnM (dataConWrapId dc)
+
+ other -> notFound "tcLookupGlobal (id)" name
tcLookupDataCon :: Name -> TcM DataCon
tcLookupDataCon con_name
- = tcLookupGlobalId con_name `thenM` \ con_id ->
- case isDataConWrapId_maybe con_id of
- Just data_con -> returnM data_con
- Nothing -> failWithTc (badCon con_id)
+ = tcLookupGlobal_maybe con_name `thenM` \ maybe_thing ->
+ case maybe_thing of
+ Just (ADataCon data_con) -> returnM data_con
+ other -> notFound "tcLookupDataCon" con_name
tcLookupClass :: Name -> TcM Class
tcLookupClass name
tcLookupId name
= tcLookup name `thenM` \ thing ->
case thing of
- ATcId tc_id lvl -> returnM tc_id
- AGlobal (AnId id) -> returnM id
- other -> pprPanic "tcLookupId" (ppr name)
+ ATcId tc_id lvl -> returnM tc_id
+ AGlobal (AnId id) -> returnM id
+ AGlobal (ADataCon dc) -> returnM (dataConWrapId dc)
+ -- C.f. tcLookupGlobalId
+ other -> pprPanic "tcLookupId" (ppr name)
tcLookupIdLvl :: Name -> TcM (Id, Level)
tcLookupIdLvl name
= tcLookup name `thenM` \ thing ->
case thing of
- ATcId tc_id lvl -> returnM (tc_id, lvl)
- AGlobal (AnId id) -> returnM (id, topIdLvl id)
+ ATcId tc_id lvl -> returnM (tc_id, lvl)
+ AGlobal (AnId id) -> returnM (id, topIdLvl id)
+ AGlobal (ADataCon dc) -> returnM (dataConWrapId dc, impLevel)
other -> pprPanic "tcLookupIdLvl" (ppr name)
tcLookupLocalIds :: [Name] -> TcM [TcId]
import TcRnTypes
import TcRnMonad
import TcMonoType ( tcIfaceType, kcHsSigType )
-import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId )
+import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupGlobalId,
+ tcLookupDataCon )
import RnHsSyn ( RenamedCoreDecl, RenamedTyClDecl )
import HsCore
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWrapId_maybe )
+import Id ( Id, mkVanillaGlobal, mkLocalId, isDataConWorkId_maybe )
import MkId ( mkFCallId )
import IdInfo
import TyCon ( tyConDataCons, tyConTyVars )
tcConAlt (UfTupleAlt (HsTupCon boxity arity))
= returnM (tupleCon boxity arity)
-tcConAlt (UfDataAlt con_name)
- = tcVar con_name `thenM` \ con_id ->
- returnM (case isDataConWrapId_maybe con_id of
- Just con -> con
- Nothing -> pprPanic "tcCoreAlt" (ppr con_id))
+tcConAlt (UfDataAlt con_name) -- When reading interface files
+ -- the con_name will be the real name of
+ -- the data con
+ = tcLookupDataCon con_name
\end{code}
%************************************************************************
-- This checks the argument types and
-- ambiguity of the existential context (if any)
addErrCtxt (existentialCtxt con)
- (checkFreeness ex_tvs ex_theta)
+ (checkFreeness ex_tvs ex_theta)
where
ctxt = ConArgCtxt (dataConName con)
(_, _, ex_tvs, ex_theta, _, _) = dataConSig con
wrongThingErr expected thing name
= pp_thing thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected
where
- pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor")
- pp_thing (AGlobal (AClass _)) = ptext SLIT("Class")
- pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier")
+ pp_thing (AGlobal (ATyCon _)) = ptext SLIT("Type constructor")
+ pp_thing (AGlobal (AClass _)) = ptext SLIT("Class")
+ pp_thing (AGlobal (AnId _)) = ptext SLIT("Identifier")
+ pp_thing (AGlobal (ADataCon _)) = ptext SLIT("Data constructor")
pp_thing (ATyVar _) = ptext SLIT("Type variable")
pp_thing (ATcId _ _) = ptext SLIT("Local identifier")
pp_thing (AThing _) = ptext SLIT("Utterly bogus")
-- an error we'd better stop now, to avoid a cascade
traceTc (text "TyCl1") `thenM_`
- tcTyAndClassDecls tycl_decls `thenM` \ tycl_things ->
- tcExtendGlobalEnv tycl_things $
+ tcTyAndClassDecls tycl_decls `thenM` \ tcg_env ->
+ -- Returns the extended environment
+ setGblEnv tcg_env $
traceTc (text "TyCl2") `thenM_`
tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
)
import RnHsSyn ( RenamedTyClDecl, tyClDeclFVs )
import BasicTypes ( RecFlag(..), NewOrData(..) )
-import HscTypes ( implicitTyThingIds )
+import HscTypes ( implicitTyThings )
import TcRnMonad
import TcEnv ( TcTyThing(..), TyThing(..), TyThingDetails(..),
~~~~~~~~~~~~~~~~~
\begin{code}
tcTyAndClassDecls :: [RenamedTyClDecl]
- -> TcM [TyThing] -- Returns newly defined things:
- -- types, classes and implicit Ids
+ -> TcM TcGblEnv -- Returns extended environment
tcTyAndClassDecls decls
= tcGroups (stronglyConnComp edges)
where
edges = map mkEdges (filter isTypeOrClassDecl decls)
-tcGroups []
- = returnM []
+tcGroups [] = getGblEnv
tcGroups (group:groups)
- = tcGroup group `thenM` \ (env, new_things1) ->
+ = tcGroup group `thenM` \ env ->
setGblEnv env $
- tcGroups groups `thenM` \ new_things2 ->
- returnM (new_things1 ++ new_things2)
+ tcGroups groups
\end{code}
Dealing with a group
\begin{code}
tcGroup :: SCC RenamedTyClDecl
- -> TcM (TcGblEnv, -- Input env extended by types and classes only
- [TyThing]) -- Things defined by this group
+ -> TcM TcGblEnv -- Input env extended by types and classes
+ -- and their implicit Ids,DataCons
tcGroup scc
= -- Step 1
) `thenM` \ (_, env, tyclss) ->
-- Step 7: Check validity
+ setGblEnv env $
+
traceTc (text "ready for validity check") `thenM_`
getModule `thenM` \ mod ->
- setGblEnv env (
- mappM_ (checkValidTyCl mod) decls
- ) `thenM_`
+ mappM_ (checkValidTyCl mod) decls `thenM_`
traceTc (text "done") `thenM_`
let -- Add the tycons that come from the classes
-- We want them in the environment because
-- they are mentioned in interface files
- implicit_tycons, implicit_ids, all_tyclss :: [TyThing]
- implicit_tycons = [ATyCon (classTyCon clas) | AClass clas <- tyclss]
- all_tyclss = implicit_tycons ++ tyclss
- implicit_ids = [AnId id | id <- implicitTyThingIds all_tyclss]
- new_things = implicit_ids ++ all_tyclss
+ implicit_things = implicitTyThings tyclss
in
- returnM (env, new_things)
+ traceTc ((text "Adding" <+> ppr tyclss) $$ (text "and" <+> ppr implicit_things)) `thenM_`
+ tcExtendGlobalEnv implicit_things getGblEnv
where
decls = case scc of
\section[TcTyDecls]{Typecheck type declarations}
\begin{code}
-module TcTyDecls ( tcTyDecl, kcConDetails ) where
+module TcTyDecls ( tcTyDecl, kcConDetails, tcMkDataCon ) where
#include "HsVersions.h"
getBangType, getBangStrictness, conDetailsTys
)
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
-import BasicTypes ( NewOrData(..) )
+import BasicTypes ( NewOrData(..), StrictnessMark )
import TcMonoType ( tcHsTyVars, tcHsTheta, tcHsType,
kcHsContext, kcHsSigType, kcHsLiftedSigType
)
import TcEnv ( tcExtendTyVarEnv, tcLookupTyCon, TyThingDetails(..) )
-import TcType ( tyVarsOfTypes, tyVarsOfPred, ThetaType )
+import TcType ( Type, tyVarsOfTypes, tyVarsOfPred, ThetaType )
import RnEnv ( lookupSysName )
import TcRnMonad
import DataCon ( DataCon, mkDataCon, dataConFieldLabels )
-import FieldLabel ( fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel )
-import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
+import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, allFieldLabelTags, mkFieldLabel )
+import MkId ( mkDataConWorkId, mkDataConWrapId, mkRecordSelId )
import Var ( TyVar )
import Name ( Name )
-import OccName ( mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
+import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc,
+ mkGenOcc1, mkGenOcc2, setOccNameSpace )
import Outputable
import TyCon ( TyCon, DataConDetails(..), visibleDataCons,
tyConTyVars, tyConName )
tc_datacon ex_tyvars ex_theta btys
= mappM tcHsType (map getBangType btys) `thenM` \ arg_tys ->
- mk_data_con ex_tyvars ex_theta (map getBangStrictness btys) arg_tys []
+ tcMkDataCon name
+ (map getBangStrictness btys)
+ [{- No field labels -}]
+ tyvars ctxt ex_tyvars ex_theta
+ arg_tys tycon
tc_rec_con ex_tyvars ex_theta fields
- = checkTc (null ex_tyvars) (exRecConErr name) `thenM_`
+ = checkTc (null ex_tyvars) (exRecConErr name) `thenM_`
mappM tc_field (fields `zip` allFieldLabelTags) `thenM` \ field_labels ->
let
- arg_stricts = [str | (n, bty) <- fields,
- let str = getBangStrictness bty
- ]
+ arg_stricts = [getBangStrictness bty | (n, bty) <- fields]
+ arg_tys = map fieldLabelType field_labels
in
- mk_data_con ex_tyvars ex_theta arg_stricts
- (map fieldLabelType field_labels) field_labels
+ tcMkDataCon name arg_stricts field_labels
+ tyvars ctxt ex_tyvars ex_theta
+ arg_tys tycon
tc_field ((field_label_name, bty), tag)
= tcHsType (getBangType bty) `thenM` \ field_ty ->
returnM (mkFieldLabel field_label_name tycon field_ty tag)
- mk_data_con ex_tyvars ex_theta arg_stricts arg_tys fields
- = lookupSysName name mkWorkerOcc `thenM` \ wkr_name ->
- let
- data_con = mkDataCon name arg_stricts fields
- tyvars (thinContext arg_tys ctxt)
- ex_tyvars ex_theta
- arg_tys
- tycon data_con_id data_con_wrap_id
-
- data_con_id = mkDataConId wkr_name data_con
- data_con_wrap_id = mkDataConWrapId data_con
- in
- returnM data_con
+tcMkDataCon :: Name
+ -> [StrictnessMark] -> [FieldLabel]
+ -> [TyVar] -> ThetaType
+ -> [TyVar] -> ThetaType
+ -> [Type] -> TyCon
+ -> TcM DataCon
+-- A wrapper for DataCon.mkDataCon that
+-- a) makes the worker Id
+-- b) makes the wrapper Id if necessary, including
+-- allocating its unique (hence monadic)
+tcMkDataCon src_name arg_stricts fields
+ tyvars ctxt ex_tyvars ex_theta
+ arg_tys tycon
+ = lookupSysName src_name mkDataConWrapperOcc `thenM` \ wrap_name ->
+ lookupSysName src_name mkDataConWorkerOcc `thenM` \ work_name ->
+ -- This last one takes the name of the data constructor in the source
+ -- code, which (for Haskell source anyway) will be in the SrcDataName name
+ -- space, and makes it into a "real data constructor name"
+ let
+ data_con = mkDataCon src_name arg_stricts fields
+ tyvars (thinContext arg_tys ctxt)
+ ex_tyvars ex_theta
+ arg_tys tycon
+ data_con_work_id data_con_wrap_id
+ data_con_work_id = mkDataConWorkId work_name data_con
+ data_con_wrap_id = mkDataConWrapId wrap_name data_con
+ in
+ returnM data_con
-- The context for a data constructor should be limited to
-- the type variables mentioned in the arg_tys
\begin{code}
module TcType (
--------------------------------
+ -- TyThing
+ TyThing(..), -- instance NamedThing
+
+ --------------------------------
-- Types
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcKind,
hasMoreBoxityInfo, liftedBoxity,
superBoxity, typeKind, superKind, repType
)
+import DataCon ( DataCon )
import TyCon ( TyCon, isUnLiftedTyCon )
import Class ( classHasFDs, Class )
-import Var ( TyVar, tyVarKind, isMutTyVar, mutTyVarDetails )
+import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails )
import ForeignCall ( Safety, playSafe )
import VarEnv
import VarSet
%************************************************************************
%* *
+ TyThing
+%* *
+%************************************************************************
+
+\begin{code}
+data TyThing = AnId Id
+ | ADataCon DataCon
+ | ATyCon TyCon
+ | AClass Class
+
+instance NamedThing TyThing where
+ getName (AnId id) = getName id
+ getName (ATyCon tc) = getName tc
+ getName (AClass cl) = getName cl
+ getName (ADataCon dc) = getName dc
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Types}
%* *
%************************************************************************
-- friends:
-- (PprType can see all the representations it's trying to print)
import TypeRep ( Type(..), TyNote(..), Kind ) -- friend
-import Type ( SourceType(..), TyThing(..) )
-import TcType ( ThetaType, PredType,
+import Type ( SourceType(..) )
+import TcType ( ThetaType, PredType, TyThing(..),
tcSplitSigmaTy, isPredTy, isDictTy,
tcSplitTyConApp_maybe, tcSplitFunTy_maybe
)
pprBndr _ n = ppr n -- Simple for now
instance Outputable TyThing where
- ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
- ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
- ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
+ ppr (AnId id) = ptext SLIT("AnId") <+> ppr id
+ ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc
+ ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl
+ ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr dc
\end{code}
import Name ( Name, nameUnique, NamedThing(getName) )
import PrelNames ( Unique, Uniquable(..), anyBoxConKey )
import PrimRep ( PrimRep(..), isFollowableRep )
-import Maybes ( expectJust )
+import Maybes ( expectJust, orElse )
import Outputable
import FastString
\end{code}
\end{code}
\begin{code}
+isFunTyCon :: TyCon -> Bool
isFunTyCon (FunTyCon {}) = True
isFunTyCon _ = False
+isPrimTyCon :: TyCon -> Bool
isPrimTyCon (PrimTyCon {}) = True
isPrimTyCon _ = False
+isUnLiftedTyCon :: TyCon -> Bool
isUnLiftedTyCon (PrimTyCon {isUnLifted = is_unlifted}) = is_unlifted
isUnLiftedTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity)
isUnLiftedTyCon _ = False
-- isBoxedTyCon should not be applied to SynTyCon, nor KindCon
+isBoxedTyCon :: TyCon -> Bool
isBoxedTyCon (AlgTyCon {}) = True
isBoxedTyCon (FunTyCon {}) = True
isBoxedTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isBoxedTyCon (PrimTyCon {primTyConRep = rep}) = isFollowableRep rep
-- isAlgTyCon returns True for both @data@ and @newtype@
+isAlgTyCon :: TyCon -> Bool
isAlgTyCon (AlgTyCon {}) = True
isAlgTyCon (TupleTyCon {}) = True
isAlgTyCon other = False
+isDataTyCon :: TyCon -> Bool
-- isDataTyCon returns True for data types that are represented by
-- heap-allocated constructors.
-- These are srcutinised by Core-level @case@ expressions, and they
-- True for all @data@ types
-- False for newtypes
-- unboxed tuples
-isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data, algTyConRec = is_rec})
+isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data})
= case new_or_data of
NewTyCon _ -> False
other -> True
isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isDataTyCon other = False
+isNewTyCon :: TyCon -> Bool
isNewTyCon (AlgTyCon {algTyConFlavour = NewTyCon _}) = True
isNewTyCon other = False
-newTyConRep :: TyCon -> ([TyVar], Type)
-newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep)
-
+isProductTyCon :: TyCon -> Bool
-- A "product" tycon
-- has *one* constructor,
-- is *not* existential
isProductTyCon (TupleTyCon {}) = True
isProductTyCon other = False
+isSynTyCon :: TyCon -> Bool
isSynTyCon (SynTyCon {}) = True
isSynTyCon _ = False
+isEnumerationTyCon :: TyCon -> Bool
isEnumerationTyCon (AlgTyCon {algTyConFlavour = EnumTyCon}) = True
isEnumerationTyCon other = False
+isTupleTyCon :: TyCon -> Bool
-- The unit tycon didn't used to be classed as a tuple tycon
-- but I thought that was silly so I've undone it
-- If it can't be for some reason, it should be a AlgTyCon
isTupleTyCon (TupleTyCon {}) = True
isTupleTyCon other = False
+isUnboxedTupleTyCon :: TyCon -> Bool
isUnboxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = not (isBoxed boxity)
isUnboxedTupleTyCon other = False
+isBoxedTupleTyCon :: TyCon -> Bool
isBoxedTupleTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity
isBoxedTupleTyCon other = False
tupleTyConBoxity tc = tyConBoxed tc
+isRecursiveTyCon :: TyCon -> Bool
isRecursiveTyCon (AlgTyCon {algTyConRec = Recursive}) = True
isRecursiveTyCon other = False
+isForeignTyCon :: TyCon -> Bool
-- isForeignTyCon identifies foreign-imported type constructors
-- For the moment, they are primitive but lifted, but that may change
isForeignTyCon (PrimTyCon {isUnLifted = is_unlifted}) = not is_unlifted
tyConDataConDetails other = Unknown
tyConDataCons :: TyCon -> [DataCon]
-tyConDataCons tycon = expectJust "tyConDataCons" (tyConDataCons_maybe tycon)
+-- It's convenient for tyConDataCons to return the
+-- empty list for type synonyms etc
+tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []
tyConDataCons_maybe :: TyCon -> Maybe [DataCon]
tyConDataCons_maybe (AlgTyCon {dataCons = DataCons cons}) = Just cons
\end{code}
\begin{code}
+newTyConRep :: TyCon -> ([TyVar], Type)
+newTyConRep (AlgTyCon {tyConTyVars = tvs, algTyConFlavour = NewTyCon rep}) = (tvs, rep)
+
tyConPrimRep :: TyCon -> PrimRep
tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
tyConPrimRep tc = ASSERT( not (isUnboxedTupleTyCon tc) )
Type, PredType, ThetaType,
Kind, TyVarSubst,
- TyThing(..), isTyClThing,
-
superKind, superBoxity, -- KX and BX respectively
liftedBoxity, unliftedBoxity, -- :: BX
openKindCon, -- :: KX
%************************************************************************
%* *
- TyThing
-%* *
-%************************************************************************
-
-\begin{code}
-data TyThing = AnId Id
- | ATyCon TyCon
- | AClass Class
-
-isTyClThing :: TyThing -> Bool
-isTyClThing (ATyCon _) = True
-isTyClThing (AClass _) = True
-isTyClThing (AnId _) = False
-
-instance NamedThing TyThing where
- getName (AnId id) = getName id
- getName (ATyCon tc) = getName tc
- getName (AClass cl) = getName cl
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Stuff to do with kinds.}
%* *
%************************************************************************
projects / ghc-hetmet.git / commitdiff