Fixed reading and generating VectInfo as well as naming of vectorised versions of imported identifiers

14 files changed, 320 insertions, 251 deletions

diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs
index 6e566a23ad..e35c4d5a31 100644
--- a/compiler/basicTypes/Module.lhs
+++ b/compiler/basicTypes/Module.lhs
@@ -11,15 +11,15 @@ the keys.
 \begin{code}
 module Module 
     (
-	-- * The ModuleName type
-	ModuleName,
-	pprModuleName,
-	moduleNameFS,
-	moduleNameString,
-        moduleNameSlashes,
-	mkModuleName,
-	mkModuleNameFS,
-	stableModuleNameCmp,
+        -- * The ModuleName type
+        ModuleName,
+        pprModuleName,
+        moduleNameFS,
+        moduleNameString,
+        moduleNameSlashes, moduleNameColons,
+        mkModuleName,
+        mkModuleNameFS,
+        stableModuleNameCmp,
 
         -- * The PackageId type
         PackageId,
@@ -205,10 +205,17 @@ mkModuleName s = ModuleName (mkFastString s)
 mkModuleNameFS :: FastString -> ModuleName
 mkModuleNameFS s = ModuleName s
 
--- | Returns the string version of the module name, with dots replaced by slashes
+-- |Returns the string version of the module name, with dots replaced by slashes.
+--
 moduleNameSlashes :: ModuleName -> String
 moduleNameSlashes = dots_to_slashes . moduleNameString
   where dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c)
+
+-- |Returns the string version of the module name, with dots replaced by underscores.
+--
+moduleNameColons :: ModuleName -> String
+moduleNameColons = dots_to_colons . moduleNameString
+  where dots_to_colons = map (\c -> if c == '.' then ':' else c)
 \end{code}
 
 %************************************************************************
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index b9f96e7adf..8bdcb9ebb6 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -42,6 +42,7 @@ module Name (
 	mkFCallName, mkIPName,
         mkTickBoxOpName,
 	mkExternalName, mkWiredInName,
+  mkLocalisedOccName,
 
 	-- ** Manipulating and deconstructing 'Name's
 	nameUnique, setNameUnique,
@@ -326,6 +327,18 @@ localiseName :: Name -> Name
 localiseName n = n { n_sort = Internal }
 \end{code}
 
+\begin{code}
+-- |Create a localised variant of a name.  
+--
+-- If the name is external, encode the original's module name to disambiguate.
+--
+mkLocalisedOccName :: (Maybe String -> OccName -> OccName) -> Name -> OccName
+mkLocalisedOccName mk_occ name = mk_occ origin (nameOccName name)
+  where
+    origin | isExternalName name = Just (moduleNameColons . moduleName . nameModule $ name)
+           | otherwise           = Nothing
+\end{code}
+
 %************************************************************************
 %*									*
 \subsection{Hashing and comparison}
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 446d11a994..3ae9b54085 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -541,14 +541,12 @@ isDerivedOccName occ =
 
 \begin{code}
 mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
-  	mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
- 	mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
- 	mkGenD, mkGenR, mkGenRCo,
-	mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
-	mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
-        mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
-	mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc,
-	mkPDataTyConOcc, mkPDataDataConOcc, mkPReprTyConOcc, mkPADFunOcc
+  mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc,
+  mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
+  mkGenD, mkGenR, mkGenRCo,
+  mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
+  mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
+  mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
    :: OccName -> OccName
 
 -- These derived variables have a prefix that no Haskell value could have
@@ -598,18 +596,24 @@ mkDataTOcc = mk_simple_deriv varName  "$t"
 mkDataCOcc = mk_simple_deriv varName  "$c"
 
 -- Vectorisation
-mkVectOcc          = mk_simple_deriv varName  "$v_"
-mkVectTyConOcc     = mk_simple_deriv tcName   ":V_"
-mkVectDataConOcc   = mk_simple_deriv dataName ":VD_"
-mkVectIsoOcc       = mk_simple_deriv varName  "$VI_"
-mkPDataTyConOcc    = mk_simple_deriv tcName   ":VP_"
-mkPDataDataConOcc  = mk_simple_deriv dataName ":VPD_"
-mkPReprTyConOcc    = mk_simple_deriv tcName   ":VR_"
-mkPADFunOcc        = mk_simple_deriv varName  "$PA_"
+mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPADFunOcc, mkPReprTyConOcc,
+  mkPDataTyConOcc, mkPDataDataConOcc :: Maybe String -> OccName -> OccName
+mkVectOcc         = mk_simple_deriv_with varName  "$v_"
+mkVectTyConOcc    = mk_simple_deriv_with tcName   ":V_"
+mkVectDataConOcc  = mk_simple_deriv_with dataName ":VD_"
+mkVectIsoOcc      = mk_simple_deriv_with varName  "$VI_"
+mkPADFunOcc       = mk_simple_deriv_with varName  "$PA_"
+mkPReprTyConOcc   = mk_simple_deriv_with tcName   ":VR_"
+mkPDataTyConOcc   = mk_simple_deriv_with tcName   ":VP_"
+mkPDataDataConOcc = mk_simple_deriv_with dataName ":VPD_"
 
 mk_simple_deriv :: NameSpace -> String -> OccName -> OccName
 mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
 
+mk_simple_deriv_with :: NameSpace -> String -> Maybe String -> OccName -> OccName
+mk_simple_deriv_with sp px Nothing     occ = mk_deriv sp px                  (occNameString occ)
+mk_simple_deriv_with sp px (Just with) occ = mk_deriv sp (px ++ with ++ "_") (occNameString occ)
+
 -- Data constructor workers are made by setting the name space
 -- of the data constructor OccName (which should be a DataName)
 -- to VarName
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 335e3cb54a..52311baa20 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -722,7 +722,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
        }
   where
     vectVarMapping name 
