Commit 9003a18c authored by simonpj's avatar simonpj
Browse files

[project @ 2002-04-01 08:23:30 by simonpj]

------------------------------------
	Change the treatment of the stupid
	   context on data constructors
	-----------------------------------

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 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.

To this end

* Lots of changes in DataCon, MkId

* New function Inst.tcInstDataCon to instantiate a data constructor



I also took the opportunity to

* Rename
	dataConId --> dataConWorkId
  for consistency.

* Tidied up MkId.rebuildConArgs quite a bit, and renamed it
	mkReboxingAlt

* Add function DataCon.dataConExistentialTyVars, with the obvious meaning
parent 7f9f2f0a
......@@ -10,12 +10,12 @@ module DataCon (
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
......@@ -63,6 +63,41 @@ Every constructor, C, comes with a
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.
%************************************************************************
%* *
......@@ -83,9 +118,13 @@ data DataCon
-- 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.
......@@ -97,11 +136,23 @@ data DataCon
-- 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
......@@ -136,7 +187,7 @@ data DataCon
--
-- 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
......@@ -199,7 +250,7 @@ instance Show DataCon where
%************************************************************************
%* *
\subsection{Consruction}
\subsection{Construction}
%* *
%************************************************************************
......@@ -223,13 +274,13 @@ mkDataCon name arg_stricts fields
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*,
......@@ -244,7 +295,7 @@ mkDataCon name arg_stricts fields
(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
......@@ -267,8 +318,8 @@ dataConTyCon = dcTyCon
dataConRepType :: DataCon -> Type
dataConRepType = dcRepType
dataConId :: DataCon -> Id
dataConId = dcId
dataConWorkId :: DataCon -> Id
dataConWorkId = dcWorkId
dataConWrapId :: DataCon -> Id
dataConWrapId = dcWrapId
......@@ -305,7 +356,7 @@ dataConSig :: DataCon -> ([TyVar], ThetaType,
[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)
......@@ -320,17 +371,20 @@ dataConArgTys :: DataCon
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,
......
......@@ -14,12 +14,14 @@ have a standard form, namely:
\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,
......@@ -52,7 +54,7 @@ import Literal ( Literal(..), nullAddrLit )
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 )
......@@ -61,9 +63,9 @@ import ForeignCall ( ForeignCall )
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,
......@@ -92,6 +94,7 @@ import Util ( dropList, isSingleton )
import Outputable
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
import List ( nubBy )
import Char ( ord )
\end{code}
......@@ -234,7 +237,7 @@ Notice that
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
......@@ -244,11 +247,9 @@ mkDataConWrapId data_con
-- 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
......@@ -265,10 +266,10 @@ mkDataConWrapId data_con
-- 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
......@@ -289,7 +290,7 @@ mkDataConWrapId data_con
| 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 []
......@@ -297,20 +298,23 @@ mkDataConWrapId data_con
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
......@@ -401,13 +405,22 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
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
......@@ -427,12 +440,6 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
-- 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 $
......@@ -489,18 +496,17 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
-- 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
......@@ -520,46 +526,63 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
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}
......
......@@ -42,7 +42,7 @@ module Unique (
mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique,
mkBuiltinUnique,
mkBuiltinUnique, builtinUniques,
mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
) where
......@@ -339,6 +339,9 @@ initTidyUniques = (mkUnique 'g' 0, mkUnique 'x' 0)
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
......
......@@ -45,7 +45,7 @@ import ClosureInfo ( mkConLFInfo, mkLFArgument, closureLFInfo,
import CostCentre ( currentOrSubsumedCCS, dontCareCCS, CostCentreStack,
currentCCS )
import DataCon ( DataCon, dataConName, dataConTag,
isUnboxedTupleCon, isNullaryDataCon, dataConId,
isUnboxedTupleCon, isNullaryDataCon, dataConWorkId,
dataConWrapId, dataConRepArity
)
import Id ( Id, idName, idPrimRep )
......@@ -379,7 +379,7 @@ cgReturnDataCon con amodes
-- 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 ->
......
......@@ -27,7 +27,6 @@ import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
isDataConId_maybe, idUnfolding
)
import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts )
import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
......@@ -160,8 +159,6 @@ mkImplicitBinds type_env
-- 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
......
......@@ -54,7 +54,7 @@ import CostCentre ( CostCentre, noCostCentre )
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
......@@ -376,7 +376,7 @@ mkLets :: [Bind b] -> Expr b -> Expr b
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
......
......@@ -72,10 +72,10 @@ collect_tdefs _ tdefs = tdefs
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))
......@@ -113,7 +113,7 @@ make_exp _ = error "MkExternalCore died: make_exp"
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)
......
......@@ -451,10 +451,10 @@ might do some argument-evaluation first; and may have to throw away some
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' ->
......@@ -477,9 +477,7 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty dicts rbinds)
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)]
......
......@@ -40,12 +40,11 @@ import DsMonad
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 )
......@@ -279,16 +278,11 @@ mkCoAlgCaseMatchResult var match_alts
-- 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]
......@@ -300,12 +294,9 @@ mkCoAlgCaseMatchResult var match_alts
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)]
......@@ -606,10 +597,10 @@ interact well with rules.
\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]