[project @ 2003-05-27 12:40:19 by simonmar]

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

diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs
index 8e461ca..e489fb2 100644 (file)
--- a/ghc/compiler/main/BinIface.hs
+++ b/ghc/compiler/main/BinIface.hs
@@ -5,7 +5,7 @@
 -- 
 -- Binary interface file support.
 
-module BinIface ( writeBinIface, readBinIface ) where
+module BinIface ( writeBinIface, readBinIface, v_IgnoreHiVersion ) where
 
 #include "HsVersions.h"
 
@@ -32,8 +32,9 @@ import CmdLineOpts    ( opt_IgnoreIfacePragmas, opt_HiVersion )
 import Panic
 import SrcLoc
 import Binary
+import Util
 
-import DATA_IOREF      ( readIORef )
+import DATA_IOREF
 import EXCEPTION       ( throwDyn )
 import Monad           ( when )
 
@@ -269,12 +270,13 @@ instance Binary ModIface where
   put_ bh iface =  do
        build_tag <- readIORef v_Build_tag
        put_ bh (show opt_HiVersion ++ build_tag)
-       p <- put_ bh (mi_module iface)
+       p <- put_ bh (moduleName (mi_module iface))
        put_ bh (mi_package iface)
        put_ bh (vers_module (mi_version iface))
        put_ bh (mi_orphan iface)
        -- no: mi_boot
-       lazyPut bh (map importVersionNameToOccName (mi_usages iface))
+       lazyPut bh (mi_deps iface)
+       lazyPut bh (map usageToOccName (mi_usages iface))
        put_ bh (vers_exports (mi_version iface),
                 map exportItemToRdrExportItem (mi_exports iface))
        put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
@@ -309,14 +311,9 @@ deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env))
 {-! for WhatsImported derive: Binary !-}
 
 -- For binary interfaces we need to convert the ImportVersion Names to OccNames
-importVersionNameToOccName :: ImportVersion Name -> ImportVersion OccName
-importVersionNameToOccName (mod, orphans, boot, what)
-  = (mod, orphans, boot, fiddle_with what)
-  where fiddle_with NothingAtAll = NothingAtAll
-       fiddle_with (Everything v) = Everything v
-       fiddle_with (Specifically v ev ns rv) = Specifically v ev ns' rv
-         where ns' = [ (nameOccName n, v) | (n,v) <- ns ]
-
+usageToOccName :: Usage Name -> Usage OccName
+usageToOccName usg
+  = usg { usg_entities = [ (nameOccName n, v) | (n,v) <- usg_entities usg ] }
 
 exportItemToRdrExportItem (mn, avails) 
   = (mn, map availInfoToRdrAvailInfo avails)
@@ -358,9 +355,10 @@ instance Binary ParsedIface where
        lazyPut bh deprecs
    get bh = do
        check_ver   <- get bh
+        ignore_ver <- readIORef v_IgnoreHiVersion
        build_tag <- readIORef v_Build_tag
        let our_ver = show opt_HiVersion ++ build_tag
-        when (check_ver /= our_ver) $
+        when (check_ver /= our_ver && not ignore_ver) $
           -- use userError because this will be caught by readIface
           -- which will emit an error msg containing the iface module name.
           throwDyn (ProgramError (
@@ -370,6 +368,7 @@ instance Binary ParsedIface where
        pkg_name    <- get bh
        module_ver  <- get bh
        orphan      <- get bh
+       deps        <- lazyGet bh
        usages      <- {-# SCC "bin_usages" #-} lazyGet bh
        exports     <- {-# SCC "bin_exports" #-} get bh
         tycl_decls  <- {-# SCC "bin_tycldecls" #-} get bh
@@ -382,6 +381,7 @@ instance Binary ParsedIface where
                 pi_pkg = pkg_name,
                 pi_vers = module_ver,
                 pi_orphan = orphan,
+                pi_deps = deps,
                 pi_usages = usages,
                 pi_exports = exports,
                 pi_decls = tycl_decls,
@@ -390,11 +390,23 @@ instance Binary ParsedIface where
                 pi_rules = rules,
                 pi_deprecs = deprecs })
 
+GLOBAL_VAR(v_IgnoreHiVersion, False, Bool)
+
 -- ----------------------------------------------------------------------------
 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
 
 --  Imported from other files :-
 
+instance Binary Dependencies where
+    put_ bh deps = do put_ bh (dep_mods deps)
+                     put_ bh (dep_pkgs deps)
+                     put_ bh (dep_orphs deps)
+
+    get bh = do ms <- get bh 
+               ps <- get bh
+               os <- get bh
+               return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
+
 instance (Binary name) => Binary (GenAvailInfo name) where
     put_ bh (Avail aa) = do
            putByte bh 0
@@ -412,29 +424,23 @@ instance (Binary name) => Binary (GenAvailInfo name) where
                      ac <- get bh
                      return (AvailTC ab ac)
 
-instance (Binary name) => Binary (WhatsImported name) where
-    put_ bh NothingAtAll = do
-           putByte bh 0
-    put_ bh (Everything aa) = do
-           putByte bh 1
-           put_ bh aa
-    put_ bh (Specifically ab ac ad ae) = do
-           putByte bh 2
-           put_ bh ab
-           put_ bh ac
-           put_ bh ad
-           put_ bh ae
+instance (Binary name) => Binary (Usage name) where
+    put_ bh usg        = do 
+       put_ bh (usg_name     usg)
+       put_ bh (usg_mod      usg)
+       put_ bh (usg_exports  usg)
+       put_ bh (usg_entities usg)
+       put_ bh (usg_rules    usg)
+
     get bh = do
-           h <- getByte bh
-           case h of
-             0 -> do return NothingAtAll
-             1 -> do aa <- get bh
-                     return (Everything aa)
-             _ -> do ab <- get bh
-                     ac <- get bh
-                     ad <- get bh
-                     ae <- get bh
-                     return (Specifically ab ac ad ae)
+       nm    <- get bh
+       mod   <- get bh
+       exps  <- get bh
+       ents  <- get bh
+       rules <- get bh
+       return (Usage { usg_name = nm, usg_mod = mod,
+                       usg_exports = exps, usg_entities = ents,
+                       usg_rules = rules })
 
 instance Binary Activation where
     put_ bh NeverActive = do
@@ -934,6 +940,9 @@ instance (Binary name) => Binary (UfNote name) where
            putByte bh 2
     put_ bh UfInlineMe = do
            putByte bh 3
+    put_ bh (UfCoreNote s) = do
+            putByte bh 4
+            put_ bh s
     get bh = do
            h <- getByte bh
            case h of
@@ -942,7 +951,9 @@ instance (Binary name) => Binary (UfNote name) where
              1 -> do ab <- get bh
                      return (UfCoerce ab)
              2 -> do return UfInlineCall
-             _ -> do return UfInlineMe
+             3 -> do return UfInlineMe
+              _ -> do ac <- get bh
+                      return (UfCoreNote ac)
 
 instance (Binary name) => Binary (BangType name) where
     put_ bh (BangType aa ab) = do