[commit: ghc] ghc-7.4: Fix -ddump-tc-trace for recursively defined type constructors (c0835f8)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : ghc-7.4

http://hackage.haskell.org/trac/ghc/changeset/c0835f8933df1b1fccef07058ad6f14ceb074ebf

>---------------------------------------------------------------

commit c0835f8933df1b1fccef07058ad6f14ceb074ebf
Author: Manuel M T Chakravarty <chak at cse.unsw.edu.au>
Date:   Wed Dec 14 13:25:37 2011 +1100

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

>---------------------------------------------------------------

 compiler/vectorise/Vectorise/Monad/Global.hs   |   17 +++++++++++++----
 compiler/vectorise/Vectorise/Type/TyConDecl.hs |   15 +++++----------
 2 files changed, 18 insertions(+), 14 deletions(-)

diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs
index bb8cc1a..e728d6a 100644
--- a/compiler/vectorise/Vectorise/Monad/Global.hs
+++ b/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)
diff --git a/compiler/vectorise/Vectorise/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index 6db7dab..88ff686 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/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)