From b210f01150cfd78f54d2edd9e7b049f7d8513761 Mon Sep 17 00:00:00 2001 From: Josh Meredith Date: Wed, 16 Oct 2019 02:13:10 +1100 Subject: Abstract binary serialization behind a ReaderT newtype with pure encode/decode interface --- compiler/iface/BinFingerprint.hs | 23 +- compiler/iface/BinIface.hs | 301 ++++++------- compiler/iface/FlagChecker.hs | 10 +- compiler/iface/IfaceSyn.hs | 942 +++++++++++++++++++-------------------- compiler/iface/IfaceType.hs | 459 ++++++++++--------- compiler/iface/MkIface.hs | 49 +- 6 files changed, 882 insertions(+), 902 deletions(-) (limited to 'compiler/iface') diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs index 1eef4d67b4..dfcc6cac4a 100644 --- a/compiler/iface/BinFingerprint.hs +++ b/compiler/iface/BinFingerprint.hs @@ -14,11 +14,12 @@ import GhcPrelude import Fingerprint import Binary +import Binary.Unsafe (runBuffer) import Name import PlainPanic import Util -fingerprintBinMem :: BinHandle -> IO Fingerprint +fingerprintBinMem :: BinData -> IO Fingerprint fingerprintBinMem bh = withBinBuffer bh f where f bs = @@ -29,21 +30,19 @@ fingerprintBinMem bh = withBinBuffer bh f in fp `seq` return fp computeFingerprint :: (Binary a) - => (BinHandle -> Name -> IO ()) + => (Name -> Put ()) -> a -> IO Fingerprint computeFingerprint put_nonbinding_name a = do - bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block - put_ bh a - fp <- fingerprintBinMem bh - return fp + bd <- runBuffer (3 * 1024) (setUserData (put a)) -- just less than a block + fingerprintBinMem bd where - set_user_data bh = - setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS + setUserData = + writeState put_nonbinding_name putNameLiterally putAFastString -- | Used when we want to fingerprint a structure without depending on the -- fingerprints of external Names that it refers to. -putNameLiterally :: BinHandle -> Name -> IO () -putNameLiterally bh name = ASSERT( isExternalName name ) do - put_ bh $! nameModule name - put_ bh $! nameOccName name +putNameLiterally :: Name -> Put () +putNameLiterally name = ASSERT( isExternalName name ) do + put $! nameModule name + put $! nameOccName name diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index e1ca00e8a8..cfe3142bd3 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -36,6 +36,7 @@ import UniqFM import UniqSupply import Panic import Binary +import Binary.Unsafe (ioP, ioG) import SrcLoc import ErrUtils import FastMutInt @@ -93,174 +94,166 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do sd QuietBinIFaceReading -> \_ -> return () - wantedGot :: String -> a -> a -> (a -> SDoc) -> IO () - wantedGot what wanted got ppr' = + wantedGot :: String -> a -> a -> (a -> SDoc) -> Get () + wantedGot what wanted got ppr' = ioG $ 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 = + errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> Get () + errorOnMismatch what wanted got = ioG $ -- This will be caught by readIface which will emit an error -- msg containing the iface module name. when (wanted /= got) $ throwGhcExceptionIO $ ProgramError (what ++ " (wanted " ++ show wanted ++ ", got " ++ show got ++ ")") - bh <- Binary.readBinMem hi_path - - -- Read the magic number to check that this really is a GHC .hi file - -- (This magic number does not change when we change - -- GHC interface file format) - magic <- get bh - wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr - errorOnMismatch "magic number mismatch: old/corrupt interface file?" - (binaryInterfaceMagic dflags) magic - - -- Note [dummy iface field] - -- read a dummy 32/64 bit value. This field used to hold the - -- dictionary pointer in old interface file formats, but now - -- the dictionary pointer is after the version (where it - -- should be). Also, the serialisation of value of type "Bin - -- a" used to depend on the word size of the machine, now they - -- are always 32 bits. - if wORD_SIZE dflags == 4 - then do _ <- Binary.get bh :: IO Word32; return () - else do _ <- Binary.get bh :: IO Word64; return () - - -- Check the interface file version and ways. - check_ver <- get bh - let our_ver = show hiVersion - wantedGot "Version" our_ver check_ver text - errorOnMismatch "mismatched interface file versions" our_ver check_ver - - check_way <- get bh - let way_descr = getWayDescr dflags - wantedGot "Way" way_descr check_way ppr - when (checkHiWay == CheckHiWay) $ - errorOnMismatch "mismatched interface file ways" way_descr check_way - getWithUserData ncu bh + + bd <- Binary.readBinData hi_path + + runGetIO bd $ do + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) + magic <- get + wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr + errorOnMismatch "magic number mismatch: old/corrupt interface file?" + (binaryInterfaceMagic dflags) magic + + -- Note [dummy iface field] + -- read a dummy 32/64 bit value. This field used to hold the + -- dictionary pointer in old interface file formats, but now + -- the dictionary pointer is after the version (where it + -- should be). Also, the serialisation of value of type "Bin + -- a" used to depend on the word size of the machine, now they + -- are always 32 bits. + if wORD_SIZE dflags == 4 + then do _ <- Binary.get :: Get Word32; return () + else do _ <- Binary.get :: Get Word64; return () + + -- Check the interface file version and ways. + check_ver <- get + let our_ver = show hiVersion + wantedGot "Version" our_ver check_ver text + errorOnMismatch "mismatched interface file versions" our_ver check_ver + + check_way <- get + let way_descr = getWayDescr dflags + wantedGot "Way" way_descr check_way ppr + when (checkHiWay == CheckHiWay) $ + errorOnMismatch "mismatched interface file ways" way_descr check_way + getWithUserData ncu -- | This performs a get action after reading the dictionary and symbol -- table. It is necessary to run this before trying to deserialise any -- Names or FastStrings. -getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a -getWithUserData ncu bh = do +getWithUserData :: Binary a => NameCacheUpdater -> Get a +getWithUserData ncu = do -- Read the dictionary -- The next word in the file is a pointer to where the dictionary is -- (probably at the end of the file) - dict_p <- Binary.get bh - data_p <- tellBin bh -- Remember where we are now - seekBin bh dict_p - dict <- getDictionary bh - 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 + dict_p <- Binary.get + data_p <- tellG -- Remember where we are now + seekG dict_p + dict <- getDictionary + seekG data_p -- Back to where we were before + + readState (error "getSymtabName") (getDictFastString dict) $ do + + symtab_p <- Binary.get -- Get the symtab ptr + data_p <- tellG -- Remember where we are now + seekG symtab_p + symtab <- getSymbolTable ncu + seekG data_p -- Back to where we were before + + -- It is only now that we know how to get a `Name` + readState (getSymtabName ncu dict symtab) (getDictFastString dict) get -- | Write an interface file writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () writeBinIface dflags hi_path mod_iface = do - bh <- openBinMem initBinMemSize - put_ bh (binaryInterfaceMagic dflags) - -- dummy 32/64-bit field before the version/way for - -- compatibility with older interface file formats. - -- See Note [dummy iface field] above. - if wORD_SIZE dflags == 4 - then Binary.put_ bh (0 :: Word32) - else Binary.put_ bh (0 :: Word64) + bd <- runPutIO $ do + put (binaryInterfaceMagic dflags) + + -- dummy 32/64-bit field before the version/way for + -- compatibility with older interface file formats. + -- See Note [dummy iface field] above. + if wORD_SIZE dflags == 4 + then Binary.put (0 :: Word32) + else Binary.put (0 :: Word64) - -- The version and way descriptor go next - put_ bh (show hiVersion) - let way_descr = getWayDescr dflags - put_ bh way_descr + -- The version and way descriptor go next + put (show hiVersion) + let way_descr = getWayDescr dflags + put way_descr + putWithUserData (ioP . debugTraceMsg dflags 3) mod_iface - putWithUserData (debugTraceMsg dflags 3) bh mod_iface -- And send the result to the file - writeBinMem bh hi_path + writeBinData bd hi_path -- | Put a piece of data with an initialised `UserData` field. This -- is necessary if you want to serialise Names or FastStrings. -- It also writes a symbol table and the dictionary. -- This segment should be read using `getWithUserData`. -putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO () -putWithUserData log_action bh payload = do +putWithUserData :: Binary a => (SDoc -> Put ()) -> a -> Put () +putWithUserData log_action payload = do -- Remember where the dictionary pointer will go - dict_p_p <- tellBin bh + dict_p_p <- tellP -- Placeholder for ptr to dictionary - put_ bh dict_p_p + put dict_p_p -- Remember where the symbol table pointer will go - symtab_p_p <- tellBin bh - put_ bh symtab_p_p + symtab_p_p <- tellP + put symtab_p_p -- Make some initial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM + symtab_next <- ioP $ newFastMutInt + ioP $ writeFastMutInt symtab_next 0 + symtab_map <- ioP $ newIORef emptyUFM let bin_symtab = BinSymbolTable { bin_symtab_next = symtab_next, bin_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 - dict_map_ref <- newIORef emptyUFM + dict_next_ref <- ioP $ newFastMutInt + ioP $ writeFastMutInt dict_next_ref 0 + dict_map_ref <- ioP $ newIORef emptyUFM let bin_dict = BinDictionary { 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 (putName bin_dict bin_symtab) + (putName bin_dict bin_symtab) + (putFastString bin_dict) $ do + put payload + + -- Write the symtab pointer at the front of the file + symtab_p <- tellP -- This is where the symtab will start + putAt symtab_p_p symtab_p -- Fill in the placeholder + seekP symtab_p -- Seek back to the end of the file + + -- Write the symbol table itself + symtab_next <- ioP $ readFastMutInt symtab_next + symtab_map <- ioP $ readIORef symtab_map + putSymbolTable 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 <- tellP -- This is where the dictionary will start + putAt dict_p_p dict_p -- Fill in the placeholder + seekP dict_p -- Seek back to the end of the file + + -- Write the dictionary itself + dict_next <- ioP $ readFastMutInt dict_next_ref + dict_map <- ioP $ readIORef dict_map_ref + putDictionary dict_next dict_map + log_action (text "writeBinIface:" <+> int dict_next + <+> text "dict entries") --- | Initial ram buffer to allocate for writing interface files -initBinMemSize :: Int -initBinMemSize = 1024 * 1024 binaryInterfaceMagic :: DynFlags -> Word32 binaryInterfaceMagic dflags @@ -272,19 +265,19 @@ binaryInterfaceMagic dflags -- The symbol table -- -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off +putSymbolTable :: Int -> UniqFM (Int,Name) -> Put () +putSymbolTable next_off symtab = do + put next_off let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab)) -- It's OK to use nonDetEltsUFM here because the elements have -- indices that array uses to create order - mapM_ (\n -> serialiseName bh n symtab) names + mapM_ (\n -> serialiseName n symtab) names -getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable -getSymbolTable bh ncu = do - sz <- get bh - od_names <- sequence (replicate sz (get bh)) - updateNameCache ncu $ \namecache -> +getSymbolTable :: NameCacheUpdater -> Get SymbolTable +getSymbolTable ncu = do + sz <- get + od_names <- sequence (replicate sz get) + ioG $ updateNameCache ncu $ \namecache -> runST $ flip State.evalStateT namecache $ do mut_arr <- lift $ newSTArray_ (0, sz-1) for_ (zip [0..] od_names) $ \(i, odn) -> do @@ -313,10 +306,10 @@ fromOnDiskName nc (pid, mod_name, occ) = new_cache = extendNameCache cache mod occ name in ( nc{ nsUniqs = us, nsNames = new_cache }, name ) -serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () -serialiseName bh name _ = do +serialiseName :: Name -> UniqFM (Int,Name) -> Put () +serialiseName name _ = do let mod = ASSERT2( isExternalName name, ppr name ) nameModule name - put_ bh (moduleUnitId mod, moduleName mod, nameOccName name) + put (moduleUnitId mod, moduleName mod, nameOccName name) -- Note [Symbol table representation of names] @@ -337,36 +330,36 @@ serialiseName bh name _ = do -- See Note [Symbol table representation of names] -putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO () +putName :: BinDictionary -> BinSymbolTable -> Name -> Put () putName _dict BinSymbolTable{ bin_symtab_map = symtab_map_ref, bin_symtab_next = symtab_next } - bh name + name | isKnownKeyName name , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits = -- ASSERT(u < 2^(22 :: Int)) - put_ bh (0x80000000 - .|. (fromIntegral (ord c) `shiftL` 22) - .|. (fromIntegral u :: Word32)) + put (0x80000000 + .|. (fromIntegral (ord c) `shiftL` 22) + .|. (fromIntegral u :: Word32)) | otherwise - = do symtab_map <- readIORef symtab_map_ref + = do symtab_map <- ioP $ readIORef symtab_map_ref case lookupUFM symtab_map name of - Just (off,_) -> put_ bh (fromIntegral off :: Word32) + Just (off,_) -> put (fromIntegral off :: Word32) Nothing -> do - off <- readFastMutInt symtab_next + off <- ioP $ readFastMutInt symtab_next -- MASSERT(off < 2^(30 :: Int)) - writeFastMutInt symtab_next (off+1) - writeIORef symtab_map_ref + ioP $ writeFastMutInt symtab_next (off+1) + ioP $ writeIORef symtab_map_ref $! addToUFM symtab_map name (off,name) - put_ bh (fromIntegral off :: Word32) + put (fromIntegral off :: Word32) -- See Note [Symbol table representation of names] getSymtabName :: NameCacheUpdater -> Dictionary -> SymbolTable - -> BinHandle -> IO Name -getSymtabName _ncu _dict symtab bh = do - i :: Word32 <- get bh + -> Get Name +getSymtabName _ncu _dict symtab = do + i :: Word32 <- get case i .&. 0xC0000000 of 0x00000000 -> return $! symtab ! fromIntegral i @@ -389,8 +382,8 @@ data BinSymbolTable = BinSymbolTable { -- indexed by Name } -putFastString :: BinDictionary -> BinHandle -> FastString -> IO () -putFastString dict bh fs = allocateFastString dict fs >>= put_ bh +putFastString :: BinDictionary -> FastString -> Put () +putFastString dict fs = ioP (allocateFastString dict fs) >>= put allocateFastString :: BinDictionary -> FastString -> IO Word32 allocateFastString BinDictionary { bin_dict_next = j_r, @@ -405,9 +398,9 @@ allocateFastString BinDictionary { bin_dict_next = j_r, writeIORef out_r $! addToUFM out uniq (j, f) return (fromIntegral j :: Word32) -getDictFastString :: Dictionary -> BinHandle -> IO FastString -getDictFastString dict bh = do - j <- get bh +getDictFastString :: Dictionary -> Get FastString +getDictFastString dict = do + j <- get return $! (dict ! fromIntegral (j :: Word32)) data BinDictionary = BinDictionary { diff --git a/compiler/iface/FlagChecker.hs b/compiler/iface/FlagChecker.hs index 34b55e9fef..15824d0f28 100644 --- a/compiler/iface/FlagChecker.hs +++ b/compiler/iface/FlagChecker.hs @@ -30,7 +30,7 @@ import System.FilePath (normalise) -- *interface* file, not the actual 'Module' according to our -- 'DynFlags'. fingerprintDynFlags :: DynFlags -> Module - -> (BinHandle -> Name -> IO ()) + -> (Name -> Put ()) -> IO Fingerprint fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = @@ -68,8 +68,8 @@ fingerprintDynFlags dflags@DynFlags{..} this_mod nameio = -- object files as they can. -- See Note [Ignoring some flag changes] fingerprintOptFlags :: DynFlags - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint + -> (Name -> Put ()) + -> IO Fingerprint fingerprintOptFlags DynFlags{..} nameio = let -- See https://gitlab.haskell.org/ghc/ghc/issues/10923 @@ -86,8 +86,8 @@ fingerprintOptFlags DynFlags{..} nameio = -- file compiled for HPC when not actually using HPC. -- See Note [Ignoring some flag changes] fingerprintHpcFlags :: DynFlags - -> (BinHandle -> Name -> IO ()) - -> IO Fingerprint + -> (Name -> Put ()) + -> IO Fingerprint fingerprintHpcFlags dflags@DynFlags{..} nameio = let -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798 diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index ce4332c27b..26dd36b21e 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -100,15 +100,11 @@ type IfaceTopBndr = Name -- We don't serialise the namespace onto the disk though; rather we -- drop it when serialising and add it back in when deserialising. -getIfaceTopBndr :: BinHandle -> IO IfaceTopBndr -getIfaceTopBndr bh = get bh +getIfaceTopBndr :: Get IfaceTopBndr +getIfaceTopBndr = get -putIfaceTopBndr :: BinHandle -> IfaceTopBndr -> IO () -putIfaceTopBndr bh name = - case getUserData bh of - UserData{ ud_put_binding_name = put_binding_name } -> - --pprTrace "putIfaceTopBndr" (ppr name) $ - put_binding_name bh name +putIfaceTopBndr :: IfaceTopBndr -> Put () +putIfaceTopBndr = putBindingName data IfaceDecl = IfaceId { ifName :: IfaceTopBndr, @@ -1766,43 +1762,43 @@ details. -} instance Binary IfaceDecl where - put_ bh (IfaceId name ty details idinfo) = do - putByte bh 0 - putIfaceTopBndr bh name - lazyPut bh (ty, details, idinfo) + put (IfaceId name ty details idinfo) = do + putByte 0 + putIfaceTopBndr name + lazyPut (ty, details, idinfo) -- See Note [Lazy deserialization of IfaceId] - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do - putByte bh 2 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - - put_ bh (IfaceSynonym a1 a2 a3 a4 a5) = do - putByte bh 3 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - - put_ bh (IfaceFamily a1 a2 a3 a4 a5 a6) = do - putByte bh 4 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 + put (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) = do + putByte 2 + putIfaceTopBndr a1 + put a2 + put a3 + put a4 + put a5 + put a6 + put a7 + put a8 + put a9 + + put (IfaceSynonym a1 a2 a3 a4 a5) = do + putByte 3 + putIfaceTopBndr a1 + put a2 + put a3 + put a4 + put a5 + + put (IfaceFamily a1 a2 a3 a4 a5 a6) = do + putByte 4 + putIfaceTopBndr a1 + put a2 + put a3 + put a4 + put a5 + put a6 -- NB: Written in a funny way to avoid an interface change - put_ bh (IfaceClass { + put (IfaceClass { ifName = a2, ifRoles = a3, ifBinders = a4, @@ -1813,88 +1809,88 @@ instance Binary IfaceDecl where ifSigs = a7, ifMinDef = a8 }}) = do - putByte bh 5 - put_ bh a1 - putIfaceTopBndr bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - - put_ bh (IfaceAxiom a1 a2 a3 a4) = do - putByte bh 6 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - - put_ bh (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do - putByte bh 7 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh a9 - put_ bh a10 - put_ bh a11 - - put_ bh (IfaceClass { + putByte 5 + put a1 + putIfaceTopBndr a2 + put a3 + put a4 + put a5 + put a6 + put a7 + put a8 + + put (IfaceAxiom a1 a2 a3 a4) = do + putByte 6 + putIfaceTopBndr a1 + put a2 + put a3 + put a4 + + put (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putByte 7 + putIfaceTopBndr a1 + put a2 + put a3 + put a4 + put a5 + put a6 + put a7 + put a8 + put a9 + put a10 + put a11 + + put (IfaceClass { ifName = a1, ifRoles = a2, ifBinders = a3, ifFDs = a4, ifBody = IfAbstractClass }) = do - putByte bh 8 - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - - get bh = do - h <- getByte bh + putByte 8 + putIfaceTopBndr a1 + put a2 + put a3 + put a4 + + get = do + h <- getByte case h of - 0 -> do name <- get bh - ~(ty, details, idinfo) <- lazyGet bh + 0 -> do name <- get + ~(ty, details, idinfo) <- lazyGet -- See Note [Lazy deserialization of IfaceId] return (IfaceId name ty details idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" - 2 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh + 2 -> do a1 <- getIfaceTopBndr + a2 <- get + a3 <- get + a4 <- get + a5 <- get + a6 <- get + a7 <- get + a8 <- get + a9 <- get return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8 a9) - 3 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh + 3 -> do a1 <- getIfaceTopBndr + a2 <- get + a3 <- get + a4 <- get + a5 <- get return (IfaceSynonym a1 a2 a3 a4 a5) - 4 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh + 4 -> do a1 <- getIfaceTopBndr + a2 <- get + a3 <- get + a4 <- get + a5 <- get + a6 <- get return (IfaceFamily a1 a2 a3 a4 a5 a6) - 5 -> do a1 <- get bh - a2 <- getIfaceTopBndr bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh + 5 -> do a1 <- get + a2 <- getIfaceTopBndr + a3 <- get + a4 <- get + a5 <- get + a6 <- get + a7 <- get + a8 <- get return (IfaceClass { ifName = a2, ifRoles = a3, @@ -1904,29 +1900,29 @@ instance Binary IfaceDecl where ifClassCtxt = a1, ifATs = a6, ifSigs = a7, - ifMinDef = a8 + ifMinDef = a8 }}) - 6 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh + 6 -> do a1 <- getIfaceTopBndr + a2 <- get + a3 <- get + a4 <- get return (IfaceAxiom a1 a2 a3 a4) - 7 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - a9 <- get bh - a10 <- get bh - a11 <- get bh + 7 -> do a1 <- getIfaceTopBndr + a2 <- get + a3 <- get + a4 <- get + a5 <- get + a6 <- get + a7 <- get + a8 <- get + a9 <- get + a10 <- get + a11 <- get return (IfacePatSyn a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) - 8 -> do a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh + 8 -> do a1 <- getIfaceTopBndr + a2 <- get + a3 <- get + a4 <- get return (IfaceClass { ifName = a1, ifRoles = a2, @@ -1961,462 +1957,462 @@ represent a small proportion of all declarations. -} instance Binary IfaceFamTyConFlav where - put_ bh IfaceDataFamilyTyCon = putByte bh 0 - put_ bh IfaceOpenSynFamilyTyCon = putByte bh 1 - put_ bh (IfaceClosedSynFamilyTyCon mb) = putByte bh 2 >> put_ bh mb - put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 3 - put_ _ IfaceBuiltInSynFamTyCon + put IfaceDataFamilyTyCon = putByte 0 + put IfaceOpenSynFamilyTyCon = putByte 1 + put (IfaceClosedSynFamilyTyCon mb) = putByte 2 >> put mb + put IfaceAbstractClosedSynFamilyTyCon = putByte 3 + put IfaceBuiltInSynFamTyCon = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty - get bh = do { h <- getByte bh - ; case h of - 0 -> return IfaceDataFamilyTyCon - 1 -> return IfaceOpenSynFamilyTyCon - 2 -> do { mb <- get bh - ; return (IfaceClosedSynFamilyTyCon mb) } - 3 -> return IfaceAbstractClosedSynFamilyTyCon - _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" - (ppr (fromIntegral h :: Int)) } + get = do { h <- getByte + ; case h of + 0 -> return IfaceDataFamilyTyCon + 1 -> return IfaceOpenSynFamilyTyCon + 2 -> do { mb <- get + ; return (IfaceClosedSynFamilyTyCon mb) } + 3 -> return IfaceAbstractClosedSynFamilyTyCon + _ -> pprPanic "Binary.get(IfaceFamTyConFlav): Invalid tag" + (ppr (fromIntegral h :: Int)) } instance Binary IfaceClassOp where - put_ bh (IfaceClassOp n ty def) = do - putIfaceTopBndr bh n - put_ bh ty - put_ bh def - get bh = do - n <- getIfaceTopBndr bh - ty <- get bh - def <- get bh + put (IfaceClassOp n ty def) = do + putIfaceTopBndr n + put ty + put def + get = do + n <- getIfaceTopBndr + ty <- get + def <- get return (IfaceClassOp n ty def) instance Binary IfaceAT where - put_ bh (IfaceAT dec defs) = do - put_ bh dec - put_ bh defs - get bh = do - dec <- get bh - defs <- get bh + put (IfaceAT dec defs) = do + put dec + put defs + get = do + dec <- get + defs <- get return (IfaceAT dec defs) instance Binary IfaceAxBranch where - put_ bh (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh + put (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) = do + put a1 + put a2 + put a3 + put a4 + put a5 + put a6 + put a7 + get = do + a1 <- get + a2 <- get + a3 <- get + a4 <- get + a5 <- get + a6 <- get + a7 <- get return (IfaceAxBranch a1 a2 a3 a4 a5 a6 a7) instance Binary IfaceConDecls where - put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon cs) = putByte bh 1 >> put_ bh cs - put_ bh (IfNewTyCon c) = putByte bh 2 >> put_ bh c - get bh = do - h <- getByte bh + put IfAbstractTyCon = putByte 0 + put (IfDataTyCon cs) = putByte 1 >> put cs + put (IfNewTyCon c) = putByte 2 >> put c + get = do + h <- getByte case h of 0 -> return IfAbstractTyCon - 1 -> liftM IfDataTyCon (get bh) - 2 -> liftM IfNewTyCon (get bh) + 1 -> liftM IfDataTyCon get + 2 -> liftM IfNewTyCon get _ -> error "Binary(IfaceConDecls).get: Invalid IfaceConDecls" instance Binary IfaceConDecl where - put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do - putIfaceTopBndr bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - put_ bh (length a9) - mapM_ (put_ bh) a9 - put_ bh a10 - put_ bh a11 - get bh = do - a1 <- getIfaceTopBndr bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh - n_fields <- get bh - a9 <- replicateM n_fields (get bh) - a10 <- get bh - a11 <- get bh + put (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) = do + putIfaceTopBndr a1 + put a2 + put a3 + put a4 + put a5 + put a6 + put a7 + put a8 + put (length a9) + mapM_ put a9 + put a10 + put a11 + get = do + a1 <- getIfaceTopBndr + a2 <- get + a3 <- get + a4 <- get + a5 <- get + a6 <- get + a7 <- get + a8 <- get + n_fields <- get + a9 <- replicateM n_fields get + a10 <- get + a11 <- get return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) instance Binary IfaceBang where - put_ bh IfNoBang = putByte bh 0 - put_ bh IfStrict = putByte bh 1 - put_ bh IfUnpack = putByte bh 2 - put_ bh (IfUnpackCo co) = putByte bh 3 >> put_ bh co + put IfNoBang = putByte 0 + put IfStrict = putByte 1 + put IfUnpack = putByte 2 + put (IfUnpackCo co) = putByte 3 >> put co - get bh = do - h <- getByte bh + get = do + h <- getByte case h of 0 -> do return IfNoBang 1 -> do return IfStrict 2 -> do return IfUnpack - _ -> do { a <- get bh; return (IfUnpackCo a) } + _ -> do { a <- get; return (IfUnpackCo a) } instance Binary IfaceSrcBang where - put_ bh (IfSrcBang a1 a2) = - do put_ bh a1 - put_ bh a2 + put (IfSrcBang a1 a2) = + do put a1 + put a2 - get bh = - do a1 <- get bh - a2 <- get bh + get = + do a1 <- get + a2 <- get return (IfSrcBang a1 a2) instance Binary IfaceClsInst where - put_ bh (IfaceClsInst cls tys dfun flag orph) = do - put_ bh cls - put_ bh tys - put_ bh dfun - put_ bh flag - put_ bh orph - get bh = do - cls <- get bh - tys <- get bh - dfun <- get bh - flag <- get bh - orph <- get bh + put (IfaceClsInst cls tys dfun flag orph) = do + put cls + put tys + put dfun + put flag + put orph + get = do + cls <- get + tys <- get + dfun <- get + flag <- get + orph <- get return (IfaceClsInst cls tys dfun flag orph) instance Binary IfaceFamInst where - put_ bh (IfaceFamInst fam tys name orph) = do - put_ bh fam - put_ bh tys - put_ bh name - put_ bh orph - get bh = do - fam <- get bh - tys <- get bh - name <- get bh - orph <- get bh + put (IfaceFamInst fam tys name orph) = do + put fam + put tys + put name + put orph + get = do + fam <- get + tys <- get + name <- get + orph <- get return (IfaceFamInst fam tys name orph) instance Binary IfaceRule where - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do - put_ bh a1 - put_ bh a2 - put_ bh a3 - put_ bh a4 - put_ bh a5 - put_ bh a6 - put_ bh a7 - put_ bh a8 - get bh = do - a1 <- get bh - a2 <- get bh - a3 <- get bh - a4 <- get bh - a5 <- get bh - a6 <- get bh - a7 <- get bh - a8 <- get bh + put (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do + put a1 + put a2 + put a3 + put a4 + put a5 + put a6 + put a7 + put a8 + get = do + a1 <- get + a2 <- get + a3 <- get + a4 <- get + a5 <- get + a6 <- get + a7 <- get + a8 <- get return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) instance Binary IfaceAnnotation where - put_ bh (IfaceAnnotation a1 a2) = do - put_ bh a1 - put_ bh a2 - get bh = do - a1 <- get bh - a2 <- get bh + put (IfaceAnnotation a1 a2) = do + put a1 + put a2 + get = do + a1 <- get + a2 <- get return (IfaceAnnotation a1 a2) instance Binary IfaceIdDetails where - put_ bh IfVanillaId = putByte bh 0 - put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b - put_ bh IfDFunId = putByte bh 2 - get bh = do - h <- getByte bh + put IfVanillaId = putByte 0 + put (IfRecSelId a b) = putByte 1 >> put a >> put b + put IfDFunId = putByte 2 + get = do + h <- getByte case h of 0 -> return IfVanillaId - 1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) } + 1 -> do { a <- get; b <- get; return (IfRecSelId a b) } _ -> return IfDFunId instance Binary IfaceIdInfo where - put_ bh NoInfo = putByte bh 0 - put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut + put NoInfo = putByte 0 + put (HasInfo i) = putByte 1 >> lazyPut i -- NB lazyPut - get bh = do - h <- getByte bh + get = do + h <- getByte case h of 0 -> return NoInfo - _ -> liftM HasInfo $ lazyGet bh -- NB lazyGet + _ -> liftM HasInfo $ lazyGet -- NB lazyGet instance Binary IfaceInfoItem where - put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa - put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab - put_ bh (HsUnfold lb ad) = putByte bh 2 >> put_ bh lb >> put_ bh ad - put_ bh (HsInline ad) = putByte bh 3 >> put_ bh ad - put_ bh HsNoCafRefs = putByte bh 4 - put_ bh HsLevity = putByte bh 5 - get bh = do - h <- getByte bh + put (HsArity aa) = putByte 0 >> put aa + put (HsStrictness ab) = putByte 1 >> put ab + put (HsUnfold lb ad) = putByte 2 >> put lb >> put ad + put (HsInline ad) = putByte 3 >> put ad + put HsNoCafRefs = putByte 4 + put HsLevity = putByte 5 + get = do + h <- getByte case h of - 0 -> liftM HsArity $ get bh - 1 -> liftM HsStrictness $ get bh - 2 -> do lb <- get bh - ad <- get bh + 0 -> liftM HsArity $ get + 1 -> liftM HsStrictness $ get + 2 -> do lb <- get + ad <- get return (HsUnfold lb ad) - 3 -> liftM HsInline $ get bh + 3 -> liftM HsInline $ get 4 -> return HsNoCafRefs _ -> return HsLevity instance Binary IfaceUnfolding where - 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 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfDFunUnfold as bs) = do - putByte bh 2 - put_ bh as - put_ bh bs - put_ bh (IfCompulsory e) = do - putByte bh 3 - put_ bh e - get bh = do - h <- getByte bh + put (IfCoreUnfold s e) = do + putByte 0 + put s + put e + put (IfInlineRule a b c d) = do + putByte 1 + put a + put b + put c + put d + put (IfDFunUnfold as bs) = do + putByte 2 + put as + put bs + put (IfCompulsory e) = do + putByte 3 + put e + get = do + h <- getByte case h of - 0 -> do s <- get bh - e <- get bh + 0 -> do s <- get + e <- get return (IfCoreUnfold s e) - 1 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh + 1 -> do a <- get + b <- get + c <- get + d <- get return (IfInlineRule a b c d) - 2 -> do as <- get bh - bs <- get bh + 2 -> do as <- get + bs <- get return (IfDFunUnfold as bs) - _ -> do e <- get bh + _ -> do e <- get return (IfCompulsory e) instance Binary IfaceExpr where - put_ bh (IfaceLcl aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceType ab) = do - putByte bh 1 - put_ bh ab - put_ bh (IfaceCo ab) = do - putByte bh 2 - put_ bh ab - put_ bh (IfaceTuple ac ad) = do - putByte bh 3 - put_ bh ac - put_ bh ad - put_ bh (IfaceLam (ae, os) af) = do - putByte bh 4 - put_ bh ae - put_ bh os - put_ bh af - put_ bh (IfaceApp ag ah) = do - putByte bh 5 - put_ bh ag - put_ bh ah - put_ bh (IfaceCase ai aj ak) = do - putByte bh 6 - put_ bh ai - put_ bh aj - put_ bh ak - put_ bh (IfaceLet al am) = do - putByte bh 7 - put_ bh al - put_ bh am - put_ bh (IfaceTick an ao) = do - putByte bh 8 - put_ bh an - put_ bh ao - put_ bh (IfaceLit ap) = do - putByte bh 9 - put_ bh ap - put_ bh (IfaceFCall as at) = do - putByte bh 10 - put_ bh as - put_ bh at - put_ bh (IfaceExt aa) = do - putByte bh 11 - put_ bh aa - put_ bh (IfaceCast ie ico) = do - putByte bh 12 - put_ bh ie - put_ bh ico - put_ bh (IfaceECase a b) = do - putByte bh 13 - put_ bh a - put_ bh b - get bh = do - h <- getByte bh + put (IfaceLcl aa) = do + putByte 0 + put aa + put (IfaceType ab) = do + putByte 1 + put ab + put (IfaceCo ab) = do + putByte 2 + put ab + put (IfaceTuple ac ad) = do + putByte 3 + put ac + put ad + put (IfaceLam (ae, os) af) = do + putByte 4 + put ae + put os + put af + put (IfaceApp ag ah) = do + putByte 5 + put ag + put ah + put (IfaceCase ai aj ak) = do + putByte 6 + put ai + put aj + put ak + put (IfaceLet al am) = do + putByte 7 + put al + put am + put (IfaceTick an ao) = do + putByte 8 + put an + put ao + put (IfaceLit ap) = do + putByte 9 + put ap + put (IfaceFCall as at) = do + putByte 10 + put as + put at + put (IfaceExt aa) = do + putByte 11 + put aa + put (IfaceCast ie ico) = do + putByte 12 + put ie + put ico + put (IfaceECase a b) = do + putByte 13 + put a + put b + get = do + h <- getByte case h of - 0 -> do aa <- get bh + 0 -> do aa <- get return (IfaceLcl aa) - 1 -> do ab <- get bh + 1 -> do ab <- get return (IfaceType ab) - 2 -> do ab <- get bh + 2 -> do ab <- get return (IfaceCo ab) - 3 -> do ac <- get bh - ad <- get bh + 3 -> do ac <- get + ad <- get return (IfaceTuple ac ad) - 4 -> do ae <- get bh - os <- get bh - af <- get bh + 4 -> do ae <- get + os <- get + af <- get return (IfaceLam (ae, os) af) - 5 -> do ag <- get bh - ah <- get bh + 5 -> do ag <- get + ah <- get return (IfaceApp ag ah) - 6 -> do ai <- get bh - aj <- get bh - ak <- get bh + 6 -> do ai <- get + aj <- get + ak <- get return (IfaceCase ai aj ak) - 7 -> do al <- get bh - am <- get bh + 7 -> do al <- get + am <- get return (IfaceLet al am) - 8 -> do an <- get bh - ao <- get bh + 8 -> do an <- get + ao <- get return (IfaceTick an ao) - 9 -> do ap <- get bh + 9 -> do ap <- get return (IfaceLit ap) - 10 -> do as <- get bh - at <- get bh + 10 -> do as <- get + at <- get return (IfaceFCall as at) - 11 -> do aa <- get bh + 11 -> do aa <- get return (IfaceExt aa) - 12 -> do ie <- get bh - ico <- get bh + 12 -> do ie <- get + ico <- get return (IfaceCast ie ico) - 13 -> do a <- get bh - b <- get bh + 13 -> do a <- get + b <- get return (IfaceECase a b) _ -> panic ("get IfaceExpr " ++ show h) instance Binary IfaceTickish where - put_ bh (IfaceHpcTick m ix) = do - putByte bh 0 - put_ bh m - put_ bh ix - put_ bh (IfaceSCC cc tick push) = do - putByte bh 1 - put_ bh cc - put_ bh tick - put_ bh push - put_ bh (IfaceSource src name) = do - putByte bh 2 - put_ bh (srcSpanFile src) - put_ bh (srcSpanStartLine src) - put_ bh (srcSpanStartCol src) - put_ bh (srcSpanEndLine src) - put_ bh (srcSpanEndCol src) - put_ bh name - - get bh = do - h <- getByte bh + put (IfaceHpcTick m ix) = do + putByte 0 + put m + put ix + put (IfaceSCC cc tick push) = do + putByte 1 + put cc + put tick + put push + put (IfaceSource src name) = do + putByte 2 + put (srcSpanFile src) + put (srcSpanStartLine src) + put (srcSpanStartCol src) + put (srcSpanEndLine src) + put (srcSpanEndCol src) + put name + + get = do + h <- getByte case h of - 0 -> do m <- get bh - ix <- get bh + 0 -> do m <- get + ix <- get return (IfaceHpcTick m ix) - 1 -> do cc <- get bh - tick <- get bh - push <- get bh + 1 -> do cc <- get + tick <- get + push <- get return (IfaceSCC cc tick push) - 2 -> do file <- get bh - sl <- get bh - sc <- get bh - el <- get bh - ec <- get bh + 2 -> do file <- get + sl <- get + sc <- get + el <- get + ec <- get let start = mkRealSrcLoc file sl sc end = mkRealSrcLoc file el ec - name <- get bh + name <- get return (IfaceSource (mkRealSrcSpan start end) name) _ -> panic ("get IfaceTickish " ++ show h) instance Binary IfaceConAlt where - put_ bh IfaceDefault = putByte bh 0 - put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa - put_ bh (IfaceLitAlt ac) = putByte bh 2 >> put_ bh ac - get bh = do - h <- getByte bh + put IfaceDefault = putByte 0 + put (IfaceDataAlt aa) = putByte 1 >> put aa + put (IfaceLitAlt ac) = putByte 2 >> put ac + get = do + h <- getByte case h of 0 -> return IfaceDefault - 1 -> liftM IfaceDataAlt $ get bh - _ -> liftM IfaceLitAlt $ get bh + 1 -> liftM IfaceDataAlt $ get + _ -> liftM IfaceLitAlt $ get instance Binary IfaceBinding where - put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab - put_ bh (IfaceRec ac) = putByte bh 1 >> put_ bh ac - get bh = do - h <- getByte bh + put (IfaceNonRec aa ab) = putByte 0 >> put aa >> put ab + put (IfaceRec ac) = putByte 1 >> put ac + get = do + h <- getByte case h of - 0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) } - _ -> do { ac <- get bh; return (IfaceRec ac) } + 0 -> do { aa <- get; ab <- get; return (IfaceNonRec aa ab) } + _ -> do { ac <- get; return (IfaceRec ac) } instance Binary IfaceLetBndr where - put_ bh (IfLetBndr a b c d) = do - put_ bh a - put_ bh b - put_ bh c - put_ bh d - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - return (IfLetBndr a b c d) + put (IfLetBndr a b c d) = do + put a + put b + put c + put d + get = do a <- get + b <- get + c <- get + d <- get + return (IfLetBndr a b c d) instance Binary IfaceJoinInfo where - put_ bh IfaceNotJoinPoint = putByte bh 0 - put_ bh (IfaceJoinPoint ar) = do - putByte bh 1 - put_ bh ar - get bh = do - h <- getByte bh + put IfaceNotJoinPoint = putByte 0 + put (IfaceJoinPoint ar) = do + putByte 1 + put ar + get = do + h <- getByte case h of 0 -> return IfaceNotJoinPoint - _ -> liftM IfaceJoinPoint $ get bh + _ -> liftM IfaceJoinPoint $ get instance Binary IfaceTyConParent where - put_ bh IfNoParent = putByte bh 0 - put_ bh (IfDataInstance ax pr ty) = do - putByte bh 1 - put_ bh ax - put_ bh pr - put_ bh ty - get bh = do - h <- getByte bh + put IfNoParent = putByte 0 + put (IfDataInstance ax pr ty) = do + putByte 1 + put ax + put pr + put ty + get = do + h <- getByte case h of 0 -> return IfNoParent _ -> do - ax <- get bh - pr <- get bh - ty <- get bh + ax <- get + pr <- get + ty <- get return $ IfDataInstance ax pr ty instance Binary IfaceCompleteMatch where - put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts - get bh = IfaceCompleteMatch <$> get bh <*> get bh + put (IfaceCompleteMatch cs ts) = put cs >> put ts + get = IfaceCompleteMatch <$> get <*> get {- diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index acf116169e..3d8ec367a1 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -783,27 +783,23 @@ pprIfaceTyConBinders suppress_sig = sep . map go ppr_bndr = pprIfaceTvBndr bndr suppress_sig instance Binary IfaceBndr where - put_ bh (IfaceIdBndr aa) = do - putByte bh 0 - put_ bh aa - put_ bh (IfaceTvBndr ab) = do - putByte bh 1 - put_ bh ab - get bh = do - h <- getByte bh + put (IfaceIdBndr aa) = do + putByte 0 + put aa + put (IfaceTvBndr ab) = do + putByte 1 + put ab + get = do + h <- getByte case h of - 0 -> do aa <- get bh - return (IfaceIdBndr aa) - _ -> do ab <- get bh - return (IfaceTvBndr ab) + 0 -> IfaceIdBndr <$> get + _ -> IfaceTvBndr <$> get instance Binary IfaceOneShot where - put_ bh IfaceNoOneShot = do - putByte bh 0 - put_ bh IfaceOneShot = do - putByte bh 1 - get bh = do - h <- getByte bh + put IfaceNoOneShot = putByte 0 + put IfaceOneShot = putByte 1 + get = do + h <- getByte case h of 0 -> do return IfaceNoOneShot _ -> do return IfaceOneShot @@ -1610,60 +1606,55 @@ instance Outputable IfaceCoercion where ppr = pprIfaceCoercion instance Binary IfaceTyCon where - put_ bh (IfaceTyCon n i) = put_ bh n >> put_ bh i - - get bh = do n <- get bh - i <- get bh - return (IfaceTyCon n i) + put (IfaceTyCon n i) = put n >> put i + get = IfaceTyCon <$> get <*> get instance Binary IfaceTyConSort where - put_ bh IfaceNormalTyCon = putByte bh 0 - put_ bh (IfaceTupleTyCon arity sort) = putByte bh 1 >> put_ bh arity >> put_ bh sort - put_ bh (IfaceSumTyCon arity) = putByte bh 2 >> put_ bh arity - put_ bh IfaceEqualityTyCon = putByte bh 3 + put IfaceNormalTyCon = putByte 0 + put (IfaceTupleTyCon arity sort) = putByte 1 >> put arity >> put sort + put (IfaceSumTyCon arity) = putByte 2 >> put arity + put IfaceEqualityTyCon = putByte 3 - get bh = do - n <- getByte bh + get = do + n <- getByte case n of 0 -> return IfaceNormalTyCon - 1 -> IfaceTupleTyCon <$> get bh <*> get bh - 2 -> IfaceSumTyCon <$> get bh + 1 -> IfaceTupleTyCon <$> get <*> get + 2 -> IfaceSumTyCon <$> get _ -> return IfaceEqualityTyCon instance Binary IfaceTyConInfo where - put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s + put (IfaceTyConInfo i s) = put i >> put s - get bh = IfaceTyConInfo <$> get bh <*> get bh + get = IfaceTyConInfo <$> get <*> get instance Outputable IfaceTyLit where ppr = pprIfaceTyLit instance Binary IfaceTyLit where - put_ bh (IfaceNumTyLit n) = putByte bh 1 >> put_ bh n - put_ bh (IfaceStrTyLit n) = putByte bh 2 >> put_ bh n + put (IfaceNumTyLit n) = putByte 1 >> put n + put (IfaceStrTyLit n) = putByte 2 >> put n - get bh = - do tag <- getByte bh + get = + do tag <- getByte case tag of - 1 -> do { n <- get bh - ; return (IfaceNumTyLit n) } - 2 -> do { n <- get bh - ; return (IfaceStrTyLit n) } + 1 -> IfaceNumTyLit <$> get + 2 -> IfaceStrTyLit <$> get _ -> panic ("get IfaceTyLit " ++ show tag) instance Binary IfaceAppArgs where - put_ bh tk = + put tk = case tk of - IA_Arg t a ts -> putByte bh 0 >> put_ bh t >> put_ bh a >> put_ bh ts - IA_Nil -> putByte bh 1 + IA_Arg t a ts -> putByte 0 >> put t >> put a >> put ts + IA_Nil -> putByte 1 - get bh = - do c <- getByte bh + get = + do c <- getByte case c of 0 -> do - t <- get bh - a <- get bh - ts <- get bh + t <- get + a <- get + ts <- get return $! IA_Arg t a ts 1 -> return IA_Nil _ -> panic ("get IfaceAppArgs " ++ show c) @@ -1721,246 +1712,246 @@ ppr_parend_preds :: [IfacePredType] -> SDoc ppr_parend_preds preds = parens (fsep (punctuate comma (map ppr preds))) instance Binary IfaceType where - put_ _ (IfaceFreeTyVar tv) + put (IfaceFreeTyVar tv) = pprPanic "Can't serialise IfaceFreeTyVar" (ppr tv) - put_ bh (IfaceForAllTy aa ab) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh (IfaceTyVar ad) = do - putByte bh 1 - put_ bh ad - put_ bh (IfaceAppTy ae af) = do - putByte bh 2 - put_ bh ae - put_ bh af - put_ bh (IfaceFunTy af ag ah) = do - putByte bh 3 - put_ bh af - put_ bh ag - put_ bh ah - put_ bh (IfaceTyConApp tc tys) - = do { putByte bh 5; put_ bh tc; put_ bh tys } - put_ bh (IfaceCastTy a b) - = do { putByte bh 6; put_ bh a; put_ bh b } - put_ bh (IfaceCoercionTy a) - = do { putByte bh 7; put_ bh a } - put_ bh (IfaceTupleTy s i tys) - = do { putByte bh 8; put_ bh s; put_ bh i; put_ bh tys } - put_ bh (IfaceLitTy n) - = do { putByte bh 9; put_ bh n } - - get bh = do - h <- getByte bh + put (IfaceForAllTy aa ab) = do + putByte 0 + put aa + put ab + put (IfaceTyVar ad) = do + putByte 1 + put ad + put (IfaceAppTy ae af) = do + putByte 2 + put ae + put af + put (IfaceFunTy af ag ah) = do + putByte 3 + put af + put ag + put ah + put (IfaceTyConApp tc tys) + = do { putByte 5; put tc; put tys } + put (IfaceCastTy a b) + = do { putByte 6; put a; put b } + put (IfaceCoercionTy a) + = do { putByte 7; put a } + put (IfaceTupleTy s i tys) + = do { putByte 8; put s; put i; put tys } + put (IfaceLitTy n) + = do { putByte 9; put n } + + get = do + h <- getByte case h of - 0 -> do aa <- get bh - ab <- get bh + 0 -> do aa <- get + ab <- get return (IfaceForAllTy aa ab) - 1 -> do ad <- get bh + 1 -> do ad <- get return (IfaceTyVar ad) - 2 -> do ae <- get bh - af <- get bh + 2 -> do ae <- get + af <- get return (IfaceAppTy ae af) - 3 -> do af <- get bh - ag <- get bh - ah <- get bh + 3 -> do af <- get + ag <- get + ah <- get return (IfaceFunTy af ag ah) - 5 -> do { tc <- get bh; tys <- get bh + 5 -> do { tc <- get; tys <- get ; return (IfaceTyConApp tc tys) } - 6 -> do { a <- get bh; b <- get bh + 6 -> do { a <- get; b <- get ; return (IfaceCastTy a b) } - 7 -> do { a <- get bh + 7 -> do { a <- get ; return (IfaceCoercionTy a) } - 8 -> do { s <- get bh; i <- get bh; tys <- get bh + 8 -> do { s <- get; i <- get; tys <- get ; return (IfaceTupleTy s i tys) } - _ -> do n <- get bh + _ -> do n <- get return (IfaceLitTy n) instance Binary IfaceMCoercion where - put_ bh IfaceMRefl = do - putByte bh 1 - put_ bh (IfaceMCo co) = do - putByte bh 2 - put_ bh co - - get bh = do - tag <- getByte bh + put IfaceMRefl = do + putByte 1 + put (IfaceMCo co) = do + putByte 2 + put co + + get = do + tag <- getByte case tag of 1 -> return IfaceMRefl - 2 -> do a <- get bh + 2 -> do a <- get return $ IfaceMCo a _ -> panic ("get IfaceMCoercion " ++ show tag) instance Binary IfaceCoercion where - put_ bh (IfaceReflCo a) = do - putByte bh 1 - put_ bh a - put_ bh (IfaceGReflCo a b c) = do - putByte bh 2 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceFunCo a b c) = do - putByte bh 3 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceTyConAppCo a b c) = do - putByte bh 4 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceAppCo a b) = do - putByte bh 5 - put_ bh a - put_ bh b - put_ bh (IfaceForAllCo a b c) = do - putByte bh 6 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceCoVarCo a) = do - putByte bh 7 - put_ bh a - put_ bh (IfaceAxiomInstCo a b c) = do - putByte bh 8 - put_ bh a - put_ bh b - put_ bh c - put_ bh (IfaceUnivCo a b c d) = do - putByte bh 9 - put_ bh a - put_ bh b - put_ bh c - put_ bh d - put_ bh (IfaceSymCo a) = do - putByte bh 10 - put_ bh a - put_ bh (IfaceTransCo a b) = do - putByte bh 11 - put_ bh a - put_ bh b - put_ bh (IfaceNthCo a b) = do - putByte bh 12 - put_ bh a - put_ bh b - put_ bh (IfaceLRCo a b) = do - putByte bh 13 - put_ bh a - put_ bh b - put_ bh (IfaceInstCo a b) = do - putByte bh 14 - put_ bh a - put_ bh b - put_ bh (IfaceKindCo a) = do - putByte bh 15 - put_ bh a - put_ bh (IfaceSubCo a) = do - putByte bh 16 - put_ bh a - put_ bh (IfaceAxiomRuleCo a b) = do - putByte bh 17 - put_ bh a - put_ bh b - put_ _ (IfaceFreeCoVar cv) - = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) - put_ _ (IfaceHoleCo cv) - = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) + put (IfaceReflCo a) = do + putByte 1 + put a + put (IfaceGReflCo a b c) = do + putByte 2 + put a + put b + put c + put (IfaceFunCo a b c) = do + putByte 3 + put a + put b + put c + put (IfaceTyConAppCo a b c) = do + putByte 4 + put a + put b + put c + put (IfaceAppCo a b) = do + putByte 5 + put a + put b + put (IfaceForAllCo a b c) = do + putByte 6 + put a + put b + put c + put (IfaceCoVarCo a) = do + putByte 7 + put a + put (IfaceAxiomInstCo a b c) = do + putByte 8 + put a + put b + put c + put (IfaceUnivCo a b c d) = do + putByte 9 + put a + put b + put c + put d + put (IfaceSymCo a) = do + putByte 10 + put a + put (IfaceTransCo a b) = do + putByte 11 + put a + put b + put (IfaceNthCo a b) = do + putByte 12 + put a + put b + put (IfaceLRCo a b) = do + putByte 13 + put a + put b + put (IfaceInstCo a b) = do + putByte 14 + put a + put b + put (IfaceKindCo a) = do + putByte 15 + put a + put (IfaceSubCo a) = do + putByte 16 + put a + put (IfaceAxiomRuleCo a b) = do + putByte 17 + put a + put b + put (IfaceFreeCoVar cv) + = pprPanic "Can't serialise IfaceFreeCoVar" (ppr cv) + put (IfaceHoleCo cv) + = pprPanic "Can't serialise IfaceHoleCo" (ppr cv) -- See Note [Holes in IfaceCoercion] - get bh = do - tag <- getByte bh + get = do + tag <- getByte case tag of - 1 -> do a <- get bh + 1 -> do a <- get return $ IfaceReflCo a - 2 -> do a <- get bh - b <- get bh - c <- get bh + 2 -> do a <- get + b <- get + c <- get return $ IfaceGReflCo a b c - 3 -> do a <- get bh - b <- get bh - c <- get bh + 3 -> do a <- get + b <- get + c <- get return $ IfaceFunCo a b c - 4 -> do a <- get bh - b <- get bh - c <- get bh + 4 -> do a <- get + b <- get + c <- get return $ IfaceTyConAppCo a b c - 5 -> do a <- get bh - b <- get bh + 5 -> do a <- get + b <- get return $ IfaceAppCo a b - 6 -> do a <- get bh - b <- get bh - c <- get bh + 6 -> do a <- get + b <- get + c <- get return $ IfaceForAllCo a b c - 7 -> do a <- get bh + 7 -> do a <- get return $ IfaceCoVarCo a - 8 -> do a <- get bh - b <- get bh - c <- get bh + 8 -> do a <- get + b <- get + c <- get return $ IfaceAxiomInstCo a b c - 9 -> do a <- get bh - b <- get bh - c <- get bh - d <- get bh + 9 -> do a <- get + b <- get + c <- get + d <- get return $ IfaceUnivCo a b c d - 10-> do a <- get bh + 10-> do a <- get return $ IfaceSymCo a - 11-> do a <- get bh - b <- get bh + 11-> do a <- get + b <- get return $ IfaceTransCo a b - 12-> do a <- get bh - b <- get bh + 12-> do a <- get + b <- get return $ IfaceNthCo a b - 13-> do a <- get bh - b <- get bh + 13-> do a <- get + b <- get return $ IfaceLRCo a b - 14-> do a <- get bh - b <- get bh + 14-> do a <- get + b <- get return $ IfaceInstCo a b - 15-> do a <- get bh + 15-> do a <- get return $ IfaceKindCo a - 16-> do a <- get bh + 16-> do a <- get return $ IfaceSubCo a - 17-> do a <- get bh - b <- get bh + 17-> do a <- get + b <- get return $ IfaceAxiomRuleCo a b _ -> panic ("get IfaceCoercion " ++ show tag) instance Binary IfaceUnivCoProv where - put_ bh IfaceUnsafeCoerceProv = putByte bh 1 - put_ bh (IfacePhantomProv a) = do - putByte bh 2 - put_ bh a - put_ bh (IfaceProofIrrelProv a) = do - putByte bh 3 - put_ bh a - put_ bh (IfacePluginProv a) = do - putByte bh 4 - put_ bh a - - get bh = do - tag <- getByte bh + put IfaceUnsafeCoerceProv = putByte 1 + put (IfacePhantomProv a) = do + putByte 2 + put a + put (IfaceProofIrrelProv a) = do + putByte 3 + put a + put (IfacePluginProv a) = do + putByte 4 + put a + + get = do + tag <- getByte case tag of 1 -> return $ IfaceUnsafeCoerceProv - 2 -> do a <- get bh + 2 -> do a <- get return $ IfacePhantomProv a - 3 -> do a <- get bh + 3 -> do a <- get return $ IfaceProofIrrelProv a - 4 -> do a <- get bh + 4 -> do a <- get return $ IfacePluginProv a _ -> panic ("get IfaceUnivCoProv " ++ show tag) instance Binary (DefMethSpec IfaceType) where - put_ bh VanillaDM = putByte bh 0 - put_ bh (GenericDM t) = putByte bh 1 >> put_ bh t - get bh = do - h <- getByte bh + put VanillaDM = putByte 0 + put (GenericDM t) = putByte 1 >> put t + get = do + h <- getByte case h of 0 -> return VanillaDM - _ -> do { t <- get bh; return (GenericDM t) } + _ -> do { t <- get; return (GenericDM t) } instance NFData IfaceType where rnf = \case diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index 296e72a814..eec71e0b29 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -105,6 +105,7 @@ import Util hiding ( eqListBy ) import FastString import Maybes import Binary +import Binary.Unsafe (ioP) import Fingerprint import Exception import UniqSet @@ -484,13 +485,13 @@ addFingerprints hsc_env iface0 new_decls -- change if the fingerprint for anything it refers to (transitively) -- changes. mk_put_name :: OccEnv (OccName,Fingerprint) - -> BinHandle -> Name -> IO () - mk_put_name local_env bh name - | isWiredInName name = putNameLiterally bh name + -> Name -> Put () + mk_put_name local_env name + | isWiredInName name = putNameLiterally name -- wired-in names don't have fingerprints | otherwise = ASSERT2( isExternalName name, ppr name ) - let hash | nameModule name /= semantic_mod = global_hash_fn name + let hash | nameModule name /= semantic_mod = global_hash_fn name -- Get it from the REAL interface!! -- This will trigger when we compile an hsig file -- and we know a backing impl for it. @@ -507,7 +508,7 @@ addFingerprints hsc_env iface0 new_decls -- pprTraces below, run the compile again, and inspect -- the output and the generated .hi file with -- --show-iface. - in hash >>= put_ bh + in ioP hash >>= put -- take a strongly-connected group of declarations and compute -- its fingerprint. @@ -911,27 +912,27 @@ ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vca -- This instance is used only to compute fingerprints instance Binary IfaceDeclExtras where - get _bh = panic "no get for IfaceDeclExtras" - put_ bh (IfaceIdExtras extras) = do - putByte bh 1; put_ bh extras - put_ bh (IfaceDataExtras fix insts anns cons) = do - putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons - put_ bh (IfaceClassExtras fix insts anns methods defms) = do - putByte bh 3 - put_ bh fix - put_ bh insts - put_ bh anns - put_ bh methods - put_ bh defms - put_ bh (IfaceSynonymExtras fix anns) = do - putByte bh 4; put_ bh fix; put_ bh anns - put_ bh (IfaceFamilyExtras fix finsts anns) = do - putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns - put_ bh IfaceOtherDeclExtras = putByte bh 6 + get = panic "no get for IfaceDeclExtras" + put (IfaceIdExtras extras) = do + putByte 1; put extras + put (IfaceDataExtras fix insts anns cons) = do + putByte 2; put fix; put insts; put anns; put cons + put (IfaceClassExtras fix insts anns methods defms) = do + putByte 3 + put fix + put insts + put anns + put methods + put defms + put (IfaceSynonymExtras fix anns) = do + putByte 4; put fix; put anns + put (IfaceFamilyExtras fix finsts anns) = do + putByte 5; put fix; put finsts; put anns + put IfaceOtherDeclExtras = putByte 6 instance Binary IfaceIdExtras where - get _bh = panic "no get for IfaceIdExtras" - put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns } + get = panic "no get for IfaceIdExtras" + put (IdExtras fix rules anns) = do { put fix; put rules; put anns } declExtras :: (OccName -> Maybe Fixity) -> (OccName -> [AnnPayload]) -- cgit v1.2.1 From e783e32cdb50eb9e8f2898d69398be06824d6ce4 Mon Sep 17 00:00:00 2001 From: Josh Meredith Date: Mon, 21 Oct 2019 01:36:20 +1100 Subject: Fix FastString put looping and get off by one error --- compiler/iface/BinFingerprint.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'compiler/iface') diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs index dfcc6cac4a..e1a0f8177f 100644 --- a/compiler/iface/BinFingerprint.hs +++ b/compiler/iface/BinFingerprint.hs @@ -38,7 +38,7 @@ computeFingerprint put_nonbinding_name a = do fingerprintBinMem bd where setUserData = - writeState put_nonbinding_name putNameLiterally putAFastString + writeState 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. -- cgit v1.2.1 From f6f2944f93234128d0d3db259d67a7dde838d0a6 Mon Sep 17 00:00:00 2001 From: Josh Meredith Date: Thu, 21 Nov 2019 19:17:53 +1100 Subject: Fix byte-for-byte compatibility with old binary implementation --- compiler/iface/BinIface.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'compiler/iface') diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index cfe3142bd3..b5f4162c87 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -131,7 +131,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do else do _ <- Binary.get :: Get Word64; return () -- Check the interface file version and ways. - check_ver <- get + check_ver <- get let our_ver = show hiVersion wantedGot "Version" our_ver check_ver text errorOnMismatch "mismatched interface file versions" our_ver check_ver -- cgit v1.2.1