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

fix bugs, add boolean flag to identify coercion variables

Mon Sep 18 16:41:32 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * fix bugs, add boolean flag to identify coercion variables
  Sun Aug  6 17:04:02 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * fix bugs, add boolean flag to identify coercion variables
    Tue Jul 25 06:20:05 EDT 2006  kevind@bu.edu
parent 6fcf9006
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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) $
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
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