Treat modified Binary UserData as a local state with a sub-actionwip/binary-reader/step1

5 files changed, 108 insertions, 118 deletions

diff --git a/compiler/GHC/Iface/Binary.hs b/compiler/GHC/Iface/Binary.hs
index af0e9bfac6..75c2f9a0cb 100644
--- a/compiler/GHC/Iface/Binary.hs
+++ b/compiler/GHC/Iface/Binary.hs
@@ -166,21 +166,15 @@ getWithUserData ncu bh = do
     seekBin bh data_p             -- Back to where we were before
 
     -- Initialise the user-data field of bh
-    bh <- do
-        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
-                                                     (getDictFastString dict)
-        symtab_p <- Binary.get bh     -- Get the symtab ptr
-        data_p <- tellBin bh          -- Remember where we are now
-        seekBin bh symtab_p
-        symtab <- getSymbolTable bh ncu
-        seekBin bh data_p             -- Back to where we were before
-
-        -- It is only now that we know how to get a Name
-        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
-                                               (getDictFastString dict)
-
-    -- Read the interface file
-    get bh
+    readState bh (error "getSymtabName") (getDictFastString dict) $ \bh -> do
+      symtab_p <- Binary.get bh     -- Get the symtab ptr
+      data_p <- tellBin bh          -- Remember where we are now
+      seekBin bh symtab_p
+      symtab <- getSymbolTable bh ncu
+      seekBin bh data_p             -- Back to where we were before
+
+      -- It is only now that we know how to get a Name
+      readState bh (getSymtabName ncu dict symtab) (getDictFastString dict) get
 
 -- | Write an interface file
 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
@@ -233,38 +227,39 @@ putWithUserData log_action bh payload = do
                        bin_dict_next = dict_next_ref,
                        bin_dict_map  = dict_map_ref }
 
-    -- Put the main thing,
-    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
-                                                  (putName bin_dict bin_symtab)
-                                                  (putFastString bin_dict)
-    put_ bh payload
-
-    -- Write the symtab pointer at the front of the file
-    symtab_p <- tellBin bh        -- This is where the symtab will start
-    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
-    seekBin bh symtab_p           -- Seek back to the end of the file
-
-    -- Write the symbol table itself
-    symtab_next <- readFastMutInt symtab_next
-    symtab_map  <- readIORef symtab_map
-    putSymbolTable bh symtab_next symtab_map
-    log_action (text "writeBinIface:" <+> int symtab_next
-                                <+> text "Names")
-
-    -- NB. write the dictionary after the symbol table, because
-    -- writing the symbol table may create more dictionary entries.
-
-    -- Write the dictionary pointer at the front of the file
-    dict_p <- tellBin bh          -- This is where the dictionary will start
-    putAt bh dict_p_p dict_p      -- Fill in the placeholder
-    seekBin bh dict_p             -- Seek back to the end of the file
-
-    -- Write the dictionary itself
-    dict_next <- readFastMutInt dict_next_ref
-    dict_map  <- readIORef dict_map_ref
-    putDictionary bh dict_next dict_map
-    log_action (text "writeBinIface:" <+> int dict_next
-                                <+> text "dict entries")
+    writeState bh (putName bin_dict bin_symtab)
+                  (putName bin_dict bin_symtab)
+                  (putFastString bin_dict) $ \bh -> do
+
+      -- Put the main thing,
+      put_ bh payload
+
+      -- Write the symtab pointer at the front of the file
+      symtab_p <- tellBin bh        -- This is where the symtab will start
+      putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
+      seekBin bh symtab_p           -- Seek back to the end of the file
+
+      -- Write the symbol table itself
+      symtab_next <- readFastMutInt symtab_next
+      symtab_map  <- readIORef symtab_map
+      putSymbolTable bh symtab_next symtab_map
+      log_action (text "writeBinIface:" <+> int symtab_next
+                                  <+> text "Names")
+
+      -- NB. write the dictionary after the symbol table, because
+      -- writing the symbol table may create more dictionary entries.
+
+      -- Write the dictionary pointer at the front of the file
+      dict_p <- tellBin bh          -- This is where the dictionary will start
+      putAt bh dict_p_p dict_p      -- Fill in the placeholder
+      seekBin bh dict_p             -- Seek back to the end of the file
+
+      -- Write the dictionary itself
+      dict_next <- readFastMutInt dict_next_ref
+      dict_map  <- readIORef dict_map_ref
+      putDictionary bh dict_next dict_map
+      log_action (text "writeBinIface:" <+> int dict_next
+                                  <+> text "dict entries")
 
 
 
