import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
+import Rules ( mkSpecInfo )
import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
realWorldStatePrimTy, addrPrimTy
)
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
-import Rules ( addRule )
-import Type ( TyThing(..) )
+import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
- mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred,
+ mkTyConApp, mkTyVarTys, mkClassPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
- tcSplitFunTys, tcSplitForAllTys
+ tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
)
import CoreUtils ( exprType )
-import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
+import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
-import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
+import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var )
-import VarSet ( isEmptyVarSet )
+import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) )
-import OccName ( mkOccFS, varName )
+import OccName ( mkOccNameFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, DataConIds(..), dataConTyVars,
- dataConFieldLabels, dataConRepArity,
+ dataConFieldLabels, dataConRepArity, dataConResTys,
dataConRepArgTys, dataConRepType,
- dataConStupidTheta, dataConOrigArgTys,
dataConSig, dataConStrictMarks, dataConExStricts,
- splitProductType, isVanillaDataCon
+ splitProductType, isVanillaDataCon, dataConFieldType,
+ dataConInstOrigArgTys
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
import Maybes
import PrelNames
-import Maybe ( isJust )
import Util ( dropList, isSingleton )
import Outputable
import FastString
-import ListSetOps ( assoc, assocMaybe )
-import List ( nubBy )
+import ListSetOps ( assoc )
\end{code}
%************************************************************************
wkr_info = noCafIdInfo
`setArityInfo` wkr_arity
`setAllStrictnessInfo` Just wkr_sig
+ `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated,
+ -- even if arity = 0
wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
-- Notice that we do *not* say the worker is strict
-- If we pretend it is strict then when we see
-- case x of y -> $wMkT y
-- the simplifier thinks that y is "sure to be evaluated" (because
- -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
+ -- $wMkT is strict) and drops the case. No, $wMkT is not strict.
--
-- When the simplifer sees a pattern
-- case e of MkT x -> ...
MarkedStrict
| isUnLiftedType (idType arg) -> body i (arg:rep_args)
| otherwise ->
--- gaw 2004
Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
MarkedUnboxed
-> case splitProductType "do_unbox" (idType arg) of
(tycon, tycon_args, con, tys) ->
--- gaw 2004
- Case (Var arg) arg result_ty [(DataAlt con, con_args,
- body i' (reverse con_args ++ rep_args))]
+ Case (Var arg) arg result_ty
+ [(DataAlt con,
+ con_args,
+ body i' (reverse con_args ++ rep_args))]
where
(con_args, i') = mkLocals i tys
unN :: forall b. N -> b -> b
unN = /\b -> \n:N -> (coerce (forall a. a->a) n)
+
+Note [Naughty record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+A "naughty" field is one for which we can't define a record
+selector, because an existential type variable would escape. For example:
+ data T = forall a. MkT { x,y::a }
+We obviously can't define
+ x (MkT v _) = v
+Nevertheless we *do* put a RecordSelId into the type environment
+so that if the user tries to use 'x' as a selector we can bleat
+helpfully, rather than saying unhelpfully that 'x' is not in scope.
+Hence the sel_naughty flag, to identify record selcectors that don't really exist.
+
+In general, a field is naughty if its type mentions a type variable that
+isn't in the result type of the constructor.
+
+For GADTs, we require that all constructors with a common field 'f' have the same
+result type (modulo alpha conversion). [Checked in TcTyClsDecls.checkValidTyCon]
+E.g.
+ data T where
+ T1 { f :: a } :: T [a]
+ T2 { f :: a, y :: b } :: T [a]
+and now the selector takes that type as its argument:
+ f :: forall a. T [a] -> a
+ f t = case t of
+ T1 { f = v } -> v
+ T2 { f = v } -> v
+Note the forall'd tyvars of the selector are just the free tyvars
+of the result type; there may be other tyvars in the constructor's
+type (e.g. 'b' in T2).
+
\begin{code}
-mkRecordSelId tycon field_label field_ty
+
+-- XXX - autrijus -
+-- Plan: 1. Determine naughtiness by comparing field type vs result type
+-- 2. Install naughty ones with selector_ty of type _|_ and fill in mzero for info
+-- 3. If it's not naughty, do the normal plan.
+
+mkRecordSelId :: TyCon -> FieldLabel -> Id
+mkRecordSelId tycon field_label
-- Assumes that all fields with the same field label have the same type
- = sel_id
+ | is_naughty = naughty_id
+ | otherwise = sel_id
where
- sel_id = mkGlobalId (RecordSelId tycon field_label) field_label selector_ty info
- data_cons = tyConDataCons tycon
- tyvars = tyConTyVars tycon -- These scope over the types in
- -- the FieldLabels of constructors of this type
- data_ty = mkTyConApp tycon tyvar_tys
- tyvar_tys = mkTyVarTys tyvars
-
- -- Very tiresomely, the selectors are (unnecessarily!) overloaded over
+ is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set)
+ sel_id_details = RecordSelId tycon field_label is_naughty
+
+ -- Escapist case here for naughty construcotrs
+ -- 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
+ forall_a_a = mkForAllTy alphaTyVar (mkTyVarTy alphaTyVar)
+
+ -- Normal case starts here
+ sel_id = mkGlobalId sel_id_details field_label selector_ty info
+ 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
+ res_tys = dataConResTys con1
+ tyvar_set = tyVarsOfTypes res_tys
+ tyvars = varSetElems tyvar_set
+ data_ty = mkTyConApp tycon res_tys
+ 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
-- 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
+ -- BuildTyCl.mkDataConStupidTheta). 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
- needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConStupidTheta dc]
- dict_tys = mkPredTys (nubBy tcEqPred needed_preds)
- n_dict_tys = length dict_tys
+ stupid_dict_tys = mkPredTys (dataConsStupidTheta data_cons_w_field)
+ n_stupid_dicts = length stupid_dict_tys
(field_tyvars,field_theta,field_tau) = tcSplitSigmaTy field_ty
field_dict_tys = mkPredTys field_theta
selector_ty :: Type
selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
- mkFunTys dict_tys $ mkFunTys field_dict_tys $
+ mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $
mkFunTy data_ty field_tau
- arity = 1 + n_dict_tys + n_field_dict_tys
+ arity = 1 + n_stupid_dicts + n_field_dict_tys
(strict_sig, rhs_w_str) = dmdAnalTopRhs sel_rhs
-- Use the demand analyser to work out strictness.
-- rather than n_dict_tys, because the latter gives an infinite loop:
-- n_dict tys depends on the_alts, which depens on arg_ids, which depends
-- on arity, which depends on n_dict tys. Sigh! Mega sigh!
- dict_ids = mkTemplateLocalsNum 1 dict_tys
- max_dict_tys = length (tyConStupidTheta tycon)
- field_dict_base = max_dict_tys + 1
- field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
- dict_id_base = field_dict_base + n_field_dict_tys
- data_id = mkTemplateLocal dict_id_base data_ty
- arg_base = dict_id_base + 1
-
- alts = map mk_maybe_alt data_cons
- the_alts = catMaybes alts
-
- no_default = all isJust alts -- No default needed
+ stupid_dict_ids = mkTemplateLocalsNum 1 stupid_dict_tys
+ max_stupid_dicts = length (tyConStupidTheta tycon)
+ field_dict_base = max_stupid_dicts + 1
+ field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
+ dict_id_base = field_dict_base + n_field_dict_tys
+ data_id = mkTemplateLocal dict_id_base data_ty
+ arg_base = dict_id_base + 1
+
+ the_alts :: [CoreAlt]
+ the_alts = map mk_alt data_cons_w_field -- Already sorted by data-con
+ no_default = length data_cons == length data_cons_w_field -- No default needed
+
default_alt | no_default = []
| otherwise = [(DEFAULT, [], error_expr)]
| otherwise = MayHaveCafRefs
sel_rhs = mkLams tyvars $ mkLams field_tyvars $
- mkLams dict_ids $ mkLams field_dict_ids $
+ mkLams stupid_dict_ids $ mkLams field_dict_ids $
Lam data_id $ sel_body
sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
-- foo :: forall a. T -> a -> a
-- foo = /\a. \t:T. case t of { MkT f -> f a }
- mk_maybe_alt data_con
- = ASSERT( dc_tyvars == tyvars )
- -- The only non-vanilla case we allow is when we have an existential
- -- context that binds no type variables, thus
- -- data T a = (?v::Int) => MkT a
- -- In the non-vanilla case, the pattern must bind type variables and
+ mk_alt data_con
+ = -- In the non-vanilla case, the pattern must bind type variables and
-- the context stuff; hence the arg_prefix binding below
-
- case maybe_the_arg_id of
- Nothing -> Nothing
- Just the_arg_id -> Just (mkReboxingAlt uniqs data_con (arg_prefix ++ arg_src_ids) $
- mk_result (Var the_arg_id))
- where
- (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
- arg_src_ids = mkTemplateLocalsNum arg_base dc_arg_tys
- arg_base' = arg_base + length arg_src_ids
- arg_prefix | isVanillaDataCon data_con = []
- | otherwise = tyvars ++ mkTemplateLocalsNum arg_base' (mkPredTys dc_theta)
-
- unpack_base = arg_base' + length dc_theta
- uniqs = map mkBuiltinUnique [unpack_base..]
-
- maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_src_ids) field_label
- field_lbls = dataConFieldLabels data_con
+ mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids)
+ (mk_result (Var the_arg_id))
+ where
+ (arg_prefix, arg_ids)
+ | isVanillaDataCon data_con -- Instantiate from commmon base
+ = ([], mkTemplateLocalsNum arg_base (dataConInstOrigArgTys data_con res_tys))
+ | otherwise -- The case pattern binds type variables, which are used
+ -- in the types of the arguments of the pattern
+ = (dc_tyvars ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
+ mkTemplateLocalsNum arg_base' dc_arg_tys)
+
+ (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
+ arg_base' = arg_base + length dc_theta
+
+ unpack_base = arg_base' + length dc_arg_tys
+ uniqs = map mkBuiltinUnique [unpack_base..]
+
+ the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
+ field_lbls = dataConFieldLabels data_con
error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
- `setSpecInfo` rules
- `setArityInfo` arity
+ `setSpecInfo` mkSpecInfo (primOpRules prim_op name)
+ `setArityInfo` arity
`setAllStrictnessInfo` Just strict_sig
- rules = foldl (addRule id) emptyCoreRules (primOpRules prim_op)
-
-
-- For each ccall we manufacture a separate CCallOpId, giving it
-- a fresh unique, a type that is correct for this particular ccall,
-- and a CCall structure that gives the correct details about calling
involves user-written code, so we can't figure out their strictness etc
based on fixed info, as we can for constructors and record selectors (say).
-We build them as GlobalIds, but when in the module where they are
-bound, we turn the Id at the *binding site* into an exported LocalId.
-This ensures that they are taken to account by free-variable finding
-and dependency analysis (e.g. CoreFVs.exprFreeVars). The simplifier
-will propagate the LocalId to all occurrence sites.
+We build them as LocalIds, but with External Names. This ensures that
+they are taken to account by free-variable finding and dependency
+analysis (e.g. CoreFVs.exprFreeVars).
Why shouldn't they be bound as GlobalIds? Because, in particular, if
they are globals, the specialiser floats dict uses above their defns,
pass on to the next module (md_insts) in CoreTidy, afer tidying
and globalising the top-level Ids.
-BUT make sure they are *exported* LocalIds (setIdLocalExported) so
+BUT make sure they are *exported* LocalIds (mkExportedLocalId) so
that they aren't discarded by the occurrence analyser.
\begin{code}
\begin{code}
mkWiredInIdName mod fs uniq id
- = mkWiredInName mod (mkOccFS varName fs) uniq Nothing (AnId id) UserSyntax
+ = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId
\begin{code}
realWorldPrimId -- :: State# RealWorld
= pcMiscPrelId realWorldName realWorldStatePrimTy
- (noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
- -- The mkOtherCon makes it look that realWorld# is evaluated
+ (noCafIdInfo `setUnfoldingInfo` evaldUnfolding)
+ -- The evaldUnfolding makes it look that realWorld# is evaluated
-- which in turn makes Simplify.interestingArg return True,
-- which in turn makes INLINE things applied to realWorld# likely
-- to be inlined