-      = do { vName <- lookupOrig mod (mkVectOcc (nameOccName name))
+      = do { vName <- lookupOrig mod (mkLocalisedOccName mkVectOcc name)
            ; var  <- forkM (text ("vect var")  <+> ppr name)  $
                      tcIfaceExtId name
            ; vVar <- forkM (text ("vect vVar") <+> ppr vName) $
@@ -730,9 +730,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
            ; return (var, (var, vVar))
            }
     vectTyConMapping name 
-      = do { vName   <- lookupOrig mod (mkVectTyConOcc (nameOccName name))
-           ; paName  <- lookupOrig mod (mkPADFunOcc    (nameOccName name))
-           ; isoName <- lookupOrig mod (mkVectIsoOcc   (nameOccName name))
+      = do { vName   <- lookupOrig mod (mkLocalisedOccName mkVectTyConOcc name)
+           ; paName  <- lookupOrig mod (mkLocalisedOccName mkPADFunOcc    name)
+           ; isoName <- lookupOrig mod (mkLocalisedOccName mkVectIsoOcc   name)
            -- FIXME: we will need to use tcIfaceTyCon/tcIfaceExtId on some of these (but depends
            --   on how we exactly define the 'VECTORISE type' pragma to work)
            ; let { tycon    = lookupTyCon name
@@ -748,8 +748,8 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
                     )
            }
     vectTyConReuseMapping scalarNames name 
-      = do { paName  <- lookupOrig mod (mkPADFunOcc  (nameOccName name))
-           ; isoName <- lookupOrig mod (mkVectIsoOcc (nameOccName name))
+      = do { paName  <- lookupOrig mod (mkLocalisedOccName mkPADFunOcc  name)
+           ; isoName <- lookupOrig mod (mkLocalisedOccName mkVectIsoOcc name)
            ; tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
                       tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
            ; if name `elemNameSet` scalarNames
@@ -773,7 +773,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
            }}
     vectDataConMapping datacon
       = do { let name = dataConName datacon
-           ; vName <- lookupOrig mod (mkVectDataConOcc (nameOccName name))
+           ; vName <- lookupOrig mod (mkLocalisedOccName mkVectDataConOcc name)
            ; let vDataCon = lookupDataCon vName
            ; return (name, (datacon, vDataCon))
            }
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 9009c9de78..5b170c6c81 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -1889,6 +1889,17 @@ concatVectInfo = foldr plusVectInfo noVectInfo
 
 noIfaceVectInfo :: IfaceVectInfo
 noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
+
+instance Outputable VectInfo where
+  ppr info = vcat
+             [ ptext (sLit "variables     :") <+> ppr (vectInfoVar          info)
+             , ptext (sLit "tycons        :") <+> ppr (vectInfoTyCon        info)
+             , ptext (sLit "datacons      :") <+> ppr (vectInfoDataCon      info)
+             , ptext (sLit "PA dfuns      :") <+> ppr (vectInfoPADFun       info)
+             , ptext (sLit "iso           :") <+> ppr (vectInfoIso          info)
+             , ptext (sLit "scalar vars   :") <+> ppr (vectInfoScalarVars   info)
+             , ptext (sLit "scalar tycons :") <+> ppr (vectInfoScalarTyCons info)
+             ]
 \end{code}
 
 %************************************************************************
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index e278f6a2c8..01c9f7bb24 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -217,9 +217,10 @@ RecompilationAvoidance commentary:
 First we figure out which Ids are "external" Ids.  An
 "external" Id is one that is visible from outside the compilation
 unit.  These are
-	a) the user exported ones
-	b) ones mentioned in the unfoldings, workers, 
-	   or rules of externally-visible ones 
+  a) the user exported ones
+  b) ones mentioned in the unfoldings, workers, 
+     rules of externally-visible ones ,
+     or vectorised versions of externally-visible ones
 
 While figuring out which Ids are external, we pick a "tidy" OccName
 for each one.  That is, we make its OccName distinct from the other
