TopLevelFlag(..), isTopLevel, isNotTopLevel,
+ OverlapFlag(..),
+
Boxity(..), isBoxed,
TupCon(..), tupleParens,
%************************************************************************
%* *
-\subsection[Top-level/local]{Top-level/not-top level flag}
+ Top-level/not-top level flag
%* *
%************************************************************************
%************************************************************************
%* *
-\subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag}
+ Recursive/Non-Recursive flag
%* *
%************************************************************************
%************************************************************************
%* *
+ Instance overlap flag
+%* *
+%************************************************************************
+
+\begin{code}
+data OverlapFlag
+ = NoOverlap -- This instance must not overlap another
+
+ | OverlapOk -- Silently ignore this instance if you find a
+ -- more specific one that matches the constraint
+ -- you are trying to resolve
+ --
+ -- Example: constraint (Foo [Int])
+ -- instances (Foo [Int])
+ -- (Foo [a]) OverlapOk
+ -- Since the second instance has the OverlapOk flag,
+ -- the first instance will be chosen (otherwise
+ -- its ambiguous which to choose)
+
+ | Incoherent -- Like OverlapOk, but also ignore this instance
+ -- if it doesn't match the constraint you are
+ -- trying to resolve, but could match if the type variables
+ -- in the constraint were instantiated
+ --
+ -- Example: constraint (Foo [b])
+ -- instances (Foo [Int]) Incoherent
+ -- (Foo [a])
+ -- Without the Incoherent flag, we'd complain that
+ -- instantiating 'b' would change which instance
+ -- was chosen
+
+instance Outputable OverlapFlag where
+ ppr NoOverlap = empty
+ ppr OverlapOk = ptext SLIT("[overlap ok]")
+ ppr Incoherent = ptext SLIT("[incoherent]")
+
+\end{code}
+
+%************************************************************************
+%* *
Tuples
%* *
%************************************************************************
DataCon, DataConIds(..),
ConTag, fIRST_TAG,
mkDataCon,
- dataConRepType, dataConSig, dataConName, dataConTag, dataConTyCon,
- dataConTyVars, dataConResTys,
- dataConStupidTheta,
- dataConInstArgTys, dataConOrigArgTys, dataConInstResTy,
+ dataConRepType, dataConSig, dataConFullSig,
+ dataConName, dataConTag, dataConTyCon, dataConUserType,
+ dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, dataConResTys,
+ dataConEqSpec, dataConTheta, dataConStupidTheta,
+ dataConInstArgTys, dataConOrigArgTys,
dataConInstOrigArgTys, dataConRepArgTys,
dataConFieldLabels, dataConFieldType,
dataConStrictMarks, dataConExStricts,
#include "HsVersions.h"
-import Type ( Type, ThetaType, substTyWith, substTy, zipOpenTvSubst,
- mkForAllTys, mkFunTys, mkTyConApp,
+import Type ( Type, ThetaType,
+ substTyWith, substTyVar, mkTopTvSubst,
+ mkForAllTys, mkFunTys, mkTyConApp, mkTyVarTy, mkTyVarTys,
splitTyConApp_maybe,
mkPredTys, isStrictPred, pprType
)
+import Coercion ( isEqPred, mkEqPred )
import TyCon ( TyCon, FieldLabel, tyConDataCons,
- isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon )
+ isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon,
+ isNewTyCon )
import Class ( Class, classTyCon )
import Name ( Name, NamedThing(..), nameUnique )
import Var ( TyVar, Id )
import BasicTypes ( Arity, StrictnessMark(..) )
import Outputable
import Unique ( Unique, Uniquable(..) )
-import ListSetOps ( assoc )
+import ListSetOps ( assoc, minusList )
import Util ( zipEqual, zipWithEqual )
+import List ( partition )
import Maybes ( expectJust )
\end{code}
-- Running example:
--
- -- data Eq a => T a = forall b. Ord b => MkT a [b]
+ -- *** As declared by the user
+ -- data T a where
+ -- MkT :: forall x y. (Ord x) => x -> y -> T (x,y)
+ -- *** As represented internally
+ -- data T a where
+ -- MkT :: forall a. forall x y. (a:=:(x,y), Ord x) => x -> y -> T a
+ --
-- The next six fields express the type of the constructor, in pieces
-- e.g.
--
- -- dcTyVars = [a,b]
- -- dcStupidTheta = [Eq a]
- -- dcTheta = [Ord b]
+ -- dcUnivTyVars = [a]
+ -- dcExTyVars = [x,y]
+ -- dcEqSpec = [a:=:(x,y)]
+ -- dcTheta = [Ord x]
-- dcOrigArgTys = [a,List b]
-- dcTyCon = T
- -- dcTyArgs = [a,b]
dcVanilla :: Bool, -- True <=> This is a vanilla Haskell 98 data constructor
-- Its type is of form
-- forall a1..an . t1 -> ... tm -> T a1..an
- -- No existentials, no GADTs, nothing.
- --
- -- NB1: the order of the forall'd variables does matter;
- -- for a vanilla constructor, we assume that if the result
- -- type is (T t1 ... tn) then we can instantiate the constr
- -- at types [t1, ..., tn]
- --
- -- NB2: a vanilla constructor can still be declared in GADT-style
- -- syntax, provided its type looks like the above.
-
- dcTyVars :: [TyVar], -- Universally-quantified type vars
- -- for the data constructor.
- -- See NB1 on dcVanilla for the conneciton between dcTyVars and dcResTys
- --
- -- In general, the dcTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
+ -- No existentials, no coercions, nothing.
+ -- That is: dcExTyVars = dcEqSpec = dcTheta = []
+ -- NB 1: newtypes always have a vanilla data con
+ -- NB 2: a vanilla constructor can still be declared in GADT-style
+ -- syntax, provided its type looks like the above.
+ -- The declaration format is held in the TyCon (algTcGadtSyntax)
+
+ dcUnivTyVars :: [TyVar], -- Universally-quantified type vars
+ dcExTyVars :: [TyVar], -- Existentially-quantified type vars
+ -- In general, the dcUnivTyVars are NOT NECESSARILY THE SAME AS THE TYVARS
-- FOR THE PARENT TyCon. With GADTs the data con might not even have
-- the same number of type variables.
-- [This is a change (Oct05): previously, vanilla datacons guaranteed to
-- have the same type variables as their parent TyCon, but that seems ugly.]
- dcStupidTheta :: ThetaType, -- This is a "thinned" version of
- -- the context of the data decl.
+ dcEqSpec :: [(TyVar,Type)], -- Equalities derived from the result type,
+ -- *as written by the programmer*
+ -- This field allows us to move conveniently between the two ways
+ -- of representing a GADT constructor's type:
+ -- MkT :: forall a b. (a :=: [b]) => b -> T a
+ -- MkT :: forall b. b -> T [b]
+ -- Each equality is of the form (a :=: ty), where 'a' is one of
+ -- the universally quantified type variables
+
+ dcTheta :: ThetaType, -- The context of the constructor
+ -- In GADT form, this is *exactly* what the programmer writes, even if
+ -- the context constrains only universally quantified variables
+ -- MkT :: forall a. Eq a => a -> T a
+ -- It may contain user-written equality predicates too
+
+ dcStupidTheta :: ThetaType, -- The context of the data type declaration
+ -- data Eq a => T a = ...
+ -- or, rather, a "thinned" version thereof
-- "Thinned", because the Report says
-- to eliminate any constraints that don't mention
-- tyvars free in the arg types for this constructor
--
- -- "Stupid", because the dictionaries aren't used for anything.
+ -- INVARIANT: the free tyvars of dcStupidTheta are a subset of dcUnivTyVars
+ -- Reason: dcStupidTeta is gotten by thinning the stupid theta from the tycon
--
- -- Indeed, [as of March 02] they are no
- -- longer in the type of the wrapper Id, because
- -- that makes it harder to use the wrap-id to rebuild
- -- values after record selection or in generics.
- --
- -- Fact: the free tyvars of dcStupidTheta are a subset of
- -- the free tyvars of dcResTys
- -- Reason: dcStupidTeta is gotten by instantiating the
- -- stupid theta from the tycon (see BuildTyCl.mkDataConStupidTheta)
+ -- "Stupid", because the dictionaries aren't used for anything.
+ -- Indeed, [as of March 02] they are no longer in the type of
+ -- the wrapper Id, because that makes it harder to use the wrap-id
+ -- to rebuild values after record selection or in generics.
- dcTheta :: ThetaType, -- The existentially quantified stuff
-
dcOrigArgTys :: [Type], -- Original argument types
- -- (before unboxing and flattening of
- -- strict fields)
+ -- (before unboxing and flattening of strict fields)
-- Result type of constructor is T t1..tn
dcTyCon :: TyCon, -- Result tycon, T
- dcResTys :: [Type], -- Result type args, t1..tn
-- Now the strictness annotations and field labels of the constructor
dcStrictMarks :: [StrictnessMark],
dcRepStrictness :: [StrictnessMark], -- One for each *representation* argument
dcRepType :: Type, -- Type of the constructor
- -- forall a b . Ord b => a -> [b] -> MkT a
+ -- forall a x y. (a:=:(x,y), Ord x) => x -> y -> MkT a
-- (this is *not* of the constructor wrapper Id:
- -- see notes after this data type declaration)
- --
+ -- see Note [Data con representation] below)
-- Notice that the existential type parameters come *second*.
-- Reason: in a case expression we may find:
-- case (e :: T t) of { MkT b (d:Ord b) (x:t) (xs:[b]) -> ... }
fIRST_TAG = 1 -- Tags allocated from here for real constructors
\end{code}
+Note [Data con representation]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The dcRepType field contains the type of the representation of a contructor
This may differ from the type of the contructor *Id* (built
by MkId.mkDataConId) for two reasons:
\begin{code}
mkDataCon :: Name
-> Bool -- Declared infix
- -> Bool -- Vanilla (see notes with dcVanilla)
-> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ThetaType -> ThetaType
- -> [Type] -> TyCon -> [Type]
- -> DataConIds
+ -> [TyVar] -> [TyVar]
+ -> [(TyVar,Type)] -> ThetaType
+ -> [Type] -> TyCon
+ -> ThetaType -> DataConIds
-> DataCon
-- Can get the tag from the TyCon
-mkDataCon name declared_infix vanilla
+mkDataCon name declared_infix
arg_stricts -- Must match orig_arg_tys 1-1
fields
- tyvars stupid_theta theta orig_arg_tys tycon res_tys
- ids
+ univ_tvs ex_tvs
+ eq_spec theta
+ orig_arg_tys tycon
+ stupid_theta ids
= con
where
- con = MkData {dcName = name,
- dcUnique = nameUnique name, dcVanilla = vanilla,
- dcTyVars = tyvars, dcStupidTheta = stupid_theta, dcTheta = theta,
- dcOrigArgTys = orig_arg_tys, dcTyCon = tycon, dcResTys = res_tys,
+ is_vanilla = null ex_tvs && null eq_spec && null theta
+ con = ASSERT( is_vanilla || not (isNewTyCon tycon) )
+ -- Invariant: newtypes have a vanilla data-con
+ MkData {dcName = name, dcUnique = nameUnique name,
+ dcVanilla = is_vanilla, dcInfix = declared_infix,
+ dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs,
+ dcEqSpec = eq_spec,
+ dcStupidTheta = stupid_theta, dcTheta = theta,
+ dcOrigArgTys = orig_arg_tys, dcTyCon = tycon,
dcRepArgTys = rep_arg_tys,
dcStrictMarks = arg_stricts, dcRepStrictness = rep_arg_stricts,
dcFields = fields, dcTag = tag, dcRepType = ty,
- dcIds = ids, dcInfix = declared_infix}
+ dcIds = ids }
-- Strictness marks for source-args
-- *after unboxing choices*,
-- The 'arg_stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
+ (more_eq_preds, dict_preds) = partition isEqPred theta
dict_tys = mkPredTys theta
real_arg_tys = dict_tys ++ orig_arg_tys
- real_stricts = map mk_dict_strict_mark theta ++ arg_stricts
+ real_stricts = map mk_dict_strict_mark dict_preds ++ arg_stricts
-- Representation arguments and demands
+ -- To do: eliminate duplication with MkId
(rep_arg_stricts, rep_arg_tys) = computeRep real_stricts real_arg_tys
tag = assoc "mkDataCon" (tyConDataCons tycon `zip` [fIRST_TAG..]) con
- ty = mkForAllTys tyvars (mkFunTys rep_arg_tys result_ty)
- -- NB: the existential dict args are already in rep_arg_tys
+ ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $
+ mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $
+ -- NB: the dict args are already in rep_arg_tys
+ -- because they might be flattened..
+ -- but the equality predicates are not
+ mkFunTys rep_arg_tys $
+ mkTyConApp tycon (mkTyVarTys univ_tvs)
- result_ty = mkTyConApp tycon res_tys
+eqSpecPreds :: [(TyVar,Type)] -> ThetaType
+eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ]
mk_dict_strict_mark pred | isStrictPred pred = MarkedStrict
| otherwise = NotMarkedStrict
dataConIsInfix :: DataCon -> Bool
dataConIsInfix = dcInfix
-dataConTyVars :: DataCon -> [TyVar]
-dataConTyVars = dcTyVars
+dataConUnivTyVars :: DataCon -> [TyVar]
+dataConUnivTyVars = dcUnivTyVars
+
+dataConExTyVars :: DataCon -> [TyVar]
+dataConExTyVars = dcExTyVars
+
+dataConAllTyVars :: DataCon -> [TyVar]
+dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
+ = univ_tvs ++ ex_tvs
+
+dataConEqSpec :: DataCon -> [(TyVar,Type)]
+dataConEqSpec = dcEqSpec
+
+dataConTheta :: DataCon -> ThetaType
+dataConTheta = dcTheta
dataConWorkId :: DataCon -> Id
dataConWorkId dc = case dcIds dc of
-- Core constructor application (Con dc args)
dataConRepStrictness dc = dcRepStrictness dc
-dataConSig :: DataCon -> ([TyVar], ThetaType,
- [Type], TyCon, [Type])
+dataConSig :: DataCon -> ([TyVar], ThetaType, [Type])
+dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
+ dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon})
+ = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys)
-dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
- dcOrigArgTys = arg_tys, dcTyCon = tycon, dcResTys = res_tys})
- = (tyvars, theta, arg_tys, tycon, res_tys)
+dataConFullSig :: DataCon
+ -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type])
+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
+ dcTheta = theta, dcOrigArgTys = arg_tys, dcTyCon = tycon})
+ = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys)
dataConStupidTheta :: DataCon -> ThetaType
dataConStupidTheta dc = dcStupidTheta dc
dataConResTys :: DataCon -> [Type]
-dataConResTys dc = dcResTys dc
+dataConResTys dc = [substTyVar env tv | tv <- dcUnivTyVars dc]
+ where
+ env = mkTopTvSubst (dcEqSpec dc)
+
+dataConUserType :: DataCon -> Type
+-- The user-declared type of the data constructor
+-- in the nice-to-read form
+-- T :: forall a. a -> T [a]
+-- rather than
+-- T :: forall b. forall a. (a=[b]) => a -> T b
+dataConUserType (MkData { dcUnivTyVars = univ_tvs,
+ dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
+ dcTheta = theta, dcOrigArgTys = arg_tys,
+ dcTyCon = tycon })
+ = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
+ mkFunTys (mkPredTys theta) $
+ mkFunTys arg_tys $
+ mkTyConApp tycon (map (substTyVar subst) univ_tvs)
+ where
+ subst = mkTopTvSubst eq_spec
dataConInstArgTys :: DataCon
-> [Type] -- Instantiated at these types
-- NB: these INCLUDE the existentially quantified dict args
-- but EXCLUDE the data-decl context which is discarded
-- It's all post-flattening etc; this is a representation type
-dataConInstArgTys (MkData {dcRepArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
+dataConInstArgTys (MkData {dcRepArgTys = arg_tys,
+ dcUnivTyVars = univ_tvs,
+ dcExTyVars = ex_tvs}) inst_tys
= ASSERT( length tyvars == length inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
-
-dataConInstResTy :: DataCon -> [Type] -> Type
-dataConInstResTy (MkData {dcTyVars = tyvars, dcTyCon = tc, dcResTys = res_tys}) inst_tys
- = ASSERT( length tyvars == length inst_tys )
- substTy (zipOpenTvSubst tyvars inst_tys) (mkTyConApp tc res_tys)
- -- res_tys can't currently contain any foralls,
- -- but might in future; hence zipOpenTvSubst
+ where
+ tyvars = univ_tvs ++ ex_tvs
-- And the same deal for the original arg tys
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
-dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys, dcTyVars = tyvars}) inst_tys
+dataConInstOrigArgTys (MkData {dcOrigArgTys = arg_tys,
+ dcUnivTyVars = univ_tvs,
+ dcExTyVars = ex_tvs}) inst_tys
= ASSERT( length tyvars == length inst_tys )
map (substTyWith tyvars inst_tys) arg_tys
+ where
+ tyvars = univ_tvs ++ ex_tvs
\end{code}
These two functions get the real argument types of the constructor,
\begin{code}
zapLamIdInfo :: Id -> Id
-zapLamIdInfo id = maybeModifyIdInfo zapLamInfo id
+zapLamIdInfo id = maybeModifyIdInfo (zapLamInfo (idInfo id)) id
-zapDemandIdInfo id = maybeModifyIdInfo zapDemandInfo id
+zapDemandIdInfo id = maybeModifyIdInfo (zapDemandInfo (idInfo id)) id
\end{code}
mkRecordSelId,
mkPrimOpId, mkFCallId,
- mkReboxingAlt, mkNewTypeBody,
+ mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody,
-- And some particular Ids; see below for why they are wired in
wiredInIds, ghcPrimIds,
import TysWiredIn ( charTy, mkListTy )
import PrelRules ( primOpRules )
import Type ( TyThing(..), mkForAllTy, tyVarsOfTypes )
+import Coercion ( mkSymCoercion, mkUnsafeCoercion )
import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
mkTyConApp, mkTyVarTys, mkClassPred,
mkFunTys, mkFunTy, mkSigmaTy, tcSplitSigmaTy,
import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding )
import Literal ( nullAddrLit, mkStringLit )
import TyCon ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
- tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon )
+ tyConStupidTheta, isProductTyCon, isDataTyCon, isRecursiveTyCon,
+ newTyConCo, tyConArity )
import Class ( Class, classTyCon, classSelIds )
import Var ( Id, TyVar, Var )
import VarSet ( isEmptyVarSet, subVarSet, varSetElems )
import OccName ( mkOccNameFS, varName )
import PrimOp ( PrimOp, primOpSig, primOpOcc, primOpTag )
import ForeignCall ( ForeignCall )
-import DataCon ( DataCon, DataConIds(..), dataConTyVars,
+import DataCon ( DataCon, DataConIds(..), dataConTyCon, dataConUnivTyVars,
dataConFieldLabels, dataConRepArity, dataConResTys,
dataConRepArgTys, dataConRepType,
dataConSig, dataConStrictMarks, dataConExStricts,
\begin{code}
mkDataConIds :: Name -> Name -> DataCon -> DataConIds
- -- Makes the *worker* for the data constructor; that is, the function
- -- that takes the reprsentation arguments and builds the constructor.
mkDataConIds wrap_name wkr_name data_con
| isNewTyCon tycon
= NewDC nt_wrap_id
| otherwise -- Algebraic, no wrapper
= AlgDC Nothing wrk_id
where
- (tyvars, theta, orig_arg_tys, tycon, res_tys) = dataConSig data_con
+ (tvs, theta, orig_arg_tys) = dataConSig data_con
+ tycon = dataConTyCon data_con
dict_tys = mkPredTys theta
all_arg_tys = dict_tys ++ orig_arg_tys
- result_ty = mkTyConApp tycon res_tys
+ tycon_args = dataConUnivTyVars data_con
+ result_ty_args = (mkTyVarTys tycon_args)
+ result_ty = mkTyConApp tycon result_ty_args
- wrap_ty = mkForAllTys tyvars (mkFunTys all_arg_tys result_ty)
+ wrap_ty = mkForAllTys tvs (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.
----------- Worker (algebraic data types only) --------------
+ -- The *worker* for the data constructor is the function that
+ -- takes the representation arguments and builds the constructor.
wrk_id = mkGlobalId (DataConWorkId data_con) wkr_name
(dataConRepType data_con) wkr_info
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkCompulsoryUnfolding $
- mkLams tyvars $ Lam id_arg1 $
- mkNewTypeBody tycon result_ty (Var id_arg1)
+ mkLams tvs $ Lam id_arg1 $
+ wrapNewTypeBody tycon result_ty_args
+ (Var id_arg1)
id_arg1 = mkTemplateLocal 1 (head orig_arg_tys)
-- we want to see that w is strict in its two arguments
alg_unf = mkTopUnfolding $ Note InlineMe $
- mkLams tyvars $
+ mkLams tvs $
mkLams dict_args $ mkLams id_args $
foldr mk_case con_app
(zip (dict_args ++ id_args) all_strict_marks)
i3 []
con_app i rep_ids = mkApps (Var wrk_id)
- (map varToCoreExpr (tyvars ++ reverse rep_ids))
+ (map varToCoreExpr (tvs ++ reverse rep_ids))
(dict_args,i2) = mkLocals 1 dict_tys
(id_args,i3) = mkLocals i2 orig_arg_tys
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.
+Hence the sel_naughty flag, to identify record selectors 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.
+Note [GADT record selectors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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.
| is_naughty = naughty_id
| otherwise = sel_id
where
- is_naughty = not (tyVarsOfType field_ty `subVarSet` tyvar_set)
+ is_naughty = not (tyVarsOfType field_ty `subVarSet` res_tv_set)
sel_id_details = RecordSelId tycon field_label is_naughty
-- Escapist case here for naughty construcotrs
con1 = head data_cons_w_field
res_tys = dataConResTys con1
- tyvar_set = tyVarsOfTypes res_tys
- tyvars = varSetElems tyvar_set
+ res_tv_set = tyVarsOfTypes res_tys
+ res_tvs = varSetElems res_tv_set
data_ty = mkTyConApp tycon res_tys
field_ty = dataConFieldType con1 field_label
-- op (R op) = op
selector_ty :: Type
- selector_ty = mkForAllTys tyvars $ mkForAllTys field_tyvars $
+ selector_ty = mkForAllTys res_tvs $ mkForAllTys field_tyvars $
mkFunTys stupid_dict_tys $ mkFunTys field_dict_tys $
mkFunTy data_ty field_tau
caf_info | no_default = NoCafRefs
| otherwise = MayHaveCafRefs
- sel_rhs = mkLams tyvars $ mkLams field_tyvars $
+ sel_rhs = mkLams res_tvs $ mkLams field_tyvars $
mkLams stupid_dict_ids $ mkLams field_dict_ids $
- Lam data_id $ sel_body
+ Lam data_id $ mk_result sel_body
- sel_body | isNewTyCon tycon = mk_result (mkNewTypeBody tycon field_ty (Var data_id))
+ -- NB: A newtype always has a vanilla DataCon; no existentials etc
+ -- res_tys will simply be the dataConUnivTyVars
+ sel_body | isNewTyCon tycon = unwrapNewTypeBody tycon res_tys (Var data_id)
| 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
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))
+ mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (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),
+ = (dc_tvs ++ mkTemplateLocalsNum arg_base (mkPredTys dc_theta),
mkTemplateLocalsNum arg_base' dc_arg_tys)
- (dc_tyvars, dc_theta, dc_arg_tys, _, _) = dataConSig data_con
+ (dc_tvs, dc_theta, dc_arg_tys) = dataConSig data_con
arg_base' = arg_base + length dc_theta
unpack_base = arg_base' + length dc_arg_tys
go (arg:args) (str:stricts) us
| isMarkedUnboxed str
= let
- (_, tycon_args, pack_con, con_arg_tys)
- = splitProductType "mkReboxingAlt" (idType arg)
+ ty = idType arg
+
+ (tycon, tycon_args, pack_con, con_arg_tys)
+ = splitProductType "mkReboxingAlt" ty
unpacked_args = zipWith (mkSysLocal FSLIT("rb")) us con_arg_tys
(binds, args') = go args stricts (dropList con_arg_tys us)
- con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
+ con_app | isNewTyCon tycon = ASSERT( isSingleton unpacked_args )
+ wrapNewTypeBody tycon tycon_args (Var (head unpacked_args))
+ -- ToDo: is this right? Jun06
+ | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
in
(NonRec arg con_app : binds, unpacked_args ++ args')
tycon = classTyCon clas
[data_con] = tyConDataCons tycon
- tyvars = dataConTyVars data_con
- arg_tys = dataConRepArgTys data_con
+ tyvars = dataConUnivTyVars data_con
+ arg_tys = ASSERT( isVanillaDataCon data_con ) dataConRepArgTys data_con
the_arg_id = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` arg_ids) name
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 (idType the_arg_id)
- [(DataAlt data_con, arg_ids, Var the_arg_id)]
-
-mkNewTypeBody tycon result_ty result_expr
- -- Adds a coerce where necessary
- -- Used for both wrapping and unwrapping
- | isRecursiveTyCon tycon -- Recursive case; use a coerce
- = Note (Coerce result_ty (exprType result_expr)) result_expr
- | otherwise -- Normal case
- = result_expr
+ rhs = mkLams tyvars (Lam dict_id rhs_body)
+ rhs_body | isNewTyCon tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
+ | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
+ [(DataAlt data_con, arg_ids, Var the_arg_id)]
+
+wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+-- 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
+-- 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]
+--
+-- For non-recursive newtypes, GHC currently treats them like type
+-- synonyms, so no cast is necessary. This function is the only
+-- place in the compiler that generates
+--
+wrapNewTypeBody tycon args result_expr
+-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
+ = Cast result_expr co
+-- | otherwise
+-- = result_expr
+ where
+ co = mkTyConApp (newTyConCo tycon) args
+
+unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
+unwrapNewTypeBody tycon args result_expr
+-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
+ = Cast result_expr sym_co
+-- | otherwise
+-- = result_expr
+ where
+ sym_co = mkSymCoercion co
+ co = mkTyConApp (newTyConCo tycon) args
+
+-- Old Definition of mkNewTypeBody
+-- Used for both wrapping and unwrapping
+--mkNewTypeBody tycon result_ty result_expr
+-- | isRecursiveTyCon tycon -- Recursive case; use a coerce
+-- = Note (Coerce result_ty (exprType result_expr)) result_expr
+-- | otherwise -- Normal case
+-- = result_expr
\end{code}
(mkFunTy openAlphaTy openBetaTy)
[x] = mkTemplateLocals [openAlphaTy]
rhs = mkLams [openAlphaTyVar,openBetaTyVar,x] $
- Note (Coerce openBetaTy openAlphaTy) (Var x)
+-- Note (Coerce openBetaTy openAlphaTy) (Var x)
+ Cast (Var x) (mkUnsafeCoercion openAlphaTy openBetaTy)
-- nullAddr# :: Addr#
-- The reason is is here is because we don't provide
-- ** Derived OccNames
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
+ mkNewTyCoOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc
+ mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc
:: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have
mkIPOcc = mk_simple_deriv varName "$i"
mkSpecOcc = mk_simple_deriv varName "$s"
mkForeignExportOcc = mk_simple_deriv varName "$f"
+mkNewTyCoOcc = mk_simple_deriv tcName "Co"
-- Generic derivable classes
mkGenOcc1 = mk_simple_deriv varName "$gfrom"
-- TyVars
TyVar, mkTyVar, mkTcTyVar,
tyVarName, tyVarKind,
- setTyVarName, setTyVarUnique,
+ setTyVarName, setTyVarUnique, setTyVarKind,
tcTyVarDetails,
+ -- CoVars
+ CoVar, coVarName, setCoVarUnique, setCoVarName, mkCoVar, isCoVar,
+
-- Ids
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
#include "HsVersions.h"
-import {-# SOURCE #-} TypeRep( Type )
+import {-# SOURCE #-} TypeRep( Type, Kind, isCoSuperKind )
import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails )
import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId, IdInfo, seqIdInfo )
import Name ( Name, NamedThing(..),
setNameUnique, nameUnique
)
-import Kind ( Kind )
import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey# )
import FastTypes
import Outputable
tyVarKind :: Kind }
| TcTyVar { -- Used only during type inference
+ -- Used for kind variables during
+ -- inference, as well
varName :: !Name,
realUnique :: FastInt,
tyVarKind :: Kind,
tcTyVarDetails :: TcTyVarDetails }
| GlobalId { -- Used for imported Ids, dict selectors etc
+ -- See Note [GlobalId/LocalId] below
varName :: !Name, -- Always an External or WiredIn Name
realUnique :: FastInt,
idType :: Type,
idInfo :: IdInfo,
gblDetails :: GlobalIdDetails }
- | LocalId { -- Used for locally-defined Ids (see NOTE below)
+ | LocalId { -- Used for locally-defined Ids
+ -- See Note [GlobalId/LocalId] below
varName :: !Name,
realUnique :: FastInt,
idType :: Type,
-- NotExported things may be discarded as dead code.
\end{code}
-LocalId and GlobalId
-~~~~~~~~~~~~~~~~~~~~
+Note [GlobalId/LocalId]
+~~~~~~~~~~~~~~~~~~~~~~~
A GlobalId is
* always a constant (top-level)
* imported, or data constructor, or primop, or record selector
* has a Unique that is globally unique across the whole
GHC invocation (a single invocation may compile multiple modules)
+ * never treated as a candidate by the free-variable finder;
+ it's a constant!
A LocalId is
* bound within an expression (lambda, case, local let(rec))
* or defined at top level in the module being compiled
+ * always treated as a candidate by the free-variable finder
After CoreTidy, top-level LocalIds are turned into GlobalIds
setTyVarUnique = setVarUnique
setTyVarName = setVarName
+
+setTyVarKind :: TyVar -> Kind -> TyVar
+setTyVarKind tv k = tv {tyVarKind = k}
\end{code}
\begin{code}
}
\end{code}
+%************************************************************************
+%* *
+\subsection{Coercion variables}
+%* *
+%************************************************************************
+
+\begin{code}
+type CoVar = Var -- A coercion variable is simply a type
+ -- variable of kind (ty1 :=: ty2)
+coVarName = varName
+
+setCoVarUnique = setVarUnique
+setCoVarName = setVarName
+
+mkCoVar :: Name -> Kind -> CoVar
+mkCoVar name kind = mkTyVar name kind
+
+isCoVar :: TyVar -> Bool
+isCoVar ty = isCoSuperKind (tyVarKind ty)
+\end{code}
%************************************************************************
%* *
new_info = fn (idInfo id)
-- maybeModifyIdInfo tries to avoid unnecesary thrashing
-maybeModifyIdInfo :: (IdInfo -> Maybe IdInfo) -> Id -> Id
-maybeModifyIdInfo fn id
- = case fn (idInfo id) of
- Nothing -> id
- Just new_info -> id {idInfo = new_info}
+maybeModifyIdInfo :: Maybe IdInfo -> Id -> Id
+maybeModifyIdInfo (Just new_info) id = id {idInfo = new_info}
+maybeModifyIdInfo Nothing id = id
\end{code}
%************************************************************************
-- InScopeSet
InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet,
- extendInScopeSet, extendInScopeSetList, modifyInScopeSet,
+ extendInScopeSet, extendInScopeSetList, extendInScopeSetSet,
+ modifyInScopeSet,
getInScopeVars, lookupInScope, elemInScopeSet, uniqAway,
mapInScopeSet,
= InScope (foldl (\s v -> extendVarEnv s v v) in_scope vs)
(n +# iUnbox (length vs))
+extendInScopeSetSet :: InScopeSet -> VarEnv Var -> InScopeSet
+extendInScopeSetSet (InScope in_scope n) vs
+ = InScope (in_scope `plusVarEnv` vs) (n +# iUnbox (sizeUFM vs))
+
modifyInScopeSet :: InScopeSet -> Var -> Var -> InScopeSet
-- Exploit the fact that the in-scope "set" is really a map
-- Make old_v map to new_v
projects / ghc-hetmet.git / commitdiff