-%
+\%
% (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
import FastString
import ListSetOps
import Module
-\end{code}
+\end{code}
%************************************************************************
%* *
The wrapper and worker of MapPair get the types
+ -- Wrapper
$WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
- $WMapPair a b v = $wMapPair a b v `cast` sym (Co123Map a b v)
+ $WMapPair a b v = MapPair a b v `cast` sym (Co123Map a b v)
- $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
+ -- Worker
+ MapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
This coercion is conditionally applied by wrapFamInstBody.
Now we want
+ -- Wrapper
$WT1 :: forall b. b -> T [Maybe b]
- $WT1 a b v = $wT1 b (Maybe b) (Maybe b)
+ $WT1 b v = T1 (Maybe b) b (Maybe b) v
`cast` sym (Co7T (Maybe b))
- $wT1 :: forall b c. (b ~ Maybe c) => b -> :R7T c
+ -- Worker
+ T1 :: forall c b. (c ~ Maybe b) => b -> :R7T c
\begin{code}
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon -- Newtype, only has a worker
- , not (isFamInstTyCon tycon) -- unless it's a family instancex
= DCIds Nothing nt_work_id
| any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
= DCIds Nothing wrk_id
where
(univ_tvs, ex_tvs, eq_spec,
- theta, orig_arg_tys, res_ty) = dataConFullSig data_con
- res_ty_args = tyConAppArgs res_ty
- tycon = dataConTyCon data_con
-
- ----------- Wrapper --------------
- -- 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.
- wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
- dict_tys = mkPredTys theta
- wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
- mkFunTys orig_arg_tys $ res_ty
- -- NB: watch out here if you allow user-written equality
- -- constraints in data constructor signatures
+ 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) --------------
-- The *worker* for the data constructor is the function that
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 = 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
+ -- but now we don't. Instead the type checker just injects these
+ -- extra constraints where necessary.
+ wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
+ res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
+ 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
----------- Wrappers for algebraic data types --------------
alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
- `setArityInfo` alg_arity
+ `setArityInfo` wrap_arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
- `setUnfoldingInfo` alg_unf
+ `setUnfoldingInfo` wrap_unf
`setAllStrictnessInfo` Just wrap_sig
all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
-- ...(let w = C x in ...(w p q)...)...
-- we want to see that w is strict in its two arguments
- alg_unf = mkTopUnfolding $ Note InlineMe $
+ 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
- alg_arity = i3-1
+ 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)
- sel_id_details = RecordSelId tycon field_label is_naughty
+ -- 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)
- -- 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
+ 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 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 = head data_cons_w_field
- (univ_tvs, _, eq_spec, _, _, data_ty) = dataConFullSig con1
+ con1 = ASSERT( not (null data_cons_w_field) ) head data_cons_w_field
+ (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}
-- not from GHC.Base.hi. This is important, because the strictness
-- analyser will spot it as strict!
--
--- Also no unfolding in lazyId: it gets "inlined" by a HACK in the worker/wrapper pass
+-- Also no unfolding in lazyId: it gets "inlined" by a HACK in the worker/wrapperpass
-- (see WorkWrap.wwExpr)
-- We could use inline phases to do this, but that would be vulnerable to changes in
-- phase numbering....we must inline precisely after strictness analysis.
projects / ghc-hetmet.git / blobdiff