Fix -ddump-tc-trace for recursively defined type constructors

compiler/vectorise/Vectorise/Monad/Global.hs

@@ -16,7 +16,7 @@ module Vectorise.Monad.Global (
   
   -- * TyCons
   lookupTyCon,
-  defTyCon, globalVectTyCons,
+  defTyConName, defTyCon, globalVectTyCons,
   
   -- * Datacons
   lookupDataCon,
@@ -136,9 +136,13 @@ lookupTyCon tc
 
 -- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
 --
-defTyCon :: TyCon -> TyCon -> VM ()
-defTyCon tc tc'
-  = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr tc') 
+-- The second argument is only to enable tracing for (mutually) recursively defined type
+-- constructors, where we /must not/ pull at the vectorised type constructors (because that would
+-- pull too early at the recursive knot).
+--
+defTyConName :: TyCon -> Name -> TyCon -> VM ()
+defTyConName tc nameOfTc' tc'
+  = do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr nameOfTc') 
 
            -- check for duplicate vectorisation
        ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
@@ -158,6 +162,11 @@ defTyCon tc tc'
                     | otherwise
                     = ptext (sLit "in the current module")
 
+-- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
+--
+defTyCon :: TyCon -> TyCon -> VM ()
+defTyCon tc tc' = defTyConName tc (tyConName tc') tc'
+
 -- |Get the set of all vectorised type constructors.
 --
 globalVectTyCons :: VM (NameEnv TyCon)

compiler/vectorise/Vectorise/Type/TyConDecl.hs

@@ -22,23 +22,21 @@ import Control.Monad
 --
 vectTyConDecls :: [TyCon] -> VM [TyCon]
 vectTyConDecls tcs = fixV $ \tcs' ->
-  do { mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
-     ; mapM vectTyConDecl tcs
+  do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs
+     ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')
+     ; zipWithM vectTyConDecl tcs names'
      }
 
 -- |Vectorise a single type constructor.
 --
-vectTyConDecl :: TyCon -> VM TyCon
-vectTyConDecl tycon
+vectTyConDecl :: TyCon -> Name -> VM TyCon
+vectTyConDecl tycon name'
 
       -- Type constructor representing a type class
   | Just cls <- tyConClass_maybe tycon
   = do { unless (null $ classATs cls) $
            cantVectorise "Associated types are not yet supported" (ppr cls)
 
-           -- make the name of the vectorised class tycon: "Class" --> "V:Class"
-       ; name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
-       
            -- vectorise superclass constraint (types)
        ; theta' <- mapM vectType (classSCTheta cls)
 
@@ -87,9 +85,6 @@ vectTyConDecl tycon
   = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
            cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
   
-           -- make the name of the vectorised class tycon
-       ; name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
-
            -- vectorise the data constructor of the class tycon
        ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)