module VectUtils (
collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg,
collectAnnValBinders,
+ mkDataConTag,
splitClosureTy,
mkPADictType, mkPArrayType,
- paDictArgType, paDictOfType,
+ paDictArgType, paDictOfType, paDFunType,
paMethod, lengthPA, replicatePA, emptyPA, liftPA,
polyAbstract, polyApply, polyVApply,
lookupPArrayFamInst,
import Type
import TypeRep
import TyCon
-import DataCon ( dataConWrapId )
+import DataCon ( DataCon, dataConWrapId, dataConTag )
import Var
import Id ( mkWildId )
import MkId ( unwrapFamInstScrut )
isAnnTypeArg (_, AnnType t) = True
isAnnTypeArg _ = False
+mkDataConTag :: DataCon -> CoreExpr
+mkDataConTag dc = mkConApp intDataCon [mkIntLitInt $ dataConTag dc]
+
isClosureTyCon :: TyCon -> Bool
isClosureTyCon tc = tyConName tc == closureTyConName
mkPADictType :: Type -> VM Type
mkPADictType ty
= do
- tc <- builtin paDictTyCon
+ tc <- builtin paTyCon
return $ TyConApp tc [ty]
mkPArrayType :: Type -> VM Type
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'
+ dfun <- traceMaybeV "paDictOfTyApp" (ppr tc) (lookupTyConPA tc)
+ paDFunApply (Var dfun) ty_args
paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
+paDFunType :: TyCon -> VM Type
+paDFunType tc
+ = do
+ margs <- mapM paDictArgType tvs
+ res <- mkPADictType (mkTyConApp tc arg_tys)
+ return . mkForAllTys tvs
+ $ mkFunTys [arg | Just arg <- margs] res
+ where
+ tvs = tyConTyVars tc
+ arg_tys = mkTyVarTys tvs
+
paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
paDFunApply dfun tys
= do