@@ -286,35 +287,38 @@ RHSs, so that they print nicely in interfaces.
 
 \begin{code}
 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
-tidyProgram hsc_env  (ModGuts { mg_module = mod, mg_exports = exports, 
-				mg_types = type_env, 
-				mg_insts = insts, mg_fam_insts = fam_insts,
-				mg_binds = binds, 
-				mg_rules = imp_rules,
-                                mg_vect_info = vect_info,
-                                mg_anns = anns,
-                                mg_deps = deps, 
-				mg_foreign = foreign_stubs,
-			        mg_hpc_info = hpc_info,
-                                mg_modBreaks = modBreaks })
-
-  = do	{ let { dflags     = hsc_dflags hsc_env
-	      ; omit_prags = dopt Opt_OmitInterfacePragmas dflags
-	      ; expose_all = dopt Opt_ExposeAllUnfoldings  dflags
-	      ; th	   = xopt Opt_TemplateHaskell      dflags
+tidyProgram hsc_env  (ModGuts { mg_module    = mod
+                              , mg_exports   = exports
+                              , mg_types     = type_env
+                              , mg_insts     = insts
+                              , mg_fam_insts = fam_insts
+                              , mg_binds     = binds
+                              , mg_rules     = imp_rules
+                              , mg_vect_info = vect_info
+                              , mg_anns      = anns
+                              , mg_deps      = deps 
+                              , mg_foreign   = foreign_stubs
+                              , mg_hpc_info  = hpc_info
+                              , mg_modBreaks = modBreaks 
+                              })
+
+  = do  { let { dflags     = hsc_dflags hsc_env
+              ; omit_prags = dopt Opt_OmitInterfacePragmas dflags
+              ; expose_all = dopt Opt_ExposeAllUnfoldings  dflags
+              ; th         = xopt Opt_TemplateHaskell      dflags
               }
-	; showPass dflags CoreTidy
+        ; showPass dflags CoreTidy
 
-    	; let { implicit_binds = getImplicitBinds type_env }
+        ; let { implicit_binds = getImplicitBinds type_env }
 
         ; (unfold_env, tidy_occ_env)
               <- chooseExternalIds hsc_env mod omit_prags expose_all 
-                                   binds implicit_binds imp_rules
+                                   binds implicit_binds imp_rules (vectInfoVar vect_info)
 
         ; let { ext_rules = findExternalRules omit_prags binds imp_rules unfold_env }
-	        -- Glom together imp_rules and rules currently attached to binders
-		-- Then pick just the ones we need to expose
-		-- See Note [Which rules to expose]
+                -- Glom together imp_rules and rules currently attached to binders
+                -- Then pick just the ones we need to expose
+                -- See Note [Which rules to expose]
 
 	; let { (tidy_env, tidy_binds)
                  = tidyTopBinds hsc_env unfold_env tidy_occ_env binds }
@@ -498,20 +502,22 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
          , vectInfoScalarVars   = tidy_scalarVars
          }
   where
-    tidy_vars = mkVarEnv
-              $ map tidy_var_mapping
-              $ varEnvElts vars
-
-    tidy_pas = mapNameEnv tidy_snd_var pas
+      -- we only export mappings whose co-domain is exported (otherwise, the iface is inconsistent)
+    tidy_vars = mkVarEnv [ (tidy_var, (tidy_var, tidy_var_v))
+                         | (var, var_v) <- varEnvElts vars
+                         , let tidy_var   = lookup_var var
+                               tidy_var_v = lookup_var var_v
+                         , isExportedId tidy_var_v
+                         ]
+
+    tidy_pas  = mapNameEnv tidy_snd_var pas
     tidy_isos = mapNameEnv tidy_snd_var isos
 
-    tidy_var_mapping (from, to) = (from', (from', lookup_var to))
-      where from' = lookup_var from
     tidy_snd_var (x, var) = (x, lookup_var var)
 
-    tidy_scalarVars = mkVarSet
-                    $ map lookup_var
-                    $ varSetElems scalarVars
+    tidy_scalarVars = mkVarSet [ lookup_var var 
+                               | var <- varSetElems scalarVars
+                               , isGlobalId var || isExportedId var]
       
     lookup_var var = lookupWithDefaultVarEnv var_env var var
 \end{code}
@@ -602,13 +608,14 @@ type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
 chooseExternalIds :: HscEnv
                   -> Module
                   -> Bool -> Bool
-		  -> [CoreBind]
                   -> [CoreBind]
-		  -> [CoreRule]
+                  -> [CoreBind]
+                  -> [CoreRule]
+                  -> VarEnv (Var, Var)
                   -> IO (UnfoldEnv, TidyOccEnv)
-	-- Step 1 from the notes above
+                  -- Step 1 from the notes above
 
-chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
+chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars
   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
        ; tidy_internal internal_ids unfold_env1 occ_env1 }
