Commit 27897431 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Indexed newtypes

Mon Sep 18 19:24:27 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Indexed newtypes
  Thu Aug 31 22:09:21 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * 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.
parent d5c4754d
......@@ -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
}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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.
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment