projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Rename "language" varibles etc to "extension", and add --supported-extensions
[ghc-hetmet.git]
/
compiler
/
vectorise
/
VectUtils.hs
diff --git
a/compiler/vectorise/VectUtils.hs
b/compiler/vectorise/VectUtils.hs
index
ea647c7
..
c62c405
100644
(file)
--- a/
compiler/vectorise/VectUtils.hs
+++ b/
compiler/vectorise/VectUtils.hs
@@
-11,11
+11,12
@@
module VectUtils (
pdataReprTyCon, pdataReprDataCon, mkVScrut,
prDictOfType, prDFunOfTyCon,
paDictArgType, paDictOfType, paDFunType,
pdataReprTyCon, pdataReprDataCon, mkVScrut,
prDictOfType, prDFunOfTyCon,
paDictArgType, paDictOfType, paDFunType,
- paMethod, wrapPR, replicatePD, emptyPD, packPD,
+ paMethod, wrapPR, replicatePD, emptyPD, packByTagPD,
combinePD,
liftPD,
zipScalars, scalarClosure,
combinePD,
liftPD,
zipScalars, scalarClosure,
- polyAbstract, polyApply, polyVApply,
+ polyAbstract, polyApply, polyVApply, polyArity,
+ Inline(..), addInlineArity, inlineMe,
hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
buildClosure, buildClosures,
mkClosureApp
hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
buildClosure, buildClosures,
mkClosureApp
@@
-24,9
+25,10
@@
module VectUtils (
import VectCore
import VectMonad
import VectCore
import VectMonad
-import MkCore ( mkCoreTup, mkCoreTupTy, mkWildCase )
+import MkCore ( mkCoreTup, mkWildCase )
import CoreSyn
import CoreUtils
import CoreSyn
import CoreUtils
+import CoreUnfold ( mkInlineRule )
import Coercion
import Type
import TypeRep
import Coercion
import Type
import TypeRep
@@
-34,8
+36,9
@@
import TyCon
import DataCon
import Var
import MkId ( unwrapFamInstScrut )
import DataCon
import Var
import MkId ( unwrapFamInstScrut )
+import Id ( setIdUnfolding )
import TysWiredIn
import TysWiredIn
-import BasicTypes ( Boxity(..) )
+import BasicTypes ( Boxity(..), Arity )
import Literal ( Literal, mkMachInt )
import Outputable
import Literal ( Literal, mkMachInt )
import Outputable
@@
-43,7
+46,6
@@
import FastString
import Control.Monad
import Control.Monad
-
collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
collectAnnTypeArgs expr = go expr []
where
collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
collectAnnTypeArgs expr = go expr []
where
@@
-241,7
+243,7
@@
prDictOfTyApp ty_fn ty_args
| Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args
prDictOfTyApp (TyConApp tc _) ty_args
= do
| Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args
prDictOfTyApp (TyConApp tc _) ty_args
= do
- dfun <- prDFunOfTyCon tc
+ dfun <- liftM Var $ maybeV (lookupTyConPR tc)
prDFunApply dfun ty_args
prDictOfTyApp _ _ = noV
prDFunApply dfun ty_args
prDictOfTyApp _ _ = noV
@@
-265,9
+267,11
@@
replicatePD len x = liftM (`mkApps` [len,x])
emptyPD :: Type -> VM CoreExpr
emptyPD = paMethod emptyPDVar "emptyPD"
emptyPD :: Type -> VM CoreExpr
emptyPD = paMethod emptyPDVar "emptyPD"
-packPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr
-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 :: Type -> CoreExpr -> CoreExpr -> [CoreExpr]
-> VM CoreExpr
@@
-309,13
+313,14
@@
newLocalVVar fs vty
lv <- newLocalVar fs lty
return (vv,lv)
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
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
where
mk_dict_var tv = do
r <- paDictArgType tv
@@
-323,7
+328,12
@@
polyAbstract tvs p
Just ty -> liftM Just (newLocalVar (fsLit "dPA") ty)
Nothing -> return Nothing
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
polyApply :: CoreExpr -> [Type] -> VM CoreExpr
polyApply expr tys
@@
-337,31
+347,48
@@
polyVApply expr tys
dicts <- mapM paDictOfType tys
return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
dicts <- mapM paDictOfType tys
return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
+
+data Inline = Inline 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 }
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
= do
- var <- newLocalVar fs (exprType expr)
+ var <- mk_inline `liftM` newLocalVar fs (exprType expr)
hoistBinding var expr
return var
hoistBinding var expr
return var
+ where
+ mk_inline var = case inl of
+ Inline arity -> var `setIdUnfolding`
+ mkInlineRule expr (Just arity)
+ DontInline -> var
-hoistVExpr :: VExpr -> VM VVar
-hoistVExpr (ve, le)
+hoistVExpr :: VExpr -> Inline -> VM VVar
+hoistVExpr (ve, le) inl
= do
fs <- getBindName
= 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)
return (vv, lv)
-hoistPolyVExpr :: [TyVar] -> VM VExpr -> VM VExpr
-hoistPolyVExpr tvs p
+hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr
+hoistPolyVExpr tvs inline p
= do
= 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)]
polyVApply (vVar fn) (mkTyVarTys tvs)
takeHoisted :: VM [(Var, CoreExpr)]
@@
-407,14
+434,15
@@
buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
buildClosures _ _ [] _ mk_body
= mk_body
buildClosures tvs vars [arg_ty] res_ty mk_body
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
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
$ do
lc <- builtin liftingContext
clo <- buildClosures tvs (vars ++ [arg]) arg_tys res_ty mk_body
@@
-432,11
+460,11
@@
buildClosure tvs vars arg_ty res_ty mk_body
env_bndr <- newLocalVVar (fsLit "env") env_ty
arg_bndr <- newLocalVVar (fsLit "arg") arg_ty
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
$ 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]))
. vLams lc [env_bndr, arg_bndr]
$ bind (vVar env_bndr)
(vVarApps lc body (vars ++ [arg_bndr]))
@@
-482,5
+510,5
@@
buildEnv vs
where
(vvs, lvs) = unzip vs
tys = map vVarType vs
where
(vvs, lvs) = unzip vs
tys = map vVarType vs
- ty = mkCoreTupTy tys
+ ty = mkBoxedTupleTy tys