From 0b86bc9b022a5965d2b35f143ff4b919f784e676 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Wed, 20 Sep 2006 17:39:27 +0000 Subject: [PATCH] fix bugs, add boolean flag to identify coercion variables Mon Sep 18 16:41:32 EDT 2006 Manuel M T Chakravarty * fix bugs, add boolean flag to identify coercion variables Sun Aug 6 17:04:02 EDT 2006 Manuel M T Chakravarty * fix bugs, add boolean flag to identify coercion variables Tue Jul 25 06:20:05 EDT 2006 kevind@bu.edu --- compiler/basicTypes/Var.lhs | 25 +++++++++++++++++-------- compiler/coreSyn/MkExternalCore.lhs | 1 + compiler/deSugar/Match.lhs | 5 ++++- compiler/deSugar/MatchLit.lhs | 2 +- compiler/hsSyn/HsExpr.lhs | 4 +++- compiler/iface/BuildTyCl.lhs | 13 +++++++++++-- compiler/typecheck/TcType.lhs | 23 +++++++++++++++++------ compiler/types/Type.lhs | 4 ++-- compiler/types/TypeRep.lhs | 8 +++++--- utils/runstdtest/runstdtest.prl | 6 +++--- 10 files changed, 64 insertions(+), 27 deletions(-) diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs index e4aa8c2..d4bf400 100644 --- a/compiler/basicTypes/Var.lhs +++ b/compiler/basicTypes/Var.lhs @@ -10,7 +10,7 @@ module Var ( setVarName, setVarUnique, -- TyVars - TyVar, mkTyVar, mkTcTyVar, mkWildTyVar, + TyVar, mkTyVar, mkTcTyVar, mkWildCoVar, tyVarName, tyVarKind, setTyVarName, setTyVarUnique, setTyVarKind, tcTyVarDetails, @@ -68,7 +68,9 @@ data Var realUnique :: FastInt, -- Key for fast comparison -- Identical to the Unique in the name, -- cached here for speed - tyVarKind :: Kind } + tyVarKind :: Kind, + isCoercionVar :: Bool + } | TcTyVar { -- Used only during type inference -- Used for kind variables during @@ -189,6 +191,7 @@ mkTyVar :: Name -> Kind -> TyVar mkTyVar name kind = TyVar { varName = name , realUnique = getKey# (nameUnique name) , tyVarKind = kind + , isCoercionVar = False } mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar @@ -199,11 +202,12 @@ mkTcTyVar name kind details tcTyVarDetails = details } -mkWildTyVar :: Kind -> TyVar -mkWildTyVar kind +mkWildCoVar :: Kind -> TyVar +mkWildCoVar kind = TyVar { varName = mkSysTvName wild_uniq FSLIT("co_wild"), realUnique = _ILIT(1), - tyVarKind = kind } + tyVarKind = kind, + isCoercionVar = True } where wild_uniq = (mkBuiltinUnique 1) \end{code} @@ -223,10 +227,12 @@ setCoVarUnique = setVarUnique setCoVarName = setVarName mkCoVar :: Name -> Kind -> CoVar -mkCoVar name kind = mkTyVar name kind +mkCoVar name kind = TyVar { varName = name + , realUnique = getKey# (nameUnique name) + , tyVarKind = kind + , isCoercionVar = True + } -isCoVar :: TyVar -> Bool -isCoVar ty = isCoSuperKind (tyVarKind ty) \end{code} %************************************************************************ @@ -342,6 +348,9 @@ isId other = False isLocalId (LocalId {}) = True isLocalId other = False +isCoVar (v@(TyVar {})) = isCoercionVar v +isCoVar other = False + -- isLocalVar returns True for type variables as well as local Ids -- These are the variables that we need to pay attention to when finding free -- variables, or doing dependency analysis. diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 8181754..e7d79e6 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -175,6 +175,7 @@ make_ty (NoteTy _ t) = make_ty t make_kind :: Kind -> C.Kind +make_kind (PredTy p) | isEqPred p = panic "coercion kinds in external core not implemented!" make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) make_kind k | isLiftedTypeKind k = C.Klifted diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index d793343..9ff1548 100644 --- a/compiler/deSugar/Match.lhs +++ b/compiler/deSugar/Match.lhs @@ -254,7 +254,7 @@ match :: [Id] -- Variables rep'ing the exprs we're matching with -> DsM MatchResult -- Desugared result! match [] ty eqns - = ASSERT( not (null eqns) ) + = ASSERT2( not (null eqns), ppr ty ) returnDs (foldr1 combineMatchResults match_results) where match_results = [ ASSERT( null (eqn_pats eqn) ) @@ -715,6 +715,9 @@ data PatGroup groupEquations :: [EquationInfo] -> [[(PatGroup, EquationInfo)]] +-- If the result is of form [g1, g2, g3], +-- (a) all the (pg,eq) pairs in g1 have the same pg +-- (b) none of the gi are empty groupEquations eqns = runs same_gp [(patGroup (firstPat eqn), eqn) | eqn <- eqns] where diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 3c10c1c..3751f95 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -256,7 +256,7 @@ matchNPlusKPats all_vars@(var:vars) ty (eqn1:eqns) ; lit_expr <- dsOverLit lit ; let pred_expr = mkApps ge_expr [Var var, lit_expr] minusk_expr = mkApps minus_expr [Var var, lit_expr] - (wraps, eqns') = mapAndUnzip (shift n1) eqns + (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns) ; match_result <- match vars ty eqns' ; return (mkGuardedMatchResult pred_expr $ mkCoLetMatchResult (NonRec n1 minusk_expr) $ diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index 18306a9..c42be90 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -607,7 +607,9 @@ We know the list must have at least one @Match@ in it. \begin{code} pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc -pprMatches ctxt (MatchGroup matches ty) = (ppr ty) $$ vcat (map (pprMatch ctxt) (map unLoc matches)) +pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches)) + -- Don't print the type; it's only + -- a place-holder before typechecking -- Exported to HsBinds, which can't see the defn of HsMatchContext pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs index 9eda907..d1118c0 100644 --- a/compiler/iface/BuildTyCl.lhs +++ b/compiler/iface/BuildTyCl.lhs @@ -82,15 +82,24 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs -- because the latter is part of a knot, whereas the former is not. mkNewTyConRhs tycon_name tycon con = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty + ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon tvs rhs_ty + cocon_maybe + | all_coercions || isRecursiveTyCon tycon + = Just co_tycon + | otherwise + = Nothing ; return (NewTyCon { data_con = con, - nt_co = Just co_tycon, + nt_co = cocon_maybe, -- Coreview looks through newtypes with a Nothing -- for nt_co, or uses explicit coercions otherwise nt_rhs = rhs_ty, nt_etad_rhs = eta_reduce tvs rhs_ty, nt_rep = mkNewTyConRep tycon rhs_ty }) } where + -- if all_coercions is True then we use coercions for all newtypes + -- otherwise we use coercions for recursive newtypes and look through + -- non-recursive newtypes + all_coercions = True tvs = tyConTyVars tycon rhs_ty = head (dataConInstOrigArgTys con (mkTyVarTys tvs)) -- Instantiate the data con with the diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index 727d0ab..a382808 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -170,7 +170,6 @@ import Type ( -- Re-exports pprPred, pprTheta, pprThetaArrow, pprClassPred ) import TyCon ( TyCon, isUnLiftedTyCon, isSynTyCon, synTyConDefn, tyConUnique ) -import Coercion ( splitForAllCo_maybe ) import DataCon ( DataCon, dataConStupidTheta, dataConResTys ) import Class ( Class ) import Var ( TyVar, Id, isCoVar, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails ) @@ -645,20 +644,23 @@ tcSplitForAllTys ty = split ty ty [] split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs split orig_ty (ForAllTy tv ty) tvs | not (isCoVar tv) = split ty ty (tv:tvs) - split orig_ty t tvs = (reverse tvs, orig_ty) + split orig_ty t tvs = (reverse tvs, orig_ty) tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy tv ty) = True +tcIsForAllTy (ForAllTy tv ty) = not (isCoVar tv) tcIsForAllTy t = False tcSplitPhiTy :: Type -> (ThetaType, Type) tcSplitPhiTy ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs + + split orig_ty (ForAllTy tv ty) ts + | isCoVar tv = split ty ty (eq_pred:ts) + where + PredTy eq_pred = tyVarKind tv split orig_ty (FunTy arg res) ts | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts) - split orig_ty ty ts - | Just (p, ty') <- splitForAllCo_maybe ty = split ty' ty' (p:ts) split orig_ty ty ts = (reverse ts, orig_ty) tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type) @@ -985,9 +987,14 @@ tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg -tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar +tcTyVarsOfType (ForAllTy tyvar ty) = (tcTyVarsOfType ty `delVarSet` tyvar) + `unionVarSet` tcTyVarsOfTyVar tyvar -- We do sometimes quantify over skolem TcTyVars +tcTyVarsOfTyVar :: TcTyVar -> TyVarSet +tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv) + | otherwise = emptyVarSet + tcTyVarsOfTypes :: [Type] -> TyVarSet tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys @@ -1030,11 +1037,15 @@ exactTyVarsOfType ty go (FunTy arg res) = go arg `unionVarSet` go res go (AppTy fun arg) = go fun `unionVarSet` go arg go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + `unionVarSet` go_tv tyvar go_pred (IParam _ ty) = go ty go_pred (ClassP _ tys) = exactTyVarsOfTypes tys go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 + go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar) + | otherwise = emptyVarSet + exactTyVarsOfTypes :: [TcType] -> TyVarSet exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys \end{code} diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs index b7f521a..5799147 100644 --- a/compiler/types/Type.lhs +++ b/compiler/types/Type.lhs @@ -106,7 +106,7 @@ import TypeRep -- friends: import Var ( Var, TyVar, tyVarKind, tyVarName, - setTyVarName, setTyVarKind, mkWildTyVar ) + setTyVarName, setTyVarKind, mkWildCoVar ) import VarEnv import VarSet @@ -307,7 +307,7 @@ splitAppTys ty = split ty ty [] \begin{code} mkFunTy :: Type -> Type -> Type -mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildTyVar (PredTy (EqPred ty1 ty2))) res +mkFunTy (PredTy (EqPred ty1 ty2)) res = mkForAllTy (mkWildCoVar (PredTy (EqPred ty1 ty2))) res mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index cef77a1..544b822 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -313,7 +313,7 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName -coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName +coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName openTypeKindTyCon = mkKindTyCon openTypeKindTyConName @@ -329,8 +329,8 @@ mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0 -------------------------- -- ... and now their names -tySuperKindTyConName = mkPrimTyConName FSLIT("BOX") tySuperKindTyConKey tySuperKindTyCon -coSuperKindTyConName = mkPrimTyConName FSLIT("COERCION") coSuperKindTyConKey coSuperKindTyCon +tySuperKindTyConName = mkPrimTyConName FSLIT("BOX") tySuperKindTyConKey tySuperKindTyCon +coSuperKindTyConName = mkPrimTyConName FSLIT("COERCION") coSuperKindTyConKey coSuperKindTyCon liftedTypeKindTyConName = mkPrimTyConName FSLIT("*") liftedTypeKindTyConKey liftedTypeKindTyCon openTypeKindTyConName = mkPrimTyConName FSLIT("?") openTypeKindTyConKey openTypeKindTyCon unliftedTypeKindTyConName = mkPrimTyConName FSLIT("#") unliftedTypeKindTyConKey unliftedTypeKindTyCon @@ -372,9 +372,11 @@ tySuperKind, coSuperKind :: SuperKind tySuperKind = kindTyConType tySuperKindTyCon coSuperKind = kindTyConType coSuperKindTyCon +isTySuperKind (NoteTy _ ty) = isTySuperKind ty isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey isTySuperKind other = False +isCoSuperKind (NoteTy _ ty) = isCoSuperKind ty isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey isCoSuperKind other = False diff --git a/utils/runstdtest/runstdtest.prl b/utils/runstdtest/runstdtest.prl index da08173..419e457 100644 --- a/utils/runstdtest/runstdtest.prl +++ b/utils/runstdtest/runstdtest.prl @@ -68,7 +68,7 @@ $DefaultStderrFile = "$TmpPrefix/no_stderr$$"; @PgmStderrFile = (); $PreScript = ''; $PostScript = ''; -$TimeCmd = ''; +$TimeCmd = 'time'; $StatsFile = "$TmpPrefix/stats$$"; $CachegrindStats = "cachegrind.out.summary"; $SysSpecificTiming = ''; @@ -207,8 +207,8 @@ cat /dev/null > $DefaultStdoutFile cat /dev/null > $DefaultStderrFile $PreScriptLines $SpixifyLine1 -echo $TimeCmd /bin/sh -c \'$CachegrindPrefix $ToRun $TimingMagic @PgmArgs < $PgmStdinFile 1> $TmpPrefix/runtest$$.1 2> $TmpPrefix/runtest$$.2 3> $TmpPrefix/runtest$$.3\' -$TimeCmd /bin/sh -c \'$CachegrindPrefix $ToRun $TimingMagic @PgmArgs < $PgmStdinFile 1> $TmpPrefix/runtest$$.1 2> $TmpPrefix/runtest$$.2 3> $TmpPrefix/runtest$$.3\' +echo $TimeCmd /bin/sh -c \'$CachegrindPrefix $ToRun $TimingMagic @PgmArgs < $PgmStdinFile | dos2unix 1> $TmpPrefix/runtest$$.1 2> $TmpPrefix/runtest$$.2 3> $TmpPrefix/runtest$$.3\' +$TimeCmd /bin/sh -c \'$CachegrindPrefix $ToRun $TimingMagic @PgmArgs < $PgmStdinFile | dos2unix 1> $TmpPrefix/runtest$$.1 2> $TmpPrefix/runtest$$.2 3> $TmpPrefix/runtest$$.3\' progexit=\$? if [ \$progexit -eq 0 ] && [ $PgmFail -ne 0 ]; then echo $ToRun @PgmArgs \\< $PgmStdinFile -- 1.7.10.4