2 collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg,
4 mkPADictType, mkPArrayType,
5 paDictArgType, paDictOfType,
10 #include "HsVersions.h"
25 import Control.Monad ( liftM )
27 collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
28 collectAnnTypeArgs expr = go expr []
30 go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys)
33 collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
34 collectAnnTypeBinders expr = go [] expr
36 go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
37 go bs e = (reverse bs, e)
39 isAnnTypeArg :: AnnExpr b ann -> Bool
40 isAnnTypeArg (_, AnnType t) = True
41 isAnnTypeArg _ = False
43 isClosureTyCon :: TyCon -> Bool
44 isClosureTyCon tc = tyConUnique tc == closureTyConKey
46 splitClosureTy :: Type -> (Type, Type)
48 | Just (tc, [arg_ty, res_ty]) <- splitTyConApp_maybe ty
52 | otherwise = pprPanic "splitClosureTy" (ppr ty)
54 mkPADictType :: Type -> VM Type
57 tc <- builtin paDictTyCon
58 return $ TyConApp tc [ty]
60 mkPArrayType :: Type -> VM Type
63 tc <- builtin parrayTyCon
64 return $ TyConApp tc [ty]
66 paDictArgType :: TyVar -> VM (Maybe Type)
67 paDictArgType tv = go (TyVarTy tv) (tyVarKind tv)
69 go ty k | Just k' <- kindView k = go ty k'
72 tv <- newTyVar FSLIT("a") k1
73 mty1 <- go (TyVarTy tv) k1
76 mty2 <- go (AppTy ty (TyVarTy tv)) k2
77 return $ fmap (ForAllTy tv . FunTy ty1) mty2
82 = liftM Just (mkPADictType ty)
84 go ty k = return Nothing
86 paDictOfType :: Type -> VM CoreExpr
87 paDictOfType ty = paDictOfTyApp ty_fn ty_args
89 (ty_fn, ty_args) = splitAppTys ty
91 paDictOfTyApp :: Type -> [Type] -> VM CoreExpr
92 paDictOfTyApp ty_fn ty_args
93 | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args
94 paDictOfTyApp (TyVarTy tv) ty_args
96 dfun <- maybeV (lookupTyVarPA tv)
97 paDFunApply dfun ty_args
98 paDictOfTyApp (TyConApp tc _) ty_args
100 pa_class <- builtin paClass
101 (dfun, ty_args') <- lookupInst pa_class [TyConApp tc ty_args]
102 paDFunApply (Var dfun) ty_args'
103 paDictOfTyApp ty ty_args = pprPanic "paDictOfTyApp" (ppr ty)
105 paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
108 dicts <- mapM paDictOfType tys
109 return $ mkApps (mkTyApps dfun tys) dicts
111 lookupPArrayFamInst :: Type -> VM (TyCon, [Type])
112 lookupPArrayFamInst ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
114 hoistExpr :: FastString -> CoreExpr -> VM Var
117 var <- newLocalVar fs (exprType expr)
119 env { global_bindings = (var, expr) : global_bindings env }
122 takeHoisted :: VM [(Var, CoreExpr)]
126 setGEnv $ env { global_bindings = [] }
127 return $ global_bindings env