Break out hoisting utils into their own module

diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 57b7467..06d7e28 100644 (file)
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -464,6 +464,7 @@ Library
         Vectorise.Type.TyConDecl
         Vectorise.Type.Classify
         Vectorise.Utils.Closure
+        Vectorise.Utils.Hoisting
         Vectorise.Builtins.Base
         Vectorise.Builtins.Initialise
         Vectorise.Builtins.Modules

diff --git a/compiler/vectorise/VectType.hs b/compiler/vectorise/VectType.hs
index 960028c..046acb9 100644 (file)
--- a/compiler/vectorise/VectType.hs
+++ b/compiler/vectorise/VectType.hs
@@ -15,6 +15,7 @@ import Vectorise.Type.Type
 import Vectorise.Type.TyConDecl
 import Vectorise.Type.Classify
 import Vectorise.Utils.Closure
+import Vectorise.Utils.Hoisting
 
 import HscTypes          ( TypeEnv, extendTypeEnvList, typeEnvTyCons )
 import BasicTypes

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 8c82fb0..9c50d4a 100644 (file)
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -16,37 +16,27 @@ module VectUtils (
   combinePD,
   liftPD,
   zipScalars, scalarClosure,
-  polyAbstract, polyApply, polyVApply, polyArity,
-  Inline(..), addInlineArity, inlineMe,
-  hoistBinding, hoistExpr, hoistPolyVExpr, takeHoisted,
+  polyAbstract, polyApply, polyVApply, polyArity
 ) where
-
-
 import Vectorise.Monad
-import Vectorise.Env
 import Vectorise.Vect
 import Vectorise.Builtins
 
 import CoreSyn
 import CoreUtils
-import CoreUnfold         ( mkInlineRule )
 import Coercion
 import Type
 import TypeRep
 import TyCon
 import DataCon
 import Var
-import MkId               ( unwrapFamInstScrut )
-import Id                 ( setIdUnfolding )
-import BasicTypes
-import Literal            ( Literal, mkMachInt )
-
-
+import MkId
+import Literal
 import Outputable
 import FastString
-
 import Control.Monad
 
+
 collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
 collectAnnTypeArgs expr = go expr []
   where
@@ -363,62 +353,6 @@ polyVApply expr tys
  = do Just dicts <- liftM sequence $ mapM paDictOfType tys
       return     $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr
 
