Fix name generation for vectorised identifiers

compiler/basicTypes/Name.lhs

@@ -42,13 +42,13 @@ module Name (
 	mkFCallName, mkIPName,
         mkTickBoxOpName,
 	mkExternalName, mkWiredInName,
-  mkLocalisedOccName,
 
 	-- ** Manipulating and deconstructing 'Name's
 	nameUnique, setNameUnique,
 	nameOccName, nameModule, nameModule_maybe,
 	tidyNameOcc, 
 	hashName, localiseName,
+  mkLocalisedOccName,
 
 	nameSrcLoc, nameSrcSpan, pprNameLoc,
 
@@ -332,11 +332,12 @@ localiseName n = n { n_sort = Internal }
 --
 -- 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)
+mkLocalisedOccName :: Module -> (Maybe String -> OccName -> OccName) -> Name -> OccName
+mkLocalisedOccName this_mod mk_occ name = mk_occ origin (nameOccName name)
   where
-    origin | isExternalName name = Just (moduleNameColons . moduleName . nameModule $ name)
-           | otherwise           = Nothing
+    origin 
+      | nameIsLocalOrFrom this_mod name = Nothing
+      | otherwise                       = Just (moduleNameColons . moduleName . nameModule $ name)
 \end{code}
 
 %************************************************************************

compiler/iface/MkIface.lhs

@@ -575,7 +575,8 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                 mi_iface_hash  = iface_hash,
                 mi_exp_hash    = export_hash,
                 mi_orphan_hash = orphan_hash,
-                mi_orphan      = not (null orph_rules && null orph_insts),
+                mi_orphan      = not (null orph_rules && null orph_insts
+                                      && null (ifaceVectInfoVar (mi_vect_info iface0))),
                 mi_finsts      = not . null $ mi_fam_insts iface0,
                 mi_decls       = sorted_decls,
                 mi_hash_fn     = lookupOccEnv local_env }

compiler/iface/TcIface.lhs

@@ -722,7 +722,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
        }
   where
     vectVarMapping name 