diff --git a/compiler/GHC/Iface/Ext/Binary.hs b/compiler/GHC/Iface/Ext/Binary.hs
index 91fe256cc8..70cae8e4e8 100644
--- a/compiler/GHC/Iface/Ext/Binary.hs
+++ b/compiler/GHC/Iface/Ext/Binary.hs
@@ -143,35 +143,36 @@ writeHieFile hie_file_path hiefile = do
                       hie_dict_map  = dict_map_ref }
 
   -- put the main thing
-  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)
-                                           (putName hie_symtab)
-                                           (putFastString hie_dict)
-  put_ bh hiefile
-
-  -- write the symtab pointer at the front of the file
-  symtab_p <- tellBin bh
-  putAt bh symtab_p_p symtab_p
-  seekBin bh symtab_p
-
-  -- write the symbol table itself
-  symtab_next' <- readFastMutInt symtab_next
-  symtab_map'  <- readIORef symtab_map
-  putSymbolTable bh symtab_next' symtab_map'
-
-  -- write the dictionary pointer at the front of the file
-  dict_p <- tellBin bh
-  putAt bh dict_p_p dict_p
-  seekBin bh dict_p
-
-  -- write the dictionary itself
-  dict_next <- readFastMutInt dict_next_ref
-  dict_map  <- readIORef dict_map_ref
-  putDictionary bh dict_next dict_map
-
-  -- and send the result to the file
-  createDirectoryIfMissing True (takeDirectory hie_file_path)
-  writeBinMem bh hie_file_path
-  return ()
+  writeState bh0 (putName hie_symtab)
+                 (putName hie_symtab)
+                 (putFastString hie_dict) $ \bh -> do
+
+    put_ bh hiefile
+
+    -- write the symtab pointer at the front of the file
+    symtab_p <- tellBin bh
+    putAt bh symtab_p_p symtab_p
+    seekBin bh symtab_p
+
+    -- write the symbol table itself
+    symtab_next' <- readFastMutInt symtab_next
+    symtab_map'  <- readIORef symtab_map
+    putSymbolTable bh symtab_next' symtab_map'
+
+    -- write the dictionary pointer at the front of the file
+    dict_p <- tellBin bh
+    putAt bh dict_p_p dict_p
+    seekBin bh dict_p
+
+    -- write the dictionary itself
+    dict_next <- readFastMutInt dict_next_ref
+    dict_map  <- readIORef dict_map_ref
+    putDictionary bh dict_next dict_map
+
+    -- and send the result to the file
+    createDirectoryIfMissing True (takeDirectory hie_file_path)
+    writeBinMem bh hie_file_path
+    return ()
 
 data HieFileResult
   = HieFileResult
@@ -256,19 +257,13 @@ readHieFileContents bh0 nc = do
 
   dict  <- get_dictionary bh0
 