--- Inline ---------------------------------------------------------------------
--- | Records whether we should inline a particular binding.
-data Inline 
-        = Inline Arity
-        | DontInline
-
--- | Add to the arity contained within an `Inline`, if any.
-addInlineArity :: Inline -> Int -> Inline
-addInlineArity (Inline m) n = Inline (m+n)
-addInlineArity DontInline _ = DontInline
-
--- | Says to always inline a binding.
-inlineMe :: Inline
-inlineMe = Inline 0
-
-
--- Hoising --------------------------------------------------------------------
-hoistBinding :: Var -> CoreExpr -> VM ()
-hoistBinding v e = updGEnv $ \env ->
-  env { global_bindings = (v,e) : global_bindings env }
-
-hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var
-hoistExpr fs expr inl
-  = do
-      var <- mk_inline `liftM` newLocalVar fs (exprType expr)
-      hoistBinding var expr
-      return var
-  where
-    mk_inline var = case inl of
-                      Inline arity -> var `setIdUnfolding`
-                                      mkInlineRule expr (Just arity)
-                      DontInline   -> var
-
-hoistVExpr :: VExpr -> Inline -> VM VVar
-hoistVExpr (ve, le) inl
-  = do
-      fs <- getBindName
-      vv <- hoistExpr ('v' `consFS` fs) ve inl
-      lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
-      return (vv, lv)
-
-hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr
-hoistPolyVExpr tvs inline p
-  = do
-      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)]
-takeHoisted
-  = do
-      env <- readGEnv id
-      setGEnv $ env { global_bindings = [] }
-      return $ global_bindings env
 
 {-
 boxExpr :: Type -> VExpr -> VM VExpr

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 34ca5ab..22cba53 100644 (file)
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -3,8 +3,8 @@
 module Vectorise( vectorise )
 where
 
-import VectUtils
 import VectType
+import Vectorise.Utils.Hoisting
 import Vectorise.Exp
 import Vectorise.Vect
 import Vectorise.Env

diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs
index 5597e2f..1c2ee4c 100644 (file)
--- a/compiler/vectorise/Vectorise/Exp.hs
+++ b/compiler/vectorise/Vectorise/Exp.hs
@@ -6,6 +6,7 @@ where
 import VectUtils
 import VectType
 import Vectorise.Utils.Closure
+import Vectorise.Utils.Hoisting
 import Vectorise.Var
 import Vectorise.Vect
 import Vectorise.Env

diff --git a/compiler/vectorise/Vectorise/Utils/Closure.hs b/compiler/vectorise/Vectorise/Utils/Closure.hs
index 685c82b..47cb837 100644 (file)
--- a/compiler/vectorise/Vectorise/Utils/Closure.hs
+++ b/compiler/vectorise/Vectorise/Utils/Closure.hs
@@ -8,6 +8,7 @@ module Vectorise.Utils.Closure (
 )
 where
 import VectUtils
+import Vectorise.Utils.Hoisting
 import Vectorise.Builtins
 import Vectorise.Vect
 import Vectorise.Monad

diff --git a/compiler/vectorise/Vectorise/Utils/Hoisting.hs b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
new file mode 100644 (file)
index 0000000..a604927
--- /dev/null
+++ b/compiler/vectorise/Vectorise/Utils/Hoisting.hs
@@ -0,0 +1,89 @@
+
+module Vectorise.Utils.Hoisting (
+       Inline(..),
+       addInlineArity,
+       inlineMe,
+       
+       hoistBinding,
+       hoistExpr,
+       hoistVExpr,
+       hoistPolyVExpr,
+       takeHoisted
+)
+where
+import VectUtils
+import Vectorise.Monad
+import Vectorise.Env
+import Vectorise.Vect
+
+import CoreSyn
+import CoreUtils
+import CoreUnfold
+import Type
+import Var
+import Id
+import BasicTypes
+import FastString
+import Control.Monad
+
+
+-- Inline ---------------------------------------------------------------------
+-- | Records whether we should inline a particular binding.
+data Inline 
+        = Inline Arity
+        | DontInline
+
+-- | Add to the arity contained within an `Inline`, if any.
+addInlineArity :: Inline -> Int -> Inline
+addInlineArity (Inline m) n = Inline (m+n)
+addInlineArity DontInline _ = DontInline
+
+-- | Says to always inline a binding.
+inlineMe :: Inline
+inlineMe = Inline 0
+
+
+-- Hoising --------------------------------------------------------------------
+hoistBinding :: Var -> CoreExpr -> VM ()
+hoistBinding v e = updGEnv $ \env ->
+  env { global_bindings = (v,e) : global_bindings env }
+
+
+hoistExpr :: FastString -> CoreExpr -> Inline -> VM Var
+hoistExpr fs expr inl
+  = do
+      var <- mk_inline `liftM` newLocalVar fs (exprType expr)
+      hoistBinding var expr
+      return var
+  where
+    mk_inline var = case inl of
+                      Inline arity -> var `setIdUnfolding`
+                                      mkInlineRule expr (Just arity)
+                      DontInline   -> var
+
+
+hoistVExpr :: VExpr -> Inline -> VM VVar
+hoistVExpr (ve, le) inl
+  = do
+      fs <- getBindName
+      vv <- hoistExpr ('v' `consFS` fs) ve inl
+      lv <- hoistExpr ('l' `consFS` fs) le (addInlineArity inl 1)
+      return (vv, lv)
+
+
+hoistPolyVExpr :: [TyVar] -> Inline -> VM VExpr -> VM VExpr
+hoistPolyVExpr tvs inline p
+  = do
+      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)]
+takeHoisted
+  = do
+      env <- readGEnv id
+      setGEnv $ env { global_bindings = [] }
+      return $ global_bindings env