projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
169f597
)
Comments and formatting only
author
benl@ouroborus.net
<unknown>
Thu, 9 Sep 2010 02:21:17 +0000
(
02:21
+0000)
committer
benl@ouroborus.net
<unknown>
Thu, 9 Sep 2010 02:21:17 +0000
(
02:21
+0000)
compiler/vectorise/Vectorise/Utils/Closure.hs
patch
|
blob
|
history
diff --git
a/compiler/vectorise/Vectorise/Utils/Closure.hs
b/compiler/vectorise/Vectorise/Utils/Closure.hs
index
47cb837
..
d8be668
100644
(file)
--- a/
compiler/vectorise/Vectorise/Utils/Closure.hs
+++ b/
compiler/vectorise/Vectorise/Utils/Closure.hs
@@
-1,4
+1,5
@@
+-- | Utils concerning closure construction and application.
module Vectorise.Utils.Closure (
mkClosure,
mkClosureApp,
module Vectorise.Utils.Closure (
mkClosure,
mkClosureApp,
@@
-26,7
+27,15
@@
import BasicTypes
import FastString
import FastString
-mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr
+-- | Make a closure.
+mkClosure
+ :: Type -- ^ Type of the argument.
+ -> Type -- ^ Type of the result.
+ -> Type -- ^ Type of the environment.
+ -> VExpr -- ^ The function to apply.
+ -> VExpr -- ^ The environment to use.
+ -> VM VExpr
+
mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
= do Just dict <- paDictOfType env_ty
mkv <- builtin closureVar
mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
= do Just dict <- paDictOfType env_ty
mkv <- builtin closureVar
@@
-35,7
+44,14
@@
mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv])
Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv])
-mkClosureApp :: Type -> Type -> VExpr -> VExpr -> VM VExpr
+-- | Make a closure application.
+mkClosureApp
+ :: Type -- ^ Type of the argument.
+ -> Type -- ^ Type of the result.
+ -> VExpr -- ^ Closure to apply.
+ -> VExpr -- ^ Argument to use.
+ -> VM VExpr
+
mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
= do vapply <- builtin applyVar
lapply <- builtin liftedApplyVar
mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
= do vapply <- builtin applyVar
lapply <- builtin liftedApplyVar
@@
-44,22
+60,29
@@
mkClosureApp arg_ty res_ty (vclo, lclo) (varg, larg)
Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg])
Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [Var lc, lclo, larg])
-buildClosures :: [TyVar] -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
+
+buildClosures
+ :: [TyVar]
+ -> [VVar]
+ -> [Type] -- ^ Type of the arguments.
+ -> Type -- ^ Type of result.
+ -> VM VExpr
+ -> VM VExpr
+
buildClosures _ _ [] _ mk_body
buildClosures _ _ [] _ mk_body
- = mk_body
+ = mk_body
+
buildClosures tvs vars [arg_ty] res_ty mk_body
buildClosures tvs vars [arg_ty] res_ty mk_body
- = -- liftM vInlineMe $
- buildClosure tvs vars arg_ty res_ty mk_body
+ = buildClosure tvs vars arg_ty res_ty mk_body
+
buildClosures tvs vars (arg_ty : arg_tys) 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
+ = do res_ty' <- mkClosureTypes arg_tys res_ty
+ arg <- newLocalVVar (fsLit "x") arg_ty
buildClosure tvs vars arg_ty res_ty'
. hoistPolyVExpr tvs (Inline (length vars + 1))
$ do
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
+ lc <- builtin liftingContext
+ clo <- buildClosures tvs (vars ++ [arg]) arg_tys res_ty mk_body
return $ vLams lc (vars ++ [arg]) clo
return $ vLams lc (vars ++ [arg]) clo
@@
-77,31
+100,29
@@
buildClosure tvs vars arg_ty res_ty mk_body
fn <- hoistPolyVExpr tvs (Inline 2)
$ do
fn <- hoistPolyVExpr tvs (Inline 2)
$ do
- lc <- builtin liftingContext
- body <- mk_body
- return -- . vInlineMe
- . vLams lc [env_bndr, arg_bndr]
- $ bind (vVar env_bndr)
- (vVarApps lc body (vars ++ [arg_bndr]))
+ lc <- builtin liftingContext
+ body <- mk_body
+ return . vLams lc [env_bndr, arg_bndr]
+ $ bind (vVar env_bndr)
+ (vVarApps lc body (vars ++ [arg_bndr]))
mkClosure arg_ty res_ty env_ty fn env
-- Environments ---------------------------------------------------------------
buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr)
mkClosure arg_ty res_ty env_ty fn env
-- Environments ---------------------------------------------------------------
buildEnv :: [VVar] -> VM (Type, VExpr, VExpr -> VExpr -> VExpr)
-buildEnv [] = do
- ty <- voidType
- void <- builtin voidVar
- pvoid <- builtin pvoidVar
- return (ty, vVar (void, pvoid), \_ body -> body)
+buildEnv []
+ = do
+ ty <- voidType
+ void <- builtin voidVar
+ pvoid <- builtin pvoidVar
+ return (ty, vVar (void, pvoid), \_ body -> body)
buildEnv [v] = return (vVarType v, vVar v,
\env body -> vLet (vNonRec v env) body)
buildEnv vs
buildEnv [v] = return (vVarType v, vVar v,
\env body -> vLet (vNonRec v env) body)
buildEnv vs
- = do
-
- (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty
+ = do (lenv_tc, lenv_tyargs) <- pdataReprTyCon ty
let venv_con = tupleCon Boxed (length vs)
[lenv_con] = tyConDataCons lenv_tc
let venv_con = tupleCon Boxed (length vs)
[lenv_con] = tyConDataCons lenv_tc