)
import TysWiredIn ( boolTy, charTy, mkListTy )
import PrelMods ( pREL_ERR, pREL_GHC )
-import Type ( Type, ThetaType,
- mkDictTy, mkTyConApp, mkTyVarTys, mkFunTys, mkFunTy, mkSigmaTy,
+import PrelRules ( primOpRule )
+import Rules ( addRule )
+import Type ( Type, ClassContext, mkDictTy, mkTyConApp, mkTyVarTys,
+ mkFunTys, mkFunTy, mkSigmaTy, classesToPreds,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfTypes,
splitSigmaTy, splitFunTy_maybe, splitAlgTyConApp,
splitFunTys, splitForAllTys, unUsgTy,
mkUsgTy, UsageAnn(..)
)
import Module ( Module )
-import CoreUnfold ( mkUnfolding )
-import Subst ( mkTopTyVarSubst, substTheta )
+import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
+import Subst ( mkTopTyVarSubst, substClasses )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, isDataTyCon )
-import Class ( Class, classBigSig, classTyCon )
+import Class ( Class, classBigSig, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar )
import VarSet ( isEmptyVarSet )
import Const ( Con(..) )
Name, NamedThing(..),
)
import OccName ( mkSrcVarOcc )
-import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName )
+import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName, primOpArity, primOpStrictness )
import Demand ( wwStrict )
import DataCon ( DataCon, StrictnessMark(..), dataConStrictMarks, dataConFieldLabels,
dataConArgTys, dataConSig, dataConRawArgTys
)
import IdInfo ( vanillaIdInfo, mkIdInfo,
exactArity, setUnfoldingInfo, setCafInfo,
- setArityInfo, setInlinePragInfo,
+ setArityInfo, setInlinePragInfo, setSpecInfo,
mkStrictnessInfo, setStrictnessInfo,
IdFlavour(..), InlinePragInfo(..), CafInfo(..), IdInfo
)
where
(tyvars, theta, ex_tyvars, ex_theta, arg_tys, tycon) = dataConSig data_con
id_ty = mkSigmaTy (tyvars ++ ex_tyvars)
- (theta ++ ex_theta)
+ (classesToPreds (theta ++ ex_theta))
(mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
\end{code}
`setArityInfo` exactArity (n_dicts + n_ex_dicts + n_id_args)
`setUnfoldingInfo` unfolding
where
- unfolding = mkUnfolding (Note InlineMe con_rhs)
+ unfolding = mkTopUnfolding (Note InlineMe con_rhs)
+ -- The dictionary constructors of a class don't get a binding,
+ -- but they are always saturated, so they should always be inlined.
(tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon)
= dataConSig data_con
-- ToDo: consider adding further IdInfo
- unfolding = mkUnfolding sel_rhs
+ unfolding = mkTopUnfolding sel_rhs
(tyvars, theta, tau) = splitSigmaTy selector_ty
(data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
-- ToDo: consider adding further IdInfo
- unfolding = mkUnfolding sel_rhs
+ unfolding = mkTopUnfolding sel_rhs
(tyvars, theta, tau) = splitSigmaTy selector_ty
(data_ty,rhs_ty) = expectJust "StdIdInfoRec" (splitFunTy_maybe tau)
[data_id] = mkTemplateLocals [data_ty]
sel_rhs = mkLams tyvars $ Lam data_id $
- Note (Coerce rhs_ty data_ty) (Var data_id)
+ Note (Coerce (unUsgTy rhs_ty) (unUsgTy data_ty)) (Var data_id)
\end{code}
where
sel_id = mkId name ty info
field_lbl = mkFieldLabel name ty tag
- tag = assoc "MkId.mkDictSelId" ((sc_sel_ids ++ op_sel_ids) `zip` allFieldLabelTags) sel_id
+ tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
info = mkIdInfo (RecordSelId field_lbl)
`setUnfoldingInfo` unfolding
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
- unfolding = mkUnfolding rhs
+ unfolding = mkTopUnfolding rhs
- (tyvars, _, sc_sel_ids, op_sel_ids, defms) = classBigSig clas
+ tyvars = classTyVars clas
tycon = classTyCon clas
[data_con] = tyConDataCons tycon
info = mkIdInfo (ConstantId (PrimOp prim_op))
`setUnfoldingInfo` unfolding
- `setInlinePragInfo` IMustBeINLINEd
- -- The pragma @IMustBeINLINEd@ says that this Id absolutely
+
+-- Not yet...
+-- `setSpecInfo` rules
+-- `setArityInfo` exactArity arity
+-- `setStrictnessInfo` strict_info
+
+ arity = primOpArity prim_op
+ (dmds, result_bot) = primOpStrictness prim_op
+ strict_info = mkStrictnessInfo (take arity dmds, result_bot)
+ -- primOpStrictness can return an infinite list of demands
+ -- (cheap hack) but Ids mustn't have such things.
+ -- What a mess.
+
+ rules = addRule id emptyCoreRules (primOpRule prim_op)
+
+ unfolding = mkCompulsoryUnfolding rhs
+ -- The mkCompulsoryUnfolding says that this Id absolutely
-- must be inlined. It's only used for primitives,
-- because we don't want to make a closure for each of them.
-
-
- unfolding = mkUnfolding rhs
args = mkTemplateLocals arg_tys
rhs = mkLams tyvars $ mkLams args $
-> Class
-> [TyVar]
-> [Type]
- -> ThetaType
+ -> ClassContext
-> Id
mkDictFunId dfun_name clas inst_tyvars inst_tys inst_decl_theta
= mkVanillaId dfun_name dfun_ty
where
- (class_tyvars, sc_theta, _, _, _) = classBigSig clas
- sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
+ (class_tyvars, sc_theta, _, _) = classBigSig clas
+ sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys) sc_theta
+
+ dfun_theta = classesToPreds inst_decl_theta
+
+{- 1 dec 99: disable the Mark Jones optimisation for the sake
+ of compatibility with Hugs.
+ See `types/InstEnv' for a discussion related to this.
dfun_theta = case inst_decl_theta of
[] -> [] -- If inst_decl_theta is empty, then we don't
-- class Foo a => Baz a b where ...
-- instance Wob b => Baz T b where..
-- Now sc_theta' has Foo T
-
+-}
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
not_const (clas, tys) = not (isEmptyVarSet (tyVarsOfTypes tys))
= pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
where
info = vanillaIdInfo
- `setUnfoldingInfo` mkUnfolding rhs
- `setInlinePragInfo` IMustBeINLINEd
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
= pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
where
info = vanillaIdInfo
- `setUnfoldingInfo` mkUnfolding rhs
- `setInlinePragInfo` IMustBeINLINEd
+ `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
projects / ghc-hetmet.git / blobdiff