X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Fvectorise%2FVectUtils.hs;h=199ef68e093c2d3ea349460ab99a1456285d3e85;hb=c6eadadbefe2ec5709e9d31893f79c4ff78754b4;hp=2a3b3facae153a9b6be64cc1a8000b80fad7b75d;hpb=5e979164079ae89ca01483131149b8727dd82686;p=ghc-hetmet.git

diff --git a/compiler/vectorise/VectUtils.hs b/compiler/vectorise/VectUtils.hs
index 2a3b3fa..199ef68 100644
--- a/compiler/vectorise/VectUtils.hs
+++ b/compiler/vectorise/VectUtils.hs
@@ -1,7 +1,10 @@
 module VectUtils (
+  collectAnnTypeBinders, collectAnnTypeArgs, isAnnTypeArg,
   splitClosureTy,
   mkPADictType, mkPArrayType,
-  paDictArgType, paDictOfType
+  paDictArgType, paDictOfType,
+  lookupPArrayFamInst,
+  hoistExpr, takeHoisted
 ) where
 
 #include "HsVersions.h"
@@ -9,6 +12,7 @@ module VectUtils (
 import VectMonad
 
 import CoreSyn
+import CoreUtils
 import Type
 import TypeRep
 import TyCon
@@ -16,9 +20,26 @@ import Var
 import PrelNames
 
 import Outputable
+import FastString
 
 import Control.Monad         ( liftM )
 
+collectAnnTypeArgs :: AnnExpr b ann -> (AnnExpr b ann, [Type])
+collectAnnTypeArgs expr = go expr []
+  where
+    go (_, AnnApp f (_, AnnType ty)) tys = go f (ty : tys)
+    go e                             tys = (e, tys)
+
+collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann)
+collectAnnTypeBinders expr = go [] expr
+  where
+    go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e
+    go bs e                           = (reverse bs, e)
+
+isAnnTypeArg :: AnnExpr b ann -> Bool
+isAnnTypeArg (_, AnnType t) = True
+isAnnTypeArg _              = False
+
 isClosureTyCon :: TyCon -> Bool
 isClosureTyCon tc = tyConUnique tc == closureTyConKey
 
@@ -87,3 +108,21 @@ paDFunApply dfun tys
       dicts <- mapM paDictOfType tys
       return $ mkApps (mkTyApps dfun tys) dicts
 
+lookupPArrayFamInst :: Type -> VM (TyCon, [Type])
+lookupPArrayFamInst ty = builtin parrayTyCon >>= (`lookupFamInst` [ty])
+
+hoistExpr :: FastString -> CoreExpr -> VM Var
+hoistExpr fs expr
+  = do
+      var <- newLocalVar fs (exprType expr)
+      updGEnv $ \env ->
+        env { global_bindings = (var, expr) : global_bindings env }
+      return var
+
+takeHoisted :: VM [(Var, CoreExpr)]
+takeHoisted
+  = do
+      env <- readGEnv id
+      setGEnv $ env { global_bindings = [] }
+      return $ global_bindings env
+