@@ -627,11 +634,13 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
   init_ext_ids   = sortBy (compare `on` getOccName) $
                    filter is_external binders
 
-  -- An Id should be external if either (a) it is exported or
-  -- (b) it appears in the RHS of a local rule for an imported Id.   
+  -- An Id should be external if either (a) it is exported,
+  -- (b) it appears in the RHS of a local rule for an imported Id, or
+  -- (c) it is the vectorised version of an imported Id
   -- See Note [Which rules to expose]
-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
-  rule_rhs_vars = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules
+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs
+  rule_rhs_vars  = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet imp_id_rules
+  vect_var_vs    = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]
 
   binders          = bindersOfBinds binds
   implicit_binders = bindersOfBinds implicit_binds
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index 2f9035e500..c699441bb9 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -25,7 +25,6 @@ import CoreSyn
 import CoreMonad            ( CoreM, getHscEnv )
 import Type
 import Id
-import OccName
 import DynFlags
 import BasicTypes           ( isStrongLoopBreaker )
 import Outputable
@@ -250,7 +249,7 @@ vectTopBinder var inline expr
 
           -- Make the vectorised version of binding's name, and set the unfolding used for inlining
       ; var' <- liftM (`setIdUnfoldingLazily` unfolding) 
-                $  cloneId mkVectOcc var vty
+                $  mkVectId var vty
 
           -- Add the mapping between the plain and vectorised name to the state.
       ; defGlobalVar var var'
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index 3514698440..dd21762df7 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -35,15 +35,16 @@ import HscTypes hiding ( MonadThings(..) )
 import DynFlags
 import MonadUtils (liftIO)
 import TyCon
-import Var
+import VarSet
 import VarEnv
+import Var
 import Id
 import DsMonad
+import ErrUtils
 import Outputable
 import FastString
 
 import Control.Monad
-import VarSet
 
 -- |Run a vectorisation computation.
 --
@@ -53,10 +54,20 @@ initV :: HscEnv
       -> VM a
       -> IO (Maybe (VectInfo, a))
 initV hsc_env guts info thing_inside