-      = do { vName <- lookupOrig mod (mkLocalisedOccName mkVectOcc name)
+      = do { vName <- lookupOrig mod (mkLocalisedOccName mod 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 (mkLocalisedOccName mkVectTyConOcc name)
-           ; paName  <- lookupOrig mod (mkLocalisedOccName mkPADFunOcc    name)
-           ; isoName <- lookupOrig mod (mkLocalisedOccName mkVectIsoOcc   name)
+      = do { vName   <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
+           ; paName  <- lookupOrig mod (mkLocalisedOccName mod mkPADFunOcc    name)
+           ; isoName <- lookupOrig mod (mkLocalisedOccName mod 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 (mkLocalisedOccName mkPADFunOcc  name)
-           ; isoName <- lookupOrig mod (mkLocalisedOccName mkVectIsoOcc name)
+      = do { paName  <- lookupOrig mod (mkLocalisedOccName mod mkPADFunOcc  name)
+           ; isoName <- lookupOrig mod (mkLocalisedOccName mod 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 (mkLocalisedOccName mkVectDataConOcc name)
+           ; vName <- lookupOrig mod (mkLocalisedOccName mod mkVectDataConOcc name)
            ; let vDataCon = lookupDataCon vName
            ; return (name, (datacon, vDataCon))
            }

compiler/vectorise/Vectorise/Monad/Naming.hs

@@ -32,10 +32,16 @@ import Control.Monad
 -- 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
+mkLocalisedName mk_occ name = 
+  do { mod <- liftDs getModuleDs
+     ; u   <- liftDs newUnique
+     ; let occ_name = mkLocalisedOccName mod mk_occ name
+
+           new_name | isExternalName name = mkExternalName u mod occ_name (nameSrcSpan name)
+                    | otherwise           = mkSystemName   u     occ_name
+
+     ; return new_name
+     }
 
 -- |Produce the vectorised variant of an `Id` with the given type.
 --

compiler/vectorise/Vectorise/Type/PADict.hs

@@ -13,20 +13,21 @@ import BasicTypes
 import CoreSyn
 import CoreUtils
 import CoreUnfold
+import DsMonad
 import TyCon
 import Type
 import TypeRep
 import Id
 import Var
 import Name
--- import FastString
--- import Outputable
 
 -- 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.
+-- |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.
@@ -55,51 +56,54 @@ buildPADict vect_tc prepr_tc arr_tc repr
                                   -- 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
+   do { mod <- liftDs getModuleDs
+      ; let dfun_name = mkLocalisedOccName mod mkPADFunOcc vect_tc_name
+      
+          -- Get ids for each of the methods in the dictionary, including superclass
+      ; method_ids <- mapM (method args dfun_name) buildPAScAndMethods
 
-      -- Expression to build the dictionary.
-      pa_dc  <- builtin paDataCon
-      let dict = mkLams (tvs ++ args)
-               $ mkConApp pa_dc
-               $ Type inst_ty
-                 : map (method_call args) method_ids
+          -- Expression to build the dictionary.
+      ; pa_dc  <- builtin paDataCon
+      ; let dict = mkLams (tvs ++ args)
+                 $ mkConApp pa_dc
+                 $ Type inst_ty
+                   : map (method_call args) method_ids
 
-      -- Build the type of the dictionary function.
-      pa_cls <- builtin paClass
-      let dfun_ty = mkForAllTys tvs
-                  $ mkFunTys (map varType args)
-                             (PredTy $ ClassP pa_cls [inst_ty])
+          -- Build the type of the dictionary function.
+      ; pa_cls <- builtin paClass
+      ; let dfun_ty = mkForAllTys tvs
+                    $ mkFunTys (map varType args)
+                               (PredTy $ ClassP pa_cls [inst_ty])
 
-      -- Set the unfolding for the inliner.
-      raw_dfun <- newExportedVar dfun_name dfun_ty
-      let dfun_unf = mkDFunUnfolding dfun_ty $
-                     map Var method_ids
-          dfun = raw_dfun `setIdUnfolding`  dfun_unf
-                          `setInlinePragma` dfunInlinePragma
+          -- Set the unfolding for the inliner.
+      ; raw_dfun <- newExportedVar dfun_name dfun_ty
+      ; let dfun_unf = mkDFunUnfolding dfun_ty $
+                       map Var method_ids
+            dfun = raw_dfun `setIdUnfolding`  dfun_unf
+                            `setInlinePragma` dfunInlinePragma
 
-      -- Add the new binding to the top-level environment.
-      hoistBinding dfun dict
-      return dfun
+          -- Add the new binding to the top-level environment.
+      ; hoistBinding dfun dict
+      ; return dfun
+      }
   where
     tvs       = tyConTyVars vect_tc
     arg_tys   = mkTyVarTys tvs
     inst_ty   = mkTyConApp vect_tc arg_tys
 
     vect_tc_name = getName vect_tc
-    dfun_name    = mkLocalisedOccName mkPADFunOcc vect_tc_name
 
-    method args (name, build)
+    method args dfun_name (name, build)
       = localV
       $ do
           expr     <- build vect_tc prepr_tc arr_tc repr
           let body = mkLams (tvs ++ args) expr
-          raw_var  <- newExportedVar (method_name name) (exprType body)
+          raw_var  <- newExportedVar (method_name dfun_name name) (exprType body)
           let var  = raw_var
                       `setIdUnfolding` mkInlineUnfolding (Just (length args)) body
                       `setInlinePragma` alwaysInlinePragma
           hoistBinding var body
           return var
 
-    method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args)
-    method_name name    = mkVarOcc $ occNameString dfun_name ++ ('$' : name)
+    method_call args id        = mkApps (Var id) (map Type arg_tys ++ map Var args)
+    method_name dfun_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name)