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 TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp,
- mkTyVarTys, mkClassPred, tcEqPred,
+import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
+import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
+ mkTyConApp, mkTyVarTys, mkClassPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
- tcSplitFunTys, tcSplitForAllTys, mkPredTy
+ tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
)
import CoreUtils ( exprType )
-import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon )
-import Literal ( Literal(..), nullAddrLit )
-import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons,
- tyConTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
-import Class ( Class, classTyCon, classTyVars, classSelIds )
+import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
+import Literal ( nullAddrLit, mkStringLit )
+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(..),
- dataConFieldLabels, dataConRepArity,
- dataConArgTys, dataConRepType,
- dataConOrigArgTys, dataConTheta,
+import DataCon ( DataCon, DataConIds(..), dataConTyVars,
+ dataConFieldLabels, dataConRepArity, dataConResTys,
+ dataConRepArgTys, dataConRepType,
dataConSig, dataConStrictMarks, dataConExStricts,
- splitProductType
+ splitProductType, isVanillaDataCon, dataConFieldType,
+ dataConInstOrigArgTys
)
import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
import NewDemand ( mkStrictSig, DmdResult(..),
mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
Demand(..), Demands(..) )
-import FieldLabel ( fieldLabelName, firstFieldLabelTag,
- allFieldLabelTags, fieldLabelType
- )
import DmdAnal ( dmdAnalTopRhs )
import CoreSyn
import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
import Maybes
import PrelNames
-import Maybe ( isJust )
import Util ( dropList, isSingleton )
import Outputable
import FastString
-import ListSetOps ( assoc, assocMaybe )
-import UnicodeUtil ( stringToUtf8 )
-import List ( nubBy )
+import ListSetOps ( assoc )
\end{code}
%************************************************************************
| otherwise -- Algebraic, no wrapper
= AlgDC Nothing wrk_id
where
- (tyvars, _, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
- all_tyvars = tyvars ++ ex_tyvars
+ (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
- ex_dict_tys = mkPredTys ex_theta
- all_arg_tys = ex_dict_tys ++ orig_arg_tys
- result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
+ dict_tys = mkPredTys theta
+ all_arg_tys = dict_tys ++ orig_arg_tys
+ result_ty = mkTyConApp tycon res_tys
- wrap_ty = mkForAllTys all_tyvars (mkFunTys all_arg_tys result_ty)
+ wrap_ty = mkForAllTys 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.
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 -> ...
nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setUnfoldingInfo` newtype_unf
- newtype_unf = ASSERT( null ex_tyvars && null ex_theta &&
- isSingleton orig_arg_tys )
+ newtype_unf = 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 (...)
mkTopUnfolding $ Note InlineMe $
-- we want to see that w is strict in its two arguments
alg_unf = mkTopUnfolding $ Note InlineMe $
- mkLams all_tyvars $
- mkLams ex_dict_args $ mkLams id_args $
+ mkLams tyvars $
+ mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
- (zip (ex_dict_args ++ id_args) all_strict_marks)
+ (zip (dict_args ++ id_args) all_strict_marks)
i3 []
con_app i rep_ids = mkApps (Var wrk_id)
- (map varToCoreExpr (all_tyvars ++ reverse rep_ids))
+ (map varToCoreExpr (tyvars ++ reverse rep_ids))
- (ex_dict_args,i2) = mkLocals 1 ex_dict_tys
- (id_args,i3) = mkLocals i2 orig_arg_tys
- alg_arity = i3-1
+ (dict_args,i2) = mkLocals 1 dict_tys
+ (id_args,i3) = mkLocals i2 orig_arg_tys
+ alg_arity = i3-1
mk_case
:: (Id, StrictnessMark) -- Arg, strictness
MarkedStrict
| isUnLiftedType (idType arg) -> body i (arg:rep_args)
| otherwise ->
- Case (Var arg) arg [(DEFAULT,[], body i (arg:rep_args))]
+ 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) ->
- Case (Var arg) arg [(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}
+
+-- 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 field_label) (fieldLabelName field_label) selector_ty info
- field_ty = fieldLabelType field_label
- 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
- tycon_theta = tyConTheta tycon -- The context on the data decl
- -- eg data (Eq a, Ord b) => T a b = ...
- needed_preds = [pred | (DataAlt dc, _, _) <- the_alts, pred <- dataConTheta dc]
- dict_tys = map mkPredTy (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 = map mkPredTy field_theta
+ field_dict_tys = mkPredTys field_theta
n_field_dict_tys = length field_dict_tys
-- If the field has a universally quantified type we have to
-- be a bit careful. Suppose we have
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.
`setAllStrictnessInfo` Just strict_sig
-- Allocate Ids. We do it a funny way round because field_dict_tys is
- -- almost always empty. Also note that we use length_tycon_theta
+ -- almost always empty. Also note that we use max_dict_tys
-- 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!
- field_dict_base = length tycon_theta + 1
- dict_id_base = field_dict_base + n_field_dict_tys
- field_base = dict_id_base + 1
- dict_ids = mkTemplateLocalsNum 1 dict_tys
- field_dict_ids = mkTemplateLocalsNum field_dict_base field_dict_tys
- data_id = mkTemplateLocal dict_id_base data_ty
-
- alts = map mk_maybe_alt data_cons
- the_alts = catMaybes alts
+ 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
- no_default = all isJust alts -- 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))
- | otherwise = Case (Var data_id) data_id (default_alt ++ the_alts)
+ | otherwise = Case (Var data_id) data_id field_tau (default_alt ++ the_alts)
mk_result poly_result = mkVarApps (mkVarApps poly_result field_tyvars) field_dict_ids
-- We pull the field lambdas to the top, so we need to
-- foo :: forall a. T -> a -> a
-- foo = /\a. \t:T. case t of { MkT f -> f a }
- mk_maybe_alt data_con
- = case maybe_the_arg_id of
- Nothing -> Nothing
- Just the_arg_id -> Just (mkReboxingAlt uniqs data_con arg_ids body)
- where
- body = mk_result (Var the_arg_id)
- where
- arg_ids = mkTemplateLocalsNum field_base (dataConOrigArgTys data_con)
- -- No need to instantiate; same tyvars in datacon as tycon
- -- Records can't be existential, so no existential tyvars or dicts
-
- 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
- field_lbls = dataConFieldLabels data_con
+ 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
+ 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])
mkReboxingAlt
:: [Unique] -- Uniques for the new Ids
-> DataCon
- -> [Var] -- Source-level args
+ -> [Var] -- Source-level args, including existential dicts
-> CoreExpr -- RHS
-> CoreAlt
-- But it's type must expose the representation of the dictionary
-- to gat (say) C a -> (a -> a)
- tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name
-
info = noCafIdInfo
`setArityInfo` 1
`setUnfoldingInfo` mkTopUnfolding rhs
| otherwise = Eval (Prod [ if the_arg_id == id then evalDmd else Abs
| id <- arg_ids ])
- tyvars = classTyVars clas
-
tycon = classTyCon clas
[data_con] = tyConDataCons tycon
- tyvar_tys = mkTyVarTys tyvars
- arg_tys = dataConArgTys data_con tyvar_tys
- the_arg_id = arg_ids !! (tag - firstFieldLabelTag)
+ tyvars = dataConTyVars data_con
+ arg_tys = dataConRepArgTys data_con
+ the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
- pred = mkClassPred clas tyvar_tys
+ pred = mkClassPred clas (mkTyVarTys tyvars)
(dict_id:arg_ids) = mkTemplateLocals (mkPredTy pred : arg_tys)
rhs | isNewTyCon tycon = mkLams tyvars $ Lam dict_id $
mkNewTypeBody tycon (head arg_tys) (Var dict_id)
| otherwise = mkLams tyvars $ Lam dict_id $
- Case (Var dict_id) dict_id
+ Case (Var dict_id) dict_id (idType the_arg_id)
[(DataAlt data_con, arg_ids, Var the_arg_id)]
mkNewTypeBody tycon result_ty result_expr
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}
(class_tyvars, sc_theta, _, _) = classBigSig clas
not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
- sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
+ sc_theta' = substClasses (zipTopTvSubst class_tyvars inst_tys) sc_theta
dfun_theta = case inst_decl_theta of
[] -> [] -- If inst_decl_theta is empty, then we don't
-- want to have any dict arguments, so that we can
\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
ty = mkForAllTys [alphaTyVar,openBetaTyVar]
(mkFunTy alphaTy (mkFunTy openBetaTy openBetaTy))
[x,y] = mkTemplateLocals [alphaTy, openBetaTy]
- rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x [(DEFAULT, [], Var y)])
+-- gaw 2004
+ rhs = mkLams [alphaTyVar,openBetaTyVar,x,y] (Case (Var x) x openBetaTy [(DEFAULT, [], Var y)])
-- lazy :: forall a?. a? -> a? (i.e. works for unboxed types too)
-- Used to lazify pseq: pseq a b = a `seq` lazy b
\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
mkRuntimeErrorApp err_id res_ty err_msg
= mkApps (Var err_id) [Type res_ty, err_string]
where
- err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg)))
+ err_string = Lit (mkStringLit err_msg)
rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName
rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName
projects / ghc-hetmet.git / blobdiff