-  = do { (_, Just r) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go
-       ; return r
+  = do { (_, Just res) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go
+
+       ; dumpIfVtTrace "Incoming VectInfo" (ppr info)
+       ; case res of
+           Nothing
+             -> dumpIfVtTrace "Vectorisation FAILED!" empty
+           Just (info', _)
+             -> dumpIfVtTrace "Outgoing VectInfo" (ppr info')
+
+       ; return res
        }
   where
+    dumpIfVtTrace = dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_vt_trace
+
     go 
       = do {   -- pick a DPH backend
            ; dflags <- getDOptsDs
@@ -114,9 +125,12 @@ builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi))
 
 
 -- Var ------------------------------------------------------------------------
--- | Lookup the vectorised and\/or lifted versions of this variable.
---  If it's in the global environment we get the vectorised version.
---      If it's in the local environment we get both the vectorised and lifted version.
+
+-- |Lookup the vectorised, and if local, also the lifted versions of a variable.
+--
+-- * If it's in the global environment we get the vectorised version.
+-- * If it's in the local environment we get both the vectorised and lifted version.
+--
 lookupVar :: Var -> VM (Scope Var (Var, Var))
 lookupVar v
  = do r <- readLEnv $ \env -> lookupVarEnv (local_vars env) v
@@ -144,13 +158,16 @@ dumpVar var
 
 -- Global scalars --------------------------------------------------------------
 
+-- |Mark the given variable as scalar — i.e., executing the associated code does not involve any
+-- parallel array computations.
+--
 addGlobalScalar :: Var -> VM ()
-addGlobalScalar var 
+addGlobalScalar var
   = do { traceVt "addGlobalScalar" (ppr var)
        ; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var}
        }
-     
-     
+
+
 -- Primitives -----------------------------------------------------------------
 
 lookupPrimPArray :: TyCon -> VM (Maybe TyCon)
diff --git a/compiler/vectorise/Vectorise/Monad/Naming.hs b/compiler/vectorise/Vectorise/Monad/Naming.hs
index 3241913447..78787f8e00 100644
--- a/compiler/vectorise/Vectorise/Monad/Naming.hs
+++ b/compiler/vectorise/Vectorise/Monad/Naming.hs
@@ -1,16 +1,16 @@
+-- |Computations in the vectorisation monad concerned with naming and fresh variable generation.
 
--- | Computations in the vectorisation monad concerned with naming
---   and fresh variable generation.
 module Vectorise.Monad.Naming
-	( cloneName
-	, cloneId
-	, cloneVar
-	, newExportedVar
-	, newLocalVar
-	, newLocalVars
-	, newDummyVar
-	, newTyVar)
-where
+  ( mkLocalisedName
+  , mkVectId
+  , cloneVar
+  , newExportedVar
+  , newLocalVar
+  , newLocalVars
+  , newDummyVar
+  , newTyVar
+  ) where
+
 import Vectorise.Monad.Base
 
 import DsMonad
@@ -20,38 +20,43 @@ import Name
 import SrcLoc
 import Id
 import FastString
-import Control.Monad
-
-
--- Naming ---------------------------------------------------------------------	
--- | Clone a name, using the provide function to transform its `OccName`.	
-cloneName :: (OccName -> OccName) -> Name -> VM Name
-cloneName mk_occ name = liftM make (liftDs newUnique)
-  where
-    occ_name = mk_occ (nameOccName name)
-
-    make u | isExternalName name = mkExternalName u (nameModule name)
-                                                    occ_name
-                                                    (nameSrcSpan name)
-           | otherwise           = mkSystemName u occ_name
 
+import Control.Monad
 
--- | Clone an `Id`, using the provided function to transform its `OccName`. 
-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'
 
+-- Naming ---------------------------------------------------------------------
 
--- | Make a fresh instance of this var, with a new unique.
+-- |Create a localised variant of a name, using the provided function to transform its `OccName`.
+--
+-- If the name external, encode the orignal name's module into the new 'OccName'.  The result is
+-- always an internal system name.
+--
+mkLocalisedName :: (Maybe String -> OccName -> OccName) -> Name -> VM Name
+mkLocalisedName mk_occ name = liftM make (liftDs newUnique)
+  where
+    occ_name = mkLocalisedOccName mk_occ name
+    make u   = mkSystemName u occ_name
+
+-- |Produce the vectorised variant of an `Id` with the given type.
+--
+-- Force the new name to be a system name and, if the original was an external name, disambiguate
+-- the new name with the module name of the original.
+--
+mkVectId :: Id -> Type -> VM Id
+mkVectId id ty
+  = do { name <- mkLocalisedName mkVectOcc (getName id)
+       ; let id' | isExportedId id = Id.mkExportedLocalId name ty
+                 | otherwise       = Id.mkLocalId         name ty
+       ; return id'
+       }
+
+-- |Make a fresh instance of this var, with a new unique.
+--
 cloneVar :: Var -> VM Var
 cloneVar var = liftM (setIdUnique var) (liftDs newUnique)
 
-
--- | Make a fresh exported variable with the given type.
+-- |Make a fresh exported variable with the given type.
+--
 newExportedVar :: OccName -> Type -> VM Var
 newExportedVar occ_name ty 
  = do mod <- liftDs getModuleDs
@@ -61,30 +66,29 @@ newExportedVar occ_name ty
       
       return $ Id.mkExportedLocalId name ty
 
-
--- | Make a fresh local variable with the given type.
---   The variable's name is formed using the given string as the prefix.
+-- |Make a fresh local variable with the given type.
+-- The variable's name is formed using the given string as the prefix.
+--
 newLocalVar :: FastString -> Type -> VM Var
 newLocalVar fs ty
  = do u <- liftDs newUnique
       return $ mkSysLocal fs u ty
 
-
--- | Make several fresh local varaiables with the given types.
---   The variable's names are formed using the given string as the prefix.
+-- |Make several fresh local variables with the given types.
+-- The variable's names are formed using the given string as the prefix.
+--
 newLocalVars :: FastString -> [Type] -> VM [Var]
 newLocalVars fs = mapM (newLocalVar fs)
 
-
--- | Make a new local dummy variable.
+-- |Make a new local dummy variable.
+--
 newDummyVar :: Type -> VM Var
 newDummyVar = newLocalVar (fsLit "vv")
 
-
--- | Make a fresh type variable with the given kind.
---   The variable's name is formed using the given string as the prefix.
+-- |Make a fresh type variable with the given kind.
+-- The variable's name is formed using the given string as the prefix.
+--
 newTyVar :: FastString -> Kind -> VM Var
 newTyVar fs k
  = do u <- liftDs newUnique
       return $ mkTyVar (mkSysTvName u fs) k
-
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index d6e50809c7..063e04dd5e 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -30,7 +30,6 @@ import DataCon
 import TyCon
 import Type
 import FamInstEnv
-import OccName
 import Id
 import MkId
 import NameEnv
@@ -248,7 +247,7 @@ vectDataConWorkers orig_tc vect_tc arr_tc
                   liftM (mkLams (tyvars ++ args) . vectorised)
                 $ buildClosures tyvars [] arg_tys res_ty mk_body
 
-          raw_worker <- cloneId mkVectOcc orig_worker (exprType body)
+          raw_worker <- mkVectId orig_worker (exprType body)
           let vect_worker = raw_worker `setIdUnfolding`
                               mkInlineUnfolding (Just arity) body
           defGlobalVar orig_worker vect_worker
diff --git a/compiler/vectorise/Vectorise/Type/PADict.hs b/compiler/vectorise/Vectorise/Type/PADict.hs
index ba2b3950a8..ea77a696be 100644
--- a/compiler/vectorise/Vectorise/Type/PADict.hs
+++ b/compiler/vectorise/Vectorise/Type/PADict.hs
@@ -1,11 +1,12 @@
 
 module Vectorise.Type.PADict
-	(buildPADict)
-where
+  ( buildPADict
+  ) where
+
 import Vectorise.Monad
 import Vectorise.Builtins
 import Vectorise.Type.Repr
-import Vectorise.Type.PRepr( buildPAScAndMethods )
+import Vectorise.Type.PRepr ( buildPAScAndMethods )
 import Vectorise.Utils
 
 import BasicTypes
@@ -21,17 +22,17 @@ import Name
 -- import FastString
 -- import Outputable
 
--- debug		= False
--- dtrace s x	= if debug then pprTrace "Vectoris.Type.PADict" s x else x
+-- debug                = False
+-- dtrace s x   = if debug then pprTrace "Vectoris.Type.PADict" s x else x
 
 -- | Build the PA dictionary function for some type and hoist it to top level.
 --   The PA dictionary holds fns that convert values to and from their vectorised representations.
 buildPADict
-	:: TyCon	-- ^ tycon of the type being vectorised.
-	-> TyCon	-- ^ tycon of the type used for the vectorised representation.
-	-> TyCon	-- ^ PRepr instance tycon
-	-> SumRepr	-- ^ representation used for the type being vectorised.
-	-> VM Var	-- ^ name of the top-level dictionary function.
+  :: TyCon  -- ^ tycon of the type being vectorised.
+  -> TyCon  -- ^ tycon of the type used for the vectorised representation.
+  -> TyCon  -- ^ PRepr instance tycon
+  -> SumRepr  -- ^ representation used for the type being vectorised.
+  -> VM Var -- ^ name of the top-level dictionary function.
 
 -- Recall the definition:
 --    class class PR (PRepr a) => PA a where
@@ -51,9 +52,9 @@ buildPADict
 
 buildPADict vect_tc prepr_tc arr_tc repr
  = polyAbstract tvs $ \args ->    -- The args are the dictionaries we lambda
-   		      	    	  -- abstract over; and they are put in the
-				  -- envt, so when we need a (PA a) we can 
-				  -- find it in the envt
+                                  -- abstract over; and they are put in the
+                                  -- envt, so when we need a (PA a) we can 
+                                  -- find it in the envt
    do -- Get ids for each of the methods in the dictionary, including superclass
       method_ids <- mapM (method args) buildPAScAndMethods
 
@@ -67,7 +68,7 @@ buildPADict vect_tc prepr_tc arr_tc repr
       -- Build the type of the dictionary function.
       pa_cls <- builtin paClass
       let dfun_ty = mkForAllTys tvs
-		  $ mkFunTys (map varType args)
+                  $ mkFunTys (map varType args)
                              (PredTy $ ClassP pa_cls [inst_ty])
 
       -- Set the unfolding for the inliner.
@@ -85,7 +86,8 @@ buildPADict vect_tc prepr_tc arr_tc repr
     arg_tys   = mkTyVarTys tvs
     inst_ty   = mkTyConApp vect_tc arg_tys
 
-    dfun_name = mkPADFunOcc (getOccName vect_tc)
+    vect_tc_name = getName vect_tc
+    dfun_name    = mkLocalisedOccName mkPADFunOcc vect_tc_name
 
     method args (name, build)
       = localV
diff --git a/compiler/vectorise/Vectorise/Type/PData.hs b/compiler/vectorise/Vectorise/Type/PData.hs
index b7bd95e940..34b6b35b1d 100644
--- a/compiler/vectorise/Vectorise/Type/PData.hs
+++ b/compiler/vectorise/Vectorise/Type/PData.hs
@@ -1,7 +1,8 @@
 
 module Vectorise.Type.PData
-	(buildPDataTyCon)
-where
+  (buildPDataTyCon
+  ) where
+
 import Vectorise.Monad
 import Vectorise.Builtins
 import Vectorise.Type.Repr
@@ -22,7 +23,7 @@ import Control.Monad
 buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
 buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc ->
   do
-    name' <- cloneName mkPDataTyConOcc orig_name
+    name' <- mkLocalisedName mkPDataTyConOcc orig_name
     rhs   <- buildPDataTyConRhs orig_name vect_tc repr_tc repr
     pdata <- builtin pdataTyCon
 
@@ -49,7 +50,7 @@ buildPDataTyConRhs orig_name vect_tc repr_tc repr
 buildPDataDataCon :: Name -> TyCon -> TyCon -> SumRepr -> VM DataCon
 buildPDataDataCon orig_name vect_tc repr_tc repr
   = do
-      dc_name  <- cloneName mkPDataDataConOcc orig_name
+      dc_name  <- mkLocalisedName mkPDataDataConOcc orig_name
       comp_tys <- sum_tys repr
 
       liftDs $ buildDataCon dc_name
@@ -61,7 +62,7 @@ buildPDataDataCon orig_name vect_tc repr_tc repr
                             []                     -- no eq spec
                             []                     -- no context
                             comp_tys
-			    (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
+                            (mkFamilyTyConApp repr_tc (mkTyVarTys tvs))
                             repr_tc
   where
     tvs   = tyConTyVars vect_tc
diff --git a/compiler/vectorise/Vectorise/Type/PRepr.hs b/compiler/vectorise/Vectorise/Type/PRepr.hs
index a7c0a9116e..2a953ff947 100644
--- a/compiler/vectorise/Vectorise/Type/PRepr.hs
+++ b/compiler/vectorise/Vectorise/Type/PRepr.hs
@@ -1,7 +1,9 @@
 
 module Vectorise.Type.PRepr
-	( buildPReprTyCon, buildPAScAndMethods )
-where
+  ( buildPReprTyCon
+  , buildPAScAndMethods 
+  ) where
+
 import Vectorise.Utils
 import Vectorise.Monad
 import Vectorise.Builtins
@@ -30,14 +32,14 @@ mk_fam_inst fam_tc arg_tc
 buildPReprTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon
 buildPReprTyCon orig_tc vect_tc repr
   = do
-      name     <- cloneName mkPReprTyConOcc (tyConName orig_tc)
+      name     <- mkLocalisedName mkPReprTyConOcc (tyConName orig_tc)
       -- rhs_ty   <- buildPReprType vect_tc
       rhs_ty   <- sumReprType repr
       prepr_tc <- builtin preprTyCon
       liftDs $ buildSynTyCon name
                              tyvars
                              (SynonymTyCon rhs_ty)
-			     (typeKind rhs_ty)
+                             (typeKind rhs_ty)
                              NoParentTyCon
                              (Just $ mk_fam_inst prepr_tc vect_tc)
   where
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 7a9d89189f..a8290befcc 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -25,95 +25,96 @@ vectTyConDecls tcs = fixV $ \tcs' ->
     mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
     mapM vectTyConDecl tcs
 
--- | Vectorise a single type construcrtor.
+-- |Vectorise a single type constructor.
+--
 vectTyConDecl :: TyCon -> VM TyCon
 vectTyConDecl tycon
-    -- a type class constructor.
-    -- TODO: check for no stupid theta, fds, assoc types. 
-    | isClassTyCon tycon
-    , Just cls		<- tyConClass_maybe tycon
-
-    = do    -- make the name of the vectorised class tycon.
-	    name'	<- cloneName mkVectTyConOcc (tyConName tycon)
-
-            -- vectorise right of definition.
-            rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)
-
-            -- vectorise method selectors.
-            -- This also adds a mapping between the original and vectorised method selector
-            -- to the state.
-            methods'	<- mapM vectMethod
-			$  [(id, defMethSpecOfDefMeth meth) 
-				| (id, meth)	<- classOpItems cls]
-
-            -- keep the original recursiveness flag.
-            let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
-	
-	    -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
-            cls'     <- liftDs 
-             	    $  buildClass
-                             False               -- include unfoldings on dictionary selectors.
-                             name'               -- new name  V_T:Class
-                             (tyConTyVars tycon) -- keep original type vars
-                             []                  -- no stupid theta
-                             []                  -- no functional dependencies
-                             []                  -- no associated types
-                             methods'            -- method info
-                             rec_flag            -- whether recursive
-
-            let tycon'  = mkClassTyCon name'
-			     (tyConKind tycon)
-			     (tyConTyVars tycon)
-			     rhs'
-			     cls'
-			     rec_flag
-
-            return $ tycon'
-			
-    -- a regular algebraic type constructor.
-    -- TODO: check for stupid theta, generaics, GADTS etc
-    | isAlgTyCon tycon
-    = do    name'	<- cloneName mkVectTyConOcc (tyConName tycon)
-            rhs'	<- vectAlgTyConRhs tycon (algTyConRhs tycon)
-            let rec_flag =  boolToRecFlag (isRecursiveTyCon tycon)
-
-            liftDs $ buildAlgTyCon 
-                            name'               -- new name
-                            (tyConTyVars tycon) -- keep original type vars.
-                            []                  -- no stupid theta.
-                            rhs'                -- new constructor defs.
-                            rec_flag            -- FIXME: is this ok?
-                            False               -- not GADT syntax
-                            NoParentTyCon
-                            Nothing             -- not a family instance
-
-    -- some other crazy thing that we don't handle.
-    | otherwise
-    = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
-
-
--- | Vectorise a class method.
+  -- a type class constructor.
+  -- TODO: check for no stupid theta, fds, assoc types. 
+  | isClassTyCon tycon
+  , Just cls <- tyConClass_maybe tycon
+
+  = do  -- make the name of the vectorised class tycon.
+        name'       <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
+
+        -- vectorise right of definition.
+        rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)
+
+        -- vectorise method selectors.
+        -- This also adds a mapping between the original and vectorised method selector
+        -- to the state.
+        methods'    <- mapM vectMethod
+                    $  [(id, defMethSpecOfDefMeth meth) 
+                            | (id, meth)    <- classOpItems cls]
+
+        -- keep the original recursiveness flag.
+        let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
+  
+        -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
+        cls'     <- liftDs 
+                $  buildClass
+                         False               -- include unfoldings on dictionary selectors.
+                         name'               -- new name  V_T:Class
+                         (tyConTyVars tycon) -- keep original type vars
+                         []                  -- no stupid theta
+                         []                  -- no functional dependencies
+                         []                  -- no associated types
+                         methods'            -- method info
+                         rec_flag            -- whether recursive
+
+        let tycon'  = mkClassTyCon name'
+                         (tyConKind tycon)
+                         (tyConTyVars tycon)
+                         rhs'
+                         cls'
+                         rec_flag
+
+        return $ tycon'
+                      
+  -- a regular algebraic type constructor.
+  -- TODO: check for stupid theta, generaics, GADTS etc
+  | isAlgTyCon tycon
+  = do  name'       <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
+        rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)
+        let rec_flag =  boolToRecFlag (isRecursiveTyCon tycon)
+
+        liftDs $ buildAlgTyCon 
+                        name'               -- new name
+                        (tyConTyVars tycon) -- keep original type vars.
+                        []                  -- no stupid theta.
+                        rhs'                -- new constructor defs.
+                        rec_flag            -- FIXME: is this ok?
+                        False               -- not GADT syntax
+                        NoParentTyCon
+                        Nothing             -- not a family instance
+
+  -- some other crazy thing that we don't handle.
+  | otherwise
+  = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
+
+-- |Vectorise a class method.
+--
 vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
 vectMethod (id, defMeth)
