Move code

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index d6569e7..718db85 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -8,7 +8,8 @@ module VectUtils (
   polyAbstract, polyApply, polyVApply,
   lookupPArrayFamInst,
   hoistExpr, hoistPolyVExpr, takeHoisted,
-  buildClosure, buildClosures
+  buildClosure, buildClosures,
+  mkClosureApp
 ) where
 
 #include "HsVersions.h"
@@ -239,7 +240,6 @@ takeHoisted
       setGEnv $ env { global_bindings = [] }
       return $ global_bindings env
 
-
 mkClosure :: Type -> Type -> Type -> VExpr -> VExpr -> VM VExpr
 mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
   = do
@@ -249,6 +249,16 @@ mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv)
       return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv],
               Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv])
 
+mkClosureApp :: VExpr -> VExpr -> VM VExpr
+mkClosureApp (vclo, lclo) (varg, larg)
+  = do
+      vapply <- builtin applyClosureVar
+      lapply <- builtin applyClosurePVar
+      return (Var vapply `mkTyApps` [arg_ty, res_ty] `mkApps` [vclo, varg],
+              Var lapply `mkTyApps` [arg_ty, res_ty] `mkApps` [lclo, larg])
+  where
+    (arg_ty, res_ty) = splitClosureTy (exprType vclo)
+
 buildClosures :: [TyVar] -> Var -> [VVar] -> [Type] -> Type -> VM VExpr -> VM VExpr
 buildClosures tvs lc vars [arg_ty] res_ty mk_body
   = buildClosure tvs lc vars arg_ty res_ty mk_body

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 59e5264..75d1cb1 100644 (file)
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -150,17 +150,6 @@ vectBndrsIn vs p
 -- ----------------------------------------------------------------------------
 -- Expressions
 
-capply :: VExpr -> VExpr -> VM VExpr
-capply (vfn, lfn) (varg, larg)
-  = do
-      apply  <- builtin applyClosureVar
-      applyP <- builtin applyClosurePVar
-      return (mkApps (Var apply)  [Type arg_ty, Type res_ty, vfn, varg],
-              mkApps (Var applyP) [Type arg_ty, Type res_ty, lfn, larg])
-  where
-    fn_ty            = exprType vfn
-    (arg_ty, res_ty) = splitClosureTy fn_ty
-
 vectVar :: Var -> Var -> VM VExpr
 vectVar lc v
   = do
@@ -222,7 +211,7 @@ vectExpr lc (_, AnnApp fn arg)
   = do
       fn'  <- vectExpr lc fn
       arg' <- vectExpr lc arg
-      capply fn' arg'
+      mkClosureApp fn' arg'
 
 vectExpr lc (_, AnnCase expr bndr ty alts)
   = panic "vectExpr: case"
@@ -272,7 +261,7 @@ vectLam lc fvs bs body
                                            (vectExpr new_lc body)
             return $ vLams new_lc vbndrs vbody
   
-vectTyAppExpr :: Var -> CoreExprWithFVs -> [Type] -> VM (CoreExpr, CoreExpr)
+vectTyAppExpr :: Var -> CoreExprWithFVs -> [Type] -> VM VExpr
 vectTyAppExpr lc (_, AnnVar v) tys = vectPolyVar lc v tys
 vectTyAppExpr lc e tys = pprPanic "vectTyAppExpr" (ppr $ deAnnotate e)