setVarName, setVarUnique,
-- TyVars
- TyVar, mkTyVar, mkTcTyVar, mkWildTyVar,
+ TyVar, mkTyVar, mkTcTyVar, mkWildCoVar,
tyVarName, tyVarKind,
setTyVarName, setTyVarUnique, setTyVarKind,
tcTyVarDetails,
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
mkTyVar name kind = TyVar { varName = name
, realUnique = getKey# (nameUnique name)
, tyVarKind = kind
+ , isCoercionVar = False
}
mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
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}
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}
%************************************************************************
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.
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
-> 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) )
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
; 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) $
\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
-- 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
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 )
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)
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
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}
-- friends:
import Var ( Var, TyVar, tyVarKind, tyVarName,
- setTyVarName, setTyVarKind, mkWildTyVar )
+ setTyVarName, setTyVarKind, mkWildCoVar )
import VarEnv
import VarSet
\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
tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName
-coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName
+coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName
liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName
openTypeKindTyCon = mkKindTyCon openTypeKindTyConName
--------------------------
-- ... 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
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
@PgmStderrFile = ();
$PreScript = '';
$PostScript = '';
-$TimeCmd = '';
+$TimeCmd = 'time';
$StatsFile = "$TmpPrefix/stats$$";
$CachegrindStats = "cachegrind.out.summary";
$SysSpecificTiming = '';
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