From: Manuel M T Chakravarty Date: Mon, 18 Sep 2006 18:10:54 +0000 (+0000) Subject: Massive patch for the first months work adding System FC to GHC #1 X-Git-Tag: After_FC_branch_merge~116 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=d5bba9ee196f64a077e922680b16fe6f28fb79db Massive patch for the first months work adding System FC to GHC #1 Fri Aug 4 15:11:01 EDT 2006 Manuel M T Chakravarty * Massive patch for the first months work adding System FC to GHC #1 Broken up massive patch -=chak Original log message: This is (sadly) all done in one patch to avoid Darcs bugs. It's not complete work... more FC stuff to come. A compiler using just this patch will fail dismally. --- diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 6b662bd..ab6d463 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -31,6 +31,8 @@ module BasicTypes( TopLevelFlag(..), isTopLevel, isNotTopLevel, + OverlapFlag(..), + Boxity(..), isBoxed, TupCon(..), tupleParens, @@ -217,7 +219,7 @@ instance Outputable TopLevelFlag where %************************************************************************ %* * -\subsection[Top-level/local]{Top-level/not-top level flag} + Top-level/not-top level flag %* * %************************************************************************ @@ -235,7 +237,7 @@ isBoxed Unboxed = False %************************************************************************ %* * -\subsection[Recursive/Non-Recursive]{Recursive/Non-Recursive flag} + Recursive/Non-Recursive flag %* * %************************************************************************ @@ -263,6 +265,46 @@ instance Outputable RecFlag where %************************************************************************ %* * + 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 %* * %************************************************************************ diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index 8b1ed9e..3eaadf7 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -8,10 +8,11 @@ module DataCon ( 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, @@ -27,21 +28,25 @@ module DataCon ( #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} @@ -184,68 +189,77 @@ data DataCon -- 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], @@ -266,10 +280,9 @@ data DataCon 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]) -> ... } @@ -321,6 +334,8 @@ fIRST_TAG :: ConTag 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: @@ -379,29 +394,36 @@ instance Show DataCon where \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*, @@ -410,18 +432,26 @@ mkDataCon name declared_infix vanilla -- 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 @@ -443,8 +473,21 @@ dataConRepType = dcRepType 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 @@ -505,18 +548,41 @@ dataConRepStrictness :: DataCon -> [StrictnessMark] -- 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 @@ -525,22 +591,23 @@ dataConInstArgTys :: DataCon -- 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, diff --git a/compiler/basicTypes/Id.lhs b/compiler/basicTypes/Id.lhs index 798bde6..e14e47a 100644 --- a/compiler/basicTypes/Id.lhs +++ b/compiler/basicTypes/Id.lhs @@ -525,8 +525,8 @@ clearOneShotLambda id \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} diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 8f71aab..33482fe 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -20,7 +20,7 @@ module MkId ( mkRecordSelId, mkPrimOpId, mkFCallId, - mkReboxingAlt, mkNewTypeBody, + mkReboxingAlt, wrapNewTypeBody, unwrapNewTypeBody, -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, @@ -46,6 +46,7 @@ import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, 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, @@ -56,7 +57,8 @@ import CoreUtils ( exprType ) 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 ) @@ -64,7 +66,7 @@ import Name ( mkFCallName, mkWiredInName, Name, BuiltInSyntax(..) ) 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, @@ -184,8 +186,6 @@ Notice that \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 @@ -196,18 +196,23 @@ mkDataConIds wrap_name wkr_name data_con | 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 @@ -253,8 +258,9 @@ mkDataConIds wrap_name wkr_name data_con -- 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) @@ -282,14 +288,14 @@ mkDataConIds wrap_name wkr_name data_con -- 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 @@ -391,11 +397,13 @@ We obviously can't define 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. @@ -424,7 +432,7 @@ mkRecordSelId tycon field_label | 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 @@ -440,8 +448,8 @@ mkRecordSelId tycon field_label 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 @@ -475,7 +483,7 @@ mkRecordSelId tycon 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 @@ -515,11 +523,13 @@ mkRecordSelId tycon field_label 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 @@ -533,18 +543,17 @@ mkRecordSelId tycon field_label 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 @@ -602,12 +611,17 @@ mkReboxingAlt us con args rhs 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') @@ -672,26 +686,58 @@ mkDictSelId name clas 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} @@ -882,7 +928,8 @@ unsafeCoerceId (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 diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs index a3661a9..48137c6 100644 --- a/compiler/basicTypes/OccName.lhs +++ b/compiler/basicTypes/OccName.lhs @@ -28,6 +28,7 @@ module OccName ( -- ** Derived OccNames mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, + mkNewTyCoOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, @@ -425,7 +426,7 @@ mk_deriv occ_sp sys_prefix str = mkOccName occ_sp (sys_prefix ++ str) 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 @@ -440,6 +441,7 @@ mkDictOcc = mk_simple_deriv varName "$d" 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" diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index 4ba7d89..697f089 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -12,9 +12,12 @@ module Var ( -- 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, @@ -32,14 +35,13 @@ module Var ( #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 @@ -68,19 +70,23 @@ data Var 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, @@ -94,17 +100,20 @@ data LocalIdDetails -- 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 @@ -169,6 +178,9 @@ tyVarName = varName setTyVarUnique = setVarUnique setTyVarName = setVarName + +setTyVarKind :: TyVar -> Kind -> TyVar +setTyVarKind tv k = tv {tyVarKind = k} \end{code} \begin{code} @@ -187,6 +199,26 @@ mkTcTyVar name kind details } \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} %************************************************************************ %* * @@ -246,11 +278,9 @@ modifyIdInfo fn id 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} %************************************************************************ diff --git a/compiler/basicTypes/VarEnv.lhs b/compiler/basicTypes/VarEnv.lhs index dba4ec0..e59c800 100644 --- a/compiler/basicTypes/VarEnv.lhs +++ b/compiler/basicTypes/VarEnv.lhs @@ -20,7 +20,8 @@ module VarEnv ( -- InScopeSet InScopeSet, emptyInScopeSet, mkInScopeSet, delInScopeSet, - extendInScopeSet, extendInScopeSetList, modifyInScopeSet, + extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, + modifyInScopeSet, getInScopeVars, lookupInScope, elemInScopeSet, uniqAway, mapInScopeSet, @@ -80,6 +81,10 @@ extendInScopeSetList (InScope in_scope n) vs = 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