This BIG PATCH contains most of the work for the New Coercion Representation

[ghc-hetmet.git] / compiler / vectorise / Vectorise / Utils / Closure.hs

diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs
index 685c82b..d784984 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,
@@ -7,34 +8,50 @@ module Vectorise.Utils.Closure (
        buildEnv
 )
 where
-import VectUtils
 import Vectorise.Builtins
 import Vectorise.Vect
 import Vectorise.Monad
+import Vectorise.Utils.Base
+import Vectorise.Utils.PADict
+import Vectorise.Utils.Hoisting
 
 import CoreSyn
 import Type
-import Var
 import MkCore
 import CoreUtils
 import TyCon
 import DataCon
 import MkId
 import TysWiredIn
-import BasicTypes
+import BasicTypes( Boxity(..) )
 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
-      mkl       <- builtin liftedClosureVar
+ = do dict <- paDictOfType env_ty
+      mkv  <- builtin closureVar
+      mkl  <- builtin liftedClosureVar
       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 :: 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
@@ -43,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
 
 
@@ -76,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