%
+% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1998
%
-\section[StdIdInfo]{Standard unfoldings}
This module contains definitions for the IdInfo for things that
have a standard form, namely:
#include "HsVersions.h"
-
-import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict )
-import Rules ( mkSpecInfo )
-import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy,
- realWorldStatePrimTy, addrPrimTy
- )
-import TysWiredIn ( charTy, mkListTy )
-import PrelRules ( primOpRules )
-import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes,
- newTyConInstRhs, mkTopTvSubst, substTyVar, substTy )
-import TcGadt ( gadtRefine, refineType, emptyRefinement )
-import HsBinds ( ExprCoFn(..), isIdCoercion )
-import Coercion ( mkSymCoercion, mkUnsafeCoercion, isEqPred )
-import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
- mkTyConApp, mkTyVarTys, mkClassPred, isPredTy,
- mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy, tcEqType,
- isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
- tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
- )
-import CoreUtils ( exprType, dataConOrigInstPat, mkCoerce )
-import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
-import Literal ( nullAddrLit, mkStringLit )
-import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
- tyConStupidTheta, isProductTyCon, isDataTyCon,
- isRecursiveTyCon, isFamInstTyCon,
- tyConFamInst_maybe, tyConFamilyCoercion_maybe,
- newTyConCo_maybe )
-import Class ( Class, classTyCon, classSelIds )
-import Var ( Id, TyVar, Var, setIdType )
-import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
-import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..))
-import OccName ( mkOccNameFS, varName )
-import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
-import ForeignCall ( ForeignCall )
-import DataCon ( DataCon, DataConIds(..), dataConTyCon,
- dataConUnivTyVars,
- dataConFieldLabels, dataConRepArity, dataConResTys,
- dataConRepArgTys, dataConRepType, dataConFullSig,
- dataConStrictMarks, dataConExStricts,
- splitProductType, isVanillaDataCon, dataConFieldType,
- deepSplitProductType,
- )
-import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
- mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
- mkTemplateLocal, idName
- )
-import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
- setArityInfo, setSpecInfo, setCafInfo,
- setAllStrictnessInfo, vanillaIdInfo,
- GlobalIdDetails(..), CafInfo(..)
- )
-import NewDemand ( mkStrictSig, DmdResult(..),
- mkTopDmdType, topDmd, evalDmd, lazyDmd, retCPR,
- Demand(..), Demands(..) )
-import DmdAnal ( dmdAnalTopRhs )
+import Rules
+import TysPrim
+import TysWiredIn
+import PrelRules
+import Type
+import TcGadt
+import HsBinds
+import Coercion
+import TcType
+import CoreUtils
+import CoreUnfold
+import Literal
+import TyCon
+import Class
+import VarSet
+import Name
+import OccName
+import PrimOp
+import ForeignCall
+import DataCon
+import Id
+import Var ( Var, TyVar)
+import IdInfo
+import NewDemand
+import DmdAnal
import CoreSyn
-import Unique ( mkBuiltinUnique, mkPrimOpIdUnique )
-import Maybe ( fromJust )
+import Unique
import Maybes
import PrelNames
-import Util ( dropList, isSingleton )
+import BasicTypes hiding ( SuccessFlag(..) )
+import Util
import Outputable
import FastString
-import ListSetOps ( assoc, minusList )
+import ListSetOps
\end{code}
%************************************************************************
-- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
subst = mkTopTvSubst eq_spec
+ famSubst = ASSERT( length (tyConTyVars tycon ) ==
+ length (mkTyVarTys univ_tvs) )
+ zipTopTvSubst (tyConTyVars tycon) (mkTyVarTys univ_tvs)
+ -- substitution mapping the type constructor's type
+ -- arguments to the universals of the data constructor
+ -- (crucial when type checking interfaces)
dict_tys = mkPredTys theta
result_ty_args = map (substTyVar subst) univ_tvs
result_ty = case tyConFamInst_maybe tycon of
-- family instance constructor
Just (familyTyCon,
instTys) ->
- mkTyConApp familyTyCon (map (substTy subst) instTys)
+ mkTyConApp familyTyCon ( substTys subst
+ . substTys famSubst
+ $ instTys)
wrap_ty = mkForAllTys wrap_tvs $ mkFunTys dict_tys $
mkFunTys orig_arg_tys $ result_ty
-- NB: watch out here if you allow user-written equality
-- even if arity = 0
wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info)
+ -- Note [Data-con worker strictness]
-- Notice that we do *not* say the worker is strict
-- even if the data constructor is declared strict
-- e.g. data T = MkT !(Int,Int)
= mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
| otherwise
= result_expr
-
--- Apply the coercion in the opposite direction.
---
-unwrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
-unwrapFamInstBody tycon args result_expr
- | Just co_con <- tyConFamilyCoercion_maybe tycon
- = mkCoerce (mkTyConApp co_con args) result_expr
- | otherwise
- = result_expr
-
\end{code}
-- T1 b' (c : [b]=[b']) (x:Maybe b')
-- -> x `cast` Maybe (sym (right c))
- Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
- (co_fn, res_ty) = refineType refinement (idType the_arg_id)
+
-- Generate the refinement for b'=b,
-- and apply to (Maybe b'), to get (Maybe b)
-
- rhs = case co_fn of
- ExprCoFn co -> Cast (Var the_arg_id) co
- id_co -> ASSERT(isIdCoercion id_co) Var the_arg_id
+ Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
+ the_arg_id_ty = idType the_arg_id
+ (rhs, res_ty) = case refineType refinement the_arg_id_ty of
+ Just (co, res_ty) -> (Cast (Var the_arg_id) co, res_ty)
+ Nothing -> (Var the_arg_id, the_arg_id_ty)
field_vs = filter (not . isPredTy . idType) arg_vs
the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
name = mkWiredInName gHC_PRIM (primOpOcc prim_op)
(mkPrimOpIdUnique (primOpTag prim_op))
- Nothing (AnId id) UserSyntax
+ (AnId id) UserSyntax
id = mkGlobalId (PrimOpId prim_op) name ty info
info = noCafIdInfo
\begin{code}
mkWiredInIdName mod fs uniq id
- = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax
+ = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax
unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId
nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId
strict_sig = mkStrictSig (mkTopDmdType [evalDmd] BotRes)
-- These "bottom" out, no matter what their arguments
-
-(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
-openAlphaTy = mkTyVarTy openAlphaTyVar
-openBetaTy = mkTyVarTy openBetaTyVar
\end{code}