-  -- read the symbol table so we are capable of reading the actual data
-  (bh1, nc') <- do
-      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")
-                                               (getDictFastString dict)
-      (nc', symtab) <- get_symbol_table bh1
-      let bh1' = setUserData bh1
-               $ newReadState (getSymTabName symtab)
-                              (getDictFastString dict)
-      return (bh1', nc')
-
-  -- load the actual data
-  hiefile <- get bh1
-  return (hiefile, nc')
+  readState bh0 (error "getSymtabName") (getDictFastString dict) $ \bh1 -> do
+    -- read the symbol table so we are capable of reading the actual data
+    (nc', symtab) <- get_symbol_table bh1
+    readState bh1 (getSymTabName symtab) (getDictFastString dict) $ \bh -> do
+      hiefile <- get bh
+      return (hiefile, nc')
+
   where
     get_dictionary bin_handle = do
       dict_p <- get bin_handle
diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs
index 1eef4d67b4..11b6556d4d 100644
--- a/compiler/iface/BinFingerprint.hs
+++ b/compiler/iface/BinFingerprint.hs
@@ -33,13 +33,11 @@ computeFingerprint :: (Binary a)
                    -> a
                    -> IO Fingerprint
 computeFingerprint put_nonbinding_name a = do
-    bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block
+  bh <- openBinMem (3*1024)
+  writeState bh put_nonbinding_name putNameLiterally putFS $ \bh -> do
     put_ bh a
     fp <- fingerprintBinMem bh
     return fp
-  where
-    set_user_data bh =
-      setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
 
 -- | Used when we want to fingerprint a structure without depending on the
 -- fingerprints of external Names that it refers to.
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 498c4924de..dd6567a08c 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -58,7 +58,7 @@ module Binary
 
    -- * User data
    UserData(..), getUserData, setUserData,
-   newReadState, newWriteState,
+   readState, writeState,
    putDictionary, getDictionary, putFS,
   ) where
 
@@ -1058,30 +1058,32 @@ data UserData =
         ud_put_fs   :: BinHandle -> FastString -> IO ()
    }
 
-newReadState :: (BinHandle -> IO Name)   -- ^ how to deserialize 'Name's
-             -> (BinHandle -> IO FastString)
-             -> UserData
-newReadState get_name get_fs
-  = UserData { ud_get_name = get_name,
-               ud_get_fs   = get_fs,
-               ud_put_nonbinding_name = undef "put_nonbinding_name",
-               ud_put_binding_name    = undef "put_binding_name",
-               ud_put_fs   = undef "put_fs"
-             }
-
-newWriteState :: (BinHandle -> Name -> IO ())
-                 -- ^ how to serialize non-binding 'Name's
-              -> (BinHandle -> Name -> IO ())
-                 -- ^ how to serialize binding 'Name's
-              -> (BinHandle -> FastString -> IO ())
-              -> UserData
-newWriteState put_nonbinding_name put_binding_name put_fs
-  = UserData { ud_get_name = undef "get_name",
-               ud_get_fs   = undef "get_fs",
-               ud_put_nonbinding_name = put_nonbinding_name,
-               ud_put_binding_name    = put_binding_name,
-               ud_put_fs   = put_fs
-             }
+readState :: BinHandle
+          -> (BinHandle -> IO Name)
+          -> (BinHandle -> IO FastString)
+          -> (BinHandle -> IO a)
+          -> IO a
+readState bh get_name get_fs read = read $ setUserData bh
+  UserData { ud_get_name = get_name,
+             ud_get_fs   = get_fs,
+             ud_put_nonbinding_name = undef "put_nonbinding_name",
+             ud_put_binding_name    = undef "put_binding_name",
+             ud_put_fs   = undef "put_fs"
+           }
+
+writeState :: BinHandle
+           -> (BinHandle -> Name -> IO ())
+           -> (BinHandle -> Name -> IO ())
+           -> (BinHandle -> FastString -> IO ())
+           -> (BinHandle -> IO a)
+           -> IO a
+writeState bh put_nonbinding_name put_binding_name put_fs write = write $ setUserData bh
+  UserData { ud_get_name = undef "get_name",
+             ud_get_fs   = undef "get_fs",
+             ud_put_nonbinding_name = put_nonbinding_name,
+             ud_put_binding_name    = put_binding_name,
+             ud_put_fs   = put_fs
+           }
 
 noUserData :: a
 noUserData = undef "UserData"
diff --git a/utils/haddock b/utils/haddock
-Subproject f3e3c4a766805a1bbea75bf23b84fdaaf053c22
+Subproject 3e8b9c640f847a5a9b116a7db0a57d11c2d3d94