Commit 856de825 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

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

parent 64caa89e
...@@ -16,7 +16,7 @@ module Vectorise.Monad.Global ( ...@@ -16,7 +16,7 @@ module Vectorise.Monad.Global (
-- * TyCons -- * TyCons
lookupTyCon, lookupTyCon,
defTyCon, globalVectTyCons, defTyConName, defTyCon, globalVectTyCons,
-- * Datacons -- * Datacons
lookupDataCon, lookupDataCon,
...@@ -136,9 +136,13 @@ lookupTyCon tc ...@@ -136,9 +136,13 @@ lookupTyCon tc
-- |Add a mapping between plain and vectorised `TyCon`s to the global environment. -- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
-- --
defTyCon :: TyCon -> TyCon -> VM () -- The second argument is only to enable tracing for (mutually) recursively defined type
defTyCon tc tc' -- constructors, where we /must not/ pull at the vectorised type constructors (because that would
= do { traceVt "add global tycon mapping:" (ppr tc <+> text "-->" <+> ppr tc') -- 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 -- check for duplicate vectorisation
; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) ; currentDef <- readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
...@@ -158,6 +162,11 @@ defTyCon tc tc' ...@@ -158,6 +162,11 @@ defTyCon tc tc'
| otherwise | otherwise
= ptext (sLit "in the current module") = 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. -- |Get the set of all vectorised type constructors.
-- --
globalVectTyCons :: VM (NameEnv TyCon) globalVectTyCons :: VM (NameEnv TyCon)
......
...@@ -22,23 +22,21 @@ import Control.Monad ...@@ -22,23 +22,21 @@ import Control.Monad
-- --
vectTyConDecls :: [TyCon] -> VM [TyCon] vectTyConDecls :: [TyCon] -> VM [TyCon]
vectTyConDecls tcs = fixV $ \tcs' -> vectTyConDecls tcs = fixV $ \tcs' ->
do { mapM_ (uncurry defTyCon) (zipLazy tcs tcs') do { names' <- mapM (mkLocalisedName mkVectTyConOcc . tyConName) tcs
; mapM vectTyConDecl tcs ; mapM_ (uncurry (uncurry defTyConName)) (tcs `zip` names' `zipLazy` tcs')
; zipWithM vectTyConDecl tcs names'
} }
-- |Vectorise a single type constructor. -- |Vectorise a single type constructor.
-- --
vectTyConDecl :: TyCon -> VM TyCon vectTyConDecl :: TyCon -> Name -> VM TyCon
vectTyConDecl tycon vectTyConDecl tycon name'
-- Type constructor representing a type class -- Type constructor representing a type class
| Just cls <- tyConClass_maybe tycon | Just cls <- tyConClass_maybe tycon
= do { unless (null $ classATs cls) $ = do { unless (null $ classATs cls) $
cantVectorise "Associated types are not yet supported" (ppr 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) -- vectorise superclass constraint (types)
; theta' <- mapM vectType (classSCTheta cls) ; theta' <- mapM vectType (classSCTheta cls)
...@@ -87,9 +85,6 @@ vectTyConDecl tycon ...@@ -87,9 +85,6 @@ vectTyConDecl tycon
= do { unless (all isVanillaDataCon (tyConDataCons tycon)) $ = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr 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 -- vectorise the data constructor of the class tycon
; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon) ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment