newLocalVVar,
- mkBuiltinCo, voidType,
+ mkBuiltinCo, voidType, mkWrapType,
mkPADictType, mkPArrayType, mkPDataType, mkPReprType, mkPArray,
pdataReprTyCon, pdataReprDataCon, mkVScrut,
- prDFunOfTyCon,
+ prDictOfType, prDFunOfTyCon,
paDictArgType, paDictOfType, paDFunType,
- paMethod, mkPR, replicatePD, emptyPD, packPD,
+ paMethod, wrapPR, replicatePD, emptyPD, packPD, packByTagPD,
combinePD,
liftPD,
zipScalars, scalarClosure,
- polyAbstract, polyApply, polyVApply,
+ polyAbstract, polyApply, polyVApply, polyArity,
+ Inline(..), addInlineArity, inlineMe,
hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
buildClosure, buildClosures,
mkClosureApp
import VectCore
import VectMonad
-import MkCore ( mkCoreTup, mkCoreTupTy, mkWildCase )
+import MkCore ( mkCoreTup, mkWildCase )
import CoreSyn
import CoreUtils
+import CoreUnfold ( mkInlineRule )
import Coercion
import Type
import TypeRep
import DataCon
import Var
import MkId ( unwrapFamInstScrut )
+import Id ( setIdUnfolding )
import TysWiredIn
import BasicTypes ( Boxity(..) )
import Literal ( Literal, mkMachInt )
import Control.Monad
-
collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
collectAnnTypeArgs expr = go expr []
where
mk tc ty1 ty2 = mkTyConApp tc [ty1,ty2]
voidType :: VM Type
-voidType = mkBuiltinTyConApp voidTyCon []
+voidType = mkBuiltinTyConApp VectMonad.voidTyCon []
+
+mkWrapType :: Type -> VM Type
+mkWrapType ty = mkBuiltinTyConApp wrapTyCon [ty]
mkClosureTypes :: [Type] -> Type -> VM Type
mkClosureTypes = mkBuiltinTyConApps closureTyCon
dicts <- mapM paDictOfType tys
return $ mkApps (mkTyApps dfun tys) dicts
-type PAMethod = (Builtins -> Var, String)
-
paMethod :: (Builtins -> Var) -> String -> Type -> VM CoreExpr
paMethod _ name ty
| Just tycon <- splitPrimTyCon ty
dict <- paDictOfType ty
return $ mkApps (Var fn) [Type ty, dict]
-mkPR :: Type -> VM CoreExpr
-mkPR ty
+prDictOfType :: Type -> VM CoreExpr
+prDictOfType ty = prDictOfTyApp ty_fn ty_args
+ where
+ (ty_fn, ty_args) = splitAppTys ty
+
+prDictOfTyApp :: Type -> [Type] -> VM CoreExpr
+prDictOfTyApp ty_fn ty_args
+ | Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args
+prDictOfTyApp (TyConApp tc _) ty_args
= do
- fn <- builtin mkPRVar
- dict <- paDictOfType ty
- return $ mkApps (Var fn) [Type ty, dict]
+ dfun <- liftM Var $ maybeV (lookupTyConPR tc)
+ prDFunApply dfun ty_args
+prDictOfTyApp _ _ = noV
+
+prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr
+prDFunApply dfun tys
+ = do
+ dicts <- mapM prDictOfType tys
+ return $ mkApps (mkTyApps dfun tys) dicts
+
+wrapPR :: Type -> VM CoreExpr
+wrapPR ty
+ = do
+ pa_dict <- paDictOfType ty
+ pr_dfun <- prDFunOfTyCon =<< builtin wrapTyCon
+ return $ mkApps pr_dfun [Type ty, pa_dict]
replicatePD :: CoreExpr -> CoreExpr -> VM CoreExpr
replicatePD len x = liftM (`mkApps` [len,x])
packPD ty xs len sel = liftM (`mkApps` [xs, len, sel])
(paMethod packPDVar "packPD" ty)
+packByTagPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr
+ -> VM CoreExpr
+packByTagPD ty xs len tags t
+ = liftM (`mkApps` [xs, len, tags, t])
+ (paMethod packByTagPDVar "packByTagPD" ty)
+
combinePD :: Type -> CoreExpr -> CoreExpr -> [CoreExpr]
-> VM CoreExpr
combinePD ty len sel xs
lv <- newLocalVar fs lty
return (vv,lv)
-polyAbstract :: [TyVar] -> ((CoreExpr -> CoreExpr) -> VM a) -> VM a
+polyAbstract :: [TyVar] -> ([Var] -> VM a) -> VM a
polyAbstract tvs p
= localV
$ do
mdicts <- mapM mk_dict_var tvs
- zipWithM_ (\tv -> maybe (defLocalTyVar tv) (defLocalTyVarWithPA tv . Var)) tvs mdicts
- p (mk_lams mdicts)
+ zipWithM_ (\tv -> maybe (defLocalTyVar tv)
+ (defLocalTyVarWithPA tv . Var)) tvs mdicts
+ p (mk_args mdicts)
where
mk_dict_var tv = do
r <- paDictArgType tv
Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty)
Nothing -> return Nothing
- mk_lams mdicts = mkLams (tvs ++ [dict | Just dict <- mdicts])
+ mk_args mdicts = [dict | Just dict <- mdicts]
+
+polyArity :: [TyVar] -> VM Int
+polyArity tvs = do
+ tys <- mapM paDictArgType tvs
+ return $ length [() | Just _ <- tys]
polyApply :: CoreExpr -> [Type] -> VM CoreExpr
polyApply expr tys
dicts <- mapM paDictOfType tys
return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
+
+data Inline = Inline Int -- arity
+ | DontInline
+
+addInlineArity :: Inline -> Int -> Inline
+addInlineArity (Inline m) n = Inline (m+n)
+addInlineArity DontInline _ = DontInline
+
+inlineMe :: Inline
+inlineMe = Inline 0
+
hoistBinding :: Var -> CoreExpr -> VM ()
hoistBinding v e = updGEnv $ \env ->
env { global_bindings = (v,e) : global_bindings env }
-hoistExpr :: FastString -> CoreExpr -> VM Var
-hoistExpr fs expr
+hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var
+hoistExpr fs expr inl
= do
- var <- newLocalVar fs (exprType expr)
+ var <- mk_inline `liftM` newLocalVar fs (exprType expr)
hoistBinding var expr
return var
+ where
+ mk_inline var = case inl of
+ Inline arity -> var `setIdUnfolding`
+ mkInlineRule InlSat expr arity
+ DontInline -> var
-hoistVExpr :: VExpr -> VM VVar
-hoistVExpr (ve, le)
+hoistVExpr :: VExpr -> Inline -> VM VVar
+hoistVExpr (ve, le) inl
= do
fs <- getBindName
- vv <- hoistExpr ('v' `consFS` fs) ve
- lv <- hoistExpr ('l' `consFS` fs) le
+ vv <- hoistExpr ('v' `consFS` fs) ve inl
+ lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
return (vv, lv)
-hoistPolyVExpr :: [TyVar] -> VM VExpr -> VM VExpr
-hoistPolyVExpr tvs p
+hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr
+hoistPolyVExpr tvs inline p
= do
- expr <- closedV . polyAbstract tvs $ \abstract ->
- liftM (mapVect abstract) p
- fn <- hoistVExpr expr
+ inline' <- liftM (addInlineArity inline) (polyArity tvs)
+ expr <- closedV . polyAbstract tvs $ \args ->
+ liftM (mapVect (mkLams $ tvs ++ args)) p
+ fn <- hoistVExpr expr inline'
polyVApply (vVar fn) (mkTyVarTys tvs)
takeHoisted :: VM [(Var, CoreExpr)]
buildClosures _ _ [] _ mk_body
= mk_body
buildClosures tvs vars [arg_ty] res_ty mk_body
- = liftM vInlineMe (buildClosure tvs vars arg_ty res_ty mk_body)
+ = -- liftM vInlineMe $
+ buildClosure tvs vars arg_ty res_ty mk_body
buildClosures tvs vars (arg_ty : arg_tys) res_ty mk_body
= do
res_ty' <- mkClosureTypes arg_tys res_ty
arg <- newLocalVVar (fsLit "x") arg_ty
- liftM vInlineMe
- . buildClosure tvs vars arg_ty res_ty'
- . hoistPolyVExpr tvs
+ -- liftM vInlineMe
+ buildClosure tvs vars arg_ty res_ty'
+ . hoistPolyVExpr tvs (Inline (length vars + 1))
$ do
lc <- builtin liftingContext
clo <- buildClosures tvs (vars ++ [arg]) arg_tys res_ty mk_body
env_bndr <- newLocalVVar (fsLit "env") env_ty
arg_bndr <- newLocalVVar (fsLit "arg") arg_ty
- fn <- hoistPolyVExpr tvs
+ fn <- hoistPolyVExpr tvs (Inline 2)
$ do
lc <- builtin liftingContext
body <- mk_body
- return . vInlineMe
+ return -- . vInlineMe
. vLams lc [env_bndr, arg_bndr]
$ bind (vVar env_bndr)
(vVarApps lc body (vars ++ [arg_bndr]))
`mkTyApps` lenv_tyargs
`mkApps` map Var lvs
- vbind env body = mkWildCase venv ty (exprType body)
- [(DataAlt venv_con, vvs, body)]
+ vbind env body = mkWildCase env ty (exprType body)
+ [(DataAlt venv_con, vvs, body)]
lbind env body =
- let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs lenv
+ let scrut = unwrapFamInstScrut lenv_tc lenv_tyargs env
in
mkWildCase scrut (exprType scrut) (exprType body)
[(DataAlt lenv_con, lvs, body)]
where
(vvs, lvs) = unzip vs
tys = map vVarType vs
- ty = mkCoreTupTy tys
+ ty = mkBoxedTupleTy tys
projects / ghc-hetmet.git / blobdiff