X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=de5893b071b8732204cea4674333e39e39bef1a0;hp=175bc5b8cbf8856c41a35a0d7dfb5fd5a79776e5;hb=08a681f1f95b465867c362faf8eb1b40f7bd19dd;hpb=574022a869f3a24f58fc3e55d586773f24c57724 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 175bc5b..de5893b 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -12,10 +12,9 @@ module TcTyClsDecls ( import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ConDecl(..), Sig(..), NewOrData(..), ResType(..), - tyClDeclTyVars, isSynDecl, isClassDecl, isIdxTyDecl, + tyClDeclTyVars, isSynDecl, isIdxTyDecl, isKindSigDecl, hsConArgs, LTyClDecl, tcdName, - hsTyVarName, LHsTyVarBndr, LHsType, HsType(..), - mkHsAppTy + hsTyVarName, LHsTyVarBndr, LHsType ) import HsTypes ( HsBang(..), getBangStrictness, hsLTyVarNames ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) @@ -38,9 +37,9 @@ import TcMType ( newKindVar, checkValidTheta, checkValidType, -- checkFreeness, UserTypeCtxt(..), SourceTyCtxt(..) ) import TcType ( TcKind, TcType, Type, tyVarsOfType, mkPhiTy, - mkArrowKind, liftedTypeKind, mkTyVarTys, - tcSplitSigmaTy, tcEqTypes, tcGetTyVar_maybe ) -import Type ( PredType(..), splitTyConApp_maybe, mkTyVarTy, + mkArrowKind, liftedTypeKind, + tcSplitSigmaTy, tcGetTyVar_maybe ) +import Type ( splitTyConApp_maybe, newTyConInstRhs, isLiftedTypeKind, Kind, splitKindFunTys, mkArrowKinds -- pprParendType, pprThetaArrow @@ -51,22 +50,23 @@ import TyCon ( TyCon, AlgTyConRhs( AbstractTyCon, OpenDataTyCon, OpenNewTyCon ), SynTyConRhs( OpenSynTyCon, SynonymTyCon ), tyConDataCons, mkForeignTyCon, isProductTyCon, - isRecursiveTyCon, isOpenTyCon, + isRecursiveTyCon, tyConStupidTheta, synTyConRhs, isSynTyCon, tyConName, isNewTyCon, isDataTyCon, tyConKind, setTyConArgPoss ) import DataCon ( DataCon, dataConUserType, dataConName, dataConFieldLabels, dataConTyCon, dataConAllTyVars, dataConFieldType, dataConResTys ) -import Var ( TyVar, idType, idName ) +import Var ( TyVar, idType, idName, tyVarName, setTyVarName ) import VarSet ( elemVarSet, mkVarSet ) -import Name ( Name, getSrcLoc ) +import Name ( Name, getSrcLoc, tidyNameOcc, getOccName ) +import OccName ( initTidyOccEnv, tidyOccName ) import Outputable import Maybe ( isJust, fromJust, isNothing, catMaybes ) import Maybes ( expectJust ) import Monad ( unless ) import Unify ( tcMatchTys, tcMatchTyX ) -import Util ( zipLazy, isSingleton, notNull, sortLe ) +import Util ( zipLazy, isSingleton, notNull, sortLe, mapAccumL ) import List ( partition, elemIndex ) import SrcLoc ( Located(..), unLoc, getLoc, srcLocSpan, srcSpanStart ) @@ -797,11 +797,12 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- Data types { ctxt' <- tcHsKindedContext ctxt ; (univ_tvs, ex_tvs, eq_preds, data_tc) <- tcResultType tycon tc_tvs tvs' res_ty ; let + -- Tiresome: tidy the tyvar binders, since tc_tvs and tvs' may have the same OccNames tc_datacon is_infix field_lbls btys = do { let bangs = map getBangStrictness btys ; arg_tys <- mappM tcHsBangType btys ; buildDataCon (unLoc name) is_infix - (argStrictness unbox_strict tycon bangs arg_tys) + (argStrictness unbox_strict bangs arg_tys) (map unLoc field_lbls) univ_tvs ex_tvs eq_preds ctxt' arg_tys data_tc } @@ -823,7 +824,7 @@ tcResultType :: TyCon -> [TyVar] -- where MkT :: forall a b c. ... -> ResType Name -> TcM ([TyVar], -- Universal - [TyVar], -- Existential + [TyVar], -- Existential (distinct OccNames from univs) [(TyVar,Type)], -- Equality predicates TyCon) -- TyCon given in the ResTy -- We don't check that the TyCon given in the ResTy is @@ -843,8 +844,8 @@ tcResultType _ tc_tvs dc_tvs (ResTyGADT res_ty) -- ([a,z,c], [x,y], [a:=:(x,y), c:=:z], T) = do { (dc_tycon, res_tys) <- tcLHsConResTy res_ty - -- NB: tc_tvs and dc_tvs are distinct - ; let univ_tvs = choose_univs [] tc_tvs res_tys + + ; let univ_tvs = choose_univs [] tidy_tc_tvs res_tys -- Each univ_tv is either a dc_tv or a tc_tv ex_tvs = dc_tvs `minusList` univ_tvs eq_spec = [ (tv, ty) | (tv,ty) <- univ_tvs `zip` res_tys, @@ -861,13 +862,25 @@ tcResultType _ tc_tvs dc_tvs (ResTyGADT res_ty) | otherwise = tc_tv : choose_univs used tc_tvs res_tys -------------------- + -- NB: tc_tvs and dc_tvs are distinct, but + -- we want them to be *visibly* distinct, both for + -- interface files and general confusion. So rename + -- the tc_tvs, since they are not used yet (no + -- consequential renaming needed) + init_occ_env = initTidyOccEnv (map getOccName dc_tvs) + (_, tidy_tc_tvs) = mapAccumL tidy_one init_occ_env tc_tvs + tidy_one env tv = (env', setTyVarName tv (tidyNameOcc name occ')) + where + name = tyVarName tv + (env', occ') = tidyOccName env (getOccName name) + + ------------------- argStrictness :: Bool -- True <=> -funbox-strict_fields - -> TyCon -> [HsBang] + -> [HsBang] -> [TcType] -> [StrictnessMark] -argStrictness unbox_strict tycon bangs arg_tys +argStrictness unbox_strict bangs arg_tys = ASSERT( length bangs == length arg_tys ) - zipWith (chooseBoxingStrategy unbox_strict tycon) arg_tys bangs + zipWith (chooseBoxingStrategy unbox_strict) arg_tys bangs -- We attempt to unbox/unpack a strict field when either: -- (i) The field is marked '!!', or @@ -875,8 +888,8 @@ argStrictness unbox_strict tycon bangs arg_tys -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TyCon -> TcType -> HsBang -> StrictnessMark -chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang +chooseBoxingStrategy :: Bool -> TcType -> HsBang -> StrictnessMark +chooseBoxingStrategy unbox_strict_fields arg_ty bang = case bang of HsNoBang -> NotMarkedStrict HsStrict | unbox_strict_fields @@ -889,13 +902,21 @@ chooseBoxingStrategy unbox_strict_fields tycon arg_ty bang can_unbox arg_ty = case splitTyConApp_maybe arg_ty of Nothing -> False Just (arg_tycon, tycon_args) -> - not (isRecursiveTyCon tycon) && + not (isRecursiveTyCon arg_tycon) && -- Note [Recusive unboxing] isProductTyCon arg_tycon && (if isNewTyCon arg_tycon then can_unbox (newTyConInstRhs arg_tycon tycon_args) else True) \end{code} +Note [Recursive unboxing] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Be careful not to try to unbox this! + data T = MkT !T Int +But it's the *argument* type that matters. This is fine: + data S = MkS S !Int +because Int is non-recursive. + %************************************************************************ %* * \subsection{Dependency analysis}