From: Adam Megacz Date: Tue, 31 May 2011 05:53:03 +0000 (-0700) Subject: adapt HetMet extensions to new GHC coercion representation X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=41cecc14547b049cec20e827ceae8ff312c9ff4f adapt HetMet extensions to new GHC coercion representation --- diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index b2131ca..7ba91d9 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -15,6 +15,7 @@ import HsSyn import TcRnTypes import MkIface import Id +import Pair import Name import CoreSyn import CoreSubst @@ -577,13 +578,14 @@ simplify (Var v) = Var v simplify (App e1 e2) = App (simplify e1) (simplify e2) simplify (Lit lit) = Lit lit simplify (Note note e) = Note note (simplify e) -simplify (Cast e co) = if tcEqType (fst $ coercionKind co) (snd $ coercionKind co) +simplify (Cast e co) = if eqType (fst $ unPair $ coercionKind co) (snd $ unPair $ coercionKind co) then simplify e else Cast (simplify e) co simplify (Lam v e) = Lam v (simplify e) -simplify (Type t) = Type t simplify (Case e b ty as) = Case (simplify e) b ty (map (\(a,b,e) -> (a,b,simplify e)) as) simplify (Let bind body) = foldr Let (simplify body) (simplifyBind bind) +simplify (Type t) = Type t +simplify (Coercion co) = Coercion co simplifyBind :: Bind CoreBndr -> [Bind CoreBndr] simplifyBind (NonRec b e) = [NonRec b (simplify e)] diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index aee1594..2c2d5f9 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -30,6 +30,7 @@ import Coercion import TcType import CmmExpr +import qualified Var import CmmUtils import HscTypes import ForeignCall diff --git a/compiler/hetmet b/compiler/hetmet index d97b00a..0f137f4 160000 --- a/compiler/hetmet +++ b/compiler/hetmet @@ -1 +1 @@ -Subproject commit d97b00a6ff6e8e2244927d17bda4b9762fc3d716 +Subproject commit 0f137f4fbe7076b7a0f6b33d661b4f7aa8b4f160 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index aa5de15..4bbb479 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -1328,7 +1328,6 @@ noSelTyConKey = mkPreludeTyConUnique 154 repTyConKey = mkPreludeTyConUnique 155 rep1TyConKey = mkPreludeTyConUnique 156 ->>>>>>> 18691d440f90a3dff4ef538091c886af505e5cf5 ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 4c70bcb..5cacacd 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -27,6 +27,7 @@ module TysPrim( liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, mkArrowKind, mkArrowKinds, isCoercionKind, + ecKind, funTyCon, funTyConName, primTyCons, @@ -74,8 +75,6 @@ import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) import OccName ( mkTcOcc,mkTyVarOccFS, mkTcOccFS ) import TyCon import TypeRep -import Type -import Coercion import SrcLoc import Unique ( mkAlphaTyVarUnique ) import PrelNames @@ -177,6 +176,8 @@ tyVarList kind = [ mkTyVar (mkInternalName (mkAlphaTyVarUnique u) where c = chr (u-2 + ord 'a') ] +ecKind = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind) + ecTyVars :: [TyVar] ecTyVars = tyVarList ecKind diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 8b907d2..70592af 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -48,7 +48,7 @@ import Var import VarSet import VarEnv import TysWiredIn -import TysPrim( intPrimTy ) +import TysPrim( intPrimTy, ecKind ) import PrimOp( tagToEnumKey ) import PrelNames import Module @@ -173,18 +173,18 @@ tcExpr (HsHetMetBrak _ e) res_ty = ; expr' <- updHetMetLevel (\old_lev -> (fresh_ec_name:old_lev)) $ tcPolyExpr e elt_ty ; unifyType (TyVarTy fresh_ec_name) inferred_name - ; return $ mkHsWrapCoI coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') } + ; return $ mkHsWrapCo coi (HsHetMetBrak (TyVarTy fresh_ec_name) expr') } tcExpr (HsHetMetEsc _ _ e) res_ty = do { cur_level <- getHetMetLevel ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) $ tcExpr (unLoc e) (mkTyConApp hetMetCodeTypeTyCon [(TyVarTy $ head cur_level),res_ty]) ; ty' <- zonkTcType res_ty - ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr')) } + ; return $ HsHetMetEsc (TyVarTy $ head cur_level) ty' (noLoc expr') } tcExpr (HsHetMetCSP _ e) res_ty = do { cur_level <- getHetMetLevel ; expr' <- updHetMetLevel (\old_lev -> tail old_lev) $ tcExpr (unLoc e) res_ty - ; return $ mkHsWrapCoI (ACo res_ty) (HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr')) } + ; return $ HsHetMetCSP (TyVarTy $ head cur_level) (noLoc expr') } tcExpr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index 2174be3..f011f19 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -37,7 +37,7 @@ import TcMType import TcUnify import TcIface import TcType -import TypeRep ( ecKind ) +import TysPrim ( ecKind ) import {- Kind parts of -} Type import Var import VarSet diff --git a/compiler/types/Kind.lhs b/compiler/types/Kind.lhs index 32a9eac..668ddda 100644 --- a/compiler/types/Kind.lhs +++ b/compiler/types/Kind.lhs @@ -15,7 +15,6 @@ module Kind ( -- Kind constructors... liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, - ecKind, -- Super Kinds tySuperKind, tySuperKindTyCon, @@ -234,5 +233,4 @@ defaultKind k | isSubArgTypeKind k = liftedTypeKind | otherwise = k -ecKind = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind) \end{code} \ No newline at end of file diff --git a/libraries/base b/libraries/base index 696df0c..a166b10 160000 --- a/libraries/base +++ b/libraries/base @@ -1 +1 @@ -Subproject commit 696df0cbdfe203a618c325e25c2ed60408ee54b9 +Subproject commit a166b102f16b45e2116f84f01fed840b981d3d40