- = do	
-	-- Vectorise the method type.
-	typ'	<- vectType (varType id)
-
-	-- Create a name for the vectorised method.
-	id'	<- cloneId mkVectOcc id typ'
-	defGlobalVar id id'
+ = do {   -- Vectorise the method type.
+      ; typ' <- vectType (varType id)
 
-	-- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
-	-- to the types of each method. However, the types we get back from vectType
-	-- above already already have these, so we need to chop them off here otherwise
-	-- we'll get two copies in the final version.
-	let (_tyvars, tyBody) = splitForAllTys typ'
-	let (_dict,   tyRest) = splitFunTy tyBody
+          -- Create a name for the vectorised method.
+      ; id' <- mkVectId id typ'
+      ; defGlobalVar id id'
 
-	return	(Var.varName id', defMeth, tyRest)
+          -- When we call buildClass in vectTyConDecl, it adds foralls and dictionaries
+          -- to the types of each method. However, the types we get back from vectType
+          -- above already already have these, so we need to chop them off here otherwise
+          -- we'll get two copies in the final version.
+      ; let (_tyvars, tyBody) = splitForAllTys typ'
+      ; let (_dict,   tyRest) = splitFunTy tyBody
 
+      ; return  (Var.varName id', defMeth, tyRest)
+      }
 
--- | Vectorise the RHS of an algebraic type.
+-- |Vectorise the RHS of an algebraic type.
+--
 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
 vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
                              , is_enum   = is_enum
@@ -124,13 +125,13 @@ vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
       return $ DataTyCon { data_cons = data_cons'
                          , is_enum   = is_enum
                          }
-
 vectAlgTyConRhs tc _ 
-	= cantVectorise "Can't vectorise type definition:" (ppr tc)
-
+        = cantVectorise "Can't vectorise type definition:" (ppr tc)
 
--- | Vectorise a data constructor.
---   Vectorises its argument and return types.
+-- |Vectorise a data constructor.
+--
+-- Vectorises its argument and return types.
+--
 vectDataCon :: DataCon -> VM DataCon
 vectDataCon dc
   | not . null $ dataConExTyVars dc
@@ -141,12 +142,12 @@ vectDataCon dc
 
   | otherwise
   = do
-      name'    <- cloneName mkVectDataConOcc name
+      name'    <- mkLocalisedName mkVectDataConOcc name
       tycon'   <- vectTyCon tycon
       arg_tys  <- mapM vectType rep_arg_tys
 
       liftDs $ buildDataCon 
-		name'
+                name'
                 False                          -- not infix
                 (map (const HsNoBang) arg_tys) -- strictness annots on args.
                 []                             -- no labelled fields
@@ -155,7 +156,7 @@ vectDataCon dc
                 []                             -- no eq spec for now
                 []                             -- no context
                 arg_tys                        -- argument types
-		(mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
+                (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
                 tycon'                         -- representation tycon
   where
     name        = dataConName dc