mkDataCon,
dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
dataConArgTys, dataConOrigArgTys, dataConInstOrigArgTys,
- dataConRepArgTys, dataConTheta,
+ dataConRepArgTys, dataConTheta,
dataConFieldLabels, dataConStrictMarks,
dataConSourceArity, dataConRepArity,
- dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness,
+ dataConNumInstArgs, dataConWorkId, dataConWrapId, dataConRepStrictness,
isNullaryDataCon, isTupleCon, isUnboxedTupleCon,
- isExistentialDataCon, classDataCon,
+ isExistentialDataCon, classDataCon, dataConExistentialTyVars,
splitProductType_maybe, splitProductType,
) where
The worker is very like a primop, in that it has no binding,
+A note about the stupid context
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Data types can have a context:
+
+ data (Eq a, Ord b) => T a b = T1 a b | T2 a
+
+and that makes the constructors have a context too
+(notice that T2's context is "thinned"):
+
+ T1 :: (Eq a, Ord b) => a -> b -> T a b
+ T2 :: (Eq a) => a -> T a b
+
+Furthermore, this context pops up when pattern matching
+(though GHC hasn't implemented this, but it is in H98, and
+I've fixed GHC so that it now does):
+
+ f (T2 x) = x
+gets inferred type
+ f :: Eq a => T a b -> a
+
+I say the context is "stupid" because the dictionaries passed
+are immediately discarded -- they do nothing and have no benefit.
+It's a flaw in the language.
+
+Up to now [March 2002] I have put this stupid context into the type of
+the "wrapper" constructors functions, T1 and T2, but that turned out
+to be jolly inconvenient for generics, and record update, and other
+functions that build values of type T (because they don't have
+suitable dictionaries available).
+
+So now I've taken the stupid context out. I simply deal with it
+separately in the type checker on occurrences of a constructor, either
+in an expression or in a pattern.
+
+
%************************************************************************
%* *
-- data Eq a => T a = forall b. Ord b => MkT a [b]
dcRepType :: Type, -- Type of the constructor
- -- forall ab . Ord b => a -> [b] -> MkT a
- -- (this is *not* of the constructor Id:
+ -- forall b a . Ord b => a -> [b] -> MkT a
+ -- (this is *not* of the constructor wrapper Id:
-- see notes after this data type declaration)
+ --
+ -- Notice that the existential type parameters come
+ -- *first*. It doesn't really matter provided we are
+ -- consistent.
-- The next six fields express the type of the constructor, in pieces
-- e.g.
-- dcOrigArgTys = [a,List b]
-- dcTyCon = T
- dcTyVars :: [TyVar], -- Type vars and context for the data type decl
+ dcTyVars :: [TyVar], -- Type vars for the data type decl
-- These are ALWAYS THE SAME AS THE TYVARS
-- FOR THE PARENT TyCon. We occasionally rely on
-- this just to avoid redundant instantiation
- dcTheta :: ThetaType,
+
+ dcStupidTheta :: ThetaType, -- This is a "thinned" version of the context of
+ -- the data decl.
+ -- "Thinned", because the Report says
+ -- to eliminate any constraints that don't mention
+ -- tyvars free in the arg types for this constructor
+ --
+ -- "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
+ -- that makes it harder to use the wrap-id to rebuild
+ -- values after record selection or in generics.
dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
dcExTheta :: ThetaType, -- the existentially quantified stuff
--
-- An entirely separate wrapper function is built in TcTyDecls
- dcId :: Id, -- The corresponding worker Id
+ dcWorkId :: Id, -- The corresponding worker Id
-- Takes dcRepArgTys as its arguments
dcWrapId :: Id -- The wrapper Id
%************************************************************************
%* *
-\subsection{Consruction}
+\subsection{Construction}
%* *
%************************************************************************
con
where
con = MkData {dcName = name, dcUnique = nameUnique name,
- dcTyVars = tyvars, dcTheta = theta,
+ dcTyVars = tyvars, dcStupidTheta = theta,
dcOrigArgTys = orig_arg_tys,
dcRepArgTys = rep_arg_tys,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dcStrictMarks = real_stricts, dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcTyCon = tycon, dcRepType = ty,
- dcId = work_id, dcWrapId = wrap_id}
+ dcWorkId = work_id, dcWrapId = wrap_id}
-- Strictness marks for source-args
-- *after unboxing choices*,
(rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
- ty = mkForAllTys (tyvars ++ ex_tyvars)
+ ty = mkForAllTys (ex_tyvars ++ tyvars)
(mkFunTys rep_arg_tys result_ty)
-- NB: the existential dict args are already in rep_arg_tys
dataConRepType :: DataCon -> Type
dataConRepType = dcRepType
-dataConId :: DataCon -> Id
-dataConId = dcId
+dataConWorkId :: DataCon -> Id
+dataConWorkId = dcWorkId
dataConWrapId :: DataCon -> Id
dataConWrapId = dcWrapId
[TyVar], ThetaType,
[Type], TyCon)
-dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
+dataConSig (MkData {dcTyVars = tyvars, dcStupidTheta = theta,
dcExTyVars = ex_tyvars, dcExTheta = ex_theta,
dcOrigArgTys = arg_tys, dcTyCon = tycon})
= (tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon)
dataConArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
- = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
+ = map (substTyWith (ex_tyvars ++ tyvars) inst_tys) arg_tys
dataConTheta :: DataCon -> ThetaType
-dataConTheta dc = dcTheta dc
+dataConTheta dc = dcStupidTheta dc
+
+dataConExistentialTyVars :: DataCon -> [TyVar]
+dataConExistentialTyVars dc = dcExTyVars dc
-- And the same deal for the original arg tys:
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars,
dcExTyVars = ex_tyvars}) inst_tys
- = map (substTyWith (tyvars ++ ex_tyvars) inst_tys) arg_tys
+ = map (substTyWith (ex_tyvars ++ tyvars) inst_tys) arg_tys
\end{code}
These two functions get the real argument types of the constructor,
\begin{code}
module MkId (
mkDictFunId, mkDefaultMethodId,
- mkDictSelId,
+ mkDictSelId,
mkDataConId, mkDataConWrapId,
- mkRecordSelId, rebuildConArgs,
+ mkRecordSelId,
mkPrimOpId, mkFCallId,
+ mkReboxingAlt, mkNewTypeBody,
+
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
unsafeCoerceId, realWorldPrimId, voidArgId, nullAddrId, seqId,
import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon, classTyVars, classSelIds )
-import Var ( Id, TyVar )
+import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet )
import Name ( mkWiredInName, mkFCallName, Name )
import OccName ( mkVarOcc )
import DataCon ( DataCon,
dataConFieldLabels, dataConRepArity, dataConTyCon,
dataConArgTys, dataConRepType,
- dataConInstOrigArgTys,
+ dataConOrigArgTys,
dataConName, dataConTheta,
- dataConSig, dataConStrictMarks, dataConId,
+ dataConSig, dataConStrictMarks, dataConWorkId,
splitProductType
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
import Outputable
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
+import List ( nubBy )
import Char ( ord )
\end{code}
mkDataConWrapId data_con
= mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
where
- work_id = dataConId data_con
+ work_id = dataConWorkId data_con
info = noCafNoTyGenIdInfo
`setUnfoldingInfo` wrap_unf
-- applications are treated as values
`setAllStrictnessInfo` Just wrap_sig
- wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
-
wrap_sig = mkStrictSig (mkTopDmdType arg_dmds res_info)
res_info = strictSigResInfo (idNewStrictness work_id)
- arg_dmds = [Abs | d <- dict_args] ++ map mk_dmd strict_marks
+ arg_dmds = map mk_dmd strict_marks
mk_dmd str | isMarkedStrict str = evalDmd
| otherwise = lazyDmd
-- The Cpr info can be important inside INLINE rhss, where the
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkTopUnfolding $ Note InlineMe $
- mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
+ mkLams tyvars $ Lam id_arg1 $
mkNewTypeBody tycon result_ty (Var id_arg1)
- | null dict_args && not (any isMarkedStrict strict_marks)
+ | 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
| otherwise
= mkTopUnfolding $ Note InlineMe $
- mkLams all_tyvars $ mkLams dict_args $
+ mkLams all_tyvars $
mkLams ex_dict_args $ mkLams id_args $
foldr mk_case con_app
(zip (ex_dict_args++id_args) strict_marks) i3 []
con_app i rep_ids = mkApps (Var work_id)
(map varToCoreExpr (all_tyvars ++ reverse rep_ids))
- (tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
- all_tyvars = tyvars ++ ex_tyvars
+ (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
+ all_tyvars = ex_tyvars ++ tyvars
- dict_tys = mkPredTys theta
ex_dict_tys = mkPredTys ex_theta
- all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys
+ all_arg_tys = ex_dict_tys ++ orig_arg_tys
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
+ wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
+ -- We used to include the stupid theta in the wrapper's args
+ -- but now we don't. Instead the type checker just injects these
+ -- extra constraints where necessary.
+
mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
where
n = length tys
- (dict_args, i1) = mkLocals 1 dict_tys
- (ex_dict_args,i2) = mkLocals i1 ex_dict_tys
+ (ex_dict_args,i2) = mkLocals 1 ex_dict_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
arity = i3-1
(id_arg1:_) = id_args -- Used for newtype only
data_ty = mkTyConApp tycon tyvar_tys
tyvar_tys = mkTyVarTys tyvars
- tycon_theta = tyConTheta tycon -- The context on the data decl
+ -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
+ -- just the dictionaries in the types of the constructors that contain
+ -- the relevant field. [The Report says that pattern matching on a
+ -- constructor gives the same constraints as applying it.] Urgh.
+ --
+ -- However, not all data cons have all constraints (because of
+ -- TcTyDecls.thinContext). So we need to find all the data cons
+ -- involved in the pattern match and take the union of their constraints.
+ --
+ -- NB: this code relies on the fact that DataCons are quantified over
+ -- the identical type variables as their parent TyCon
+ tycon_theta = tyConTheta tycon -- The context on the data decl
-- eg data (Eq a, Ord b) => T a b = ...
- dict_tys = [mkPredTy pred | pred <- tycon_theta,
- needed_dict pred]
- needed_dict pred = or [ tcEqPred pred p
- | (DataAlt dc, _, _) <- the_alts, p <- dataConTheta dc]
- n_dict_tys = length dict_tys
+ needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConTheta dc]
+ dict_tys = map mkPredTy (nubBy tcEqPred needed_preds)
+ n_dict_tys = length dict_tys
(field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
field_dict_tys = map mkPredTy field_theta
-- Note that this is exactly the type we'd infer from a user defn
-- op (R op) = op
- -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
- -- just the dictionaries in the types of the constructors that contain
- -- the relevant field. Urgh.
- -- NB: this code relies on the fact that DataCons are quantified over
- -- the identical type variables as their parent TyCon
-
selector_ty :: Type
selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
mkFunTys dict_tys $ mkFunTys field_dict_tys $
-- foo = /\a. \t:T. case t of { MkT f -> f a }
mk_maybe_alt data_con
- = case maybe_the_arg_id of
+ = case maybe_the_arg_id of
Nothing -> Nothing
- Just the_arg_id -> Just (DataAlt data_con, real_args, mkLets binds body)
- where
- body = mk_result the_arg_id
- strict_marks = dataConStrictMarks data_con
- (binds, real_args) = rebuildConArgs arg_ids strict_marks
- (map mkBuiltinUnique [unpack_base..])
+ Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids body)
+ where
+ body = mk_result the_arg_id
where
- arg_ids = mkTemplateLocalsNum field_base (dataConInstOrigArgTys data_con tyvar_tys)
+ arg_ids = mkTemplateLocalsNum field_base (dataConOrigArgTys data_con)
+ -- No need to instantiate; same tyvars in datacon as tycon
unpack_base = field_base + length arg_ids
+ uniqs = map mkBuiltinUnique [unpack_base..]
-- arity+1 avoids all shadowing
maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_label
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
--- This rather ugly function converts the unpacked data con
--- arguments back into their packed form.
-
-rebuildConArgs
- :: [Id] -- Source-level args
- -> [StrictnessMark] -- Strictness annotations (per-arg)
- -> [Unique] -- Uniques for the new Ids
- -> ([CoreBind], [Id]) -- A binding for each source-level arg, plus
- -- a list of the representation-level arguments
--- e.g. data T = MkT Int !Int
+-- (mkReboxingAlt us con xs rhs) basically constructs the case
+-- alternative (con, xs, rhs)
+-- but it does the reboxing necessary to construct the *source*
+-- arguments, xs, from the representation arguments ys.
+-- For example:
+-- data T = MkT !(Int,Int) Bool
+--
+-- mkReboxingAlt MkT [x,b] r
+-- = (DataAlt MkT, [y::Int,z::Int,b], let x = (y,z) in r)
--
--- rebuild [x::Int, y::Int] [Not, Unbox]
--- = ([ y = I# t ], [x,t])
+-- mkDataAlt should really be in DataCon, but it can't because
+-- it manipulates CoreSyn.
-rebuildConArgs [] stricts us = ([], [])
+mkReboxingAlt
+ :: [Unique] -- Uniques for the new Ids
+ -> DataCon
+ -> [Var] -- Source-level args
+ -> CoreExpr -- RHS
+ -> CoreAlt
--- Type variable case
-rebuildConArgs (arg:args) stricts us
- | isTyVar arg
- = let (binds, args') = rebuildConArgs args stricts us
- in (binds, arg:args')
+mkReboxingAlt us con args rhs
+ | not (any isMarkedUnboxed stricts)
+ = (DataAlt con, args, rhs)
--- Term variable case
-rebuildConArgs (arg:args) (str:stricts) us
- | isMarkedUnboxed str
+ | otherwise
= let
- arg_ty = idType arg
-
- (_, tycon_args, pack_con, con_arg_tys)
- = splitProductType "rebuildConArgs" arg_ty
-
- unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
- (binds, args') = rebuildConArgs args stricts (dropList con_arg_tys us)
- con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
+ (binds, args') = go args stricts us
in
- (NonRec arg con_app : binds, unpacked_args ++ args')
+ (DataAlt con, args', mkLets binds rhs)
- | otherwise
- = let (binds, args') = rebuildConArgs args stricts us
- in (binds, arg:args')
+ where
+ stricts = dataConStrictMarks con
+
+ go [] stricts us = ([], [])
+
+ -- Type variable case
+ go (arg:args) stricts us
+ | isTyVar arg
+ = let (binds, args') = go args stricts us
+ in (binds, arg:args')
+
+ -- Term variable case
+ go (arg:args) (str:stricts) us
+ | isMarkedUnboxed str
+ = let
+ (_, tycon_args, pack_con, con_arg_tys)
+ = splitProductType "mkReboxingAlt" (idType arg)
+
+ unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
+ (binds, args') = go args stricts (dropList con_arg_tys us)
+ con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
+ in
+ (NonRec arg con_app : binds, unpacked_args ++ args')
+
+ | otherwise
+ = let (binds, args') = go args stricts us
+ in (binds, arg:args')
\end{code}
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
- mkBuiltinUnique,
+ mkBuiltinUnique, builtinUniques,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
) where
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
mkBuiltinUnique :: Int -> Unique
+builtinUniques :: [Unique]
+builtinUniques = map mkBuiltinUnique [1..]
+
mkBuiltinUnique i = mkUnique 'B' i
mkPseudoUnique1 i = mkUnique 'C' i -- used for getUnique on Regs
mkPseudoUnique2 i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs
import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
currentCCS )
import DataCon ( DataCon, dataConName, dataConTag,
- isUnboxedTupleCon, isNullaryDataCon, dataConId,
+ isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
dataConWrapId, dataConRepArity
)
import Id ( Id, idName, idPrimRep )
-- temporary variable, if the closure is a CHARLIKE.
-- funnily enough, this makes the unique always come
-- out as '54' :-)
- buildDynCon (dataConId con) currentCCS con amodes `thenFC` \ idinfo ->
+ buildDynCon (dataConWorkId con) currentCCS con amodes `thenFC` \ idinfo ->
idInfoToAmode PtrRep idinfo `thenFC` \ amode ->
isDataConId_maybe, idUnfolding
)
import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
-import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
-- 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
- where
- tmpl_uniqs = map mkBuiltinUnique [1..]
get_unfolding id -- See notes above
| Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
import Literal ( Literal, mkMachInt )
-import DataCon ( DataCon, dataConId )
+import DataCon ( DataCon, dataConWorkId )
import BasicTypes ( Activation )
import VarSet
import Outputable
mkLams :: [b] -> Expr b -> Expr b
mkLit lit = Lit lit
-mkConApp con args = mkApps (Var (dataConId con)) args
+mkConApp con args = mkApps (Var (dataConWorkId con)) args
mkLams binders body = foldr Lam body binders
mkLets binds body = foldr Let body binds
make_cdef :: DataCon -> C.Cdef
make_cdef dcon = C.Constr dcon_name existentials tys
where
- dcon_name = make_con_qid (idName (dataConId dcon))
+ dcon_name = make_con_qid (idName (dataConWorkId dcon))
existentials = map make_tbind ex_tyvars
- where (_,_,ex_tyvars,_,_,_) = dataConSig dcon
- tys = map make_ty (dataConRepArgTys dcon)
+ ex_tyvars = dataConExistentialTyVars dcon
+ tys = map make_ty (dataConRepArgTys dcon)
make_tbind :: TyVar -> C.Tbind
make_tbind tv = (make_var_id (tyVarName tv), make_kind (tyVarKind tv))
make_alt :: CoreAlt -> C.Alt
make_alt (DataAlt dcon, vs, e) =
- C.Acon (make_con_qid (idName (dataConId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
+ C.Acon (make_con_qid (idName (dataConWorkId dcon))) (map make_tbind tbs) (map make_vbind vbs) (make_exp e)
where (tbs,vbs) = span isTyVar vs
make_alt (LitAlt l,_,e) = C.Alit (make_lit l) (make_exp e)
make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
dictionaries.
\begin{code}
-dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty dicts [])
+dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty [])
= dsExpr record_expr
-dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty dicts rbinds)
+dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds)
= getSrcLocDs `thenDs` \ src_loc ->
dsExpr record_expr `thenDs` \ record_expr' ->
let
val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
(dataConFieldLabels con) arg_ids
- rhs = foldl HsApp (DictApp (TyApp (HsVar (dataConWrapId con))
- out_inst_tys)
- dicts)
+ rhs = foldl HsApp (TyApp (HsVar (dataConWrapId con)) out_inst_tys)
val_args
in
returnDs (mkSimpleMatch [ConPat con record_in_ty [] [] (map VarPat arg_ids)]
import CoreUtils ( exprType, mkIfThenElse )
import PrelInfo ( iRREFUT_PAT_ERROR_ID )
-import MkId ( rebuildConArgs )
+import MkId ( mkReboxingAlt, mkNewTypeBody )
import Id ( idType, Id, mkWildId )
import Literal ( Literal(..), inIntRange, tARGET_MAX_INT )
import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon )
-import DataCon ( DataCon, dataConStrictMarks, dataConId,
- dataConSourceArity )
+import DataCon ( DataCon, dataConSourceArity )
import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp )
import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy )
import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy )
-- Stuff for newtype
(_, arg_ids, match_result) = head match_alts
arg_id = head arg_ids
-
- newtype_rhs | isRecursiveTyCon tycon -- Recursive case; need a case
- = Note (Coerce (idType arg_id) scrut_ty) (Var var)
- | otherwise -- Normal case (newtype is transparent)
- = Var var
+ newtype_rhs = mkNewTypeBody tycon (idType arg_id) (Var var)
-- Stuff for data types
- data_cons = tyConDataCons tycon
-
- match_results = [match_result | (_,_,match_result) <- match_alts]
+ data_cons = tyConDataCons tycon
+ match_results = [match_result | (_,_,match_result) <- match_alts]
fail_flag | exhaustive_case
= foldr1 orFail [can_it_fail | MatchResult can_it_fail _ <- match_results]
returnDs (Case (Var var) wild_var (mk_default fail ++ alts))
mk_alt fail (con, args, MatchResult _ body_fn)
- = body_fn fail `thenDs` \ body ->
- getUniquesDs `thenDs` \ us ->
- let
- (binds, real_args) = rebuildConArgs args (dataConStrictMarks con) us
- in
- returnDs (DataAlt con, real_args, mkDsLets binds body)
+ = body_fn fail `thenDs` \ body ->
+ getUniquesDs `thenDs` \ us ->
+ returnDs (mkReboxingAlt us con args body)
mk_default fail | exhaustive_case = []
| otherwise = [(DEFAULT, [], fail)]
\begin{code}
mkNilExpr :: Type -> CoreExpr
-mkNilExpr ty = App (Var (dataConId nilDataCon)) (Type ty)
+mkNilExpr ty = mkConApp nilDataCon [Type ty]
mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr
-mkConsExpr ty hd tl = mkApps (Var (dataConId consDataCon)) [Type ty, hd, tl]
+mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl]
\end{code}
Type -- Type of *input* record
Type -- Type of *result* record (may differ from
-- type of input record)
- [id] -- Dicts needed for construction
(HsRecordBinds id pat)
| ExprWithTySig -- signature binding
ppr_expr (RecordUpd aexp rbinds)
= pp_rbinds (pprParendExpr aexp) rbinds
-ppr_expr (RecordUpdOut aexp _ _ _ rbinds)
+ppr_expr (RecordUpdOut aexp _ _ rbinds)
= pp_rbinds (pprParendExpr aexp) rbinds
ppr_expr (ExprWithTySig expr sig)
import Name ( NamedThing(..), getOccString, isExternalName, isInternalName
, nameModule )
import PrimRep ( PrimRep(..) )
-import DataCon ( DataCon, dataConRepArity, dataConRepArgTys, dataConId )
+import DataCon ( DataCon, dataConRepArity, dataConRepArgTys, dataConWorkId )
import qualified Type
import qualified CoreSyn
import CoreSyn ( CoreBind, CoreExpr, CoreAlt, CoreBndr,
-- would return the name "Test.Foo".
javaConstrWkrName :: DataCon -> TypeName
-javaConstrWkrName = javaIdTypeName . dataConId
+javaConstrWkrName = javaIdTypeName . dataConWorkId
-- Makes x_inst for Rec decls
-- They are *never* is primitive
import Id ( Id )
import Class ( Class, classSelIds )
import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe )
-import DataCon ( dataConId, dataConWrapId )
+import DataCon ( dataConWorkId, dataConWrapId )
import BasicTypes ( Version, initialVersion, Fixity, defaultFixity, IPName )
implicitConIds tc dc -- Newtypes have a constructor wrapper,
-- but no worker
| isNewTyCon tc = [dataConWrapId dc]
- | otherwise = [dataConId dc, dataConWrapId dc]
+ | otherwise = [dataConWorkId dc, dataConWrapId dc]
\end{code}
import Id ( idType, idInfo, isImplicitId, idCgInfo,
isLocalId, idName,
)
-import DataCon ( dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
+import DataCon ( dataConWorkId, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
import Var ( Var )
import CoreSyn ( CoreRule(..), IdCoreRule )
tycon = classTyCon clas
data_con = head (tyConDataCons tycon)
sys_names = mkClassDeclSysNames (getName tycon, getName data_con,
- getName (dataConId data_con), map getName sc_sels)
+ getName (dataConWorkId data_con), map getName sc_sels)
toClassOpSig (sel_id, def_meth)
= ASSERT(sel_tyvars == clas_tyvars)
ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs)
ifaceConDecl data_con
- = ConDecl (getName data_con) (getName (dataConId data_con))
+ = ConDecl (getName data_con) (getName (dataConWorkId data_con))
(toHsTyVars ex_tyvars)
(toHsContext ex_theta)
details noSrcLoc
import PrimOp ( PrimOp(..), primOpOcc )
import TysWiredIn ( trueDataConId, falseDataConId )
import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon )
-import DataCon ( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
+import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG )
import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
import Type ( tyConAppTyCon, eqType )
import OccName ( occNameUserString)
[] -> Nothing -- Abstract type
(dc:rest) -> ASSERT( null rest )
- Just (Var (dataConId dc))
+ Just (Var (dataConWorkId dc))
where
correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
tag = fromInteger i
nameModule, mkWiredInName )
import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 )
import RdrName ( rdrNameOcc )
-import DataCon ( DataCon, mkDataCon, dataConId, dataConSourceArity )
+import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity )
import Var ( TyVar, tyVarKind )
import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons,
mkTupleTyCon, mkAlgTyCon, tyConName
gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon
unitTyCon = tupleTyCon Boxed 0
-unitDataConId = dataConId (head (tyConDataCons unitTyCon))
+unitDataConId = dataConWorkId (head (tyConDataCons unitTyCon))
pairTyCon = tupleTyCon Boxed 2
falseDataCon = pcDataCon falseDataConName [] [] [] boolTyCon
trueDataCon = pcDataCon trueDataConName [] [] [] boolTyCon
-falseDataConId = dataConId falseDataCon
-trueDataConId = dataConId trueDataCon
+falseDataConId = dataConWorkId falseDataCon
+trueDataConId = dataConWorkId trueDataCon
\end{code}
%************************************************************************
import Class ( FunDep, DefMeth (..) )
import TyCon ( DataConDetails(..), visibleDataCons )
-import DataCon ( dataConId )
+import DataCon ( dataConWorkId )
import Name ( Name, NamedThing(..) )
import NameSet
import PrelNames ( deRefStablePtrName, newStablePtrName,
= mapRn rnCoreExpr args `thenRn` \ args' ->
returnRn (UfTuple (HsTupCon tup_name boxity arity) args')
where
- tup_name = getName (dataConId (tupleCon boxity arity))
+ tup_name = getName (dataConWorkId (tupleCon boxity arity))
-- Get the *worker* name and use that
rnCoreExpr (UfApp fun arg)
import TcType ( isDictTy )
import OccName ( EncodedFS )
import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon )
-import DataCon ( dataConRepArity, dataConSig, dataConArgTys )
+import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys )
import Var ( mkSysTyVar, tyVarKind )
import Util ( lengthExceeds, mapAccumL )
import Outputable
= getUniquesSmpl `thenSmpl` \ tv_uniqs ->
getUniquesSmpl `thenSmpl` \ id_uniqs ->
let
- (_,_,ex_tyvars,_,_,_) = dataConSig missing_con
+ ex_tyvars = dataConExistentialTyVars missing_con
ex_tyvars' = zipWith mk tv_uniqs ex_tyvars
mk uniq tv = mkSysTyVar uniq (tyVarKind tv)
arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars')
newDictsFromOld, newDicts, cloneDict,
newMethod, newMethodWithGivenTy, newMethodAtLoc,
- newOverloadedLit, newIPDict, tcInstCall,
+ newOverloadedLit, newIPDict, tcInstCall, tcInstDataCon,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
ipNamesOfInst, ipNamesOfInsts, predsOfInst, predsOfInsts,
import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupId )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zapToType,
- zonkTcThetaType, tcInstTyVar, tcInstType,
+ zonkTcThetaType, tcInstTyVar, tcInstType, tcInstTyVars
)
import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
SourceType(..), PredType, ThetaType, TyVarDetails(VanillaTv),
- tcSplitForAllTys, tcSplitForAllTys,
+ tcSplitForAllTys, tcSplitForAllTys, mkTyConApp,
tcSplitMethodTy, tcSplitPhiTy, tcFunArgTy,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
)
import CoreFVs ( idFreeTyVars )
import Class ( Class )
+import DataCon ( dataConSig )
import Id ( Id, idName, idType, mkUserLocal, mkSysLocal, mkLocalId, setIdUnique )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( Name, mkMethodOcc, getOccName )
in
returnNF_Tc (inst_fn, mkLIE dicts, tau)
+tcInstDataCon orig data_con
+ = let
+ (tvs, stupid_theta, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
+ -- We generate constraints for the stupid theta even when
+ -- pattern matching (as the Report requires)
+ in
+ tcInstTyVars VanillaTv (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
+ let
+ stupid_theta' = substTheta tenv stupid_theta
+ ex_theta' = substTheta tenv ex_theta
+ arg_tys' = map (substTy tenv) arg_tys
+
+ n_ex_tvs = length ex_tvs
+ ex_tvs' = take n_ex_tvs all_tvs'
+ result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
+ in
+ newDicts orig stupid_theta' `thenNF_Tc` \ stupid_dicts ->
+ newDicts orig ex_theta' `thenNF_Tc` \ ex_dicts ->
+
+ -- Note that we return the stupid theta *only* in the LIE;
+ -- we don't otherwise use it at all
+ returnNF_Tc (ty_args', map instToId ex_dicts, arg_tys', result_ty,
+ mkLIE stupid_dicts, mkLIE ex_dicts, ex_tvs')
+
+
newMethod :: InstOrigin
-> TcId
-> [TcType]
import TcMonoType ( TcSigInfo(..), tcHsType, tcHsTheta, mkTcSig )
import TcSimplify ( tcSimplifyCheck )
import TcUnify ( checkSigTyVars, sigCtxt )
-import TcMType ( tcInstTyVars, checkValidTheta, checkValidType, SourceTyCtxt(..), UserTypeCtxt(..) )
+import TcMType ( tcInstTyVars )
import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
mkTyVarTys, mkPredTys, mkClassPred,
- tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitSigmaTy
+ tcIsTyVarTy, tcSplitTyConApp_maybe
)
import TcMonad
import Generics ( mkGenericRhs )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
-import Class ( classTyVars, classBigSig, classTyCon, className,
+import Class ( classTyVars, classBigSig, classTyCon,
Class, ClassOpItem, DefMeth (..) )
+import TyCon ( tyConGenInfo )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon )
import Id ( Id, idType, idName, setIdLocalExported )
import Var ( TyVar )
import CmdLineOpts
import ErrUtils ( dumpIfSet )
-import Util ( count, isSingleton, lengthIs, equalLength )
-import Maybes ( seqMaybe, maybeToBool )
+import Util ( count, lengthIs, equalLength )
+import Maybes ( seqMaybe )
+import Maybe ( isJust )
\end{code}
returnTc (unitNameEnv op all_generic)
where
- n_generic = count (maybeToBool . maybeGenericMatch) matches
+ n_generic = count (isJust . maybeGenericMatch) matches
none_generic = n_generic == 0
all_generic = matches `lengthIs` n_generic
\end{code}
-- instance declaration is for a single-parameter type class with
-- a type constructor applied to type arguments in the instance decl
-- (checkTc, so False provokes the error)
- checkTc (not (isInstDecl origin) || simple_inst)
- (badGenericInstance sel_id) `thenTc_`
+ ASSERT( isInstDecl origin ) -- We never get here from a class decl
+
+ checkTc (isJust maybe_tycon)
+ (badGenericInstance sel_id (notSimple inst_tys)) `thenTc_`
+ checkTc (isJust (tyConGenInfo tycon))
+ (badGenericInstance sel_id (notGeneric tycon)) `thenTc_`
ioToTc (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff) `thenNF_Tc_`
returnTc rhs
-- case we require that the instance decl is for a single-parameter
-- type class with type variable arguments:
-- instance (...) => C (T a b)
- simple_inst = maybeToBool maybe_tycon
clas_tyvar = head (classTyVars clas)
Just tycon = maybe_tycon
maybe_tycon = case inst_tys of
omittedMethodWarn sel_id
= ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
-badGenericInstance sel_id
+badGenericInstance sel_id because
= sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
- ptext SLIT("because the instance declaration is not for a simple type (T a b c)"),
- ptext SLIT("(where T is a derivable type constructor)")]
+ because]
+
+notSimple inst_tys
+ = vcat [ptext SLIT("because the instance type(s)"),
+ nest 2 (ppr inst_tys),
+ ptext SLIT("is not a simple type of form (T a b c)")]
+
+notGeneric tycon
+ = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
+ ptext SLIT("was not compiled with -fgenerics")]
mixedGenericErr op
= ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
Read, Enum?
+FURTHER NOTE ADDED March 2002. In fact, Haskell98 now requires that
+pattern matching against a constructor from a data type with a context
+gives rise to the constraints for that context -- or at least the thinned
+version. So now all classes are "offending".
+
+
%************************************************************************
%* *
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
-
-- "extra_constraints": see notes above about contexts on data decls
- extra_constraints | offensive_class = tyConTheta tycon
- | otherwise = []
-
- offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
+ extra_constraints = tyConTheta tycon
+
+ -- | offensive_class = tyConTheta tycon
+ -- | otherwise = []
+ -- offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys
mk_eqn_help NewType tycon clas tys
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsMatchContext(..), HsDoContext(..), mkMonoBind
+ HsMatchContext(..), HsDoContext(..),
+ mkMonoBind
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
-import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy )
+import TcHsSyn ( TcExpr, TcRecordBinds, simpleHsLitTy, mkHsDictApp, mkHsTyApp )
import TcMonad
import TcUnify ( tcSubExp, tcGen, (<$>),
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
newOverloadedLit, newMethod, newIPDict,
newDicts, newMethodWithGivenTy,
- instToId, tcInstCall
+ instToId, tcInstCall, tcInstDataCon
)
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
newTyVarTy, newTyVarTys, zonkTcType, readHoleResult )
import TcType ( TcType, TcSigmaType, TcRhoType, TyVarDetails(VanillaTv),
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
- isSigmaTy, mkFunTy, mkAppTy, mkTyConTy,
+ isSigmaTy, mkFunTy, mkAppTy, mkTyConTy, mkFunTys,
mkTyConApp, mkClassPred, tcFunArgTy,
tyVarsOfTypes, isLinearPred,
liftedTypeKind, openTypeKind, mkArrowKind,
tidyOpenType
)
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon )
-import Id ( idType, recordSelectorFieldLabel, isRecordSelector )
+import Id ( idType, recordSelectorFieldLabel, isRecordSelector, isDataConWrapId_maybe )
import DataCon ( dataConFieldLabels, dataConSig,
dataConStrictMarks
)
import Name ( Name )
-import TyCon ( TyCon, tyConTyVars, isAlgTyCon, tyConDataCons )
+import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons )
import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
import TysWiredIn ( boolTy, mkListTy, mkPArrTy, listTyCon, parrTyCon )
-- Figure out the tycon and data cons from the first field name
let
-- It's OK to use the non-tc splitters here (for a selector)
- (Just (AnId sel_id) : _) = maybe_sel_ids
- (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded
- -- when the data type has a context
- data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector
- tycon = tcTyConAppTyCon data_ty
- data_cons = tyConDataCons tycon
- (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
+ (Just (AnId sel_id) : _) = maybe_sel_ids
+
+ (_, _, tau) = tcSplitSigmaTy (idType sel_id) -- Selectors can be overloaded
+ -- when the data type has a context
+ data_ty = tcFunArgTy tau -- Must succeed since sel_id is a selector
+ tycon = tcTyConAppTyCon data_ty
+ data_cons = tyConDataCons tycon
+ tycon_tyvars = tyConTyVars tycon -- The data cons use the same type vars
in
- tcInstTyVars VanillaTv con_tyvars `thenNF_Tc` \ (_, result_inst_tys, _) ->
+ tcInstTyVars VanillaTv tycon_tyvars `thenNF_Tc` \ (_, result_inst_tys, inst_env) ->
-- STEP 2
-- Check that at least one constructor has all the named fields
| tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty -- Same as result type
| otherwise = newTyVarTy liftedTypeKind -- Fresh type
in
- mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
+ mapNF_Tc mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenNF_Tc` \ inst_tys ->
-- STEP 5
-- Typecheck the expression to be updated
let
record_ty = mkTyConApp tycon inst_tys
in
- tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
+ tcMonoExpr record_expr record_ty `thenTc` \ (record_expr', record_lie) ->
-- STEP 6
-- Figure out the LIE we need. We have to generate some
-- dictionaries for the data type context, since we are going to
- -- do some construction.
+ -- do pattern matching over the data cons.
--
- -- What dictionaries do we need? For the moment we assume that all
- -- data constructors have the same context, and grab it from the first
- -- constructor. If they have varying contexts then we'd have to
- -- union the ones that could participate in the update.
+ -- What dictionaries do we need?
+ -- We just take the context of the type constructor
let
- (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
- inst_env = mkTopTyVarSubst tyvars result_inst_tys
- theta' = substTheta inst_env theta
+ theta' = substTheta inst_env (tyConTheta tycon)
in
newDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts ->
-- Phew!
- returnTc (RecordUpdOut record_expr' record_ty result_record_ty (map instToId dicts) rbinds',
+ returnTc (RecordUpdOut record_expr' record_ty result_record_ty rbinds',
mkLIE dicts `plusLIE` record_lie `plusLIE` rbinds_lie)
tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
tcId :: Name -> NF_TcM (TcExpr, LIE, TcType)
tcId name -- Look up the Id and instantiate its type
= tcLookupId name `thenNF_Tc` \ id ->
- loop (OccurrenceOf id) (HsVar id) emptyLIE (idType id)
+ case isDataConWrapId_maybe id of
+ Nothing -> loop (HsVar id) emptyLIE (idType id)
+ Just data_con -> inst_data_con id data_con
where
- loop orig (HsVar fun_id) lie fun_ty
+ orig = OccurrenceOf name
+
+ loop (HsVar fun_id) lie fun_ty
| want_method_inst fun_ty
= tcInstType VanillaTv fun_ty `thenNF_Tc` \ (tyvars, theta, tau) ->
newMethodWithGivenTy orig fun_id
(mkTyVarTys tyvars) theta tau `thenNF_Tc` \ meth ->
- loop orig (HsVar (instToId meth))
+ loop (HsVar (instToId meth))
(unitLIE meth `plusLIE` lie) tau
- loop orig fun lie fun_ty
+ loop fun lie fun_ty
| isSigmaTy fun_ty
= tcInstCall orig fun_ty `thenNF_Tc` \ (inst_fn, inst_lie, tau) ->
- loop orig (inst_fn fun) (inst_lie `plusLIE` lie) tau
+ loop (inst_fn fun) (inst_lie `plusLIE` lie) tau
| otherwise
= returnNF_Tc (fun, lie, fun_ty)
-- because that loses the linearity of the constraint.
-- The simplest thing to do is never to construct a method constraint
-- in the first place that has a linear implicit parameter in it.
+
+ -- We treat data constructors differently, because we have to generate
+ -- constraints for their silly theta, which no longer appears in
+ -- the type of dataConWrapId. It's dual to TcPat.tcConstructor
+ inst_data_con id data_con
+ = tcInstDataCon orig data_con `thenNF_Tc` \ (ty_args, ex_dicts, arg_tys, result_ty, stupid_lie, ex_lie, _) ->
+ returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar id) ty_args) ex_dicts,
+ stupid_lie `plusLIE` ex_lie,
+ mkFunTys arg_tys result_ty)
\end{code}
Typecheck expression which in most cases will be an Id.
zonkExpr (RecordUpd _ _) = panic "zonkExpr:RecordUpd"
-zonkExpr (RecordUpdOut expr in_ty out_ty dicts rbinds)
+zonkExpr (RecordUpdOut expr in_ty out_ty rbinds)
= zonkExpr expr `thenNF_Tc` \ new_expr ->
zonkTcTypeToType in_ty `thenNF_Tc` \ new_in_ty ->
zonkTcTypeToType out_ty `thenNF_Tc` \ new_out_ty ->
- mapNF_Tc zonkIdOcc dicts `thenNF_Tc` \ new_dicts ->
zonkRbinds rbinds `thenNF_Tc` \ new_rbinds ->
- returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_dicts new_rbinds)
+ returnNF_Tc (RecordUpdOut new_expr new_in_ty new_out_ty new_rbinds)
zonkExpr (ExprWithTySig _ _) = panic "zonkExpr:ExprWithTySig"
zonkExpr (ArithSeqIn _) = panic "zonkExpr:ArithSeqIn"
in
returnTc (mkApps (Var con_id) con_args)
where
- con_id = dataConId (tupleCon boxity arity)
+ con_id = dataConWorkId (tupleCon boxity arity)
tcCoreExpr (UfLam bndr body)
tcCoreAlt scrut_ty alt@(con, names, rhs)
= tcConAlt con `thenTc` \ con ->
let
- (main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
-
- (tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp
+ ex_tyvars = dataConExistentialTyVars con
+ (tycon, inst_tys) = splitTyConApp scrut_ty -- NB: not tcSplitTyConApp
-- We are looking at Core here
- ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
- ex_tys' = mkTyVarTys ex_tyvars'
- arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
- id_names = dropList ex_tyvars names
+ main_tyvars = tyConTyVars tycon
+ ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
+ ex_tys' = mkTyVarTys ex_tyvars'
+ arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
+ id_names = dropList ex_tyvars names
arg_ids
#ifdef DEBUG
| not (equalLength id_names arg_tys)
foldBag, unitBag, unionBags, snocBag )
import Class ( Class )
import Name ( Name )
-import Var ( Id, TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
+import Var ( TyVar, newMutTyVar, readMutTyVar, writeMutTyVar )
import VarEnv ( TidyEnv, emptyTidyEnv )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
splitUniqSupply, mkSplitUniqSupply,
type InstLoc = (InstOrigin, SrcLoc, ErrCtxt)
data InstOrigin
- = OccurrenceOf Id -- Occurrence of an overloaded identifier
+ = OccurrenceOf Name -- Occurrence of an overloaded identifier
| IPOcc (IPName Name) -- Occurrence of an implicit parameter
| IPBind (IPName Name) -- Binding site of an implicit parameter
pprInstLoc (orig, locn, ctxt)
= hsep [text "arising from", pp_orig orig, text "at", ppr locn]
where
- pp_orig (OccurrenceOf id)
- = hsep [ptext SLIT("use of"), quotes (ppr id)]
+ pp_orig (OccurrenceOf name)
+ = hsep [ptext SLIT("use of"), quotes (ppr name)]
pp_orig (IPOcc name)
= hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
pp_orig (IPBind name)
import TcMonad
import Inst ( InstOrigin(..),
emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId, isEmptyLIE,
- newMethod, newOverloadedLit, newDicts
+ newMethod, newOverloadedLit, newDicts, tcInstDataCon
)
import Id ( mkLocalId, mkSysLocal )
import Name ( Name )
import FieldLabel ( fieldLabelName )
import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
-import TcMType ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar, zapToType )
-import TcType ( TcType, TcTyVar, TcSigmaType, TyVarDetails(VanillaTv),
- mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe,
- isHoleTyVar, openTypeKind )
+import TcMType ( newTyVarTy, zapToType )
+import TcType ( TcType, TcTyVar, TcSigmaType,
+ mkClassPred, liftedTypeKind )
import TcUnify ( tcSubOff, TcHoleType,
unifyTauTy, unifyListTy, unifyPArrTy, unifyTupleTy,
mkCoercion, idCoercion, isIdCoercion,
import TysWiredIn ( stringTy )
import CmdLineOpts ( opt_IrrefutableTuples )
-import DataCon ( dataConSig, dataConFieldLabels,
- dataConSourceArity
- )
-import Subst ( substTy, substTheta )
+import DataCon ( dataConFieldLabels, dataConSourceArity )
import PrelNames ( eqStringName, eqName, geName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
- tcConstructor pat name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+ tcConstructor pat name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) ->
-- Check overall type matches (c.f. tcConPat)
- tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req1) ->
+ tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req2) ->
let
-- Don't use zipEqual! If the constructor isn't really a record, then
-- dataConFieldLabels will be empty (and each field in the pattern
in
-- Check the fields
- tc_fields field_tys rpats `thenTc` \ (rpats', lie_req2, tvs, ids, lie_avail2) ->
+ tc_fields field_tys rpats `thenTc` \ (rpats', lie_req3, tvs, ids, lie_avail2) ->
- returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
- lie_req1 `plusLIE` lie_req2,
+ returnTc (RecPat data_con pat_ty ex_tvs ex_dicts rpats',
+ lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
listToBag ex_tvs `unionBags` tvs,
ids,
lie_avail1 `plusLIE` lie_avail2)
tcLookupDataCon con_name `thenNF_Tc` \ data_con ->
-- Instantiate it
- let
- (tvs, _, ex_tvs, ex_theta, arg_tys, tycon) = dataConSig data_con
- -- Ignore the theta; overloaded constructors only
- -- behave differently when called, not when used for
- -- matching.
- in
- tcInstTyVars VanillaTv (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
- let
- ex_theta' = substTheta tenv ex_theta
- arg_tys' = map (substTy tenv) arg_tys
-
- n_ex_tvs = length ex_tvs
- ex_tvs' = take n_ex_tvs all_tvs'
- result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
- in
- newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts ->
+ tcInstDataCon (PatOrigin pat) data_con `thenNF_Tc` \ (_, ex_dicts, arg_tys, result_ty, lie_req, ex_lie, ex_tvs) ->
- returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys', result_ty)
+ returnTc (data_con, lie_req, ex_tvs, ex_dicts, ex_lie, arg_tys, result_ty)
\end{code}
------------------------------------------------------
= tcAddErrCtxt (patCtxt pat) $
-- Check the constructor itself
- tcConstructor pat con_name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+ tcConstructor pat con_name `thenTc` \ (data_con, lie_req1, ex_tvs, ex_dicts, lie_avail1, arg_tys, con_res_ty) ->
-- Check overall type matches.
-- The pat_ty might be a for-all type, in which
-- case we must instantiate to match
- tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req1) ->
+ tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req2) ->
-- Check correct arity
let
(arityErr "Constructor" data_con con_arity no_of_args) `thenTc_`
-- Check arguments
- tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req2, tvs, ids, lie_avail2) ->
+ tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req3, tvs, ids, lie_avail2) ->
- returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs dicts arg_pats',
- lie_req1 `plusLIE` lie_req2,
+ returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs ex_dicts arg_pats',
+ lie_req1 `plusLIE` lie_req2 `plusLIE` lie_req3,
listToBag ex_tvs `unionBags` tvs,
ids,
lie_avail1 `plusLIE` lie_avail2)
tcLookupTyCon, tcLookupRecId,
TyThingDetails(..), RecTcEnv
)
-import TcType ( tcEqType, tyVarsOfTypes, tyVarsOfPred, ThetaType )
+import TcType ( tyVarsOfTypes, tyVarsOfPred, ThetaType )
import TcMonad
import DataCon ( DataCon, mkDataCon, dataConFieldLabels )
import Name ( Name, NamedThing(..) )
import Outputable
import TyCon ( TyCon, DataConDetails(..), visibleDataCons,
- tyConName, tyConTheta,
- tyConTyVars, isSynTyCon )
+ tyConTyVars )
import VarSet ( intersectVarSet, isEmptyVarSet )
import PrelNames ( unpackCStringName, unpackCStringUtf8Name )
import List ( nubBy )
funTyCon
)
import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy )
-import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, dataConId, isExistentialDataCon )
+import DataCon ( DataCon, dataConOrigArgTys, dataConWrapId, isExistentialDataCon )
import TyCon ( TyCon, tyConTyVars, tyConDataCons_maybe,
tyConGenInfo, isNewTyCon, newTyConRep, isBoxedTupleTyCon
import BasicTypes ( EP(..), Boxity(..) )
import Var ( TyVar )
import VarSet ( varSetElems )
-import Id ( Id, mkVanillaGlobal, idType, idName,
- mkTemplateLocal, mkTemplateLocalsNum
- )
+import Id ( Id, mkVanillaGlobal, idType, idName, mkSysLocal )
+import MkId ( mkReboxingAlt, mkNewTypeBody )
import TysWiredIn ( genericTyCons,
genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
inlDataCon, crossTyCon, crossDataCon
import Maybe ( isNothing )
import SrcLoc ( builtinSrcLoc )
-import Unique ( mkBuiltinUnique )
-import Util ( takeList )
+import Unique ( Unique, builtinUniques, mkBuiltinUnique )
+import Util ( takeList, dropList )
import Outputable
#include "HsVersions.h"
-- The two names are the names constructed by the renamer
-- for the fromT and toT conversion functions.
+mkTyConGenInfo tycon []
+ = Nothing -- This happens when we deal with the interface-file type
+ -- decl for a module compiled without -fgenerics
+
mkTyConGenInfo tycon [from_name, to_name]
| isNothing maybe_datacons -- Abstractly imported types don't have
= Nothing -- to/from operations, (and should not need them)
(from_fn, to_fn, rep_ty)
| isNewTyCon tycon
- = ( mkLams tyvars $ Lam x $ Var x,
+ = ( mkLams tyvars $ Lam x $ mkNewTypeBody tycon newrep_ty (Var x),
Var (dataConWrapId the_datacon),
newrep_ty )
idType rep_var )
-- x :: T a b c
- x = mkTemplateLocal 1 tycon_ty
+ x = mkGenericLocal u1 tycon_ty
+ (u1 : uniqs) = builtinUniques
----------------------
-- Newtypes only
-- Non-newtypes only
-- Recurse over the sum first
-- The "2" is the first free unique
- (from_alts, to_inner, rep_var) = mk_sum_stuff 2 tyvars datacons
+ (from_alts, to_inner, rep_var) = mk_sum_stuff uniqs tyvars datacons
+mkTyConGenInfo tycon names = pprPanic "mkTyConGenInfo" (ppr tycon <+> ppr names)
----------------------------------------------------
-- Dealing with sums
----------------------------------------------------
-mk_sum_stuff :: Int -- Base for generating unique names
+mk_sum_stuff :: [Unique] -- Base for generating unique names
-> [TyVar] -- Type variables over which the tycon is abstracted
-> [DataCon] -- The data constructors
-> ([Alt Id], CoreExpr, Id)
-- D a b c }} },
-- cd)
-mk_sum_stuff i tyvars [datacon]
+mk_sum_stuff us tyvars [datacon]
= ([from_alt], to_body_fn app_exp, rep_var)
where
- types = dataConOrigArgTys datacon
- datacon_vars = mkTemplateLocalsNum i types
- new_i = i + length types
- app_exp = mkVarApps (Var (dataConId datacon)) (tyvars ++ datacon_vars)
- from_alt = (DataAlt datacon, datacon_vars, from_alt_rhs)
+ types = dataConOrigArgTys datacon -- Existentials already excluded
+ datacon_vars = zipWith mkGenericLocal us types
+ us' = dropList types us
+
+ app_exp = mkVarApps (Var (dataConWrapId datacon)) (tyvars ++ datacon_vars)
+ from_alt = mkReboxingAlt us' datacon datacon_vars from_alt_rhs
+ -- We are talking about *user* datacons here; hence
+ -- dataConWrapId
+ -- mkReboxingAlt
+
+ (_,args',_) = from_alt
+ us'' = dropList args' us' -- Conservative, but safe
- (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff new_i datacon_vars
+ (_, from_alt_rhs, to_body_fn, rep_var) = mk_prod_stuff us'' datacon_vars
-mk_sum_stuff i tyvars datacons
+mk_sum_stuff (u:us) tyvars datacons
= (wrap inlDataCon l_from_alts ++ wrap inrDataCon r_from_alts,
Case (Var rep_var) rep_var [(DataAlt inlDataCon, [l_rep_var], l_to_body),
(DataAlt inrDataCon, [r_rep_var], r_to_body)],
rep_var)
where
(l_datacons, r_datacons) = splitInHalf datacons
- (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff (i+2) tyvars l_datacons
- (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff (i+2) tyvars r_datacons
+ (l_from_alts, l_to_body, l_rep_var) = mk_sum_stuff us tyvars l_datacons
+ (r_from_alts, r_to_body, r_rep_var) = mk_sum_stuff us tyvars r_datacons
rep_tys = [idType l_rep_var, idType r_rep_var]
rep_ty = mkTyConApp plusTyCon rep_tys
- rep_var = mkTemplateLocal i rep_ty
+ rep_var = mkGenericLocal u rep_ty
wrap :: DataCon -> [Alt Id] -> [Alt Id]
-- Wrap an application of the Inl or Inr constructor round each alternative
----------------------------------------------------
-- Dealing with products
----------------------------------------------------
-mk_prod_stuff :: Int -- Base for unique names
+mk_prod_stuff :: [Unique] -- Base for unique names
-> [Id] -- arg-ids; args of the original user-defined constructor
-- They are bound enclosing from_rhs
-- Please bind these in the to_body_fn
- -> (Int, -- Depleted unique-name supply
+ -> ([Unique], -- Depleted unique-name supply
CoreExpr, -- from-rhs: puts together the representation from the arg_ids
CoreExpr -> CoreExpr, -- to_body_fn: takes apart the representation
Id) -- The rep-id; please bind this to the representation
-- because the returned to_body_fns are nested.
-- Hence the returned unqique-name supply
-mk_prod_stuff i [] -- Unit case
- = (i,
+mk_prod_stuff (u:us) [] -- Unit case
+ = (us,
Var (dataConWrapId genUnitDataCon),
\x -> x,
- mkTemplateLocal i (mkTyConApp genUnitTyCon []))
+ mkGenericLocal u (mkTyConApp genUnitTyCon []))
-mk_prod_stuff i [arg_var] -- Singleton case
- = (i, Var arg_var, \x -> x, arg_var)
+mk_prod_stuff us [arg_var] -- Singleton case
+ = (us, Var arg_var, \x -> x, arg_var)
-mk_prod_stuff i arg_vars -- Two or more
- = (r_i,
+mk_prod_stuff (u:us) arg_vars -- Two or more
+ = (us'',
mkConApp crossDataCon (map Type rep_tys ++ [l_alt_rhs, r_alt_rhs]),
\x -> Case (Var rep_var) rep_var
[(DataAlt crossDataCon, [l_rep_var, r_rep_var], l_to_body_fn (r_to_body_fn x))],
rep_var)
where
(l_arg_vars, r_arg_vars) = splitInHalf arg_vars
- (l_i, l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff (i+1) l_arg_vars
- (r_i, r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff l_i r_arg_vars
- rep_var = mkTemplateLocal i (mkTyConApp crossTyCon rep_tys)
+ (us', l_alt_rhs, l_to_body_fn, l_rep_var) = mk_prod_stuff us l_arg_vars
+ (us'', r_alt_rhs, r_to_body_fn, r_rep_var) = mk_prod_stuff us' r_arg_vars
+ rep_var = mkGenericLocal u (mkTyConApp crossTyCon rep_tys)
rep_tys = [idType l_rep_var, idType r_rep_var]
\end{code}
half = length list `div` 2
left = take half list
right = drop half list
+
+mkGenericLocal :: Unique -> Type -> Id
+mkGenericLocal uniq ty = mkSysLocal FSLIT("g") uniq ty
\end{code}
%************************************************************************
projects / ghc-hetmet.git / commitdiff