[project @ 2004-01-05 12:11:42 by simonpj]

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

diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs
index 255b86a..315f35e 100644 (file)
--- a/ghc/compiler/iface/BinIface.hs
+++ b/ghc/compiler/iface/BinIface.hs
@@ -5,7 +5,7 @@
 -- 
 -- Binary interface file support.
 
-module BinIface ( writeBinIface, readBinIface, v_IgnoreHiVersion ) where
+module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where
 
 #include "HsVersions.h"
 
@@ -18,9 +18,9 @@ import TyCon          ( DataConDetails(..) )
 import Class           ( DefMeth(..) )
 import CostCentre
 import Module          ( moduleName, mkModule )
-import OccName         ( OccName )
 import DriverState     ( v_Build_tag )
 import CmdLineOpts     ( opt_HiVersion )
+import Kind            ( Kind(..) )
 import Panic
 import Binary
 import Util
@@ -112,8 +112,9 @@ instance Binary ModIface where
                 mi_insts     = insts,
                 mi_rules     = rules,
                 mi_rule_vers = rule_vers }) = do
+       put_ bh (show opt_HiVersion)
        build_tag <- readIORef v_Build_tag
-       put_ bh (show opt_HiVersion ++ build_tag)
+       put  bh build_tag
        put_ bh pkg_name
        put_ bh (moduleName mod)
        put_ bh mod_vers
@@ -131,16 +132,24 @@ instance Binary ModIface where
 
    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 && not ignore_ver) $
+       let our_ver = show opt_HiVersion
+        when (check_ver /= our_ver) $
           -- use userError because this will be caught by readIface
           -- which will emit an error msg containing the iface module name.
           throwDyn (ProgramError (
                "mismatched interface file versions: expected "
                ++ our_ver ++ ", found " ++ check_ver))
 
+       check_way <- get bh
+        ignore_way <- readIORef v_IgnoreHiWay
+       build_tag <- readIORef v_Build_tag
+        when (not ignore_way && check_way /= build_tag) $
+          -- use userError because this will be caught by readIface
+          -- which will emit an error msg containing the iface module name.
+          throwDyn (ProgramError (
+               "mismatched interface file ways: expected "
+               ++ build_tag ++ ", found " ++ check_way))
+
        pkg_name  <- get bh
        mod_name  <- get bh
 
@@ -181,7 +190,7 @@ instance Binary ModIface where
                 mi_fix_fn = mkIfaceFixCache fixities,
                 mi_ver_fn = mkIfaceVerCache decls })
 
-GLOBAL_VAR(v_IgnoreHiVersion, False, Bool)
+GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
 
 -------------------------------------------------------------------------
 --             Types from: HscTypes
@@ -561,23 +570,29 @@ instance Binary IfaceBndr where
              _ -> do ab <- get bh
                      return (IfaceTvBndr ab)
 
-instance Binary IfaceKind where
-    put_ bh IfaceLiftedTypeKind   = putByte bh 0
-    put_ bh IfaceUnliftedTypeKind = putByte bh 1
-    put_ bh IfaceOpenTypeKind     = putByte bh 2
-    put_ bh (IfaceFunKind k1 k2)  = do 
-           putByte bh 3
+instance Binary Kind where
+    put_ bh LiftedTypeKind   = putByte bh 0
+    put_ bh UnliftedTypeKind = putByte bh 1
+    put_ bh OpenTypeKind     = putByte bh 2
+    put_ bh ArgTypeKind      = putByte bh 3
+    put_ bh UbxTupleKind     = putByte bh 4
+    put_ bh (FunKind k1 k2)  = do 
+           putByte bh 5
            put_ bh k1
            put_ bh k2
+    put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
+
     get bh = do
            h <- getByte bh
            case h of
-             0 -> return IfaceLiftedTypeKind 
-             1 -> return IfaceUnliftedTypeKind
-             2 -> return IfaceOpenTypeKind
+             0 -> return LiftedTypeKind 
+             1 -> return UnliftedTypeKind
+             2 -> return OpenTypeKind
+             3 -> return ArgTypeKind
+             4 -> return UbxTupleKind
              _ -> do k1 <- get bh
                      k2 <- get bh
-                     return (IfaceFunKind k1 k2)
+                     return (FunKind k1 k2)
 
 instance Binary IfaceType where
     put_ bh (IfaceForAllTy aa ab) = do