From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 18:40:35 +0000 (+0000) Subject: Indexed newtypes X-Git-Tag: After_FC_branch_merge~19 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=27897431cf24d4bde04b15947440c7205f2d703c Indexed newtypes Mon Sep 18 19:24:27 EDT 2006 Manuel M T Chakravarty * Indexed newtypes Thu Aug 31 22:09:21 EDT 2006 Manuel M T Chakravarty * Indexed newtypes - This patch makes indexed newtypes work - Only lightly tested - We need to distinguish between open and closed newtypes in a number of places, because looking through newtypes doesn't work easily for open ones. --- diff --git a/compiler/basicTypes/DataCon.lhs b/compiler/basicTypes/DataCon.lhs index aa87958..3de9905 100644 --- a/compiler/basicTypes/DataCon.lhs +++ b/compiler/basicTypes/DataCon.lhs @@ -38,7 +38,8 @@ import Type ( Type, ThetaType, import Coercion ( isEqPred, mkEqPred ) import TyCon ( TyCon, FieldLabel, tyConDataCons, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, - isNewTyCon, isRecursiveTyCon, tyConFamInst_maybe ) + isNewTyCon, isClosedNewTyCon, isRecursiveTyCon, + tyConFamInst_maybe ) import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique, mkSysTvName, mkSystemName ) import Var ( TyVar, CoVar, Id, mkTyVar, tyVarKind, setVarUnique, @@ -727,9 +728,10 @@ splitProductType str ty deepSplitProductType_maybe ty = do { (res@(tycon, tycon_args, _, _)) <- splitProductType_maybe ty ; let {result - | isNewTyCon tycon && not (isRecursiveTyCon tycon) + | isClosedNewTyCon tycon && not (isRecursiveTyCon tycon) = deepSplitProductType_maybe (newTyConInstRhs tycon tycon_args) - | isNewTyCon tycon = Nothing -- cannot unbox through recursive newtypes + | isNewTyCon tycon = Nothing -- cannot unbox through recursive + -- newtypes nor through families | otherwise = Just res} ; result } diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 0ad0bc6..fda6763 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -394,6 +394,15 @@ wrapFamInstBody tycon args result_expr | otherwise = result_expr +-- Apply the coercion in the opposite direction. +-- +unwrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr +unwrapFamInstBody tycon args result_expr + | Just co_con <- tyConFamilyCoercion_maybe tycon + = mkCoerce (mkTyConApp co_con args) result_expr + | otherwise + = result_expr + \end{code} @@ -842,12 +851,25 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr -- 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 - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr - | otherwise - = result_expr + = wrapFamInstBody tycon args inner + where + inner + | Just co_con <- newTyConCo 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 diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index e7d79e6..246bfa0 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -69,7 +69,7 @@ collect_tdefs tcon tdefs -- | null (tyConDataCons tcon) = error "MkExternalCore died: can't handle datatype declarations with no data constructors" | otherwise = C.Data (make_con_qid (tyConName tcon)) (map make_tbind tyvars) (map make_cdef (tyConDataCons tcon)) - where repclause | isRecursiveTyCon tcon = Nothing + where repclause | isRecursiveTyCon tcon || isOpenTyCon tcon= Nothing | otherwise = Just (make_ty rep) where (_, rep) = newTyConRep tcon tyvars = tyConTyVars tcon diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs index 4f44eb2..8c5a743 100644 --- a/compiler/deSugar/DsUtils.lhs +++ b/compiler/deSugar/DsUtils.lhs @@ -312,7 +312,7 @@ mkCoAlgCaseMatchResult var ty match_alts arg_id1 = head arg_ids1 var_ty = idType var (tc, ty_args) = splitNewTyConApp var_ty - newtype_rhs = unwrapNewTypeBody tycon ty_args (Var var) + newtype_rhs = unwrapNewTypeBody tc ty_args (Var var) -- Stuff for data types data_cons = tyConDataCons tycon diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs index ebe4083..32402b2 100644 --- a/compiler/simplCore/SimplUtils.lhs +++ b/compiler/simplCore/SimplUtils.lhs @@ -51,7 +51,7 @@ import Type ( Type, splitFunTys, dropForAlls, isStrictType, import Coercion ( isEqPredTy ) import Coercion ( Coercion, mkUnsafeCoercion, coercionKind ) -import TyCon ( tyConDataCons_maybe, isNewTyCon ) +import TyCon ( tyConDataCons_maybe, isClosedNewTyCon ) import DataCon ( DataCon, dataConRepArity, dataConExTyVars, dataConInstArgTys, dataConTyCon ) import VarSet @@ -1467,7 +1467,7 @@ mkCase1 scrut case_bndr ty alts -- Identity case identity_alt (con, args, rhs) = de_note rhs `cheapEqExpr` identity_rhs con args identity_rhs (DataAlt con) args - | isNewTyCon (dataConTyCon con) + | isClosedNewTyCon (dataConTyCon con) = wrapNewTypeBody (dataConTyCon con) arg_tys (varToCoreExpr $ head args) | otherwise = mkConApp con (arg_ty_exprs ++ varsToCoreExprs args) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index f165e2e..0f923ff 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -47,7 +47,7 @@ import TysWiredIn ( boolTy, parrTyCon, tupleTyCon ) import Type ( Type, mkTyConApp, substTys, substTheta ) import StaticFlags ( opt_IrrefutableTuples ) import TyCon ( TyCon, FieldLabel, tyConFamInst_maybe, - tyConFamilyCoercion_maybe, tyConTyVars ) + tyConFamilyCoercion_maybe, tyConTyVars, isNewTyCon ) import DataCon ( DataCon, dataConTyCon, dataConFullSig, dataConName, dataConFieldLabels, dataConSourceArity, dataConStupidTheta, dataConUnivTyVars ) @@ -586,6 +586,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside -- representation tycon. -- boxySplitTyConAppWithFamily tycon pat_ty = + traceTc traceMsg >> case tyConFamInst_maybe tycon of Nothing -> boxySplitTyConApp tycon pat_ty Just (fam_tycon, instTys) -> @@ -594,6 +595,12 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside ; boxyUnifyList (substTys subst instTys) scrutinee_arg_tys ; return freshTvs } + where + traceMsg = sep [ text "tcConPat:boxySplitTyConAppWithFamily:" <+> + ppr tycon <+> ppr pat_ty + , text " family instance:" <+> + ppr (tyConFamInst_maybe tycon) + ] -- Wraps the pattern (which must be a ConPatOut pattern) in a coercion -- pattern if the tycon is an instance of a family. @@ -601,6 +608,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside unwrapFamInstScrutinee :: TyCon -> [Type] -> Pat Id -> Pat Id unwrapFamInstScrutinee tycon args pat | Just co_con <- tyConFamilyCoercion_maybe tycon +-- , not (isNewTyCon tycon) -- newtypes are explicitly unwrapped by + -- the desugarer -- NB: We can use CoPat directly, rather than mkCoPat, as we know the -- coercion is not the identity; mkCoPat is inconvenient as it -- wants a located pattern. diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index fb91a0d..ff49a6e 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -40,7 +40,7 @@ import Type ( Type, Kind, PredType, substTyWith, mkAppTy, mkForAllTy, coreEqType, splitAppTys, isTyVarTy, splitTyConApp_maybe, tyVarsOfType, mkTyVarTys ) -import TyCon ( TyCon, tyConArity, mkCoercionTyCon, isNewTyCon, +import TyCon ( TyCon, tyConArity, mkCoercionTyCon, isClosedNewTyCon, newTyConRhs, newTyConCo, isCoercionTyCon, isCoercionTyCon_maybe ) import Var ( Var, TyVar, isTyVar, tyVarKind ) @@ -451,7 +451,7 @@ splitNewTypeRepCo_maybe :: Type -> Maybe (Type, Coercion) splitNewTypeRepCo_maybe ty | Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty' splitNewTypeRepCo_maybe (TyConApp tc tys) - | isNewTyCon tc + | isClosedNewTyCon tc = ASSERT( tys `lengthIs` tyConArity tc ) -- splitNewTypeRepCo_maybe only be applied -- to *types* (of kind *) case newTyConRhs tc of diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index d536f59..1464fab 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -14,7 +14,8 @@ module TyCon( SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, - isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, + isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isClosedNewTyCon, + isPrimTyCon, isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon, assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, @@ -560,6 +561,14 @@ isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of _ -> False isNewTyCon other = False +-- This is an important refinement as typical newtype optimisations do *not* +-- hold for newtype families. Why? Given a type `T a', if T is a newtype +-- family, there is no unique right hand side by which `T a' can be replaced +-- by a cast. +-- +isClosedNewTyCon :: TyCon -> Bool +isClosedNewTyCon tycon = isNewTyCon tycon && not (isOpenTyCon tycon) + isProductTyCon :: TyCon -> Bool -- A "product" tycon -- has *one* constructor, diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index b7f1a00..e872d6a 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -117,8 +117,8 @@ import PrelNames( openTypeKindTyConKey, unliftedTypeKindTyConKey, ubxTupleKindTyConKey, argTypeKindTyConKey ) import TyCon ( TyCon, isRecursiveTyCon, isPrimTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, isNewTyCon, isOpenTyCon, newTyConRep, - newTyConRhs, + isFunTyCon, isNewTyCon, isClosedNewTyCon, isOpenTyCon, + newTyConRep, newTyConRhs, isAlgTyCon, tyConArity, isSuperKindTyCon, tcExpandTyCon_maybe, coreExpandTyCon_maybe, tyConKind, PrimRep(..), tyConPrimRep, tyConUnique, @@ -458,8 +458,7 @@ repType :: Type -> Type repType ty | Just ty' <- coreView ty = repType ty' repType (ForAllTy _ ty) = repType ty repType (TyConApp tc tys) - | isNewTyCon tc && - not (isOpenTyCon tc) = -- Recursive newtypes are opaque to coreView + | isClosedNewTyCon tc = -- Recursive newtypes are opaque to coreView -- but we must expand them here. Sure to -- be saturated because repType is only applied -- to types of kind * @@ -618,7 +617,7 @@ splitRecNewType_maybe :: Type -> Maybe Type -- Only applied to types of kind *, hence the newtype is always saturated splitRecNewType_maybe ty | Just ty' <- coreView ty = splitRecNewType_maybe ty' splitRecNewType_maybe (TyConApp tc tys) - | isNewTyCon tc + | isClosedNewTyCon tc = ASSERT( tys `lengthIs` tyConArity tc ) -- splitRecNewType_maybe only be applied -- to *types* (of kind *) ASSERT( isRecursiveTyCon tc ) -- Guaranteed by coreView