Commits

Jean-Marie Gaillourdet  committed 249df58 Merge

select the lock based workaround for typeOf with GHC 6 and 7.0

  • Participants
  • Parent commits 44d1a97, ada685a
  • Branches default

Comments (0)

Files changed (1)

File src/Data/Global/Registry.hs

 #else
     lkup :: Registry -> IO (Registry, ref a)
     lkup reg =
-     do { typVal <- evaluate $ typeOf' val
-        ; typRef <- evaluate $ typeOf' (undefined :: ref ()) -- TypeRep representing the
-                                                             -- reference, e.g. IORef, MVar
+     do { typVal <- typeOf' val
+        ; typRef <- typeOf' (undefined :: ref ()) -- TypeRep representing the reference,
+                                                  -- e.g. IORef, MVar
         ; typValIdx <- typeRepKey typVal
         ; typRefIdx <- typeRepKey typRef
         ; case M.lookup (typRefIdx, typValIdx, name) reg of
             Just ref -> return (reg, fromDyn ref (err typVal (dynTypeRep ref)))
             Nothing ->
              do { ref <- new val
-                ; _ <- evaluate $ typeOf' ref
+                ; _ <- typeOf' ref
                 ; return (M.insert (typRefIdx, typValIdx, name) (toDyn ref) reg, ref)
                 }
         }
 
+{-# NOINLINE lock #-}
+lock :: MVar ()
+lock = unsafePerformIO $ newMVar ()
 
 -- Ugly workaround to http://hackage.haskell.org/trac/ghc/ticket/5540
-typeOf', typeOf'', typeOf''':: Typeable a => a -> TypeRep
-typeOf' val
-    | t1 == t2 = t1
-    | otherwise = typeOf' val
-  where
-    t1 = typeOf'' val
-    t2 = typeOf''' val
-{-# NOINLINE typeOf' #-}
-
-
-typeOf'' x = typeOf x
-{-# NOINLINE typeOf'' #-}
-typeOf''' x = typeOf x
-{-# NOINLINE typeOf''' #-}
+typeOf' :: Typeable a => a -> IO TypeRep
+typeOf' x =
+ do { lock' <- evaluate lock
+    ; () <- takeMVar lock'
+    ; t <- evaluate $ typeOf x
+    ; putMVar lock' ()
+    ; return t
+    }
 
 #endif