Add ASSERTs to all calls of nameModule

[ghc-hetmet.git] / compiler / iface / BinIface.hs

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 152381c..58c8373 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -1,7 +1,11 @@
 
--- 
+{-# OPTIONS_GHC -O #-}
+-- We always optimise this, otherwise performance of a non-optimised
+-- compiler is severely affected
+
+--
 --  (c) The University of Glasgow 2002-2006
--- 
+--
 -- Binary interface file support.
 
 module BinIface ( writeBinIface, readBinIface,
@@ -40,7 +44,6 @@ import Data.List
 import Data.Word
 import Data.Array
 import Data.IORef
-import Control.Exception
 import Control.Monad
 
 data CheckHiWay = CheckHiWay | IgnoreHiWay
@@ -73,11 +76,12 @@ readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
           = printer (text what <> text ": " <>
                      vcat [text "Wanted " <> ppr wanted <> text ",",
                            text "got    " <> ppr got])
+
       errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
       errorOnMismatch what wanted got
             -- This will be caught by readIface which will emit an error
             -- msg containing the iface module name.
-          = when (wanted /= got) $ throwDyn $ ProgramError
+          = when (wanted /= got) $ ghcError $ ProgramError
                         (what ++ " (wanted " ++ show wanted
                               ++ ", got "    ++ show got ++ ")")
   bh <- Binary.readBinMem hi_path
@@ -259,7 +263,7 @@ fromOnDiskName _ nc (pid, mod_name, occ) =
 
 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
 serialiseName bh name _ = do
-  let mod = nameModule name
+  let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
   put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
 
 
@@ -368,7 +372,7 @@ instance Binary ModIface where
                 mi_exports   = exports,
                 mi_exp_hash  = exp_hash,
                 mi_fixities  = fixities,
-                mi_deprecs   = deprecs,
+                mi_warns     = warns,
                 mi_decls     = decls,
                 mi_insts     = insts,
                 mi_fam_insts = fam_insts,
@@ -387,7 +391,7 @@ instance Binary ModIface where
        put_ bh exports
        put_ bh exp_hash
        put_ bh fixities
-       lazyPut bh deprecs
+       lazyPut bh warns
         put_ bh decls
        put_ bh insts
        put_ bh fam_insts
@@ -408,7 +412,7 @@ instance Binary ModIface where
        exports   <- {-# SCC "bin_exports" #-} get bh
        exp_hash  <- get bh
        fixities  <- {-# SCC "bin_fixities" #-} get bh
-       deprecs   <- {-# SCC "bin_deprecs" #-} lazyGet bh
+       warns     <- {-# SCC "bin_warns" #-} lazyGet bh
         decls    <- {-# SCC "bin_tycldecls" #-} get bh
        insts     <- {-# SCC "bin_insts" #-} get bh
        fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
@@ -428,7 +432,7 @@ instance Binary ModIface where
                 mi_exports   = exports,
                 mi_exp_hash  = exp_hash,
                 mi_fixities  = fixities,
-                mi_deprecs   = deprecs,
+                mi_warns     = warns,
                 mi_decls     = decls,
                 mi_globals   = Nothing,
                 mi_insts     = insts,
@@ -438,7 +442,7 @@ instance Binary ModIface where
                  mi_vect_info = vect_info,
                 mi_hpc       = hpc_info,
                        -- And build the cached values
-                mi_dep_fn    = mkIfaceDepCache deprecs,
+                mi_warn_fn   = mkIfaceWarnCache warns,
                 mi_fix_fn    = mkIfaceFixCache fixities,
                 mi_hash_fn   = mkIfaceHashCache decls })
 
@@ -510,23 +514,39 @@ instance Binary Usage where
             return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
                             usg_exports = exps, usg_entities = ents }
 
-instance Binary Deprecations where
-    put_ bh NoDeprecs     = putByte bh 0
-    put_ bh (DeprecAll t) = do
-           putByte bh 1
-           put_ bh t
-    put_ bh (DeprecSome ts) = do
-           putByte bh 2
-           put_ bh ts
+instance Binary Warnings where
+    put_ bh NoWarnings     = putByte bh 0
+    put_ bh (WarnAll t) = do
+            putByte bh 1
+            put_ bh t
+    put_ bh (WarnSome ts) = do
+            putByte bh 2
+            put_ bh ts
 
     get bh = do
-           h <- getByte bh
-           case h of
-             0 -> return NoDeprecs
-             1 -> do aa <- get bh
-                     return (DeprecAll aa)
-             _ -> do aa <- get bh
-                     return (DeprecSome aa)
+            h <- getByte bh
+            case h of
+              0 -> return NoWarnings
+              1 -> do aa <- get bh
+                      return (WarnAll aa)
+              _ -> do aa <- get bh
+                      return (WarnSome aa)
+
+instance Binary WarningTxt where
+    put_ bh (WarningTxt w) = do
+            putByte bh 0
+            put_ bh w
+    put_ bh (DeprecatedTxt d) = do
+            putByte bh 1
+            put_ bh d
+
+    get bh = do
+            h <- getByte bh
+            case h of
+              0 -> do w <- get bh
+                      return (WarningTxt w)
+              _ -> do d <- get bh
+                      return (DeprecatedTxt d)
 
 -------------------------------------------------------------------------
 --             Types from: BasicTypes