%
+% (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:
mkDataConIds,
mkRecordSelId,
- mkPrimOpId, mkFCallId,
+ mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId,
mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
mkUnpackCase, mkProductBox,
#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, coreEqType,
- PredType(..),
- mkTopTvSubst, substTyVar )
-import TcGadt ( gadtRefine, refineType, emptyRefinement )
-import HsBinds ( ExprCoFn(..), isIdCoercion )
-import Coercion ( mkSymCoercion, mkUnsafeCoercion,
- splitNewTypeRepCo_maybe, isEqPred )
-import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
- mkTyConApp, mkTyVarTys, mkClassPred,
- mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
- isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
- tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
- )
-import CoreUtils ( exprType, dataConInstPat )
-import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
-import Literal ( nullAddrLit, mkStringLit )
-import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
- tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
- newTyConCo, tyConArity )
-import Class ( Class, classTyCon, classSelIds )
-import Var ( Id, TyVar, Var, setIdType, mkCoVar, mkWildCoVar )
-import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
-import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..),
- mkSysTvName )
-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,
- dataConSig, dataConStrictMarks, dataConExStricts,
- splitProductType, isVanillaDataCon, dataConFieldType,
- dataConInstOrigArgTys, deepSplitProductType
- )
-import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal,
- mkTemplateLocals, mkTemplateLocalsNum, mkExportedLocalId,
- mkTemplateLocal, idName, mkWildId
- )
-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 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
+import Module
\end{code}
%************************************************************************
Making an explicit case expression allows the simplifier to eliminate
it in the (common) case where the constructor arg is already evaluated.
+[Wrappers for data instance tycons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In the case of data instances, the wrapper also applies the coercion turning
+the representation type into the family instance type to cast the result of
+the wrapper. For example, consider the declarations
+
+ data family Map k :: * -> *
+ data instance Map (a, b) v = MapPair (Map a (Pair b v))
+
+The tycon to which the datacon MapPair belongs gets a unique internal name of
+the form :R123Map, and we call it the representation tycon. In contrast, Map
+is the family tycon (accessible via tyConFamInst_maybe). The wrapper and work
+of MapPair get the types
+
+ $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v
+ $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v
+
+which implies that the wrapper code will have to apply the coercion moving
+between representation and family type. It is accessible via
+tyConFamilyCoercion_maybe and has kind
+
+ Co123Map a b v :: {Map (a, b) v :=: :R123Map a b v}
+
+This coercion is conditionally applied by wrapFamInstBody.
\begin{code}
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon
- = NewDC nt_wrap_id
+ = DCIds Nothing nt_work_id -- Newtype, only has a worker
- | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
- || not (null eq_spec)
- = AlgDC (Just alg_wrap_id) wrk_id
+ | any isMarkedStrict all_strict_marks -- Algebraic, needs wrapper
+ || not (null eq_spec) -- NB: LoadIface.ifaceDeclSubBndrs
+ || isFamInstTyCon tycon -- depends on this test
+ = DCIds (Just alg_wrap_id) wrk_id
- | otherwise -- Algebraic, no wrapper
- = AlgDC Nothing wrk_id
+ | otherwise -- Algebraic, no wrapper
+ = DCIds Nothing wrk_id
where
- (univ_tvs, ex_tvs, eq_spec, theta, orig_arg_tys) = dataConFullSig data_con
- tycon = dataConTyCon data_con
+ (univ_tvs, ex_tvs, eq_spec,
+ theta, orig_arg_tys) = dataConFullSig data_con
+ tycon = dataConTyCon data_con
----------- Wrapper --------------
-- We used to include the stupid theta in the wrapper's args
-- 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 = mkTyConApp tycon result_ty_args
+ result_ty_args = substTyVars subst univ_tvs
+ result_ty = case tyConFamInst_maybe tycon of
+ -- ordinary constructor
+ Nothing -> mkTyConApp tycon result_ty_args
+ -- family instance constructor
+ Just (familyTyCon,
+ 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)
-- RetCPR is only true for products that are real data types;
-- that is, not unboxed tuples or [non-recursive] newtypes
- ----------- Wrappers for newtypes --------------
- nt_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty nt_wrap_info
- nt_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
+ ----------- Workers for newtypes --------------
+ nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info
+ nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo
`setArityInfo` 1 -- Arity 1
`setUnfoldingInfo` newtype_unf
newtype_unf = ASSERT( isVanillaDataCon data_con &&
(zip (dict_args ++ id_args) all_strict_marks)
i3 []
- con_app i rep_ids = Var wrk_id `mkTyApps` result_ty_args
- `mkVarApps` ex_tvs
- `mkTyApps` map snd eq_spec
- `mkVarApps` reverse rep_ids
+ con_app _ rep_ids = wrapFamInstBody tycon result_ty_args $
+ Var wrk_id `mkTyApps` result_ty_args
+ `mkVarApps` ex_tvs
+ `mkTyApps` map snd eq_spec
+ `mkVarApps` reverse rep_ids
(dict_args,i2) = mkLocals 1 dict_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
Case (Var arg) arg result_ty [(DEFAULT,[], body i (arg:rep_args))]
MarkedUnboxed
- -> unboxProduct i (Var arg) (idType arg) the_body result_ty
+ -> unboxProduct i (Var arg) (idType arg) the_body
where
the_body i con_args = body i (reverse con_args ++ rep_args)
mkLocals i tys = (zipWith mkTemplateLocal [i..i+n-1] tys, i+n)
where
n = length tys
+
+-- If the type constructor is a representation type of a data instance, wrap
+-- the expression into a cast adjusting the expression type, which is an
+-- instance of the representation type, to the corresponding instance of the
+-- family instance type.
+--
+wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+wrapFamInstBody tycon args result_expr
+ | Just co_con <- tyConFamilyCoercion_maybe tycon
+ = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
+ | otherwise
+ = result_expr
\end{code}
-- foo = /\a. \t:T. case t of { MkT f -> f a }
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) rhs
+ = ASSERT2( res_ty `tcEqType` field_ty, ppr data_con $$ ppr res_ty $$ ppr field_ty )
+ mkReboxingAlt rebox_uniqs data_con (ex_tvs ++ co_tvs ++ arg_vs) rhs
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
- = (ex_tvs ++ co_tvs ++ dict_vs, field_vs)
-
- (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys
- (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs
+ -- get pattern binders with types appropriately instantiated
+ arg_uniqs = map mkBuiltinUnique [arg_base..]
+ (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat arg_uniqs data_con res_tys
- (_, pre_dc_theta, dc_arg_tys) = dataConSig data_con
- dc_theta = filter (not . isEqPred) pre_dc_theta
+ rebox_base = arg_base + length ex_tvs + length co_tvs + length arg_vs
+ rebox_uniqs = map mkBuiltinUnique [rebox_base..]
- arg_base' = arg_base + length dc_theta
+ -- data T :: *->* where T1 { fld :: Maybe b } -> T [b]
+ -- Hence T1 :: forall a b. (a=[b]) => b -> T a
+ -- fld :: forall b. T [b] -> Maybe b
+ -- fld = /\b.\(t:T[b]). case t of
+ -- T1 b' (c : [b]=[b']) (x:Maybe b')
+ -- -> x `cast` Maybe (sym (right c))
- unpack_base = arg_base' + length dc_arg_tys
-
- uniq_list = map mkBuiltinUnique [unpack_base..]
+ -- Generate the refinement for b'=b,
+ -- and apply to (Maybe b'), to get (Maybe b)
Succeeded refinement = gadtRefine emptyRefinement ex_tvs co_tvs
- (co_fn, out_ty) = refineType refinement (idType the_arg_id)
-
- rhs = ASSERT(out_ty `coreEqType` field_tau) perform_co co_fn (Var the_arg_id)
-
- perform_co (ExprCoFn co) expr = Cast expr co
- perform_co id_co expr = ASSERT(isIdCoercion id_co) expr
-
- -- split the uniq_list into two
- uniqs = takeHalf uniq_list
- uniqs' = takeHalf (drop 1 uniq_list)
+ 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)
- takeHalf [] = []
- takeHalf (h:_:t) = h:(takeHalf t)
- takeHalf (h:t) = [h]
-
- the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` arg_ids) field_label
+ field_vs = filter (not . isPredTy . idType) arg_vs
+ the_arg_id = assoc "mkRecordSelId:mk_alt" (field_lbls `zip` field_vs) field_label
field_lbls = dataConFieldLabels data_con
- error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_tau full_msg
+ error_expr = mkRuntimeErrorApp rEC_SEL_ERROR_ID field_ty full_msg
full_msg = showSDoc (sep [text "No match in record selector", ppr sel_id])
-- unbox a product type...
-- If we have e = MkT (MkS (PairInt 0 1)) and some body expecting a list of
-- ids, we get (modulo int passing)
--
--- case (e `cast` (sym CoT)) `cast` (sym CoS) of
+-- case (e `cast` CoT) `cast` CoS of
-- PairInt a b -> body [a,b]
--
-- The Ints passed around are just for creating fresh locals
-unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> Type -> CoreExpr
-unboxProduct i arg arg_ty body res_ty
+unboxProduct :: Int -> CoreExpr -> Type -> (Int -> [Id] -> CoreExpr) -> CoreExpr
+unboxProduct i arg arg_ty body
= result
where
- result = mkUnpackCase the_id arg arg_ty con_args boxing_con rhs
- (tycon, tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
+ result = mkUnpackCase the_id arg con_args boxing_con rhs
+ (_tycon, _tycon_args, boxing_con, tys) = deepSplitProductType "unboxProduct" arg_ty
([the_id], i') = mkLocals i [arg_ty]
(con_args, i'') = mkLocals i' tys
rhs = body i'' con_args
-mkUnpackCase :: Id -> CoreExpr -> Type -> [Id] -> DataCon -> CoreExpr -> CoreExpr
+mkUnpackCase :: Id -> CoreExpr -> [Id] -> DataCon -> CoreExpr -> CoreExpr
-- (mkUnpackCase x e args Con body)
-- returns
-- case (e `cast` ...) of bndr { Con args -> body }
--
-- the type of the bndr passed in is irrelevent
-mkUnpackCase bndr arg arg_ty unpk_args boxing_con body
+mkUnpackCase bndr arg unpk_args boxing_con body
= Case cast_arg (setIdType bndr bndr_ty) (exprType body) [(DataAlt boxing_con, unpk_args, body)]
where
(cast_arg, bndr_ty) = go (idType bndr) arg
go ty arg
- | res@(tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
+ | (tycon, tycon_args, _, _) <- splitProductType "mkUnpackCase" ty
, isNewTyCon tycon && not (isRecursiveTyCon tycon)
= go (newTyConInstRhs tycon tycon_args)
(unwrapNewTypeBody tycon tycon_args arg)
[Id]) -- Ids being boxed into product
reboxProduct us ty
= let
- (tycon, tycon_args, pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
+ (_tycon, _tycon_args, _pack_con, con_arg_tys) = deepSplitProductType "reboxProduct" ty
us' = dropList con_arg_tys us
mkProductBox arg_ids ty
= result_expr
where
- (tycon, tycon_args, pack_con, con_arg_tys) = splitProductType "mkProductBox" ty
+ (tycon, tycon_args, pack_con, _con_arg_tys) = splitProductType "mkProductBox" ty
result_expr
| isNewTyCon tycon && not (isRecursiveTyCon tycon)
where
stricts = dataConExStricts con ++ dataConStrictMarks con
- go [] stricts us = ([], [])
+ go [] _stricts _us = ([], [])
-- Type variable case
go (arg:args) stricts us
-- The wrapper for the data constructor for a newtype looks like this:
-- newtype T a = MkT (a,Int)
-- MkT :: forall a. (a,Int) -> T a
--- MkT = /\a. \(x:(a,Int)). x `cast` CoT a
+-- MkT = /\a. \(x:(a,Int)). x `cast` sym (CoT a)
-- where CoT is the coercion TyCon assoicated with the newtype
--
-- The call (wrapNewTypeBody T [a] e) returns the
-- body of the wrapper, namely
--- e `cast` CoT [a]
+-- e `cast` (CoT [a])
--
-- If a coercion constructor is prodivided in the newtype, then we use
-- it, otherwise the wrap/unwrap are both no-ops
--
+-- If the we are dealing with a newtype instance, we have a second coercion
+-- identifying the family instance with the constructor of the newtype
+-- instance. This coercion is applied in any case (ie, composed with the
+-- coercion constructor of the newtype or applied by itself).
+--
wrapNewTypeBody tycon args result_expr
- | Just co_con <- newTyConCo tycon
- = Cast result_expr (mkTyConApp co_con args)
- | otherwise
- = result_expr
+ = wrapFamInstBody tycon args inner
+ where
+ inner
+ | Just co_con <- newTyConCo_maybe tycon
+ = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
+ | otherwise
+ = result_expr
+-- When unwrapping, we do *not* apply any family coercion, because this will
+-- be done via a CoPat by the type checker. We have to do it this way as
+-- computing the right type arguments for the coercion requires more than just
+-- a spliting operation (cf, TcPat.tcConPat).
+--
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
- | Just co_con <- newTyConCo tycon
- = Cast result_expr (mkSymCoercion (mkTyConApp co_con args))
+ | Just co_con <- newTyConCo_maybe tycon
+ = mkCoerce (mkTyConApp co_con args) result_expr
| otherwise
= result_expr
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
(arg_tys, _) = tcSplitFunTys tau
arity = length arg_tys
strict_sig = mkStrictSig (mkTopDmdType (replicate arity evalDmd) TopRes)
+
+-- Tick boxes and breakpoints are both represented as TickBoxOpIds,
+-- except for the type:
+--
+-- a plain HPC tick box has type (State# RealWorld)
+-- a breakpoint Id has type forall a.a
+--
+-- The breakpoint Id will be applied to a list of arbitrary free variables,
+-- which is why it needs a polymorphic type.
+
+mkTickBoxOpId :: Unique -> Module -> TickBoxId -> Id
+mkTickBoxOpId uniq mod ix = mkTickBox' uniq mod ix realWorldStatePrimTy
+
+mkBreakPointOpId :: Unique -> Module -> TickBoxId -> Id
+mkBreakPointOpId uniq mod ix = mkTickBox' uniq mod ix ty
+ where ty = mkSigmaTy [openAlphaTyVar] [] openAlphaTy
+
+mkTickBox' uniq mod ix ty = mkGlobalId (TickBoxOpId tickbox) name ty info
+ where
+ tickbox = TickBox mod ix
+ occ_str = showSDoc (braces (ppr tickbox))
+ name = mkTickBoxOpName uniq occ_str
+ info = noCafIdInfo
\end{code}
\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
(mkFunTy openAlphaTy openBetaTy)
[x] = mkTemplateLocals [openAlphaTy]
rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
--- Note (Coerce openBetaTy openAlphaTy) (Var x)
- Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
+ Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
-- nullAddr# :: Addr#
-- The reason is is here is because we don't provide
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}