Refactoring

[ghc-hetmet.git] / compiler / vectorise / VectMonad.hs

diff --git a/compiler/vectorise/VectMonad.hs b/compiler/vectorise/VectMonad.hs
index c244f0a..1beb550 100644 (file)
--- a/compiler/vectorise/VectMonad.hs
+++ b/compiler/vectorise/VectMonad.hs
@@ -3,7 +3,8 @@ module VectMonad (
   VM,
 
   noV, tryV, maybeV, orElseV, fixV, localV, closedV, initV,
-  cloneName, newExportedVar, newLocalVar, newDummyVar, newTyVar,
+  cloneName, cloneId,
+  newExportedVar, newLocalVar, newDummyVar, newTyVar,
   
   Builtins(..), paDictTyCon, paDictDataCon,
   builtin,
@@ -39,6 +40,7 @@ import Id
 import OccName
 import Name
 import NameEnv
+import TysPrim       ( intPrimTy )
 
 import DsMonad
 import PrelNames
@@ -69,6 +71,7 @@ data Builtins = Builtins {
                 , lengthPAVar      :: Var
                 , replicatePAVar   :: Var
                 , emptyPAVar       :: Var
+                , liftingContext   :: Var
                 }
 
 paDictTyCon :: Builtins -> TyCon
@@ -92,6 +95,9 @@ initBuiltins
       replicatePAVar   <- dsLookupGlobalId replicatePAName
       emptyPAVar       <- dsLookupGlobalId emptyPAName
 
+      liftingContext <- liftM (\u -> mkSysLocal FSLIT("lc") u intPrimTy)
+                              newUnique
+
       return $ Builtins {
                  parrayTyCon      = parrayTyCon
                , paClass          = paClass
@@ -103,6 +109,7 @@ initBuiltins
                , lengthPAVar      = lengthPAVar
                , replicatePAVar   = replicatePAVar
                , emptyPAVar       = emptyPAVar
+               , liftingContext   = liftingContext
                }
 
 data GlobalEnv = GlobalEnv {
@@ -301,6 +308,14 @@ cloneName mk_occ name = liftM make (liftDs newUnique)
                                                     (nameSrcSpan name)
            | otherwise           = mkSystemName u occ_name
 
+cloneId :: (OccName -> OccName) -> Id -> Type -> VM Id
+cloneId mk_occ id ty
+  = do
+      name <- cloneName mk_occ (getName id)
+      let id' | isExportedId id = Id.mkExportedLocalId name ty
+              | otherwise       = Id.mkLocalId         name ty
+      return id'
+
 newExportedVar :: OccName -> Type -> VM Var
 newExportedVar occ_name ty 
   = do