From: benl@ouroborus.net Date: Thu, 9 Sep 2010 02:21:17 +0000 (+0000) Subject: Comments and formatting only X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=c2beb20be49d8eff25404643f4e1adfac50a81f1 Comments and formatting only --- diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs index 47cb837..d8be668 100644 --- 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, @@ -26,7 +27,15 @@ import BasicTypes 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 @@ -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]) -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 @@ -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]) -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 - = mk_body + = 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 - = 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 - 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 @@ -77,31 +100,29 @@ buildClosure tvs vars arg_ty res_ty mk_body 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) -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 - = 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