Commit 742db8bd authored by rl@cse.unsw.edu.au's avatar rl@cse.unsw.edu.au
Browse files

More refactoring

parent 0ae3d313
......@@ -208,23 +208,9 @@ buildPReprRhsTy :: TyCon -> VM Type
buildPReprRhsTy = buildPReprTy . map dataConRepArgTys . tyConDataCons
buildPReprTy :: [[Type]] -> VM Type
buildPReprTy [] = panic "mkPRepr"
buildPReprTy tys
= do
embed <- builtin embedTyCon
plus <- builtin plusTyCon
cross <- builtin crossTyCon
return . foldr1 (mk_bin plus)
. map (mkprod cross)
. map (map (mk_un embed))
$ tys
where
mkprod cross [] = unitTy
mkprod cross tys = foldr1 (mk_bin cross) tys
mk_un tc ty = mkTyConApp tc [ty]
mk_bin tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
buildPReprTy tys = mkPlusTypes unitTy
=<< mapM (mkCrossTypes unitTy)
=<< mapM (mapM mkEmbedType) tys
buildPArrayTyCon :: TyCon -> TyCon -> VM TyCon
buildPArrayTyCon orig_tc vect_tc = fixV $ \repr_tc ->
......
......@@ -3,6 +3,7 @@ module VectUtils (
collectAnnValBinders,
mkDataConTag,
splitClosureTy,
mkPlusType, mkPlusTypes, mkCrossType, mkCrossTypes, mkEmbedType,
mkPADictType, mkPArrayType,
parrayReprTyCon, parrayReprDataCon, mkVScrut,
paDictArgType, paDictOfType, paDFunType,
......@@ -98,8 +99,9 @@ mkBuiltinTyConApps get_tc tys ty
where
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> [Type] -> VM Type
mkBuiltinTyConApps1 get_tc tys
mkBuiltinTyConApps1 :: (Builtins -> TyCon) -> Type -> [Type] -> VM Type
mkBuiltinTyConApps1 get_tc dft [] = return dft
mkBuiltinTyConApps1 get_tc dft tys
= do
tc <- builtin get_tc
case tys of
......@@ -108,6 +110,21 @@ mkBuiltinTyConApps1 get_tc tys
where
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
mkPlusType :: Type -> Type -> VM Type
mkPlusType ty1 ty2 = mkBuiltinTyConApp plusTyCon [ty1, ty2]
mkPlusTypes :: Type -> [Type] -> VM Type
mkPlusTypes = mkBuiltinTyConApps1 plusTyCon
mkCrossType :: Type -> Type -> VM Type
mkCrossType ty1 ty2 = mkBuiltinTyConApp crossTyCon [ty1, ty2]
mkCrossTypes :: Type -> [Type] -> VM Type
mkCrossTypes = mkBuiltinTyConApps1 crossTyCon
mkEmbedType :: Type -> VM Type
mkEmbedType ty = mkBuiltinTyConApp embedTyCon [ty]
mkClosureType :: Type -> Type -> VM Type
mkClosureType arg_ty res_ty = mkBuiltinTyConApp closureTyCon [arg_ty, res_ty]
......
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