Commit e8aa8ccb authored by eir@cis.upenn.edu's avatar eir@cis.upenn.edu

Implement "roles" into GHC.

Roles are a solution to the GeneralizedNewtypeDeriving type-safety
problem.

Roles were first described in the "Generative type abstraction" paper,
by Stephanie Weirich, Dimitrios Vytiniotis, Simon PJ, and Steve Zdancewic.
The implementation is a little different than that paper. For a quick
primer, check out Note [Roles] in Coercion. Also see
http://ghc.haskell.org/trac/ghc/wiki/Roles
and
http://ghc.haskell.org/trac/ghc/wiki/RolesImplementation
For a more formal treatment, check out docs/core-spec/core-spec.pdf.

This fixes Trac #1496, #4846, #7148.
parent 303d3de9
......@@ -650,11 +650,12 @@ mkDataCon name declared_infix
| isJust (promotableTyCon_maybe rep_tycon)
-- The TyCon is promotable only if all its datacons
-- are, so the promoteType for prom_kind should succeed
= Just (mkPromotedDataCon con name (getUnique name) prom_kind arity)
= Just (mkPromotedDataCon con name (getUnique name) prom_kind roles)
| otherwise
= Nothing
prom_kind = promoteType (dataConUserType con)
arity = dataConSourceArity con
roles = map (const Nominal) (univ_tvs ++ ex_tvs) ++
map (const Representational) orig_arg_tys
eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv) ty | (tv,ty) <- spec ]
......@@ -996,6 +997,7 @@ dataConCannotMatch tys con
\begin{code}
buildAlgTyCon :: Name
-> [TyVar] -- ^ Kind variables and type variables
-> [Role]
-> Maybe CType
-> ThetaType -- ^ Stupid theta
-> AlgTyConRhs
......@@ -1005,14 +1007,14 @@ buildAlgTyCon :: Name
-> TyConParent
-> TyCon
buildAlgTyCon tc_name ktvs cType stupid_theta rhs
buildAlgTyCon tc_name ktvs roles cType stupid_theta rhs
is_rec is_promotable gadt_syn parent
= tc
where
kind = mkPiKinds ktvs liftedTypeKind
-- tc and mb_promoted_tc are mutually recursive
tc = mkAlgTyCon tc_name kind ktvs cType stupid_theta
tc = mkAlgTyCon tc_name kind ktvs roles cType stupid_theta
rhs parent is_rec gadt_syn
mb_promoted_tc
......
......@@ -547,7 +547,7 @@ mkDataConRep dflags fam_envs wrap_name data_con
initial_wrap_app = Var (dataConWorkId data_con)
`mkTyApps` res_ty_args
`mkVarApps` ex_tvs
`mkCoApps` map (mkReflCo . snd) eq_spec
`mkCoApps` map (mkReflCo Nominal . snd) eq_spec
-- Dont box the eq_spec coercions since they are
-- marked as HsUnpack by mk_dict_strict_mark
......@@ -823,7 +823,7 @@ wrapNewTypeBody tycon args result_expr
wrapFamInstBody tycon args $
mkCast result_expr (mkSymCo co)
where
co = mkUnbranchedAxInstCo (newTyConCo tycon) args
co = mkUnbranchedAxInstCo Representational (newTyConCo tycon) args
-- 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
......@@ -833,7 +833,7 @@ wrapNewTypeBody tycon args result_expr
unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapNewTypeBody tycon args result_expr
= ASSERT( isNewTyCon tycon )
mkCast result_expr (mkUnbranchedAxInstCo (newTyConCo tycon) args)
mkCast result_expr (mkUnbranchedAxInstCo Representational (newTyConCo tycon) args)
-- If the type constructor is a representation type of a data instance, wrap
-- the expression into a cast adjusting the expression type, which is an
......@@ -843,7 +843,7 @@ unwrapNewTypeBody tycon args result_expr
wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
wrapFamInstBody tycon args body
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCast body (mkSymCo (mkUnbranchedAxInstCo co_con args))
= mkCast body (mkSymCo (mkUnbranchedAxInstCo Representational co_con args))
| otherwise
= body
......@@ -851,7 +851,7 @@ wrapFamInstBody tycon args body
-- represented by a `CoAxiom`, and not a `TyCon`
wrapTypeFamInstBody :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
wrapTypeFamInstBody axiom ind args body
= mkCast body (mkSymCo (mkAxInstCo axiom ind args))
= mkCast body (mkSymCo (mkAxInstCo Representational axiom ind args))
wrapTypeUnbranchedFamInstBody :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
wrapTypeUnbranchedFamInstBody axiom
......@@ -860,13 +860,13 @@ wrapTypeUnbranchedFamInstBody axiom
unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
unwrapFamInstScrut tycon args scrut
| Just co_con <- tyConFamilyCoercion_maybe tycon
= mkCast scrut (mkUnbranchedAxInstCo co_con args) -- data instances only
= mkCast scrut (mkUnbranchedAxInstCo Representational co_con args) -- data instances only
| otherwise
= scrut
unwrapTypeFamInstScrut :: CoAxiom br -> Int -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeFamInstScrut axiom ind args scrut
= mkCast scrut (mkAxInstCo axiom ind args)
= mkCast scrut (mkAxInstCo Representational axiom ind args)
unwrapTypeUnbranchedFamInstScrut :: CoAxiom Unbranched -> [Type] -> CoreExpr -> CoreExpr
unwrapTypeUnbranchedFamInstScrut axiom
......
......@@ -16,6 +16,11 @@ module SMRep (
WordOff, ByteOff,
roundUpToWords,
#if __GLASGOW_HASKELL__ > 706
-- ** Immutable arrays of StgWords
UArrayStgWord, listArray, toByteArray,
#endif
-- * Closure repesentation
SMRep(..), -- CmmInfo sees the rep; no one else does
IsStatic,
......@@ -49,8 +54,13 @@ import DynFlags
import Outputable
import Platform
import FastString
import qualified Data.Array.Base as Array
#if __GLASGOW_HASKELL__ > 706
import GHC.Base ( ByteArray# )
import Data.Ix
#endif
import Data.Array.Base
import Data.Char( ord )
import Data.Word
import Data.Bits
......@@ -80,7 +90,11 @@ newtype StgWord = StgWord Word64
#if __GLASGOW_HASKELL__ < 706
Num,
#endif
Bits, IArray UArray)
#if __GLASGOW_HASKELL__ <= 706
Array.IArray Array.UArray,
#endif
Bits)
fromStgWord :: StgWord -> Integer
fromStgWord (StgWord i) = toInteger i
......@@ -125,6 +139,30 @@ hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int
hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2
\end{code}
%************************************************************************
%* *
Immutable arrays of StgWords
%* *
%************************************************************************
\begin{code}
#if __GLASGOW_HASKELL__ > 706
-- TODO: Improve with newtype coercions!
newtype UArrayStgWord i = UArrayStgWord (Array.UArray i Word64)
listArray :: Ix i => (i, i) -> [StgWord] -> UArrayStgWord i
listArray (i,j) words
= UArrayStgWord $ Array.listArray (i,j) (map unStgWord words)
where unStgWord (StgWord w64) = w64
toByteArray :: UArrayStgWord i -> ByteArray#
toByteArray (UArrayStgWord (Array.UArray _ _ _ b)) = b
#endif
\end{code}
%************************************************************************
%* *
......
This diff is collapsed.
......@@ -1163,7 +1163,7 @@ data ConCont = CC [CoreExpr] Coercion
-- where t1..tk are the *universally-qantified* type args of 'dc'
exprIsConApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
exprIsConApp_maybe (in_scope, id_unf) expr
= go (Left in_scope) expr (CC [] (mkReflCo (exprType expr)))
= go (Left in_scope) expr (CC [] (mkReflCo Representational (exprType expr)))
where
go :: Either InScopeSet Subst
-> CoreExpr -> ConCont
......@@ -1252,9 +1252,11 @@ dealWithCoercion co dc dc_args
-- Make the "theta" from Fig 3 of the paper
gammas = decomposeCo tc_arity co
theta_subst = liftCoSubstWith
theta_subst = liftCoSubstWith Representational
(dc_univ_tyvars ++ dc_ex_tyvars)
(gammas ++ map mkReflCo (stripTypeArgs ex_args))
-- existentials are at role N
(gammas ++ map (mkReflCo Nominal)
(stripTypeArgs ex_args))
-- Cast the value arguments (which include dictionaries)
new_val_args = zipWith cast_arg arg_tys val_args
......
......@@ -187,9 +187,12 @@ mkCast (Coercion e_co) co
= Coercion (mkCoCast e_co co)
mkCast (Cast expr co2) co
= ASSERT(let { Pair from_ty _to_ty = coercionKind co;
Pair _from_ty2 to_ty2 = coercionKind co2} in
from_ty `eqType` to_ty2 )
= WARN(let { Pair from_ty _to_ty = coercionKind co;
Pair _from_ty2 to_ty2 = coercionKind co2} in
not (from_ty `eqType` to_ty2),
vcat ([ ptext (sLit "expr:") <+> ppr expr
, ptext (sLit "co2:") <+> ppr co2
, ptext (sLit "co:") <+> ppr co ]) )
mkCast expr (mkTransCo co2 co)
mkCast expr co
......@@ -1602,7 +1605,7 @@ need to address that here.
\begin{code}
tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
tryEtaReduce bndrs body
= go (reverse bndrs) body (mkReflCo (exprType body))
= go (reverse bndrs) body (mkReflCo Representational (exprType body))
where
incoming_arity = count isId bndrs
......@@ -1659,9 +1662,10 @@ tryEtaReduce bndrs body
| Just tv <- getTyVar_maybe ty
, bndr == tv = Just (mkForAllCo tv co)
ok_arg bndr (Var v) co
| bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co)
| bndr == v = Just (mkFunCo Representational
(mkReflCo Representational (idType bndr)) co)
ok_arg bndr (Cast (Var v) co_arg) co
| bndr == v = Just (mkFunCo (mkSymCo co_arg) co)
| bndr == v = Just (mkFunCo Representational (mkSymCo co_arg) co)
-- The simplifier combines multiple casts into one,
-- so we can have a simple-minded pattern match here
ok_arg _ _ _ = Nothing
......
......@@ -34,7 +34,7 @@ data Exp
| Lam Bind Exp
| Let Vdefg Exp
| Case Exp Vbind Ty [Alt] {- non-empty list -}
| Cast Exp Ty
| Cast Exp Coercion
| Tick String Exp {- XXX probably wrong -}
| External String String Ty {- target name, convention, and type -}
| DynExternal String Ty {- convention and type (incl. Addr# of target as first arg) -}
......@@ -52,23 +52,30 @@ data Alt
type Vbind = (Var,Ty)
type Tbind = (Tvar,Kind)
-- Internally, we represent types and coercions separately; but for
-- the purposes of external core (at least for now) it's still
-- convenient to collapse them into a single type.
data Ty
= Tvar Tvar
| Tcon (Qual Tcon)
| Tapp Ty Ty
| Tforall Tbind Ty
data Coercion
-- We distinguish primitive coercions because External Core treats
-- them specially, so we have to print them out with special syntax.
| TransCoercion Ty Ty
| SymCoercion Ty
| UnsafeCoercion Ty Ty
| InstCoercion Ty Ty
| NthCoercion Int Ty
| AxiomCoercion (Qual Tcon) Int [Ty]
| LRCoercion LeftOrRight Ty
= ReflCoercion Role Ty
| SymCoercion Coercion
| TransCoercion Coercion Coercion
| TyConAppCoercion Role (Qual Tcon) [Coercion]
| AppCoercion Coercion Coercion
| ForAllCoercion Tbind Coercion
| CoVarCoercion Var
| UnivCoercion Role Ty Ty
| InstCoercion Coercion Ty
| NthCoercion Int Coercion
| AxiomCoercion (Qual Tcon) Int [Coercion]
| LRCoercion LeftOrRight Coercion
| SubCoercion Coercion
data Role = Nominal | Representational | Phantom
data LeftOrRight = CLeft | CRight
......
......@@ -309,29 +309,29 @@ make_var_qid dflags force_unqual = make_qid dflags force_unqual True
make_con_qid :: DynFlags -> Name -> C.Qual C.Id
make_con_qid dflags = make_qid dflags False False
make_co :: DynFlags -> Coercion -> C.Ty
make_co dflags (Refl ty) = make_ty dflags ty
make_co dflags (TyConAppCo tc cos) = make_conAppCo dflags (qtc dflags tc) cos
make_co dflags (AppCo c1 c2) = C.Tapp (make_co dflags c1) (make_co dflags c2)
make_co dflags (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co dflags co)
make_co _ (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv))
make_co :: DynFlags -> Coercion -> C.Coercion
make_co dflags (Refl r ty) = C.ReflCoercion (make_role r) $ make_ty dflags ty
make_co dflags (TyConAppCo r tc cos) = C.TyConAppCoercion (make_role r) (qtc dflags tc) (map (make_co dflags) cos)
make_co dflags (AppCo c1 c2) = C.AppCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (ForAllCo tv co) = C.ForAllCoercion (make_tbind tv) (make_co dflags co)
make_co _ (CoVarCo cv) = C.CoVarCoercion (make_var_id (coVarName cv))
make_co dflags (AxiomInstCo cc ind cos) = C.AxiomCoercion (qcc dflags cc) ind (map (make_co dflags) cos)
make_co dflags (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty dflags t1) (make_ty dflags t2)
make_co dflags (UnivCo r t1 t2) = C.UnivCoercion (make_role r) (make_ty dflags t1) (make_ty dflags t2)
make_co dflags (SymCo co) = C.SymCoercion (make_co dflags co)
make_co dflags (TransCo c1 c2) = C.TransCoercion (make_co dflags c1) (make_co dflags c2)
make_co dflags (NthCo d co) = C.NthCoercion d (make_co dflags co)
make_co dflags (LRCo lr co) = C.LRCoercion (make_lr lr) (make_co dflags co)
make_co dflags (InstCo co ty) = C.InstCoercion (make_co dflags co) (make_ty dflags ty)
make_co dflags (SubCo co) = C.SubCoercion (make_co dflags co)
make_lr :: LeftOrRight -> C.LeftOrRight
make_lr CLeft = C.CLeft
make_lr CRight = C.CRight
-- Used for both tycon app coercions and axiom instantiations.
make_conAppCo :: DynFlags -> C.Qual C.Tcon -> [Coercion] -> C.Ty
make_conAppCo dflags con cos =
foldl C.Tapp (C.Tcon con)
(map (make_co dflags) cos)
make_role :: Role -> C.Role
make_role Nominal = C.Nominal
make_role Representational = C.Representational
make_role Phantom = C.Phantom
-------
isALocal :: Name -> CoreM Bool
......
......@@ -102,22 +102,6 @@ pbty t = paty t
pty (Tapp(Tapp(Tcon tc) t1) t2) | tc == tcArrow = fsep [pbty t1, text "->",pty t2]
pty (Tforall tb t) = text "%forall" <+> pforall [tb] t
pty (TransCoercion t1 t2) =
sep [text "%trans", paty t1, paty t2]
pty (SymCoercion t) =
sep [text "%sym", paty t]
pty (UnsafeCoercion t1 t2) =
sep [text "%unsafe", paty t1, paty t2]
pty (NthCoercion n t) =
sep [text "%nth", int n, paty t]
pty (LRCoercion CLeft t) =
sep [text "%left", paty t]
pty (LRCoercion CRight t) =
sep [text "%right", paty t]
pty (InstCoercion t1 t2) =
sep [text "%inst", paty t1, paty t2]
pty (AxiomCoercion tc i cos) =
pqname tc <+> int i <+> sep (map paty cos)
pty ty@(Tapp {}) = pappty ty []
pty ty@(Tvar {}) = paty ty
pty ty@(Tcon {}) = paty ty
......@@ -130,6 +114,48 @@ pforall :: [Tbind] -> Ty -> Doc
pforall tbs (Tforall tb t) = pforall (tbs ++ [tb]) t
pforall tbs t = hsep (map ptbind tbs) <+> char '.' <+> pty t
paco, pbco, pco :: Coercion -> Doc
paco (ReflCoercion r ty) = char '<' <> pty ty <> text ">_" <> prole r
paco (TyConAppCoercion r qtc []) = pqname qtc <> char '_' <> prole r
paco (AxiomCoercion qtc i []) = pqname qtc <> char '[' <> int i <> char ']'
paco (CoVarCoercion cv) = pname cv
paco c = parens (pco c)
pbco (TyConAppCoercion _ arr [co1, co2])
| arr == tcArrow
= parens (fsep [pbco co1, text "->", pco co2])
pbco co = paco co
pco c@(ReflCoercion {}) = paco c
pco (SymCoercion co) = sep [text "%sub", paco co]
pco (TransCoercion co1 co2) = sep [text "%trans", paco co1, paco co2]
pco (TyConAppCoercion _ arr [co1, co2])
| arr == tcArrow = fsep [pbco co1, text "->", pco co2]
pco (TyConAppCoercion r qtc cos) = parens (pqname qtc <+> sep (map paco cos)) <> char '_' <> prole r
pco co@(AppCoercion {}) = pappco co []
pco (ForAllCoercion tb co) = text "%forall" <+> pforallco [tb] co
pco co@(CoVarCoercion {}) = paco co
pco (UnivCoercion r ty1 ty2) = sep [text "%univ", prole r, paty ty1, paty ty2]
pco (InstCoercion co ty) = sep [text "%inst", paco co, paty ty]
pco (NthCoercion i co) = sep [text "%nth", int i, paco co]
pco (AxiomCoercion qtc i cos) = pqname qtc <> char '[' <> int i <> char ']' <+> sep (map paco cos)
pco (LRCoercion CLeft co) = sep [text "%left", paco co]
pco (LRCoercion CRight co) = sep [text "%right", paco co]
pco (SubCoercion co) = sep [text "%sub", paco co]
pappco :: Coercion -> [Coercion ] -> Doc
pappco (AppCoercion co1 co2) cos = pappco co1 (co2:cos)
pappco co cos = sep (map paco (co:cos))
pforallco :: [Tbind] -> Coercion -> Doc
pforallco tbs (ForAllCoercion tb co) = pforallco (tbs ++ [tb]) co
pforallco tbs co = hsep (map ptbind tbs) <+> char '.' <+> pco co
prole :: Role -> Doc
prole Nominal = char 'N'
prole Representational = char 'R'
prole Phantom = char 'P'
pvdefg :: Vdefg -> Doc
pvdefg (Rec vdefs) = text "%rec" $$ braces (indent (vcat (punctuate (char ';') (map pvdef vdefs))))
pvdefg (Nonrec vdef) = pvdef vdef
......@@ -172,7 +198,7 @@ pexp (Let vd e) = (text "%let" <+> pvdefg vd) $$ (text "%in" <+> pexp e)
pexp (Case e vb ty alts) = sep [text "%case" <+> paty ty <+> paexp e,
text "%of" <+> pvbind vb]
$$ (indent (braces (vcat (punctuate (char ';') (map palt alts)))))
pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paty co
pexp (Cast e co) = (text "%cast" <+> parens (pexp e)) $$ paco co
pexp (Tick s e) = (text "%source" <+> pstring s) $$ pexp e
pexp (External n cc t) = (text "%external" <+> text cc <+> pstring n) $$ paty t
pexp (DynExternal cc t) = (text "%dynexternal" <+> text cc) $$ paty t
......
......@@ -458,27 +458,28 @@ fdA k m = foldTM k (am_deflt m)
\begin{code}
data CoercionMap a
= EmptyKM
| KM { km_refl :: TypeMap a
, km_tc_app :: NameEnv (ListMap CoercionMap a)
| KM { km_refl :: RoleMap (TypeMap a)
, km_tc_app :: RoleMap (NameEnv (ListMap CoercionMap a))
, km_app :: CoercionMap (CoercionMap a)
, km_forall :: CoercionMap (TypeMap a)
, km_var :: VarMap a
, km_axiom :: NameEnv (IntMap.IntMap (ListMap CoercionMap a))
, km_unsafe :: TypeMap (TypeMap a)
, km_univ :: RoleMap (TypeMap (TypeMap a))
, km_sym :: CoercionMap a
, km_trans :: CoercionMap (CoercionMap a)
, km_nth :: IntMap.IntMap (CoercionMap a)
, km_left :: CoercionMap a
, km_right :: CoercionMap a
, km_inst :: CoercionMap (TypeMap a) }
, km_inst :: CoercionMap (TypeMap a)
, km_sub :: CoercionMap a }
wrapEmptyKM :: CoercionMap a
wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyNameEnv
wrapEmptyKM = KM { km_refl = emptyTM, km_tc_app = emptyTM
, km_app = emptyTM, km_forall = emptyTM
, km_var = emptyTM, km_axiom = emptyNameEnv
, km_unsafe = emptyTM, km_sym = emptyTM, km_trans = emptyTM
, km_univ = emptyTM, km_sym = emptyTM, km_trans = emptyTM
, km_nth = emptyTM, km_left = emptyTM, km_right = emptyTM
, km_inst = emptyTM }
, km_inst = emptyTM, km_sub = emptyTM }
instance TrieMap CoercionMap where
type Key CoercionMap = Coercion
......@@ -493,34 +494,35 @@ mapC _ EmptyKM = EmptyKM
mapC f (KM { km_refl = krefl, km_tc_app = ktc
, km_app = kapp, km_forall = kforall
, km_var = kvar, km_axiom = kax
, km_unsafe = kunsafe, km_sym = ksym, km_trans = ktrans
, km_univ = kuniv , km_sym = ksym, km_trans = ktrans
, km_nth = knth, km_left = kml, km_right = kmr
, km_inst = kinst })
= KM { km_refl = mapTM f krefl
, km_tc_app = mapNameEnv (mapTM f) ktc
, km_inst = kinst, km_sub = ksub })
= KM { km_refl = mapTM (mapTM f) krefl
, km_tc_app = mapTM (mapNameEnv (mapTM f)) ktc
, km_app = mapTM (mapTM f) kapp
, km_forall = mapTM (mapTM f) kforall
, km_var = mapTM f kvar
, km_axiom = mapNameEnv (IntMap.map (mapTM f)) kax
, km_unsafe = mapTM (mapTM f) kunsafe
, km_univ = mapTM (mapTM (mapTM f)) kuniv
, km_sym = mapTM f ksym
, km_trans = mapTM (mapTM f) ktrans
, km_nth = IntMap.map (mapTM f) knth
, km_left = mapTM f kml
, km_right = mapTM f kmr
, km_inst = mapTM (mapTM f) kinst }
, km_inst = mapTM (mapTM f) kinst
, km_sub = mapTM f ksub }
lkC :: CmEnv -> Coercion -> CoercionMap a -> Maybe a
lkC env co m
| EmptyKM <- m = Nothing
| otherwise = go co m
where
go (Refl ty) = km_refl >.> lkT env ty
go (TyConAppCo tc cs) = km_tc_app >.> lkNamed tc >=> lkList (lkC env) cs
go (Refl r ty) = km_refl >.> lookupTM r >=> lkT env ty
go (TyConAppCo r tc cs) = km_tc_app >.> lookupTM r >=> lkNamed tc >=> lkList (lkC env) cs
go (AxiomInstCo ax ind cs) = km_axiom >.> lkNamed ax >=> lookupTM ind >=> lkList (lkC env) cs
go (AppCo c1 c2) = km_app >.> lkC env c1 >=> lkC env c2
go (TransCo c1 c2) = km_trans >.> lkC env c1 >=> lkC env c2
go (UnsafeCo t1 t2) = km_unsafe >.> lkT env t1 >=> lkT env t2
go (UnivCo r t1 t2) = km_univ >.> lookupTM r >=> lkT env t1 >=> lkT env t2
go (InstCo c t) = km_inst >.> lkC env c >=> lkT env t
go (ForAllCo v c) = km_forall >.> lkC (extendCME env v) c >=> lkBndr env v
go (CoVarCo v) = km_var >.> lkVar env v
......@@ -528,15 +530,16 @@ lkC env co m
go (NthCo n c) = km_nth >.> lookupTM n >=> lkC env c
go (LRCo CLeft c) = km_left >.> lkC env c
go (LRCo CRight c) = km_right >.> lkC env c
go (SubCo c) = km_sub >.> lkC env c
xtC :: CmEnv -> Coercion -> XT a -> CoercionMap a -> CoercionMap a
xtC env co f EmptyKM = xtC env co f wrapEmptyKM
xtC env (Refl ty) f m = m { km_refl = km_refl m |> xtT env ty f }
xtC env (TyConAppCo tc cs) f m = m { km_tc_app = km_tc_app m |> xtNamed tc |>> xtList (xtC env) cs f }
xtC env (Refl r ty) f m = m { km_refl = km_refl m |> xtR r |>> xtT env ty f }
xtC env (TyConAppCo r tc cs) f m = m { km_tc_app = km_tc_app m |> xtR r |>> xtNamed tc |>> xtList (xtC env) cs f }
xtC env (AxiomInstCo ax ind cs) f m = m { km_axiom = km_axiom m |> xtNamed ax |>> xtInt ind |>> xtList (xtC env) cs f }
xtC env (AppCo c1 c2) f m = m { km_app = km_app m |> xtC env c1 |>> xtC env c2 f }
xtC env (TransCo c1 c2) f m = m { km_trans = km_trans m |> xtC env c1 |>> xtC env c2 f }
xtC env (UnsafeCo t1 t2) f m = m { km_unsafe = km_unsafe m |> xtT env t1 |>> xtT env t2 f }
xtC env (UnivCo r t1 t2) f m = m { km_univ = km_univ m |> xtR r |>> xtT env t1 |>> xtT env t2 f }
xtC env (InstCo c t) f m = m { km_inst = km_inst m |> xtC env c |>> xtT env t f }
xtC env (ForAllCo v c) f m = m { km_forall = km_forall m |> xtC (extendCME env v) c
|>> xtBndr env v f }
......@@ -544,23 +547,56 @@ xtC env (CoVarCo v) f m = m { km_var = km_var m |> xtVar env v f
xtC env (SymCo c) f m = m { km_sym = km_sym m |> xtC env c f }
xtC env (NthCo n c) f m = m { km_nth = km_nth m |> xtInt n |>> xtC env c f }
xtC env (LRCo CLeft c) f m = m { km_left = km_left m |> xtC env c f }
xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
xtC env (LRCo CRight c) f m = m { km_right = km_right m |> xtC env c f }
xtC env (SubCo c) f m = m { km_sub = km_sub m |> xtC env c f }
fdC :: (a -> b -> b) -> CoercionMap a -> b -> b
fdC _ EmptyKM = \z -> z
fdC k m = foldTM k (km_refl m)
. foldTM (foldTM k) (km_tc_app m)
fdC k m = foldTM (foldTM k) (km_refl m)
. foldTM (foldTM (foldTM k)) (km_tc_app m)
. foldTM (foldTM k) (km_app m)
. foldTM (foldTM k) (km_forall m)
. foldTM k (km_var m)
. foldTM (foldTM (foldTM k)) (km_axiom m)
. foldTM (foldTM k) (km_unsafe m)
. foldTM (foldTM (foldTM k)) (km_univ m)
. foldTM k (km_sym m)
. foldTM (foldTM k) (km_trans m)
. foldTM (foldTM k) (km_nth m)
. foldTM k (km_left m)
. foldTM k (km_right m)
. foldTM (foldTM k) (km_inst m)
. foldTM k (km_sub m)
\end{code}
\begin{code}
newtype RoleMap a = RM { unRM :: (IntMap.IntMap a) }
instance TrieMap RoleMap where
type Key RoleMap = Role
emptyTM = RM emptyTM
lookupTM = lkR
alterTM = xtR
foldTM = fdR
mapTM = mapR
lkR :: Role -> RoleMap a -> Maybe a
lkR Nominal = lookupTM 1 . unRM
lkR Representational = lookupTM 2 . unRM
lkR Phantom = lookupTM 3 . unRM
xtR :: Role -> XT a -> RoleMap a -> RoleMap a
xtR Nominal f = RM . alterTM 1 f . unRM
xtR Representational f = RM . alterTM 2 f . unRM
xtR Phantom f = RM . alterTM 3 f . unRM
fdR :: (a -> b -> b) -> RoleMap a -> b -> b
fdR f (RM m) = foldTM f m
mapR :: (a -> b) -> RoleMap a -> RoleMap b
mapR f = RM . mapTM f . unRM
\end{code}
......
......@@ -65,6 +65,7 @@ import Maybes
import OrdList
import Bag
import BasicTypes hiding ( TopLevel )
import Pair
import DynFlags
import FastString
import ErrUtils( MsgDoc )
......@@ -705,7 +706,7 @@ dsHsWrapper (WpTyApp ty) e = return $ App e (Type ty)
dsHsWrapper (WpLet ev_binds) e = do bs <- dsTcEvBinds ev_binds
return (mkCoreLets bs e)
dsHsWrapper (WpCompose c1 c2) e = dsHsWrapper c1 =<< dsHsWrapper c2 e
dsHsWrapper (WpCast co) e = dsTcCoercion co (mkCast e)
dsHsWrapper (WpCast co) e = dsTcCoercion Representational co (mkCast e)
dsHsWrapper (WpEvLam ev) e = return $ Lam ev e
dsHsWrapper (WpTyLam tv) e = return $ Lam tv e
dsHsWrapper (WpEvApp evtrm) e = liftM (App e) (dsEvTerm evtrm)
......@@ -739,7 +740,7 @@ dsEvTerm (EvId v) = return (Var v)
dsEvTerm (EvCast tm co)
= do { tm' <- dsEvTerm tm
; dsTcCoercion co $ mkCast tm' }
; dsTcCoercion Representational co $ mkCast tm' }
-- 'v' is always a lifted evidence variable so it is
-- unnecessary to call varToCoreExpr v here.
......@@ -747,7 +748,7 @@ dsEvTerm (EvDFunApp df tys tms) = do { tms' <- mapM dsEvTerm tms
; return (Var df `mkTyApps` tys `mkApps` tms') }
dsEvTerm (EvCoercion (TcCoVarCo v)) = return (Var v) -- See Note [Simple coercions]
dsEvTerm (EvCoercion co) = dsTcCoercion co mkEqBox
dsEvTerm (EvCoercion co) = dsTcCoercion Nominal co mkEqBox
dsEvTerm (EvTupleSel v n)
= do { tm' <- dsEvTerm v
......@@ -785,21 +786,22 @@ dsEvTerm (EvLit l) =
EvStr s -> mkStringExprFS s
---------------------------------------
dsTcCoercion :: TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
dsTcCoercion :: Role -> TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr
-- This is the crucial function that moves
-- from TcCoercions to Coercions; see Note [TcCoercions] in Coercion
-- e.g. dsTcCoercion (trans g1 g2) k
-- = case g1 of EqBox g1# ->
-- case g2 of EqBox g2# ->
-- k (trans g1# g2#)
dsTcCoercion co thing_inside
-- thing_inside will get a coercion at the role requested
dsTcCoercion role co thing_inside
= do { us <- newUniqueSupply
; let eqvs_covs :: [(EqVar,CoVar)]
eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co))
(uniqsFromSupply us)
subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs]
result_expr = thing_inside (ds_tc_coercion subst co)
result_expr = thing_inside (ds_tc_coercion subst role co)
result_ty = exprType result_expr
; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) }
......@@ -810,36 +812,41 @@ dsTcCoercion co thing_inside
eq_nm = idName eqv
occ = nameOccName eq_nm
loc = nameSrcSpan eq_nm
ty = mkCoercionType ty1 ty2
ty = mkCoercionType Nominal ty1 ty2
(ty1, ty2) = getEqPredTys (evVarPred eqv)
wrap_in_case result_ty (eqv, cov) body
= Case (Var eqv) eqv result_ty [(DataAlt eqBoxDataCon, [cov], body)]
ds_tc_coercion :: CvSubst -> TcCoercion -> Coercion
ds_tc_coercion :: CvSubst -> Role -> TcCoercion -> Coercion
-- If the incoming TcCoercion if of type (a ~ b),
-- the result is of type (a ~# b)
-- The VarEnv maps EqVars of type (a ~ b) to Coercions of type (a ~# b)
-- No need for InScope set etc because the
ds_tc_coercion subst tc_co
= go tc_co
ds_tc_coercion subst role tc_co
= go role tc_co
where
go (TcRefl ty) = Refl (Coercion.substTy subst ty)
go (TcTyConAppCo tc cos) = mkTyConAppCo tc (map go cos)
go (TcAppCo co1 co2) = mkAppCo (go co1) (go co2)
go (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' co)
go Phantom co
= mkUnivCo Phantom ty1 ty2
where Pair ty1 ty2 = tcCoercionKind co
go r (TcRefl ty) = Refl r (Coercion.substTy subst ty)
go r (TcTyConAppCo tc cos) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) cos)
go r (TcAppCo co1 co2) = mkAppCo (go r co1) (go Nominal co2)
go r (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' r co)
where
(subst', tv') = Coercion.substTyVarBndr subst tv
go (TcAxiomInstCo ax ind tys)
= mkAxInstCo ax ind (map (Coercion.substTy subst) tys)
go (TcSymCo co) = mkSymCo (go co)
go (TcTransCo co1 co2) = mkTransCo (go co1) (go co2)
go (TcNthCo n co) = mkNthCo n (go co)
go (TcLRCo lr co) = mkLRCo lr (go co)
go (TcInstCo co ty) = mkInstCo (go co) ty
go (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) co
go (TcCastCo co1 co2) = mkCoCast (go co1) (go co2)
go (TcCoVarCo v) = ds_ev_id subst v
go r (TcAxiomInstCo ax ind tys)
= mkAxInstCo r ax ind (map (Coercion.substTy subst) tys)
go r (TcSymCo co) = mkSymCo (go r co)
go r (TcTransCo co1 co2) = mkTransCo (go r co1) (go r co2)
go r (TcNthCo n co) = mkNthCoRole r n (go r co) -- the 2nd r is a harmless lie
go r (TcLRCo lr co) = maybeSubCo r $ mkLRCo lr (go Nominal co)
go r (TcInstCo co ty) = mkInstCo (go r co) ty
go r (TcLetCo bs co) = ds_tc_coercion (ds_co_binds bs) r co
go r (TcCastCo co1 co2) = maybeSubCo r $ mkCoCast (go Nominal co1)
(go Nominal co2)
go r (TcCoVarCo v) = maybeSubCo r $ ds_ev_id subst v
ds_co_binds :: TcEvBinds -> CvSubst
ds_co_binds (EvBinds bs) = foldl ds_scc subst (sccEvBinds bs)
......@@ -851,9 +858,9 @@ ds_tc_coercion subst tc_co
ds_scc _ (CyclicSCC other) = pprPanic "ds_scc:cyclic" (ppr other $$ ppr tc_co)
ds_co_term :: CvSubst -> EvTerm -> Coercion
ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst tc_co
ds_co_term subst (EvCoercion tc_co) = ds_tc_coercion subst Nominal tc_co
ds_co_term subst (EvId v) = ds_ev_id subst v
ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst co)
ds_co_term subst (EvCast tm co) = mkCoCast (ds_co_term subst tm) (ds_tc_coercion subst Nominal co)
ds_co_term _ other = pprPanic "ds_co_term" (ppr other $$ ppr tc_co)
ds_ev_id :: CvSubst -> EqVar -> Coercion
......
......@@ -418,7 +418,7 @@ dsFExportDynamic id co0 cconv = do
export_ty = mkFunTy stable_ptr_ty arg_ty
bindIOId <- dsLookupGlobalId bindIOName
stbl_value <- newSysLocalDs stable_ptr_ty
(h_code, c_code, typestring, args_size) <- dsFExport id (Refl export_ty) fe_nm cconv True
(h_code, c_code, typestring, args_size) <- dsFExport id (mkReflCo Representational export_ty) fe_nm cconv True
let
{-
The arguments to the external function which will
......
......@@ -305,7 +305,7 @@ mk_extra_tvs tc tvs defn
= do { uniq <- newUnique
; let { occ = mkTyVarOccFS (fsLit "t")
; nm = mkInternalName uniq occ loc
; hs_tv = L loc (KindedTyVar nm kind) }
; hs_tv = L loc (HsTyVarBndr nm (Just kind) Nothing) }
; hs_tvs <- go rest
; return (hs_tv : hs_tvs) }
......@@ -731,10 +731,16 @@ addTyClTyVarBinds tvs m
--
repTyVarBndrWithKind :: LHsTyVarBndr Name
-> Core TH.Name -> DsM (Core TH.TyVarBndr)
repTyVarBndrWithKind (L _ (UserTyVar {})) nm
repTyVarBndrWithKind (L _ (HsTyVarBndr _ Nothing Nothing)) nm