-%
+\%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1998
%
* primitive operations
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module MkId (
mkDictFunId, mkDefaultMethodId,
mkDictSelId,
mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
+ wrapFamInstBody, unwrapFamInstScrut,
mkUnpackCase, mkProductBox,
-- And some particular Ids; see below for why they are wired in
import TysWiredIn
import PrelRules
import Type
+import TypeRep
import TcGadt
import Coercion
import TcType
import ForeignCall
import DataCon
import Id
-import Var ( Var, TyVar)
+import Var ( Var, TyVar, mkCoVar)
import IdInfo
import NewDemand
import DmdAnal
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
- theta, orig_arg_tys, res_ty) = dataConFullSig data_con
+ eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
tycon = dataConTyCon data_con -- The representation TyCon (not family)
----------- Worker (algebraic data types only) --------------
nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setUnfoldingInfo` newtype_unf
- newtype_unf = ASSERT( isVanillaDataCon data_con &&
- isSingleton orig_arg_tys )
+ newtype_unf = -- The assertion below is no longer correct:
+ -- there may be a dict theta rather than a singleton orig_arg_ty
+ -- ASSERT( isVanillaDataCon data_con &&
+ -- isSingleton orig_arg_tys )
+ --
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkCompulsoryUnfolding $
wrapNewTypeBody tycon res_ty_args
(Var id_arg1)
- id_arg1 = ASSERT( not (null orig_arg_tys) ) mkTemplateLocal 1 (head orig_arg_tys)
+ id_arg1 = mkTemplateLocal 1
+ (if null orig_arg_tys
+ then ASSERT(not (null $ dataConDictTheta data_con)) mkPredTy $ head (dataConDictTheta data_con)
+ else head orig_arg_tys
+ )
----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
- dict_tys = mkPredTys theta
- wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
+ eq_tys = mkPredTys eq_theta
+ dict_tys = mkPredTys dict_theta
+ wrap_ty = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $
mkFunTys orig_arg_tys $ res_ty
-- NB: watch out here if you allow user-written equality
-- constraints in data constructor signatures
wrap_unf = mkTopUnfolding $ Note InlineMe $
mkLams wrap_tvs $
+ mkLams eq_args $
mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
(zip (dict_args ++ id_args) all_strict_marks)
Var wrk_id `mkTyApps` res_ty_args
`mkVarApps` ex_tvs
`mkTyApps` map snd eq_spec -- Equality evidence
+ `mkVarApps` eq_args
`mkVarApps` reverse rep_ids
(dict_args,i2) = mkLocals 1 dict_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
wrap_arity = i3-1
+ (eq_args,_) = mkCoVarLocals i3 eq_tys
+
+ mkCoVarLocals i [] = ([],i)
+ mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
+ y = mkCoVar (mkSysTvName (mkBuiltinUnique i) FSLIT("dc_co")) x
+ in (y:ys,j)
mk_case
:: (Id, StrictnessMark) -- Arg, strictness
mkRecordSelId :: TyCon -> FieldLabel -> Id
mkRecordSelId tycon field_label
-- Assumes that all fields with the same field label have the same type
- | is_naughty = naughty_id
- | otherwise = sel_id
+ = sel_id
where
- is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
+ -- Because this function gets called by implicitTyThings, we need to
+ -- produce the OccName of the Id without doing any suspend type checks.
+ -- (see the note [Tricky iface loop]).
+ -- A suspended type-check is sometimes necessary to compute field_ty,
+ -- so we need to make sure that we suspend anything that depends on field_ty.
+
+ -- the overall result
+ sel_id = mkGlobalId sel_id_details field_label theType theInfo
+
+ -- check whether the type is naughty: this thunk does not get forced
+ -- until the type is actually needed
+ field_ty = dataConFieldType con1 field_label
+ is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tv_set)
+
+ -- it's important that this doesn't force the if
+ (theType, theInfo) = if is_naughty
+ -- Escapist case here for naughty constructors
+ -- We give it no IdInfo, and a type of forall a.a (never looked at)
+ then (forall_a_a, noCafIdInfo)
+ -- otherwise do the real case
+ else (selector_ty, info)
+
sel_id_details = RecordSelId { sel_tycon = tycon, sel_label = field_label, sel_naughty = is_naughty }
- -- For a data type family, the tycon is the *instance* TyCon
+ -- For a data type family, the tycon is the *instance* TyCon
- -- Escapist case here for naughty constructors
- -- We give it no IdInfo, and a type of forall a.a (never looked at)
- naughty_id = mkGlobalId sel_id_details field_label forall_a_a noCafIdInfo
+ -- for naughty case
forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
- -- Normal case starts here
- sel_id = mkGlobalId sel_id_details field_label selector_ty info
+ -- real case starts here:
data_cons = tyConDataCons tycon
data_cons_w_field = filter has_field data_cons -- Can't be empty!
has_field con = field_label `elem` dataConFieldLabels con
con1 = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field
- (univ_tvs, _, eq_spec, _, _, data_ty) = dataConFullSig con1
+ (univ_tvs, _, eq_spec, _, _, _, data_ty) = dataConFullSig con1
-- For a data type family, the data_ty (and hence selector_ty) mentions
-- only the family TyCon, not the instance TyCon
data_tv_set = tyVarsOfType data_ty
data_tvs = varSetElems data_tv_set
- field_ty = dataConFieldType con1 field_label
-- *Very* tiresomely, the selectors are (unnecessarily!) overloaded over
-- just the dictionaries in the types of the constructors that contain
-- C a -> C a
-- for a single-op class (after all, the selector is the identity)
-- But it's type must expose the representation of the dictionary
- -- to gat (say) C a -> (a -> a)
+ -- to get (say) C a -> (a -> a)
info = noCafIdInfo
`setArityInfo` 1
tycon = classTyCon clas
[data_con] = tyConDataCons tycon
tyvars = dataConUnivTyVars data_con
- arg_tys = ASSERT( isVanillaDataCon data_con ) dataConRepArgTys data_con
+ arg_tys = {- ASSERT( isVanillaDataCon data_con ) -} dataConRepArgTys data_con
+ eq_theta = dataConEqTheta data_con
the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
- pred = mkClassPred clas (mkTyVarTys tyvars)
- (dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
+ pred = mkClassPred clas (mkTyVarTys tyvars)
+ dict_id = mkTemplateLocal 1 $ mkPredTy pred
+ (eq_ids,n) = mkCoVarLocals 2 $ mkPredTys eq_theta
+ arg_ids = mkTemplateLocalsNum n arg_tys
+
+ mkCoVarLocals i [] = ([],i)
+ mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
+ y = mkCoVar (mkSysTvName (mkBuiltinUnique i) FSLIT("dc_co")) x
+ in (y:ys,j)
- rhs = mkLams tyvars (Lam dict_id rhs_body)
+ rhs = mkLams tyvars (Lam dict_id rhs_body)
rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
| otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
- [(DataAlt data_con, arg_ids, Var the_arg_id)]
+ [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
\end{code}