Commit 398fb620 authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au
Browse files

Modify PA dictionary computation to work with the class-based scheme

parent 98abc79c
......@@ -13,7 +13,8 @@ module VectMonad (
LocalEnv(..),
readLEnv, setLEnv, updLEnv,
lookupTyCon, extendTyVarPA, deleteTyVarPA,
lookupTyCon,
lookupTyVarPA, extendTyVarPA, deleteTyVarPA,
lookupInst, lookupFamInst
) where
......@@ -236,6 +237,9 @@ newTyVar fs k
lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
lookupTyVarPA :: Var -> VM (Maybe CoreExpr)
lookupTyVarPA tv = readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv
extendTyVarPA :: Var -> CoreExpr -> VM ()
extendTyVarPA tv pa = updLEnv $ \env -> env { local_tyvar_pa = extendVarEnv (local_tyvar_pa env) tv pa }
......@@ -262,9 +266,7 @@ lookupInst cls tys
where
inst_tys' = [ty | Right ty <- inst_tys]
noFlexiVar = all isRight inst_tys
_other ->
pprPanic "VectMonad.lookupInst: not found: "
(ppr $ mkTyConApp (classTyCon cls) tys)
_other -> noV
}
where
isRight (Left _) = False
......
module VectUtils (
paDictArgType
paDictArgType, paDictOfType
) where
#include "HsVersions.h"
import VectMonad
import CoreSyn
import Type
import TypeRep
import Var
import Outputable
paDictArgType :: TyVar -> VM (Maybe Type)
paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
where
......@@ -30,6 +33,30 @@ paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
tc <- builtin paDictTyCon
return . Just $ TyConApp tc [ty]
go ty k = return Nothing
paDictOfType :: Type -> VM CoreExpr
paDictOfType ty = paDictOfTyApp ty_fn ty_args
where
(ty_fn, ty_args) = splitAppTys ty
paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
paDictOfTyApp ty_fn ty_args
| Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args
paDictOfTyApp (TyVarTy tv) ty_args
= do
dfun <- maybeV (lookupTyVarPA tv)
paDFunApply dfun ty_args
paDictOfTyApp (TyConApp tc _) ty_args
= do
pa_class <- builtin paClass
(dfun, ty_args') <- lookupInst pa_class [TyConApp tc ty_args]
paDFunApply (Var dfun) ty_args'
paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
paDFunApply dfun tys
= do
dicts <- mapM paDictOfType tys
return $ mkApps (mkTyApps dfun tys) dicts
......@@ -84,9 +84,9 @@ vectBndrsIn vs p
replicateP :: CoreExpr -> CoreExpr -> VM CoreExpr
replicateP expr len
= do
pa <- paOfType ty
rep <- builtin replicatePAVar
return $ mkApps (Var rep) [Type ty, pa, expr, len]
dict <- paDictOfType ty
rep <- builtin replicatePAVar
return $ mkApps (Var rep) [Type ty, dict, expr, len]
where
ty = exprType expr
......@@ -164,33 +164,6 @@ vectExpr lc (_, AnnLam bndr body)
return (extendTyVarPA bndr (Var pa_var),
Lam pa_var)
-- ----------------------------------------------------------------------------
-- PA dictionaries
paOfTyCon :: TyCon -> VM CoreExpr
-- FIXME: just for now
paOfTyCon tc = maybeV (readGEnv $ \env -> lookupNameEnv (global_tycon_pa env) (tyConName tc))
paOfType :: Type -> VM CoreExpr
paOfType ty | Just ty' <- coreView ty = paOfType ty'
paOfType (TyVarTy tv) = maybeV (readLEnv $ \env -> lookupVarEnv (local_tyvar_pa env) tv)
paOfType (AppTy ty1 ty2)
= do
e1 <- paOfType ty1
e2 <- paOfType ty2
return $ mkApps e1 [Type ty2, e2]
paOfType (TyConApp tc tys)
= do
e <- paOfTyCon tc
es <- mapM paOfType tys
return $ mkApps e [arg | (t,e) <- zip tys es, arg <- [Type t, e]]
paOfType (FunTy ty1 ty2) = paOfType (TyConApp funTyCon [ty1,ty2])
paOfType t@(ForAllTy tv ty) = pprPanic "paOfType:" (ppr t)
paOfType ty = pprPanic "paOfType:" (ppr ty)
-- ----------------------------------------------------------------------------
-- Types
......
Supports Markdown
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