Serialise nested unfoldings across module boundaries

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

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 4d3f619..7c84778 100644 (file)
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -256,22 +256,20 @@ fromOnDiskName
    -> OnDiskName
    -> (NameCache, Name)
 fromOnDiskName _ nc (pid, mod_name, occ) =
-  let 
+  let
         mod   = mkModule pid mod_name
         cache = nsNames nc
   in
   case lookupOrigNameCache cache  mod occ of
      Just name -> (nc, name)
-     Nothing   -> 
-        let 
-                us        = nsUniqs nc
-                uniq      = uniqFromSupply us
+     Nothing   ->
+        case takeUniqFromSupply (nsUniqs nc) of
+        (uniq, us) ->
+            let
                 name      = mkExternalName uniq mod occ noSrcSpan
                 new_cache = extendNameCache cache mod occ name
-        in        
-        case splitUniqSupply us of { (us',_) -> 
-        ( nc{ nsUniqs = us', nsNames = new_cache }, name )
-        }
+            in
+            ( nc{ nsUniqs = us, nsNames = new_cache }, name )
 
 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
 serialiseName bh name _ = do
@@ -612,6 +610,19 @@ instance Binary InlinePragma where
            d <- get bh
            return (InlinePragma a b c d)
 
+instance Binary InlineSpec where
+    put_ bh EmptyInlineSpec = putByte bh 0
+    put_ bh Inline          = putByte bh 1
+    put_ bh Inlinable       = putByte bh 2
+    put_ bh NoInline        = putByte bh 3
+
+    get bh = do h <- getByte bh
+                case h of
+                  0 -> return EmptyInlineSpec
+                  1 -> return Inline
+                  2 -> return Inlinable
+                  _ -> return NoInline
+
 instance Binary HsBang where
     put_ bh HsNoBang        = putByte bh 0
     put_ bh HsStrict        = putByte bh 1
@@ -1188,8 +1199,9 @@ instance Binary IfaceInfoItem where
              _ -> do return HsNoCafRefs
 
 instance Binary IfaceUnfolding where
-    put_ bh (IfCoreUnfold e) = do
+    put_ bh (IfCoreUnfold s e) = do
        putByte bh 0
+       put_ bh s
        put_ bh e
     put_ bh (IfInlineRule a b c d) = do
        putByte bh 1
@@ -1197,21 +1209,26 @@ instance Binary IfaceUnfolding where
        put_ bh b
        put_ bh c
        put_ bh d
-    put_ bh (IfWrapper a n) = do
+    put_ bh (IfLclWrapper a n) = do
        putByte bh 2
        put_ bh a
        put_ bh n
-    put_ bh (IfDFunUnfold as) = do
+    put_ bh (IfExtWrapper a n) = do
        putByte bh 3
+       put_ bh a
+       put_ bh n
+    put_ bh (IfDFunUnfold as) = do
+       putByte bh 4
        put_ bh as
     put_ bh (IfCompulsory e) = do
-       putByte bh 4
+       putByte bh 5
        put_ bh e
     get bh = do
        h <- getByte bh
        case h of
-         0 -> do e <- get bh
-                 return (IfCoreUnfold e)
+         0 -> do s <- get bh
+                 e <- get bh
+                 return (IfCoreUnfold s e)
          1 -> do a <- get bh
                  b <- get bh
                  c <- get bh
@@ -1219,8 +1236,11 @@ instance Binary IfaceUnfolding where
                  return (IfInlineRule a b c d)
          2 -> do a <- get bh
                  n <- get bh
-                 return (IfWrapper a n)
-         3 -> do as <- get bh
+                 return (IfLclWrapper a n)
+         3 -> do a <- get bh
+                 n <- get bh
+                 return (IfExtWrapper a n)
+         4 -> do as <- get bh
                  return (IfDFunUnfold as)
          _ -> do e <- get bh
                  return (IfCompulsory e)
@@ -1415,7 +1435,7 @@ instance Binary IfaceClassOp where
        return (IfaceClassOp occ def ty)
 
 instance Binary IfaceRule where
-    put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
+    put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
            put_ bh a1
            put_ bh a2
            put_ bh a3
@@ -1423,6 +1443,7 @@ instance Binary IfaceRule where
            put_ bh a5
            put_ bh a6
            put_ bh a7
+           put_ bh a8
     get bh = do
            a1 <- get bh
            a2 <- get bh
@@ -1431,7 +1452,8 @@ instance Binary IfaceRule where
            a5 <- get bh
            a6 <- get bh
            a7 <- get bh
-           return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
+           a8 <- get bh
+           return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
 
 instance Binary IfaceAnnotation where
     put_ bh (IfaceAnnotation a1 a2) = do