diff options
36 files changed, 2920 insertions, 2835 deletions
diff --git a/compiler/GHC/Hs/Doc.hs b/compiler/GHC/Hs/Doc.hs index 18a820fa6e..4faacf26a0 100644 --- a/compiler/GHC/Hs/Doc.hs +++ b/compiler/GHC/Hs/Doc.hs @@ -58,8 +58,8 @@ newtype HsDocString = HsDocString ByteString type LHsDocString = Located HsDocString instance Binary HsDocString where - put_ bh (HsDocString bs) = put_ bh bs - get bh = HsDocString <$> get bh + put (HsDocString bs) = put bs + get = HsDocString <$> get instance Outputable HsDocString where ppr = doubleQuotes . text . unpackHDS @@ -118,10 +118,10 @@ concatDocs xs = newtype DeclDocMap = DeclDocMap (Map Name HsDocString) instance Binary DeclDocMap where - put_ bh (DeclDocMap m) = put_ bh (Map.toList m) + put (DeclDocMap m) = put (Map.toList m) -- We can't rely on a deterministic ordering of the `Name`s here. -- See the comments on `Name`'s `Ord` instance for context. - get bh = DeclDocMap . Map.fromList <$> get bh + get = DeclDocMap . Map.fromList <$> get instance Outputable DeclDocMap where ppr (DeclDocMap m) = vcat (map pprPair (Map.toAscList m)) @@ -135,10 +135,10 @@ emptyDeclDocMap = DeclDocMap Map.empty newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString)) instance Binary ArgDocMap where - put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m)) + put (ArgDocMap m) = put (Map.toList (Map.toAscList <$> m)) -- We can't rely on a deterministic ordering of the `Name`s here. -- See the comments on `Name`'s `Ord` instance for context. - get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh + get = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get instance Outputable ArgDocMap where ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m)) diff --git a/compiler/basicTypes/Avail.hs b/compiler/basicTypes/Avail.hs index 291c95abe8..9020a2b609 100644 --- a/compiler/basicTypes/Avail.hs +++ b/compiler/basicTypes/Avail.hs @@ -267,20 +267,16 @@ pprAvail (AvailTC n ns fs) , fsep (punctuate comma (map (ppr . flLabel) fs))]) instance Binary AvailInfo where - put_ bh (Avail aa) = do - putByte bh 0 - put_ bh aa - put_ bh (AvailTC ab ac ad) = do - putByte bh 1 - put_ bh ab - put_ bh ac - put_ bh ad - get bh = do - h <- getByte bh - case h of - 0 -> do aa <- get bh - return (Avail aa) - _ -> do ab <- get bh - ac <- get bh - ad <- get bh - return (AvailTC ab ac ad) + put (Avail aa) = do + putByte 0 + put aa + put (AvailTC ab ac ad) = do + putByte 1 + put ab + put ac + put ad + get = do + h <- getByte + case h of + 0 -> Avail <$> get + _ -> AvailTC <$> get <*> get <*> get diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 47eb7a838b..8541f71cea 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -828,24 +828,24 @@ instance Outputable StrictnessMark where ppr NotMarkedStrict = empty instance Binary SrcStrictness where - put_ bh SrcLazy = putByte bh 0 - put_ bh SrcStrict = putByte bh 1 - put_ bh NoSrcStrict = putByte bh 2 + put SrcLazy = putByte 0 + put SrcStrict = putByte 1 + put NoSrcStrict = putByte 2 - get bh = - do h <- getByte bh + get = + do h <- getByte case h of 0 -> return SrcLazy 1 -> return SrcStrict _ -> return NoSrcStrict instance Binary SrcUnpackedness where - put_ bh SrcNoUnpack = putByte bh 0 - put_ bh SrcUnpack = putByte bh 1 - put_ bh NoSrcUnpack = putByte bh 2 + put SrcNoUnpack = putByte 0 + put SrcUnpack = putByte 1 + put NoSrcUnpack = putByte 2 - get bh = - do h <- getByte bh + get = + do h <- getByte case h of 0 -> return SrcNoUnpack 1 -> return SrcUnpack diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index 19fbce3690..2f9a8a1c77 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -1978,126 +1978,124 @@ out how deeply we can unpack x, or that we do not have to pass y. -} instance Binary StrDmd where - put_ bh HyperStr = do putByte bh 0 - put_ bh HeadStr = do putByte bh 1 - put_ bh (SCall s) = do putByte bh 2 - put_ bh s - put_ bh (SProd sx) = do putByte bh 3 - put_ bh sx - get bh = do - h <- getByte bh + put HyperStr = do putByte 0 + put HeadStr = do putByte 1 + put (SCall s) = do putByte 2 + put s + put (SProd sx) = do putByte 3 + put sx + get = do + h <- getByte case h of 0 -> do return HyperStr 1 -> do return HeadStr - 2 -> do s <- get bh + 2 -> do s <- get return (SCall s) - _ -> do sx <- get bh + _ -> do sx <- get return (SProd sx) instance Binary ArgStr where - put_ bh Lazy = do - putByte bh 0 - put_ bh (Str s) = do - putByte bh 1 - put_ bh s - - get bh = do - h <- getByte bh + put Lazy = do + putByte 0 + put (Str s) = do + putByte 1 + put s + + get = do + h <- getByte case h of 0 -> return Lazy - _ -> do s <- get bh + _ -> do s <- get return $ Str s instance Binary Count where - put_ bh One = do putByte bh 0 - put_ bh Many = do putByte bh 1 + put One = do putByte 0 + put Many = do putByte 1 - get bh = do h <- getByte bh - case h of - 0 -> return One - _ -> return Many + get = do h <- getByte + case h of + 0 -> return One + _ -> return Many instance Binary ArgUse where - put_ bh Abs = do - putByte bh 0 - put_ bh (Use c u) = do - putByte bh 1 - put_ bh c - put_ bh u - - get bh = do - h <- getByte bh + put Abs = putByte 0 + put (Use c u) = do + putByte 1 + put c + put u + + get = do + h <- getByte case h of 0 -> return Abs - _ -> do c <- get bh - u <- get bh + _ -> do c <- get + u <- get return $ Use c u instance Binary UseDmd where - put_ bh Used = do - putByte bh 0 - put_ bh UHead = do - putByte bh 1 - put_ bh (UCall c u) = do - putByte bh 2 - put_ bh c - put_ bh u - put_ bh (UProd ux) = do - putByte bh 3 - put_ bh ux - - get bh = do - h <- getByte bh + put Used = do + putByte 0 + put UHead = do + putByte 1 + put (UCall c u) = do + putByte 2 + put c + put u + put (UProd ux) = do + putByte 3 + put ux + + get = do + h <- getByte case h of 0 -> return $ Used 1 -> return $ UHead - 2 -> do c <- get bh - u <- get bh + 2 -> do c <- get + u <- get return (UCall c u) - _ -> do ux <- get bh + _ -> do ux <- get return (UProd ux) instance (Binary s, Binary u) => Binary (JointDmd s u) where - put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y - get bh = do - x <- get bh - y <- get bh + put (JD { sd = x, ud = y }) = do put x; put y + get = do + x <- get + y <- get return $ JD { sd = x, ud = y } instance Binary StrictSig where - put_ bh (StrictSig aa) = do - put_ bh aa - get bh = do - aa <- get bh + put (StrictSig aa) = do + put aa + get = do + aa <- get return (StrictSig aa) instance Binary DmdType where -- Ignore DmdEnv when spitting out the DmdType - put_ bh (DmdType _ ds dr) - = do put_ bh ds - put_ bh dr - get bh - = do ds <- get bh - dr <- get bh + put (DmdType _ ds dr) + = do put ds + put dr + get = do ds <- get + dr <- get return (DmdType emptyDmdEnv ds dr) instance Binary DmdResult where - put_ bh (Dunno c) = do { putByte bh 0; put_ bh c } - put_ bh Diverges = putByte bh 1 + put (Dunno c) = do { putByte 0; put c } + put Diverges = putByte 1 - get bh = do { h <- getByte bh - ; case h of - 0 -> do { c <- get bh; return (Dunno c) } - _ -> return Diverges } + get = do { h <- getByte + ; case h of + 0 -> do { c <- get; return (Dunno c) } + _ -> return Diverges } instance Binary CPRResult where - put_ bh (RetSum n) = do { putByte bh 0; put_ bh n } - put_ bh RetProd = putByte bh 1 - put_ bh NoCPR = putByte bh 2 + put (RetSum n) = do { putByte 0; put n } + put RetProd = putByte 1 + put NoCPR = putByte 2 - get bh = do - h <- getByte bh + get = do + h <- getByte case h of - 0 -> do { n <- get bh; return (RetSum n) } + 0 -> do { n <- get; return (RetSum n) } 1 -> return RetProd _ -> return NoCPR diff --git a/compiler/basicTypes/FieldLabel.hs b/compiler/basicTypes/FieldLabel.hs index d73dbd3ad3..72b90ca063 100644 --- a/compiler/basicTypes/FieldLabel.hs +++ b/compiler/basicTypes/FieldLabel.hs @@ -105,15 +105,11 @@ instance Outputable a => Outputable (FieldLbl a) where ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl)) instance Binary a => Binary (FieldLbl a) where - put_ bh (FieldLabel aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - ab <- get bh - ac <- get bh - ad <- get bh - return (FieldLabel ab ac ad) + put (FieldLabel aa ab ac) = do + put aa + put ab + put ac + get = FieldLabel <$> get <*> get <*> get -- | Record selector OccNames are built from the underlying field name diff --git a/compiler/basicTypes/Literal.hs b/compiler/basicTypes/Literal.hs index 1e088a8d1a..0bfb1f1542 100644 --- a/compiler/basicTypes/Literal.hs +++ b/compiler/basicTypes/Literal.hs @@ -207,52 +207,52 @@ for more details. -} instance Binary LitNumType where - put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp)) - get bh = do - h <- getByte bh + put numTyp = putByte (fromIntegral (fromEnum numTyp)) + get = do + h <- getByte return (toEnum (fromIntegral h)) instance Binary Literal where - put_ bh (LitChar aa) = do putByte bh 0; put_ bh aa - put_ bh (LitString ab) = do putByte bh 1; put_ bh ab - put_ bh (LitNullAddr) = do putByte bh 2 - put_ bh (LitFloat ah) = do putByte bh 3; put_ bh ah - put_ bh (LitDouble ai) = do putByte bh 4; put_ bh ai - put_ bh (LitLabel aj mb fod) - = do putByte bh 5 - put_ bh aj - put_ bh mb - put_ bh fod - put_ bh (LitNumber nt i _) - = do putByte bh 6 - put_ bh nt - put_ bh i - put_ bh (LitRubbish) = do putByte bh 7 - get bh = do - h <- getByte bh + put (LitChar aa) = do putByte 0; put aa + put (LitString ab) = do putByte 1; put ab + put (LitNullAddr) = do putByte 2 + put (LitFloat ah) = do putByte 3; put ah + put (LitDouble ai) = do putByte 4; put ai + put (LitLabel aj mb fod) + = do putByte 5 + put aj + put mb + put fod + put (LitNumber nt i _) + = do putByte 6 + put nt + put i + put (LitRubbish) = do putByte 7 + get = do + h <- getByte case h of 0 -> do - aa <- get bh + aa <- get return (LitChar aa) 1 -> do - ab <- get bh + ab <- get return (LitString ab) 2 -> do return (LitNullAddr) 3 -> do - ah <- get bh + ah <- get return (LitFloat ah) 4 -> do - ai <- get bh + ai <- get return (LitDouble ai) 5 -> do - aj <- get bh - mb <- get bh - fod <- get bh + aj <- get + mb <- get + fod <- get return (LitLabel aj mb fod) 6 -> do - nt <- get bh - i <- get bh + nt <- get + i <- get -- Note [Types of LitNumbers] let t = case nt of LitNumInt -> intPrimTy diff --git a/compiler/basicTypes/Module.hs b/compiler/basicTypes/Module.hs index f5b65e7638..e4e4ce425d 100644 --- a/compiler/basicTypes/Module.hs +++ b/compiler/basicTypes/Module.hs @@ -339,8 +339,8 @@ instance Outputable ModuleName where ppr = pprModuleName instance Binary ModuleName where - put_ bh (ModuleName fs) = put_ bh fs - get bh = do fs <- get bh; return (ModuleName fs) + put (ModuleName fs) = put fs + get = ModuleName <$> get instance BinaryStringRep ModuleName where fromStringRep = mkModuleNameFS . mkFastStringByteString @@ -445,8 +445,8 @@ instance Outputable Module where ppr = pprModule instance Binary Module where - put_ bh (Module p n) = put_ bh p >> put_ bh n - get bh = do p <- get bh; n <- get bh; return (Module p n) + put (Module p n) = put p >> put n + get = Module <$> get <*> get instance Data Module where -- don't traverse? @@ -602,12 +602,12 @@ instance Ord IndefUnitId where u1 `compare` u2 = indefUnitIdFS u1 `compare` indefUnitIdFS u2 instance Binary IndefUnitId where - put_ bh indef = do - put_ bh (indefUnitIdComponentId indef) - put_ bh (indefUnitIdInsts indef) - get bh = do - cid <- get bh - insts <- get bh + put indef = do + put (indefUnitIdComponentId indef) + put (indefUnitIdInsts indef) + get = do + cid <- get + insts <- get let fs = hashUnitId cid insts return IndefUnitId { indefUnitIdComponentId = cid, @@ -678,8 +678,8 @@ newtype InstalledUnitId = } instance Binary InstalledUnitId where - put_ bh (InstalledUnitId fs) = put_ bh fs - get bh = do fs <- get bh; return (InstalledUnitId fs) + put (InstalledUnitId fs) = put fs + get = InstalledUnitId <$> get instance BinaryStringRep InstalledUnitId where fromStringRep bs = InstalledUnitId (mkFastStringByteString bs) @@ -772,8 +772,8 @@ instance Outputable DefUnitId where ppr (DefUnitId uid) = ppr uid instance Binary DefUnitId where - put_ bh (DefUnitId uid) = put_ bh uid - get bh = do uid <- get bh; return (DefUnitId uid) + put (DefUnitId uid) = put uid + get = DefUnitId <$> get -- | A map keyed off of 'InstalledModule' newtype InstalledModuleEnv elt = InstalledModuleEnv (Map InstalledModule elt) @@ -896,20 +896,20 @@ instance Outputable UnitId where -- Performance: would prefer to have a NameCache like thing instance Binary UnitId where - put_ bh (DefiniteUnitId def_uid) = do - putByte bh 0 - put_ bh def_uid - put_ bh (IndefiniteUnitId indef_uid) = do - putByte bh 1 - put_ bh indef_uid - get bh = do b <- getByte bh - case b of - 0 -> fmap DefiniteUnitId (get bh) - _ -> fmap IndefiniteUnitId (get bh) + put (DefiniteUnitId def_uid) = do + putByte 0 + put def_uid + put (IndefiniteUnitId indef_uid) = do + putByte 1 + put indef_uid + get = do b <- getByte + case b of + 0 -> DefiniteUnitId <$> get + _ -> IndefiniteUnitId <$> get instance Binary ComponentId where - put_ bh (ComponentId fs) = put_ bh fs - get bh = do { fs <- get bh; return (ComponentId fs) } + put (ComponentId fs) = put fs + get = ComponentId <$> get -- | Create a new simple unit identifier (no holes) from a 'ComponentId'. newSimpleUnitId :: ComponentId -> UnitId diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs index 221c76327e..7ec7839610 100644 --- a/compiler/basicTypes/Name.hs +++ b/compiler/basicTypes/Name.hs @@ -500,13 +500,8 @@ instance Data Name where -- 'IfaceSyn.putIfaceTopBndr' and 'IfaceSyn.getIfaceTopBndr' for serializing -- binding 'Name's. See 'UserData' for the rationale for this distinction. instance Binary Name where - put_ bh name = - case getUserData bh of - UserData{ ud_put_nonbinding_name = put_name } -> put_name bh name - - get bh = - case getUserData bh of - UserData { ud_get_name = get_name } -> get_name bh + put = putNonBindingName + get = getAName {- ************************************************************************ diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs index fa259725cf..abe1819dc0 100644 --- a/compiler/basicTypes/OccName.hs +++ b/compiler/basicTypes/OccName.hs @@ -899,27 +899,20 @@ tidyOccName env occ@(OccName occ_sp fs) -} instance Binary NameSpace where - put_ bh VarName = do - putByte bh 0 - put_ bh DataName = do - putByte bh 1 - put_ bh TvName = do - putByte bh 2 - put_ bh TcClsName = do - putByte bh 3 - get bh = do - h <- getByte bh - case h of - 0 -> do return VarName - 1 -> do return DataName - 2 -> do return TvName - _ -> do return TcClsName + put VarName = putByte 0 + put DataName = putByte 1 + put TvName = putByte 2 + put TcClsName = putByte 3 + get = do + h <- getByte + case h of + 0 -> return VarName + 1 -> return DataName + 2 -> return TvName + _ -> return TcClsName instance Binary OccName where - put_ bh (OccName aa ab) = do - put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (OccName aa ab) + put (OccName aa ab) = do + put aa + put ab + get = OccName <$> get <*> get diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs index f5142caf3c..2d7df86817 100644 --- a/compiler/basicTypes/Var.hs +++ b/compiler/basicTypes/Var.hs @@ -415,12 +415,12 @@ instance Outputable ArgFlag where ppr Inferred = text "[infrd]" instance Binary ArgFlag where - put_ bh Required = putByte bh 0 - put_ bh Specified = putByte bh 1 - put_ bh Inferred = putByte bh 2 + put Required = putByte 0 + put Specified = putByte 1 + put Inferred = putByte 2 - get bh = do - h <- getByte bh + get = do + h <- getByte case h of 0 -> return Required 1 -> return Specified @@ -444,11 +444,11 @@ instance Outputable AnonArgFlag where ppr InvisArg = text "[invis]" instance Binary AnonArgFlag where - put_ bh VisArg = putByte bh 0 - put_ bh InvisArg = putByte bh 1 + put VisArg = putByte 0 + put InvisArg = putByte 1 - get bh = do - h <- getByte bh + get = do + h <- getByte case h of 0 -> return VisArg _ -> return InvisArg @@ -564,9 +564,8 @@ instance Outputable tv => Outputable (VarBndr tv ArgFlag) where ppr (Bndr v Inferred) = braces (ppr v) instance (Binary tv, Binary vis) => Binary (VarBndr tv vis) where - put_ bh (Bndr tv vis) = do { put_ bh tv; put_ bh vis } - - get bh = do { tv <- get bh; vis <- get bh; return (Bndr tv vis) } + put (Bndr tv vis) = put tv >> put vis + get = Bndr <$> get <*> get instance NamedThing tv => NamedThing (VarBndr tv flag) where getName (Bndr tv _) = getName tv diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 919e2300be..e7ebaaea95 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -1241,16 +1241,16 @@ chooseOrphanAnchor local_names -- It's OK to use nonDetEltsUFM here, see comments above instance Binary IsOrphan where - put_ bh IsOrphan = putByte bh 0 - put_ bh (NotOrphan n) = do - putByte bh 1 - put_ bh n - get bh = do - h <- getByte bh + put IsOrphan = putByte 0 + put (NotOrphan n) = do + putByte 1 + put n + get = do + h <- getByte case h of 0 -> return IsOrphan _ -> do - n <- get bh + n <- get return $ NotOrphan n {- diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 58b840b6ad..de25e76745 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -75,7 +75,8 @@ Library ghc-boot == @ProjectVersionMunged@, ghc-boot-th == @ProjectVersionMunged@, ghc-heap == @ProjectVersionMunged@, - ghci == @ProjectVersionMunged@ + ghci == @ProjectVersionMunged@, + mtl >= 2.0 && < 3.0 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.7 @@ -545,6 +546,8 @@ Library Unify Bag Binary + Binary.Internal + Binary.Unsafe BooleanFormula BufWrite Digraph diff --git a/compiler/hieFile/HieBin.hs b/compiler/hieFile/HieBin.hs index 0a5d60df92..ee7bc08952 100644 --- a/compiler/hieFile/HieBin.hs +++ b/compiler/hieFile/HieBin.hs @@ -9,6 +9,7 @@ import GHC.Settings ( maybeRead ) import Config ( cProjectVersion ) import GhcPrelude import Binary +import Binary.Unsafe (ioP) import BinIface ( getDictFastString ) import FastMutInt import FastString ( FastString ) @@ -79,9 +80,6 @@ data HieDictionary = HieDictionary , hie_dict_map :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString } -initBinMemSize :: Int -initBinMemSize = 1024*1024 - -- | The header for HIE files - Capital ASCII letters "HIE". hieMagic :: [Word8] hieMagic = [72,73,69] @@ -92,75 +90,75 @@ hieMagicLen = length hieMagic ghcVersion :: ByteString ghcVersion = BSC.pack cProjectVersion -putBinLine :: BinHandle -> ByteString -> IO () -putBinLine bh xs = do - mapM_ (putByte bh) $ BS.unpack xs - putByte bh 10 -- newline char +putBinLine :: ByteString -> Put () +putBinLine xs = do + mapM_ putByte $ BS.unpack xs + putByte 10 -- newline char -- | Write a `HieFile` to the given `FilePath`, with a proper header and -- symbol tables for `Name`s and `FastString`s writeHieFile :: FilePath -> HieFile -> IO () writeHieFile hie_file_path hiefile = do - bh0 <- openBinMem initBinMemSize - - -- Write the header: hieHeader followed by the - -- hieVersion and the GHC version used to generate this file - mapM_ (putByte bh0) hieMagic - putBinLine bh0 $ BSC.pack $ show hieVersion - putBinLine bh0 $ ghcVersion - - -- remember where the dictionary pointer will go - dict_p_p <- tellBin bh0 - put_ bh0 dict_p_p - - -- remember where the symbol table pointer will go - symtab_p_p <- tellBin bh0 - put_ bh0 symtab_p_p - - -- Make some initial state - symtab_next <- newFastMutInt - writeFastMutInt symtab_next 0 - symtab_map <- newIORef emptyUFM - let hie_symtab = HieSymbolTable { - hie_symtab_next = symtab_next, - hie_symtab_map = symtab_map } - dict_next_ref <- newFastMutInt - writeFastMutInt dict_next_ref 0 - dict_map_ref <- newIORef emptyUFM - let hie_dict = HieDictionary { - hie_dict_next = dict_next_ref, - 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 + + bd <- runPutIO $ do + -- Write the header: hieHeader followed by the + -- hieVersion and the GHC version used to generate this file + mapM_ putByte hieMagic + putBinLine $ BSC.pack $ show hieVersion + putBinLine $ ghcVersion + + -- remember where the dictionary pointer will go + dict_p_p <- tellP + put dict_p_p + + -- remember where the symbol table pointer will go + symtab_p_p <- tellP + put symtab_p_p + + -- Make some intial state + symtab_next <- ioP $ newFastMutInt + ioP $ writeFastMutInt symtab_next 0 + symtab_map <- ioP $ newIORef emptyUFM + let hie_symtab = HieSymbolTable { + hie_symtab_next = symtab_next, + hie_symtab_map = symtab_map } + dict_next_ref <- ioP $ newFastMutInt + ioP $ writeFastMutInt dict_next_ref 0 + dict_map_ref <- ioP $ newIORef emptyUFM + let hie_dict = HieDictionary { + hie_dict_next = dict_next_ref, + hie_dict_map = dict_map_ref } + + writeState (putName hie_symtab) + (putName hie_symtab) + (putFastString hie_dict) $ do + + -- put the main thing + put hiefile + + -- write the symtab pointer at the front of the file + symtab_p <- tellP + putAt symtab_p_p symtab_p + seekP symtab_p + + -- write the symbol table itself + symtab_next' <- ioP $ readFastMutInt symtab_next + symtab_map' <- ioP $ readIORef symtab_map + putSymbolTable symtab_next' symtab_map' + + -- write the dictionary pointer at the front of the file + dict_p <- tellP + putAt dict_p_p dict_p + seekP dict_p + + -- write the dictionary itself + dict_next <- ioP $ readFastMutInt dict_next_ref + dict_map <- ioP $ readIORef dict_map_ref + putDictionary dict_next dict_map -- and send the result to the file createDirectoryIfMissing True (takeDirectory hie_file_path) - writeBinMem bh hie_file_path - return () + writeBinData bd hie_file_path data HieFileResult = HieFileResult @@ -177,58 +175,59 @@ type HieHeader = (Integer, ByteString) -- `Left` case returns the failing header versions. readHieFileWithVersion :: (HieHeader -> Bool) -> NameCache -> FilePath -> IO (Either HieHeader (HieFileResult, NameCache)) readHieFileWithVersion readVersion nc file = do - bh0 <- readBinMem file + bd <- readBinData file - (hieVersion, ghcVersion) <- readHieFileHeader file bh0 + runGetIO bd $ do + (hieVersion, ghcVersion) <- readHieFileHeader file - if readVersion (hieVersion, ghcVersion) - then do - (hieFile, nc') <- readHieFileContents bh0 nc - return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc') - else return $ Left (hieVersion, ghcVersion) + if readVersion (hieVersion, ghcVersion) + then do + (hieFile, nc') <- readHieFileContents nc + return $ Right (HieFileResult hieVersion ghcVersion hieFile, nc') + else return $ Left (hieVersion, ghcVersion) -- | Read a `HieFile` from a `FilePath`. Can use -- an existing `NameCache`. readHieFile :: NameCache -> FilePath -> IO (HieFileResult, NameCache) readHieFile nc file = do + bd <- readBinData file + + runGetIO bd $ do + (readHieVersion, ghcVersion) <- readHieFileHeader file + + -- Check if the versions match + when (readHieVersion /= hieVersion) $ + panic $ unwords ["readHieFile: hie file versions don't match for file:" + , file + , "Expected" + , show hieVersion + , "but got", show readHieVersion + ] + (hieFile, nc') <- readHieFileContents nc + return $ (HieFileResult hieVersion ghcVersion hieFile, nc') - bh0 <- readBinMem file - - (readHieVersion, ghcVersion) <- readHieFileHeader file bh0 - - -- Check if the versions match - when (readHieVersion /= hieVersion) $ - panic $ unwords ["readHieFile: hie file versions don't match for file:" - , file - , "Expected" - , show hieVersion - , "but got", show readHieVersion - ] - (hieFile, nc') <- readHieFileContents bh0 nc - return $ (HieFileResult hieVersion ghcVersion hieFile, nc') - -readBinLine :: BinHandle -> IO ByteString -readBinLine bh = BS.pack . reverse <$> loop [] +readBinLine :: Get ByteString +readBinLine = BS.pack . reverse <$> loop [] where loop acc = do - char <- get bh :: IO Word8 + char <- get :: Get Word8 if char == 10 -- ASCII newline '\n' then return acc else loop (char : acc) -readHieFileHeader :: FilePath -> BinHandle -> IO HieHeader -readHieFileHeader file bh0 = do +readHieFileHeader :: FilePath -> Get HieHeader +readHieFileHeader file = do -- Read the header - magic <- replicateM hieMagicLen (get bh0) - version <- BSC.unpack <$> readBinLine bh0 + magic <- replicateM hieMagicLen get + version <- BSC.unpack <$> readBinLine case maybeRead version of Nothing -> panic $ unwords ["readHieFileHeader: hieVersion isn't an Integer:" , show version ] Just readHieVersion -> do - ghcVersion <- readBinLine bh0 + ghcVersion <- readBinLine -- Check if the header is valid when (magic /= hieMagic) $ @@ -240,93 +239,89 @@ readHieFileHeader file bh0 = do ] return (readHieVersion, ghcVersion) -readHieFileContents :: BinHandle -> NameCache -> IO (HieFile, NameCache) -readHieFileContents bh0 nc = do +readHieFileContents :: NameCache -> Get (HieFile, NameCache) +readHieFileContents nc = do - dict <- get_dictionary bh0 + dict <- get_dictionary -- 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 (error "getSymtabName") (getDictFastString dict) $ do + (nc', symtab) <- get_symbol_table + + readState (getSymTabName symtab) (getDictFastString dict) $ do + -- load the actual data + hiefile <- get + return (hiefile, nc') + where - get_dictionary bin_handle = do - dict_p <- get bin_handle - data_p <- tellBin bin_handle - seekBin bin_handle dict_p - dict <- getDictionary bin_handle - seekBin bin_handle data_p + get_dictionary = do + dict_p <- get + data_p <- tellG + seekG dict_p + dict <- getDictionary + seekG data_p return dict - get_symbol_table bh1 = do - symtab_p <- get bh1 - data_p' <- tellBin bh1 - seekBin bh1 symtab_p - (nc', symtab) <- getSymbolTable bh1 nc - seekBin bh1 data_p' + get_symbol_table = do + symtab_p <- get + data_p' <- tellG + seekG symtab_p + (nc', symtab) <- getSymbolTable nc + seekG data_p' return (nc', symtab) -putFastString :: HieDictionary -> BinHandle -> FastString -> IO () +putFastString :: HieDictionary -> FastString -> Put () putFastString HieDictionary { hie_dict_next = j_r, - hie_dict_map = out_r} bh f + hie_dict_map = out_r} f = do - out <- readIORef out_r + out <- ioP $ readIORef out_r let unique = getUnique f case lookupUFM out unique of - Just (j, _) -> put_ bh (fromIntegral j :: Word32) + Just (j, _) -> put (fromIntegral j :: Word32) Nothing -> do - j <- readFastMutInt j_r - put_ bh (fromIntegral j :: Word32) - writeFastMutInt j_r (j + 1) - writeIORef out_r $! addToUFM out unique (j, f) - -putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO () -putSymbolTable bh next_off symtab = do - put_ bh next_off + j <- ioP $ readFastMutInt j_r + put (fromIntegral j :: Word32) + ioP $ writeFastMutInt j_r (j + 1) + ioP $ writeIORef out_r $! addToUFM out unique (j, f) + +putSymbolTable :: Int -> UniqFM (Int,HieName) -> Put () +putSymbolTable next_off symtab = do + put next_off let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab)) - mapM_ (putHieName bh) names + mapM_ putHieName names -getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable) -getSymbolTable bh namecache = do - sz <- get bh - od_names <- replicateM sz (getHieName bh) +getSymbolTable :: NameCache -> Get (NameCache, SymbolTable) +getSymbolTable namecache = do + sz <- get + od_names <- replicateM sz getHieName let arr = A.listArray (0,sz-1) names (namecache', names) = mapAccumR fromHieName namecache od_names return (namecache', arr) -getSymTabName :: SymbolTable -> BinHandle -> IO Name -getSymTabName st bh = do - i :: Word32 <- get bh +getSymTabName :: SymbolTable -> Get Name +getSymTabName st = do + i :: Word32 <- get return $ st A.! (fromIntegral i) -putName :: HieSymbolTable -> BinHandle -> Name -> IO () -putName (HieSymbolTable next ref) bh name = do - symmap <- readIORef ref +putName :: HieSymbolTable -> Name -> Put () +putName (HieSymbolTable next ref) name = do + symmap <- ioP $ readIORef ref case lookupUFM symmap name of Just (off, ExternalName mod occ (UnhelpfulSpan _)) | isGoodSrcSpan (nameSrcSpan name) -> do let hieName = ExternalName mod occ (nameSrcSpan name) - writeIORef ref $! addToUFM symmap name (off, hieName) - put_ bh (fromIntegral off :: Word32) + ioP $ writeIORef ref $! addToUFM symmap name (off, hieName) + put (fromIntegral off :: Word32) Just (off, LocalName _occ span) | notLocal (toHieName name) || nameSrcSpan name /= span -> do - writeIORef ref $! addToUFM symmap name (off, toHieName name) - put_ bh (fromIntegral off :: Word32) - Just (off, _) -> put_ bh (fromIntegral off :: Word32) + ioP $ writeIORef ref $! addToUFM symmap name (off, toHieName name) + put (fromIntegral off :: Word32) + Just (off, _) -> put (fromIntegral off :: Word32) Nothing -> do - off <- readFastMutInt next - writeFastMutInt next (off+1) - writeIORef ref $! addToUFM symmap name (off, toHieName name) - put_ bh (fromIntegral off :: Word32) + off <- ioP $ readFastMutInt next + ioP $ writeFastMutInt next (off+1) + ioP $ writeIORef ref $! addToUFM symmap name (off, toHieName name) + put (fromIntegral off :: Word32) where notLocal :: HieName -> Bool @@ -365,28 +360,28 @@ fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of -- ** Reading and writing `HieName`'s -putHieName :: BinHandle -> HieName -> IO () -putHieName bh (ExternalName mod occ span) = do - putByte bh 0 - put_ bh (mod, occ, span) -putHieName bh (LocalName occName span) = do - putByte bh 1 - put_ bh (occName, span) -putHieName bh (KnownKeyName uniq) = do - putByte bh 2 - put_ bh $ unpkUnique uniq - -getHieName :: BinHandle -> IO HieName -getHieName bh = do - t <- getByte bh +putHieName :: HieName -> Put () +putHieName (ExternalName mod occ span) = do + putByte 0 + put (mod, occ, span) +putHieName (LocalName occName span) = do + putByte 1 + put (occName, span) +putHieName (KnownKeyName uniq) = do + putByte 2 + put $ unpkUnique uniq + +getHieName :: Get HieName +getHieName = do + t <- getByte case t of 0 -> do - (modu, occ, span) <- get bh + (modu, occ, span) <- get return $ ExternalName modu occ span 1 -> do - (occ, span) <- get bh + (occ, span) <- get return $ LocalName occ span 2 -> do - (c,i) <- get bh + (c,i) <- get return $ KnownKeyName $ mkUnique c i _ -> panic "HieBin.getHieName: invalid tag" diff --git a/compiler/hieFile/HieTypes.hs b/compiler/hieFile/HieTypes.hs index 7f500a7453..19af3a88f0 100644 --- a/compiler/hieFile/HieTypes.hs +++ b/compiler/hieFile/HieTypes.hs @@ -75,21 +75,21 @@ data HieFile = HieFile -- ^ Raw bytes of the initial Haskell source } instance Binary HieFile where - put_ bh hf = do - put_ bh $ hie_hs_file hf - put_ bh $ hie_module hf - put_ bh $ hie_types hf - put_ bh $ hie_asts hf - put_ bh $ hie_exports hf - put_ bh $ hie_hs_src hf - - get bh = HieFile - <$> get bh - <*> get bh - <*> get bh - <*> get bh - <*> get bh - <*> get bh + put hf = do + put $ hie_hs_file hf + put $ hie_module hf + put $ hie_types hf + put $ hie_asts hf + put $ hie_exports hf + put $ hie_hs_src hf + + get = HieFile + <$> get + <*> get + <*> get + <*> get + <*> get + <*> get {- @@ -146,48 +146,48 @@ type HieTypeFlat = HieType TypeIndex newtype HieTypeFix = Roll (HieType (HieTypeFix)) instance Binary (HieType TypeIndex) where - put_ bh (HTyVarTy n) = do - putByte bh 0 - put_ bh n - put_ bh (HAppTy a b) = do - putByte bh 1 - put_ bh a - put_ bh b - put_ bh (HTyConApp n xs) = do - putByte bh 2 - put_ bh n - put_ bh xs - put_ bh (HForAllTy bndr a) = do - putByte bh 3 - put_ bh bndr - put_ bh a - put_ bh (HFunTy a b) = do - putByte bh 4 - put_ bh a - put_ bh b - put_ bh (HQualTy a b) = do - putByte bh 5 - put_ bh a - put_ bh b - put_ bh (HLitTy l) = do - putByte bh 6 - put_ bh l - put_ bh (HCastTy a) = do - putByte bh 7 - put_ bh a - put_ bh (HCoercionTy) = putByte bh 8 - - get bh = do - (t :: Word8) <- get bh + put (HTyVarTy n) = do + putByte 0 + put n + put (HAppTy a b) = do + putByte 1 + put a + put b + put (HTyConApp n xs) = do + putByte 2 + put n + put xs + put (HForAllTy bndr a) = do + putByte 3 + put bndr + put a + put (HFunTy a b) = do + putByte 4 + put a + put b + put (HQualTy a b) = do + putByte 5 + put a + put b + put (HLitTy l) = do + putByte 6 + put l + put (HCastTy a) = do + putByte 7 + put a + put (HCoercionTy) = putByte 8 + + get = do + (t :: Word8) <- get case t of - 0 -> HTyVarTy <$> get bh - 1 -> HAppTy <$> get bh <*> get bh - 2 -> HTyConApp <$> get bh <*> get bh - 3 -> HForAllTy <$> get bh <*> get bh - 4 -> HFunTy <$> get bh <*> get bh - 5 -> HQualTy <$> get bh <*> get bh - 6 -> HLitTy <$> get bh - 7 -> HCastTy <$> get bh + 0 -> HTyVarTy <$> get + 1 -> HAppTy <$> get <*> get + 2 -> HTyConApp <$> get <*> get + 3 -> HForAllTy <$> get <*> get + 4 -> HFunTy <$> get <*> get + 5 -> HQualTy <$> get <*> get + 6 -> HLitTy <$> get + 7 -> HCastTy <$> get 8 -> return HCoercionTy _ -> panic "Binary (HieArgs Int): invalid tag" @@ -198,8 +198,8 @@ newtype HieArgs a = HieArgs [(Bool,a)] deriving (Functor, Foldable, Traversable, Eq) instance Binary (HieArgs TypeIndex) where - put_ bh (HieArgs xs) = put_ bh xs - get bh = HieArgs <$> get bh + put (HieArgs xs) = put xs + get = HieArgs <$> get -- | Mapping from filepaths (represented using 'FastString') to the -- corresponding AST @@ -207,8 +207,8 @@ newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) } deriving (Functor, Foldable, Traversable) instance Binary (HieASTs TypeIndex) where - put_ bh asts = put_ bh $ M.toAscList $ getAsts asts - get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh) + put asts = put $ M.toAscList $ getAsts asts + get = HieASTs <$> fmap M.fromDistinctAscList get data HieAST a = @@ -219,15 +219,15 @@ data HieAST a = } deriving (Functor, Foldable, Traversable) instance Binary (HieAST TypeIndex) where - put_ bh ast = do - put_ bh $ nodeInfo ast - put_ bh $ nodeSpan ast - put_ bh $ nodeChildren ast + put ast = do + put $ nodeInfo ast + put $ nodeSpan ast + put $ nodeChildren ast - get bh = Node - <$> get bh - <*> get bh - <*> get bh + get = Node + <$> get + <*> get + <*> get -- | The information stored in one AST node. @@ -246,14 +246,14 @@ data NodeInfo a = NodeInfo } deriving (Functor, Foldable, Traversable) instance Binary (NodeInfo TypeIndex) where - put_ bh ni = do - put_ bh $ S.toAscList $ nodeAnnotations ni - put_ bh $ nodeType ni - put_ bh $ M.toList $ nodeIdentifiers ni - get bh = NodeInfo - <$> fmap (S.fromDistinctAscList) (get bh) - <*> get bh - <*> fmap (M.fromList) (get bh) + put ni = do + put $ S.toAscList $ nodeAnnotations ni + put $ nodeType ni + put $ M.toList $ nodeIdentifiers ni + get = NodeInfo + <$> fmap (S.fromDistinctAscList) get + <*> get + <*> fmap (M.fromList) get type Identifier = Either ModuleName Name @@ -279,12 +279,12 @@ instance Monoid (IdentifierDetails a) where mempty = IdentifierDetails Nothing S.empty instance Binary (IdentifierDetails TypeIndex) where - put_ bh dets = do - put_ bh $ identType dets - put_ bh $ S.toAscList $ identInfo dets - get bh = IdentifierDetails - <$> get bh - <*> fmap (S.fromDistinctAscList) (get bh) + put dets = do + put $ identType dets + put $ S.toAscList $ identInfo dets + get = IdentifierDetails + <$> get + <*> fmap (S.fromDistinctAscList) get -- | Different contexts under which identifiers exist @@ -336,50 +336,50 @@ instance Outputable ContextInfo where ppr = text . show instance Binary ContextInfo where - put_ bh Use = putByte bh 0 - put_ bh (IEThing t) = do - putByte bh 1 - put_ bh t - put_ bh TyDecl = putByte bh 2 - put_ bh (ValBind bt sc msp) = do - putByte bh 3 - put_ bh bt - put_ bh sc - put_ bh msp - put_ bh (PatternBind a b c) = do - putByte bh 4 - put_ bh a - put_ bh b - put_ bh c - put_ bh (ClassTyDecl sp) = do - putByte bh 5 - put_ bh sp - put_ bh (Decl a b) = do - putByte bh 6 - put_ bh a - put_ bh b - put_ bh (TyVarBind a b) = do - putByte bh 7 - put_ bh a - put_ bh b - put_ bh (RecField a b) = do - putByte bh 8 - put_ bh a - put_ bh b - put_ bh MatchBind = putByte bh 9 - - get bh = do - (t :: Word8) <- get bh + put Use = putByte 0 + put (IEThing t) = do + putByte 1 + put t + put TyDecl = putByte 2 + put (ValBind bt sc msp) = do + putByte 3 + put bt + put sc + put msp + put (PatternBind a b c) = do + putByte 4 + put a + put b + put c + put (ClassTyDecl sp) = do + putByte 5 + put sp + put (Decl a b) = do + putByte 6 + put a + put b + put (TyVarBind a b) = do + putByte 7 + put a + put b + put (RecField a b) = do + putByte 8 + put a + put b + put MatchBind = putByte 9 + + get = do + (t :: Word8) <- get case t of 0 -> return Use - 1 -> IEThing <$> get bh + 1 -> IEThing <$> get 2 -> return TyDecl - 3 -> ValBind <$> get bh <*> get bh <*> get bh - 4 -> PatternBind <$> get bh <*> get bh <*> get bh - 5 -> ClassTyDecl <$> get bh - 6 -> Decl <$> get bh <*> get bh - 7 -> TyVarBind <$> get bh <*> get bh - 8 -> RecField <$> get bh <*> get bh + 3 -> ValBind <$> get <*> get <*> get + 4 -> PatternBind <$> get <*> get <*> get + 5 -> ClassTyDecl <$> get + 6 -> Decl <$> get <*> get + 7 -> TyVarBind <$> get <*> get + 8 -> RecField <$> get <*> get 9 -> return MatchBind _ -> panic "Binary ContextInfo: invalid tag" @@ -393,8 +393,8 @@ data IEType deriving (Eq, Enum, Ord, Show) instance Binary IEType where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + put = putByte . fromIntegral . fromEnum + get = do x <- getByte; pure $! (toEnum (fromIntegral x)) data RecFieldContext @@ -405,8 +405,8 @@ data RecFieldContext deriving (Eq, Enum, Ord, Show) instance Binary RecFieldContext where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + put = putByte . fromIntegral . fromEnum + get = do x <- getByte; pure $! (toEnum (fromIntegral x)) data BindType @@ -415,8 +415,8 @@ data BindType deriving (Eq, Ord, Show, Enum) instance Binary BindType where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + put = putByte . fromIntegral . fromEnum + get = do x <- getByte; pure $! (toEnum (fromIntegral x)) data DeclType @@ -430,8 +430,8 @@ data DeclType deriving (Eq, Ord, Show, Enum) instance Binary DeclType where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x)) + put = putByte . fromIntegral . fromEnum + get = do x <- getByte; pure $! (toEnum (fromIntegral x)) data Scope @@ -446,17 +446,17 @@ instance Outputable Scope where ppr ModuleScope = text "ModuleScope" instance Binary Scope where - put_ bh NoScope = putByte bh 0 - put_ bh (LocalScope span) = do - putByte bh 1 - put_ bh span - put_ bh ModuleScope = putByte bh 2 - - get bh = do - (t :: Word8) <- get bh + put NoScope = putByte 0 + put (LocalScope span) = do + putByte 1 + put span + put ModuleScope = putByte 2 + + get = do + (t :: Word8) <- get case t of 0 -> return NoScope - 1 -> LocalScope <$> get bh + 1 -> LocalScope <$> get 2 -> return ModuleScope _ -> panic "Binary Scope: invalid tag" @@ -493,17 +493,17 @@ instance Show TyVarScope where show _ = error "UnresolvedScope" instance Binary TyVarScope where - put_ bh (ResolvedScopes xs) = do - putByte bh 0 - put_ bh xs - put_ bh (UnresolvedScope ns span) = do - putByte bh 1 - put_ bh ns - put_ bh span - - get bh = do - (t :: Word8) <- get bh + put (ResolvedScopes xs) = do + putByte 0 + put xs + put (UnresolvedScope ns span) = do + putByte 1 + put ns + put span + + get = do + (t :: Word8) <- get case t of - 0 -> ResolvedScopes <$> get bh - 1 -> UnresolvedScope <$> get bh <*> get bh + 0 -> ResolvedScopes <$> get + 1 -> UnresolvedScope <$> get <*> get _ -> panic "Binary TyVarScope: invalid tag" diff --git a/compiler/iface/BinFingerprint.hs b/compiler/iface/BinFingerprint.hs index 1eef4d67b4..e1a0f8177f 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 putFS -- | 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 faee723bd2..35be4b566b 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -46,6 +46,7 @@ import UniqFM import UniqSupply import Panic import Binary +import Binary.Unsafe (ioP, ioG) import SrcLoc import ErrUtils import FastMutInt @@ -103,174 +104,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 @@ -282,19 +275,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 @@ -323,10 +316,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] @@ -347,36 +340,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 @@ -399,8 +392,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, @@ -415,9 +408,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 92caee658b..fcd9ecb905 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 = @@ -72,8 +72,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 @@ -90,8 +90,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 78eb3ea271..82350195ee 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 db3157f39b..8aba2418f3 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 @@ -1627,60 +1623,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) @@ -1738,246 +1729,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 cb9e183c1a..eee8446e35 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 -- 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 -- 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. @@ -910,27 +911,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]) diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs index c282217d33..e4320b7cc9 100644 --- a/compiler/main/Annotations.hs +++ b/compiler/main/Annotations.hs @@ -67,17 +67,17 @@ instance Outputable name => Outputable (AnnTarget name) where ppr (ModuleTarget mod) = text "Module target" <+> ppr mod instance Binary name => Binary (AnnTarget name) where - put_ bh (NamedTarget a) = do - putByte bh 0 - put_ bh a - put_ bh (ModuleTarget a) = do - putByte bh 1 - put_ bh a - get bh = do - h <- getByte bh + put (NamedTarget a) = do + putByte 0 + put a + put (ModuleTarget a) = do + putByte 1 + put a + get = do + h <- getByte case h of - 0 -> liftM NamedTarget $ get bh - _ -> liftM ModuleTarget $ get bh + 0 -> liftM NamedTarget $ get + _ -> liftM ModuleTarget $ get instance Outputable Annotation where ppr ann = ppr (ann_target ann) diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs index 5c88faf895..51967a55f0 100644 --- a/compiler/main/DriverPhases.hs +++ b/compiler/main/DriverPhases.hs @@ -103,11 +103,11 @@ data HscSource -- Ord needed for the finite maps we build in CompManager instance Binary HscSource where - put_ bh HsSrcFile = putByte bh 0 - put_ bh HsBootFile = putByte bh 1 - put_ bh HsigFile = putByte bh 2 - get bh = do - h <- getByte bh + put HsSrcFile = putByte 0 + put HsBootFile = putByte 1 + put HsigFile = putByte 2 + get = do + h <- getByte case h of 0 -> return HsSrcFile 1 -> return HsBootFile diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index d1e0603088..0ce14369fd 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -1123,7 +1123,7 @@ renameFreeHoles fhs insts = | otherwise = emptyUniqDSet instance Binary ModIface where - put_ bh (ModIface { + put (ModIface { mi_module = mod, mi_sig_of = sig_of, mi_hsc_src = hsc_src, @@ -1157,70 +1157,70 @@ instance Binary ModIface where mi_exp_hash = exp_hash, mi_orphan_hash = orphan_hash }}) = do - put_ bh mod - put_ bh sig_of - put_ bh hsc_src - put_ bh iface_hash - put_ bh mod_hash - put_ bh flag_hash - put_ bh opt_hash - put_ bh hpc_hash - put_ bh plugin_hash - put_ bh orphan - put_ bh hasFamInsts - lazyPut bh deps - lazyPut bh usages - put_ bh exports - put_ bh exp_hash - put_ bh used_th - put_ bh fixities - lazyPut bh warns - lazyPut bh anns - put_ bh decls - put_ bh insts - put_ bh fam_insts - lazyPut bh rules - put_ bh orphan_hash - put_ bh hpc_info - put_ bh trust - put_ bh trust_pkg - put_ bh complete_sigs - lazyPut bh doc_hdr - lazyPut bh decl_docs - lazyPut bh arg_docs - - get bh = do - mod <- get bh - sig_of <- get bh - hsc_src <- get bh - iface_hash <- get bh - mod_hash <- get bh - flag_hash <- get bh - opt_hash <- get bh - hpc_hash <- get bh - plugin_hash <- get bh - orphan <- get bh - hasFamInsts <- get bh - deps <- lazyGet bh - usages <- {-# SCC "bin_usages" #-} lazyGet bh - exports <- {-# SCC "bin_exports" #-} get bh - exp_hash <- get bh - used_th <- get bh - fixities <- {-# SCC "bin_fixities" #-} get bh - warns <- {-# SCC "bin_warns" #-} lazyGet bh - anns <- {-# SCC "bin_anns" #-} lazyGet bh - decls <- {-# SCC "bin_tycldecls" #-} get bh - insts <- {-# SCC "bin_insts" #-} get bh - fam_insts <- {-# SCC "bin_fam_insts" #-} get bh - rules <- {-# SCC "bin_rules" #-} lazyGet bh - orphan_hash <- get bh - hpc_info <- get bh - trust <- get bh - trust_pkg <- get bh - complete_sigs <- get bh - doc_hdr <- lazyGet bh - decl_docs <- lazyGet bh - arg_docs <- lazyGet bh + put mod + put sig_of + put hsc_src + put iface_hash + put mod_hash + put flag_hash + put opt_hash + put hpc_hash + put plugin_hash + put orphan + put hasFamInsts + lazyPut deps + lazyPut usages + put exports + put exp_hash + put used_th + put fixities + lazyPut warns + lazyPut anns + put decls + put insts + put fam_insts + lazyPut rules + put orphan_hash + put hpc_info + put trust + put trust_pkg + put complete_sigs + lazyPut doc_hdr + lazyPut decl_docs + lazyPut arg_docs + + get = do + mod <- get + sig_of <- get + hsc_src <- get + iface_hash <- get + mod_hash <- get + flag_hash <- get + opt_hash <- get + hpc_hash <- get + plugin_hash <- get + orphan <- get + hasFamInsts <- get + deps <- lazyGet + usages <- {-# SCC "bin_usages" #-} lazyGet + exports <- {-# SCC "bin_exports" #-} get + exp_hash <- get + used_th <- get + fixities <- {-# SCC "bin_fixities" #-} get + warns <- {-# SCC "bin_warns" #-} lazyGet + anns <- {-# SCC "bin_anns" #-} lazyGet + decls <- {-# SCC "bin_tycldecls" #-} get + insts <- {-# SCC "bin_insts" #-} get + fam_insts <- {-# SCC "bin_fam_insts" #-} get + rules <- {-# SCC "bin_rules" #-} lazyGet + orphan_hash <- get + hpc_info <- get + trust <- get + trust_pkg <- get + complete_sigs <- get + doc_hdr <- lazyGet + decl_docs <- lazyGet + arg_docs <- lazyGet return (ModIface { mi_module = mod, mi_sig_of = sig_of, @@ -2364,21 +2364,21 @@ data Warnings deriving( Eq ) instance Binary Warnings where - put_ bh NoWarnings = putByte bh 0 - put_ bh (WarnAll t) = do - putByte bh 1 - put_ bh t - put_ bh (WarnSome ts) = do - putByte bh 2 - put_ bh ts - - get bh = do - h <- getByte bh + put NoWarnings = putByte 0 + put (WarnAll t) = do + putByte 1 + put t + put (WarnSome ts) = do + putByte 2 + put ts + + get = do + h <- getByte case h of 0 -> return NoWarnings - 1 -> do aa <- get bh + 1 -> do aa <- get return (WarnAll aa) - _ -> do aa <- get bh + _ -> do aa <- get return (WarnSome aa) -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface' @@ -2494,19 +2494,19 @@ data Dependencies -- See 'TcRnTypes.ImportAvails' for details on dependencies. instance Binary Dependencies where - put_ bh deps = do put_ bh (dep_mods deps) - put_ bh (dep_pkgs deps) - put_ bh (dep_orphs deps) - put_ bh (dep_finsts deps) - put_ bh (dep_plgins deps) - - get bh = do ms <- get bh - ps <- get bh - os <- get bh - fis <- get bh - pl <- get bh - return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, - dep_finsts = fis, dep_plgins = pl }) + put deps = do put (dep_mods deps) + put (dep_pkgs deps) + put (dep_orphs deps) + put (dep_finsts deps) + put (dep_plgins deps) + + get = do ms <- get + ps <- get + os <- get + fis <- get + pl <- get + return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, + dep_finsts = fis, dep_plgins = pl }) noDependencies :: Dependencies noDependencies = Deps [] [] [] [] [] @@ -2577,53 +2577,53 @@ data Usage -- depend on their export lists instance Binary Usage where - put_ bh usg@UsagePackageModule{} = do - putByte bh 0 - put_ bh (usg_mod usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageHomeModule{} = do - putByte bh 1 - put_ bh (usg_mod_name usg) - put_ bh (usg_mod_hash usg) - put_ bh (usg_exports usg) - put_ bh (usg_entities usg) - put_ bh (usg_safe usg) - - put_ bh usg@UsageFile{} = do - putByte bh 2 - put_ bh (usg_file_path usg) - put_ bh (usg_file_hash usg) - - put_ bh usg@UsageMergedRequirement{} = do - putByte bh 3 - put_ bh (usg_mod usg) - put_ bh (usg_mod_hash usg) - - get bh = do - h <- getByte bh + put usg@UsagePackageModule{} = do + putByte 0 + put (usg_mod usg) + put (usg_mod_hash usg) + put (usg_safe usg) + + put usg@UsageHomeModule{} = do + putByte 1 + put (usg_mod_name usg) + put (usg_mod_hash usg) + put (usg_exports usg) + put (usg_entities usg) + put (usg_safe usg) + + put usg@UsageFile{} = do + putByte 2 + put (usg_file_path usg) + put (usg_file_hash usg) + + put usg@UsageMergedRequirement{} = do + putByte 3 + put (usg_mod usg) + put (usg_mod_hash usg) + + get = do + h <- getByte case h of 0 -> do - nm <- get bh - mod <- get bh - safe <- get bh + nm <- get + mod <- get + safe <- get return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } 1 -> do - nm <- get bh - mod <- get bh - exps <- get bh - ents <- get bh - safe <- get bh + nm <- get + mod <- get + exps <- get + ents <- get + safe <- get return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, usg_exports = exps, usg_entities = ents, usg_safe = safe } 2 -> do - fp <- get bh - hash <- get bh + fp <- get + hash <- get return UsageFile { usg_file_path = fp, usg_file_hash = hash } 3 -> do - mod <- get bh - hash <- get bh + mod <- get + hash <- get return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash } i -> error ("Binary.get(Usage): " ++ show i) @@ -3086,8 +3086,8 @@ instance Outputable IfaceTrustInfo where ppr (TrustInfo Sf_SafeInferred) = text "safe-inferred" instance Binary IfaceTrustInfo where - put_ bh iftrust = putByte bh $ trustInfoToNum iftrust - get bh = getByte bh >>= (return . numToTrustInfo) + put iftrust = putByte $ trustInfoToNum iftrust + get = getByte >>= (return . numToTrustInfo) {- ************************************************************************ diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs index c143b1ed1e..09f6810502 100644 --- a/compiler/prelude/ForeignCall.hs +++ b/compiler/prelude/ForeignCall.hs @@ -254,95 +254,69 @@ instance Outputable CType where -} instance Binary ForeignCall where - put_ bh (CCall aa) = put_ bh aa - get bh = do aa <- get bh; return (CCall aa) + put (CCall aa) = put aa + get = CCall <$> get instance Binary Safety where - put_ bh PlaySafe = do - putByte bh 0 - put_ bh PlayInterruptible = do - putByte bh 1 - put_ bh PlayRisky = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return PlaySafe - 1 -> do return PlayInterruptible - _ -> do return PlayRisky + put PlaySafe = putByte 0 + put PlayInterruptible = putByte 1 + put PlayRisky = putByte 2 + get = do h <- getByte + case h of + 0 -> do return PlaySafe + 1 -> do return PlayInterruptible + _ -> do return PlayRisky instance Binary CExportSpec where - put_ bh (CExportStatic ss aa ab) = do - put_ bh ss - put_ bh aa - put_ bh ab - get bh = do - ss <- get bh - aa <- get bh - ab <- get bh - return (CExportStatic ss aa ab) + put (CExportStatic ss aa ab) = do + put ss + put aa + put ab + get = CExportStatic <$> get <*> get <*> get instance Binary CCallSpec where - put_ bh (CCallSpec aa ab ac) = do - put_ bh aa - put_ bh ab - put_ bh ac - get bh = do - aa <- get bh - ab <- get bh - ac <- get bh - return (CCallSpec aa ab ac) + put (CCallSpec aa ab ac) = do + put aa + put ab + put ac + get = CCallSpec <$> get <*> get <*> get instance Binary CCallTarget where - put_ bh (StaticTarget ss aa ab ac) = do - putByte bh 0 - put_ bh ss - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh DynamicTarget = do - putByte bh 1 - get bh = do - h <- getByte bh + put (StaticTarget ss aa ab ac) = do + putByte 0 + put ss + put aa + put ab + put ac + put DynamicTarget = do + putByte 1 + get = do + h <- getByte case h of - 0 -> do ss <- get bh - aa <- get bh - ab <- get bh - ac <- get bh - return (StaticTarget ss aa ab ac) - _ -> do return DynamicTarget + 0 -> StaticTarget <$> get <*> get <*> get <*> get + _ -> return DynamicTarget instance Binary CCallConv where - put_ bh CCallConv = do - putByte bh 0 - put_ bh StdCallConv = do - putByte bh 1 - put_ bh PrimCallConv = do - putByte bh 2 - put_ bh CApiConv = do - putByte bh 3 - put_ bh JavaScriptCallConv = do - putByte bh 4 - get bh = do - h <- getByte bh + put CCallConv = putByte 0 + put StdCallConv = putByte 1 + put PrimCallConv = putByte 2 + put CApiConv = putByte 3 + put JavaScriptCallConv = putByte 4 + get = do + h <- getByte case h of - 0 -> do return CCallConv - 1 -> do return StdCallConv - 2 -> do return PrimCallConv - 3 -> do return CApiConv - _ -> do return JavaScriptCallConv + 0 -> return CCallConv + 1 -> return StdCallConv + 2 -> return PrimCallConv + 3 -> return CApiConv + _ -> return JavaScriptCallConv instance Binary CType where - put_ bh (CType s mh fs) = do put_ bh s - put_ bh mh - put_ bh fs - get bh = do s <- get bh - mh <- get bh - fs <- get bh - return (CType s mh fs) + put (CType s mh fs) = do put s + put mh + put fs + get = CType <$> get <*> get <*> get instance Binary Header where - put_ bh (Header s h) = put_ bh s >> put_ bh h - get bh = do s <- get bh - h <- get bh - return (Header s h) + put (Header s h) = put s >> put h + get = Header <$> get <*> get diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs index 91a4ef0ec7..95e89aff3e 100644 --- a/compiler/profiling/CostCentre.hs +++ b/compiler/profiling/CostCentre.hs @@ -314,43 +314,32 @@ costCentreSrcSpan :: CostCentre -> SrcSpan costCentreSrcSpan = cc_loc instance Binary CCFlavour where - put_ bh CafCC = do - putByte bh 0 - put_ bh (ExprCC i) = do - putByte bh 1 - put_ bh i - put_ bh (DeclCC i) = do - putByte bh 2 - put_ bh i - put_ bh (HpcCC i) = do - putByte bh 3 - put_ bh i - get bh = do - h <- getByte bh + put CafCC = putByte 0 + put (ExprCC i) = putByte 1 >> put i + put (DeclCC i) = putByte 2 >> put i + put (HpcCC i) = putByte 3 >> put i + get = do + h <- getByte case h of 0 -> do return CafCC - 1 -> ExprCC <$> get bh - 2 -> DeclCC <$> get bh - _ -> HpcCC <$> get bh + 1 -> ExprCC <$> get + 2 -> DeclCC <$> get + _ -> HpcCC <$> get instance Binary CostCentre where - put_ bh (NormalCC aa ab ac _ad) = do - putByte bh 0 - put_ bh aa - put_ bh ab - put_ bh ac - put_ bh (AllCafsCC ae _af) = do - putByte bh 1 - put_ bh ae - get bh = do - h <- getByte bh + put (NormalCC aa ab ac _ad) = do + putByte 0 + put aa + put ab + put ac + put (AllCafsCC ae _af) = do + putByte 1 + put ae + get = do + h <- getByte case h of - 0 -> do aa <- get bh - ab <- get bh - ac <- get bh - return (NormalCC aa ab ac noSrcSpan) - _ -> do ae <- get bh - return (AllCafsCC ae noSrcSpan) + 0 -> NormalCC <$> get <*> get <*> get <*> return noSrcSpan + _ -> AllCafsCC <$> get <*> return noSrcSpan -- We ignore the SrcSpans in CostCentres when we serialise them, -- and set the SrcSpans to noSrcSpan when deserialising. This is diff --git a/compiler/profiling/CostCentreState.hs b/compiler/profiling/CostCentreState.hs index 0050c1d033..4a73032f98 100644 --- a/compiler/profiling/CostCentreState.hs +++ b/compiler/profiling/CostCentreState.hs @@ -22,7 +22,11 @@ newCostCentreState = CostCentreState emptyFsEnv -- | An index into a given cost centre module,name,flavour set newtype CostCentreIndex = CostCentreIndex { unCostCentreIndex :: Int } - deriving (Eq, Ord, Data, Binary) + deriving (Eq, Ord, Data) + +instance Binary CostCentreIndex where + put = put . unCostCentreIndex + get = CostCentreIndex <$> get -- | Get a new index for a given cost centre name. getCCIndex :: FastString diff --git a/compiler/types/CoAxiom.hs b/compiler/types/CoAxiom.hs index a814b6e021..75b3a9c923 100644 --- a/compiler/types/CoAxiom.hs +++ b/compiler/types/CoAxiom.hs @@ -494,15 +494,15 @@ instance Outputable Role where ppr = ftext . fsFromRole instance Binary Role where - put_ bh Nominal = putByte bh 1 - put_ bh Representational = putByte bh 2 - put_ bh Phantom = putByte bh 3 - - get bh = do tag <- getByte bh - case tag of 1 -> return Nominal - 2 -> return Representational - 3 -> return Phantom - _ -> panic ("get Role " ++ show tag) + put Nominal = putByte 1 + put Representational = putByte 2 + put Phantom = putByte 3 + + get = do tag <- getByte + case tag of 1 -> return Nominal + 2 -> return Representational + 3 -> return Phantom + _ -> panic ("get Role " ++ show tag) {- ************************************************************************ diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 7166f85c02..5afecc9021 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -654,13 +654,13 @@ instance Outputable tv => Outputable (VarBndr tv TyConBndrVis) where ppr_bi (NamedTCB Inferred) = text "inf" instance Binary TyConBndrVis where - put_ bh (AnonTCB af) = do { putByte bh 0; put_ bh af } - put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis } + put (AnonTCB af) = do { putByte 0; put af } + put (NamedTCB vis) = do { putByte 1; put vis } - get bh = do { h <- getByte bh - ; case h of - 0 -> do { af <- get bh; return (AnonTCB af) } - _ -> do { vis <- get bh; return (NamedTCB vis) } } + get = do h <- getByte + case h of + 0 -> AnonTCB <$> get + _ -> NamedTCB <$> get {- ********************************************************************* @@ -2669,14 +2669,13 @@ instance Data.Data TyCon where dataTypeOf _ = mkNoRepType "TyCon" instance Binary Injectivity where - put_ bh NotInjective = putByte bh 0 - put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs - - get bh = do { h <- getByte bh - ; case h of - 0 -> return NotInjective - _ -> do { xs <- get bh - ; return (Injective xs) } } + put NotInjective = putByte 0 + put (Injective xs) = putByte 1 >> put xs + + get = do h <- getByte + case h of + 0 -> return NotInjective + _ -> Injective <$> get {- ************************************************************************ diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 94a09288b5..51d7db1fdf 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -1,660 +1,361 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE BangPatterns #-} - {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} --- We always optimise this, otherwise performance of a non-optimised --- compiler is severely affected - --- --- (c) The University of Glasgow 2002-2006 --- --- Binary I/O library, with special tweaks for GHC --- --- Based on the nhc98 Binary library, which is copyright --- (c) Malcolm Wallace and Colin Runciman, University of York, 1998. --- Under the terms of the license for that software, we must tell you --- where you can obtain the original version of the Binary library, namely --- http://www.cs.york.ac.uk/fp/nhc98/ - -module Binary - ( {-type-} Bin, - {-class-} Binary(..), - {-type-} BinHandle, - SymbolTable, Dictionary, - - openBinMem, --- closeBin, - - seekBin, - seekBy, - tellBin, - castBin, - isEOFBin, - withBinBuffer, - - writeBinMem, - readBinMem, - - putAt, getAt, - - -- * For writing instances - putByte, - getByte, - - -- * Variable length encodings - putULEB128, - getULEB128, - putSLEB128, - getSLEB128, - - -- * Lazy Binary I/O - lazyGet, - lazyPut, - - -- * User data - UserData(..), getUserData, setUserData, - newReadState, newWriteState, - putDictionary, getDictionary, putFS, - ) where - -#include "HsVersions.h" +{-# LANGUAGE DeriveGeneric, DefaultSignatures, KindSignatures, FlexibleContexts, TypeOperators, StandaloneDeriving, DeriveAnyClass, BangPatterns, TypeApplications, AllowAmbiguousTypes, DataKinds, TypeFamilies, MagicHash, ScopedTypeVariables, UndecidableInstances, FlexibleInstances, CPP, MultiWayIf, PolyKinds #-} -import GhcPrelude +module Binary ( -import {-# SOURCE #-} Name (Name) -import FastString -import PlainPanic -import UniqFM -import FastMutInt -import Fingerprint -import BasicTypes -import SrcLoc + Binary(..), + + putAt, getAt, + putTo, getFrom, + lazyPut, lazyGet, + + encode, decode, + + module Binary.Internal, + +) where + +import Binary.Internal + +import Data.Char import Foreign +import GHC.Generics + +import BasicTypes import Data.Array -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import Data.IORef -import Data.Char ( ord, chr ) +import Data.Kind (Type) import Data.Time -import Data.List (unfoldr) +import SrcLoc +import Fingerprint +import GHC.Serialized import Type.Reflection import Type.Reflection.Unsafe -import Data.Kind (Type) -import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) -import Control.Monad ( when, (<$!>), unless ) -import System.IO as IO -import System.IO.Unsafe ( unsafeInterleaveIO ) -import System.IO.Error ( mkIOError, eofErrorType ) -import GHC.Real ( Ratio(..) ) -import GHC.Serialized +import GHC.Real (Ratio(..)) -type BinArray = ForeignPtr Word8 +import Control.Monad +import Data.List ---------------------------------------------------------------- --- BinHandle ---------------------------------------------------------------- +import GhcPrelude +import FastString +import PlainPanic -data BinHandle - = BinMem { -- binary data stored in an unboxed array - bh_usr :: UserData, -- sigh, need parameterized modules :-) - _off_r :: !FastMutInt, -- the current offset - _sz_r :: !FastMutInt, -- size of the array (cached) - _arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) - } - -- XXX: should really store a "high water mark" for dumping out - -- the binary data to a file. +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy -getUserData :: BinHandle -> UserData -getUserData bh = bh_usr bh +import GHC.TypeLits +import GHC.Exts -setUserData :: BinHandle -> UserData -> BinHandle -setUserData bh us = bh { bh_usr = us } +-- ----------------------------------------------------------------------------- +-- Class +-- ----------------------------------------------------------------------------- --- | Get access to the underlying buffer. --- --- It is quite important that no references to the 'ByteString' leak out of the --- continuation lest terrible things happen. -withBinBuffer :: BinHandle -> (ByteString -> IO a) -> IO a -withBinBuffer (BinMem _ ix_r _ arr_r) action = do - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \ptr -> - BS.unsafePackCStringLen (castPtr ptr, ix) >>= action +class Binary a where + put :: a -> Put () + get :: Get a + default put :: (Generic a, GBinary (Rep a)) => a -> Put () + put = gput . from ---------------------------------------------------------------- --- Bin ---------------------------------------------------------------- + default get :: (Generic a, GBinary (Rep a)) => Get a + get = to <$> gget -newtype Bin a = BinPtr Int - deriving (Eq, Ord, Show, Bounded) +-- ----------------------------------------------------------------------------- +-- Convenience functions +-- ----------------------------------------------------------------------------- -castBin :: Bin a -> Bin b -castBin (BinPtr i) = BinPtr i +encode :: Binary a => a -> BinData +encode = runPut . put + +decode :: Binary a => BinData -> a +decode bd = runGet bd get + +-- Put the argument at the specified pointer, leaving the current index +-- at the location after that. +putAt :: Binary a => Bin a -> a -> Put () +putAt ptr x = seekP ptr >> put x + +-- Get data from the specified pointer, leaving the current index at the +-- location after that. +getAt :: Binary a => Bin a -> Get a +getAt ptr = seekG ptr >> get + +-- Put the argument at the specified pointer, and return to the current +-- location afterwards. +putTo :: Binary a => Bin a -> a -> Put () +putTo ptr x = do + here <- tellP + seekP ptr + put x + seekP here + +-- Get data from the specified pointer, and return to the current location +-- afterwards. +getFrom :: Binary a => Bin a -> Get a +getFrom ptr = do + here <- tellG + seekG ptr + x <- get + seekG here + return x ---------------------------------------------------------------- --- class Binary ---------------------------------------------------------------- +-- ----------------------------------------------------------------------------- +-- Lazy reading and writing +-- ----------------------------------------------------------------------------- --- | Do not rely on instance sizes for general types, --- we use variable length encoding for many of them. -class Binary a where - put_ :: BinHandle -> a -> IO () - put :: BinHandle -> a -> IO (Bin a) - get :: BinHandle -> IO a - - -- define one of put_, put. Use of put_ is recommended because it - -- is more likely that tail-calls can kick in, and we rarely need the - -- position return value. - put_ bh a = do _ <- put bh a; return () - put bh a = do p <- tellBin bh; put_ bh a; return p - -putAt :: Binary a => BinHandle -> Bin a -> a -> IO () -putAt bh p x = do seekBin bh p; put_ bh x; return () - -getAt :: Binary a => BinHandle -> Bin a -> IO a -getAt bh p = do seekBin bh p; get bh - -openBinMem :: Int -> IO BinHandle -openBinMem size - | size <= 0 = error "Data.Binary.openBinMem: size must be >= 0" - | otherwise = do - arr <- mallocForeignPtrBytes size - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r size - return (BinMem noUserData ix_r sz_r arr_r) - -tellBin :: BinHandle -> IO (Bin a) -tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix) - -seekBin :: BinHandle -> Bin a -> IO () -seekBin h@(BinMem _ ix_r sz_r _) (BinPtr !p) = do - sz <- readFastMutInt sz_r - if (p >= sz) - then do expandBin h p; writeFastMutInt ix_r p - else writeFastMutInt ix_r p - -seekBy :: BinHandle -> Int -> IO () -seekBy h@(BinMem _ ix_r sz_r _) !off = do - sz <- readFastMutInt sz_r - ix <- readFastMutInt ix_r - let ix' = ix + off - if (ix' >= sz) - then do expandBin h ix'; writeFastMutInt ix_r ix' - else writeFastMutInt ix_r ix' - -isEOFBin :: BinHandle -> IO Bool -isEOFBin (BinMem _ ix_r sz_r _) = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - return (ix >= sz) - -writeBinMem :: BinHandle -> FilePath -> IO () -writeBinMem (BinMem _ ix_r _ arr_r) fn = do - h <- openBinaryFile fn WriteMode - arr <- readIORef arr_r - ix <- readFastMutInt ix_r - withForeignPtr arr $ \p -> hPutBuf h p ix - hClose h - -readBinMem :: FilePath -> IO BinHandle --- Return a BinHandle with a totally undefined State -readBinMem filename = do - h <- openBinaryFile filename ReadMode - filesize' <- hFileSize h - let filesize = fromIntegral filesize' - arr <- mallocForeignPtrBytes filesize - count <- withForeignPtr arr $ \p -> hGetBuf h p filesize - when (count /= filesize) $ - error ("Binary.readBinMem: only read " ++ show count ++ " bytes") - hClose h - arr_r <- newIORef arr - ix_r <- newFastMutInt - writeFastMutInt ix_r 0 - sz_r <- newFastMutInt - writeFastMutInt sz_r filesize - return (BinMem noUserData ix_r sz_r arr_r) - --- expand the size of the array to include a specified offset -expandBin :: BinHandle -> Int -> IO () -expandBin (BinMem _ _ sz_r arr_r) !off = do - !sz <- readFastMutInt sz_r - let !sz' = getSize sz - arr <- readIORef arr_r - arr' <- mallocForeignPtrBytes sz' - withForeignPtr arr $ \old -> - withForeignPtr arr' $ \new -> - copyBytes new old sz - writeFastMutInt sz_r sz' - writeIORef arr_r arr' - where - getSize :: Int -> Int - getSize !sz - | sz > off - = sz - | otherwise - = getSize (sz * 2) +lazyPut :: Binary a => a -> Put () +lazyPut a = do + p_a <- tellP + put p_a + put a + q <- tellP + putAt p_a q + seekP q + +lazyGet :: Binary a => Get a +lazyGet = do + p <- get + p_a <- tellG + a <- getSlice p . interleaveG $ getAt p_a + seekG p + return a -- ----------------------------------------------------------------------------- --- Low-level reading/writing of bytes - --- | Takes a size and action writing up to @size@ bytes. --- After the action has run advance the index to the buffer --- by size bytes. -putPrim :: BinHandle -> Int -> (Ptr Word8 -> IO ()) -> IO () -putPrim h@(BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - expandBin h (ix + size) - arr <- readIORef arr_r - withForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - --- -- | Similar to putPrim but advances the index by the actual number of --- -- bytes written. --- putPrimMax :: BinHandle -> Int -> (Ptr Word8 -> IO Int) -> IO () --- putPrimMax h@(BinMem _ ix_r sz_r arr_r) size f = do --- ix <- readFastMutInt ix_r --- sz <- readFastMutInt sz_r --- when (ix + size > sz) $ --- expandBin h (ix + size) --- arr <- readIORef arr_r --- written <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) --- writeFastMutInt ix_r (ix + written) - -getPrim :: BinHandle -> Int -> (Ptr Word8 -> IO a) -> IO a -getPrim (BinMem _ ix_r sz_r arr_r) size f = do - ix <- readFastMutInt ix_r - sz <- readFastMutInt sz_r - when (ix + size > sz) $ - ioError (mkIOError eofErrorType "Data.Binary.getPrim" Nothing Nothing) - arr <- readIORef arr_r - w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix) - writeFastMutInt ix_r (ix + size) - return w - -putWord8 :: BinHandle -> Word8 -> IO () -putWord8 h !w = putPrim h 1 (\op -> poke op w) - -getWord8 :: BinHandle -> IO Word8 -getWord8 h = getPrim h 1 peek - --- putWord16 :: BinHandle -> Word16 -> IO () --- putWord16 h w = putPrim h 2 (\op -> do --- pokeElemOff op 0 (fromIntegral (w `shiftR` 8)) --- pokeElemOff op 1 (fromIntegral (w .&. 0xFF)) --- ) - --- getWord16 :: BinHandle -> IO Word16 --- getWord16 h = getPrim h 2 (\op -> do --- w0 <- fromIntegral <$> peekElemOff op 0 --- w1 <- fromIntegral <$> peekElemOff op 1 --- return $! w0 `shiftL` 8 .|. w1 --- ) - -putWord32 :: BinHandle -> Word32 -> IO () -putWord32 h w = putPrim h 4 (\op -> do - pokeElemOff op 0 (fromIntegral (w `shiftR` 24)) - pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) - pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) - pokeElemOff op 3 (fromIntegral (w .&. 0xFF)) - ) - -getWord32 :: BinHandle -> IO Word32 -getWord32 h = getPrim h 4 (\op -> do - w0 <- fromIntegral <$> peekElemOff op 0 - w1 <- fromIntegral <$> peekElemOff op 1 - w2 <- fromIntegral <$> peekElemOff op 2 - w3 <- fromIntegral <$> peekElemOff op 3 - - return $! (w0 `shiftL` 24) .|. - (w1 `shiftL` 16) .|. - (w2 `shiftL` 8) .|. - w3 - ) - --- putWord64 :: BinHandle -> Word64 -> IO () --- putWord64 h w = putPrim h 8 (\op -> do --- pokeElemOff op 0 (fromIntegral (w `shiftR` 56)) --- pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF)) --- pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF)) --- pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF)) --- pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF)) --- pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF)) --- pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF)) --- pokeElemOff op 7 (fromIntegral (w .&. 0xFF)) --- ) - --- getWord64 :: BinHandle -> IO Word64 --- getWord64 h = getPrim h 8 (\op -> do --- w0 <- fromIntegral <$> peekElemOff op 0 --- w1 <- fromIntegral <$> peekElemOff op 1 --- w2 <- fromIntegral <$> peekElemOff op 2 --- w3 <- fromIntegral <$> peekElemOff op 3 --- w4 <- fromIntegral <$> peekElemOff op 4 --- w5 <- fromIntegral <$> peekElemOff op 5 --- w6 <- fromIntegral <$> peekElemOff op 6 --- w7 <- fromIntegral <$> peekElemOff op 7 - --- return $! (w0 `shiftL` 56) .|. --- (w1 `shiftL` 48) .|. --- (w2 `shiftL` 40) .|. --- (w3 `shiftL` 32) .|. --- (w4 `shiftL` 24) .|. --- (w5 `shiftL` 16) .|. --- (w6 `shiftL` 8) .|. --- w7 --- ) - -putByte :: BinHandle -> Word8 -> IO () -putByte bh !w = putWord8 bh w - -getByte :: BinHandle -> IO Word8 -getByte h = getWord8 h - +-- Generics -- ----------------------------------------------------------------------------- --- Encode numbers in LEB128 encoding. --- Requires one byte of space per 7 bits of data. --- --- There are signed and unsigned variants. --- Do NOT use the unsigned one for signed values, at worst it will --- result in wrong results, at best it will lead to bad performance --- when coercing negative values to an unsigned type. --- --- We mark them as SPECIALIZE as it's extremely critical that they get specialized --- to their specific types. --- --- TODO: Each use of putByte performs a bounds check, --- we should use putPrimMax here. However it's quite hard to return --- the number of bytes written into putPrimMax without allocating an --- Int for it, while the code below does not allocate at all. --- So we eat the cost of the bounds check instead of increasing allocations --- for now. - --- Unsigned numbers -{-# SPECIALISE putULEB128 :: BinHandle -> Word -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word64 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word32 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Word16 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int64 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int32 -> IO () #-} -{-# SPECIALISE putULEB128 :: BinHandle -> Int16 -> IO () #-} -putULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> a -> IO () -putULEB128 bh w = -#if defined(DEBUG) - (if w < 0 then panic "putULEB128: Signed number" else id) $ -#endif - go w - where - go :: a -> IO () - go w - | w <= (127 :: a) - = putByte bh (fromIntegral w :: Word8) - | otherwise = do - -- bit 7 (8th bit) indicates more to come. - let !byte = setBit (fromIntegral w) 7 :: Word8 - putByte bh byte - go (w `unsafeShiftR` 7) - -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word64 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word32 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Word16 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int64 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int32 #-} -{-# SPECIALISE getULEB128 :: BinHandle -> IO Int16 #-} -getULEB128 :: forall a. (Integral a, FiniteBits a) => BinHandle -> IO a -getULEB128 bh = - go 0 0 - where - go :: Int -> a -> IO a - go shift w = do - b <- getByte bh - let !hasMore = testBit b 7 - let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a - if hasMore - then do - go (shift+7) val - else - return $! val - --- Signed numbers -{-# SPECIALISE putSLEB128 :: BinHandle -> Word -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word64 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word32 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Word16 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int64 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int32 -> IO () #-} -{-# SPECIALISE putSLEB128 :: BinHandle -> Int16 -> IO () #-} -putSLEB128 :: forall a. (Integral a, Bits a) => BinHandle -> a -> IO () -putSLEB128 bh initial = go initial - where - go :: a -> IO () - go val = do - let !byte = fromIntegral (clearBit val 7) :: Word8 - let !val' = val `unsafeShiftR` 7 - let !signBit = testBit byte 6 - let !done = - -- Unsigned value, val' == 0 and last value can - -- be discriminated from a negative number. - ((val' == 0 && not signBit) || - -- Signed value, - (val' == -1 && signBit)) - - let !byte' = if done then byte else setBit byte 7 - putByte bh byte' - - unless done $ go val' - -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word64 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word32 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Word16 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int64 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int32 #-} -{-# SPECIALISE getSLEB128 :: BinHandle -> IO Int16 #-} -getSLEB128 :: forall a. (Show a, Integral a, FiniteBits a) => BinHandle -> IO a -getSLEB128 bh = do - (val,shift,signed) <- go 0 0 - if signed && (shift < finiteBitSize val ) - then return $! ((complement 0 `unsafeShiftL` shift) .|. val) - else return val - where - go :: Int -> a -> IO (a,Int,Bool) - go shift val = do - byte <- getByte bh - let !byteVal = fromIntegral (clearBit byte 7) :: a - let !val' = val .|. (byteVal `unsafeShiftL` shift) - let !more = testBit byte 7 - let !shift' = shift+7 - if more - then go (shift') val' - else do - let !signed = testBit byte 6 - return (val',shift',signed) --- ----------------------------------------------------------------------------- --- Primitive Word writes +class GBinary (f :: * -> *) where + gput :: f a -> Put () + gget :: Get (f a) -instance Binary Word8 where - put_ bh !w = putWord8 bh w - get = getWord8 +instance GBinary U1 where + gput U1 = return () + gget = return U1 -instance Binary Word16 where - put_ = putULEB128 - get = getULEB128 +instance GBinary a => GBinary (M1 i c a) where + gput (M1 x) = gput x + gget = M1 <$> gget -instance Binary Word32 where - put_ = putULEB128 - get = getULEB128 +instance Binary a => GBinary (K1 i a) where + gput (K1 x) = put x + gget = K1 <$> get -instance Binary Word64 where - put_ = putULEB128 - get = getULEB128 +instance (GBinary a, GBinary b) => GBinary (a :*: b) where + gput (x :*: y) = gput x >> gput y + gget = (:*:) <$> gget <*> gget --- ----------------------------------------------------------------------------- --- Primitive Int writes +instance (GSumBinary (a :+: b)) => GBinary (a :+: b) where + gput = gsput (maxIndex @(a :+: b)) + gget = gsget =<< get -instance Binary Int8 where - put_ h w = put_ h (fromIntegral w :: Word8) - get h = do w <- get h; return $! (fromIntegral (w::Word8)) +class KnownNat (SumSize f) => GSumBinary (f :: * -> *) where + type SumSize f :: Nat + gsput :: Int8 -> f a -> Put () + gsget :: Int8 -> Get (f a) -instance Binary Int16 where - put_ = putSLEB128 - get = getSLEB128 +instance (GSumBinary a, GSumBinary b, KnownNat (SumSize (a :+: b))) + => GSumBinary (a :+: b) where + type SumSize (a :+: b) = SumSize a + SumSize b + gsput n (L1 x) = gsput (n - sumSize @b) x + gsput n (R1 x) = gsput n x + gsget n | n <= maxIndex @a = L1 <$> gsget n + | otherwise = R1 <$> gsget (n - sumSize @a) -instance Binary Int32 where - put_ = putSLEB128 - get = getSLEB128 +instance GBinary (M1 i c a) => GSumBinary (M1 i c a) where + type SumSize (M1 i c a) = 1 + gsput n x = put n >> gput x + gsget _ = gget -instance Binary Int64 where - put_ h w = putSLEB128 h w - get h = getSLEB128 h +sumSize :: forall f. GSumBinary f => Int8 +sumSize = fromIntegral $ natVal' (proxy# :: Proxy# (SumSize f)) +maxIndex :: forall f. GSumBinary f => Int8 +maxIndex = sumSize @f - 1 + +-- ----------------------------------------------------------------------------- +-- Standard instances -- ----------------------------------------------------------------------------- --- Instances for standard types instance Binary () where - put_ _ () = return () - get _ = return () + put () = return () + get = return () instance Binary Bool where - put_ bh b = putByte bh (fromIntegral (fromEnum b)) - get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x)) + put b = putByte (fromIntegral (fromEnum b)) + get = do x <- getWord8; return $! (toEnum (fromIntegral x)) instance Binary Char where - put_ bh c = put_ bh (fromIntegral (ord c) :: Word32) - get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32))) + put c = put (fromIntegral (ord c) :: Word32) + get = do x <- get; return $! chr (fromIntegral (x :: Word32)) instance Binary Int where - put_ bh i = put_ bh (fromIntegral i :: Int64) - get bh = do - x <- get bh - return $! (fromIntegral (x :: Int64)) + put = putInt + get = getInt instance Binary a => Binary [a] where - put_ bh l = do - let len = length l - put_ bh len - mapM_ (put_ bh) l - get bh = do - len <- get bh :: IO Int -- Int is variable length encoded so only - -- one byte for small lists. - let loop 0 = return [] - loop n = do a <- get bh; as <- loop (n-1); return (a:as) - loop len + put xs = do + put (length xs) + mapM_ put xs + get = do + loop =<< (get :: Get Int) + where + loop 0 = return [] + loop n = (:) <$> get <*> loop (pred n) instance (Ix a, Binary a, Binary b) => Binary (Array a b) where - put_ bh arr = do - put_ bh $ bounds arr - put_ bh $ elems arr - get bh = do - bounds <- get bh - xs <- get bh + put arr = do + put $ bounds arr + put $ elems arr + get = do + bounds <- get + xs <- get return $ listArray bounds xs instance (Binary a, Binary b) => Binary (a,b) where - put_ bh (a,b) = do put_ bh a; put_ bh b - get bh = do a <- get bh - b <- get bh - return (a,b) + put (a,b) = do put a; put b + get = do a <- get + b <- get + return (a,b) instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where - put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c - get bh = do a <- get bh - b <- get bh - c <- get bh - return (a,b,c) + put (a,b,c) = do put a; put b; put c + get = do a <- get + b <- get + c <- get + return (a,b,c) instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where - put_ bh (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 (a,b,c,d) + put (a,b,c,d) = do put a; put b; put c; put d + get = do a <- get + b <- get + c <- get + d <- get + return (a,b,c,d) instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where - put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - return (a,b,c,d,e) + put (a,b,c,d, e) = do put a; put b; put c; put d; put e; + get = do a <- get + b <- get + c <- get + d <- get + e <- get + return (a,b,c,d,e) instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d, e, f) where - put_ bh (a,b,c,d, e, f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - return (a,b,c,d,e,f) + put (a,b,c,d, e, f) = do put a; put b; put c; put d; put e; put f; + get = do a <- get + b <- get + c <- get + d <- get + e <- get + f <- get + return (a,b,c,d,e,f) instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) => Binary (a,b,c,d,e,f,g) where - put_ bh (a,b,c,d,e,f,g) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f; put_ bh g - get bh = do a <- get bh - b <- get bh - c <- get bh - d <- get bh - e <- get bh - f <- get bh - g <- get bh - return (a,b,c,d,e,f,g) + put (a,b,c,d,e,f,g) = do put a; put b; put c; put d; put e; put f; put g + get = do a <- get + b <- get + c <- get + d <- get + e <- get + f <- get + g <- get + return (a,b,c,d,e,f,g) instance Binary a => Binary (Maybe a) where - put_ bh Nothing = putByte bh 0 - put_ bh (Just a) = do putByte bh 1; put_ bh a - get bh = do h <- getWord8 bh - case h of - 0 -> return Nothing - _ -> do x <- get bh; return (Just x) + put Nothing = putByte 0 + put (Just a) = do putByte 1; put a + get = do h <- getWord8 + case h of + 0 -> return Nothing + _ -> do x <- get; return (Just x) instance (Binary a, Binary b) => Binary (Either a b) where - put_ bh (Left a) = do putByte bh 0; put_ bh a - put_ bh (Right b) = do putByte bh 1; put_ bh b - get bh = do h <- getWord8 bh - case h of - 0 -> do a <- get bh ; return (Left a) - _ -> do b <- get bh ; return (Right b) + put (Left a) = do putByte 0; put a + put (Right b) = do putByte 1; put b + get = do h <- getWord8 + case h of + 0 -> do a <- get; return (Left a) + _ -> do b <- get; return (Right b) instance Binary UTCTime where - put_ bh u = do put_ bh (utctDay u) - put_ bh (utctDayTime u) - get bh = do day <- get bh - dayTime <- get bh - return $ UTCTime { utctDay = day, utctDayTime = dayTime } + put u = do put (utctDay u) + put (utctDayTime u) + get = do day <- get + dayTime <- get + return $ UTCTime { utctDay = day, utctDayTime = dayTime } instance Binary Day where - put_ bh d = put_ bh (toModifiedJulianDay d) - get bh = do i <- get bh - return $ ModifiedJulianDay { toModifiedJulianDay = i } + put d = put (toModifiedJulianDay d) + get = do i <- get + return $ ModifiedJulianDay { toModifiedJulianDay = i } instance Binary DiffTime where - put_ bh dt = put_ bh (toRational dt) - get bh = do r <- get bh - return $ fromRational r + put dt = put (toRational dt) + get = do r <- get + return $ fromRational r -{- -Finally - a reasonable portable Integer instance. +instance (Binary a) => Binary (Ratio a) where + put (a :% b) = do put a; put b + get = do a <- get; b <- get; return (a :% b) +-- ----------------------------------------------------------------------------- +-- Primitives +-- ----------------------------------------------------------------------------- + +instance Binary Word8 where + put !w = putWord8 w + get = getWord8 + +instance Binary Word16 where + put = putULEB128 + get = getULEB128 + +instance Binary Word32 where + put = putULEB128 + get = getULEB128 + +instance Binary Word64 where + put = putULEB128 + get = getULEB128 + +instance Binary Int8 where + put w = put (fromIntegral w :: Word8) + get = do w <- get; return $! (fromIntegral (w :: Word8)) + +instance Binary Int16 where + put = putSLEB128 + get = getSLEB128 + +instance Binary Int32 where + put = putSLEB128 + get = getSLEB128 + +instance Binary Int64 where + put = putSLEB128 + get = getSLEB128 + +instance Binary FastString where + put = putAFastString + get = getAFastString + +instance Binary (Bin a) where + get = getBin + put = putBin + +instance Binary Strict.ByteString where + put = putByteString + get = getByteString + +instance Binary Lazy.ByteString where + put = put . Lazy.toStrict + get = Lazy.fromStrict <$> get + +-- ----------------------------------------------------------------------------- +-- Integer +-- ----------------------------------------------------------------------------- + +{- We used to encode values in the Int32 range as such, falling back to a string of all things. In either case we stored a tag byte to discriminate between the two cases. @@ -699,29 +400,29 @@ The instance is used for in Binary Integer and Binary Rational in basicTypes/Lit -} instance Binary Integer where - put_ bh i + put i | i >= lo64 && i <= hi64 = do - putWord8 bh 0 - put_ bh (fromIntegral i :: Int64) + putWord8 0 + put (fromIntegral i :: Int64) | otherwise = do if i < 0 - then putWord8 bh 1 - else putWord8 bh 2 - put_ bh (unroll $ abs i) + then putWord8 1 + else putWord8 2 + put (unroll $ abs i) where lo64 = fromIntegral (minBound :: Int64) hi64 = fromIntegral (maxBound :: Int64) - get bh = do - int_kind <- getWord8 bh + get = do + int_kind <- getWord8 case int_kind of - 0 -> fromIntegral <$!> (get bh :: IO Int64) + 0 -> fromIntegral <$!> (get :: Get Int64) -- Large integer - 1 -> negate <$!> getInt - 2 -> getInt + 1 -> negate <$!> getI + 2 -> getI _ -> panic "Binary Integer - Invalid byte" where - getInt :: IO Integer - getInt = roll <$!> (get bh :: IO [Word8]) + getI :: Get Integer + getI = roll <$!> (get :: Get [Word8]) unroll :: Integer -> [Word8] unroll = unfoldr step @@ -734,135 +435,58 @@ roll = foldl' unstep 0 . reverse where unstep a b = a `shiftL` 8 .|. fromIntegral b - - {- - -- This code is currently commented out. - -- See https://gitlab.haskell.org/ghc/ghc/issues/3379#note_104346 for - -- discussion. - - put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) - put_ bh (J# s# a#) = do - putByte bh 1 - put_ bh (I# s#) - let sz# = sizeofByteArray# a# -- in *bytes* - put_ bh (I# sz#) -- in *bytes* - putByteArray bh a# sz# - - get bh = do - b <- getByte bh - case b of - 0 -> do (I# i#) <- get bh - return (S# i#) - _ -> do (I# s#) <- get bh - sz <- get bh - (BA a#) <- getByteArray bh sz - return (J# s# a#) - -putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () -putByteArray bh a s# = loop 0# - where loop n# - | n# ==# s# = return () - | otherwise = do - putByte bh (indexByteArray a n#) - loop (n# +# 1#) - -getByteArray :: BinHandle -> Int -> IO ByteArray -getByteArray bh (I# sz) = do - (MBA arr) <- newByteArray sz - let loop n - | n ==# sz = return () - | otherwise = do - w <- getByte bh - writeByteArray arr n w - loop (n +# 1#) - loop 0# - freezeByteArray arr - -} - -{- -data ByteArray = BA ByteArray# -data MBA = MBA (MutableByteArray# RealWorld) - -newByteArray :: Int# -> IO MBA -newByteArray sz = IO $ \s -> - case newByteArray# sz s of { (# s, arr #) -> - (# s, MBA arr #) } - -freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray -freezeByteArray arr = IO $ \s -> - case unsafeFreezeByteArray# arr s of { (# s, arr #) -> - (# s, BA arr #) } - -writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO () -writeByteArray arr i (W8# w) = IO $ \s -> - case writeWord8Array# arr i w s of { s -> - (# s, () #) } - -indexByteArray :: ByteArray# -> Int# -> Word8 -indexByteArray a# n# = W8# (indexWord8Array# a# n#) - --} -instance (Binary a) => Binary (Ratio a) where - put_ bh (a :% b) = do put_ bh a; put_ bh b - get bh = do a <- get bh; b <- get bh; return (a :% b) - --- Instance uses fixed-width encoding to allow inserting --- Bin placeholders in the stream. -instance Binary (Bin a) where - put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32) - get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) - -- ----------------------------------------------------------------------------- --- Instances for Data.Typeable stuff +-- Data.Typeable instances +-- ----------------------------------------------------------------------------- instance Binary TyCon where - put_ bh tc = do - put_ bh (tyConPackage tc) - put_ bh (tyConModule tc) - put_ bh (tyConName tc) - put_ bh (tyConKindArgs tc) - put_ bh (tyConKindRep tc) - get bh = - mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh + put tc = do + put (tyConPackage tc) + put (tyConModule tc) + put (tyConName tc) + put (tyConKindArgs tc) + put (tyConKindRep tc) + get = + mkTyCon <$> get <*> get <*> get <*> get <*> get instance Binary VecCount where - put_ bh = putByte bh . fromIntegral . fromEnum - get bh = toEnum . fromIntegral <$> getByte bh + put = putByte . fromIntegral . fromEnum + get = toEnum . fromIntegral <$> getByte instance Binary VecElem where - put_ bh = putByte bh . fromIntegral . fromEnum - get bh = toEnum . fromIntegral <$> getByte bh + put = putByte . fromIntegral . fromEnum + get = toEnum . fromIntegral <$> getByte instance Binary RuntimeRep where - put_ bh (VecRep a b) = putByte bh 0 >> put_ bh a >> put_ bh b - put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps - put_ bh (SumRep reps) = putByte bh 2 >> put_ bh reps - put_ bh LiftedRep = putByte bh 3 - put_ bh UnliftedRep = putByte bh 4 - put_ bh IntRep = putByte bh 5 - put_ bh WordRep = putByte bh 6 - put_ bh Int64Rep = putByte bh 7 - put_ bh Word64Rep = putByte bh 8 - put_ bh AddrRep = putByte bh 9 - put_ bh FloatRep = putByte bh 10 - put_ bh DoubleRep = putByte bh 11 + put (VecRep a b) = putByte 0 >> put a >> put b + put (TupleRep reps) = putByte 1 >> put reps + put (SumRep reps) = putByte 2 >> put reps + put LiftedRep = putByte 3 + put UnliftedRep = putByte 4 + put IntRep = putByte 5 + put WordRep = putByte 6 + put Int64Rep = putByte 7 + put Word64Rep = putByte 8 + put AddrRep = putByte 9 + put FloatRep = putByte 10 + put DoubleRep = putByte 11 #if __GLASGOW_HASKELL__ >= 807 - put_ bh Int8Rep = putByte bh 12 - put_ bh Word8Rep = putByte bh 13 - put_ bh Int16Rep = putByte bh 14 - put_ bh Word16Rep = putByte bh 15 + put Int8Rep = putByte 12 + put Word8Rep = putByte 13 + put Int16Rep = putByte 14 + put Word16Rep = putByte 15 #endif #if __GLASGOW_HASKELL__ >= 809 - put_ bh Int32Rep = putByte bh 16 - put_ bh Word32Rep = putByte bh 17 + put Int32Rep = putByte 16 + put Word32Rep = putByte 17 #endif - get bh = do - tag <- getByte bh + get = do + tag <- getByte case tag of - 0 -> VecRep <$> get bh <*> get bh - 1 -> TupleRep <$> get bh - 2 -> SumRep <$> get bh + 0 -> VecRep <$> get <*> get + 1 -> TupleRep <$> get + 2 -> SumRep <$> get 3 -> pure LiftedRep 4 -> pure UnliftedRep 5 -> pure IntRep @@ -885,65 +509,65 @@ instance Binary RuntimeRep where _ -> fail "Binary.putRuntimeRep: invalid tag" instance Binary KindRep where - put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k - put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr - put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b - put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b - put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r - put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r - - get bh = do - tag <- getByte bh + put (KindRepTyConApp tc k) = putByte 0 >> put tc >> put k + put (KindRepVar bndr) = putByte 1 >> put bndr + put (KindRepApp a b) = putByte 2 >> put a >> put b + put (KindRepFun a b) = putByte 3 >> put a >> put b + put (KindRepTYPE r) = putByte 4 >> put r + put (KindRepTypeLit sort r) = putByte 5 >> put sort >> put r + + get = do + tag <- getByte case tag of - 0 -> KindRepTyConApp <$> get bh <*> get bh - 1 -> KindRepVar <$> get bh - 2 -> KindRepApp <$> get bh <*> get bh - 3 -> KindRepFun <$> get bh <*> get bh - 4 -> KindRepTYPE <$> get bh - 5 -> KindRepTypeLit <$> get bh <*> get bh + 0 -> KindRepTyConApp <$> get <*> get + 1 -> KindRepVar <$> get + 2 -> KindRepApp <$> get <*> get + 3 -> KindRepFun <$> get <*> get + 4 -> KindRepTYPE <$> get + 5 -> KindRepTypeLit <$> get <*> get _ -> fail "Binary.putKindRep: invalid tag" instance Binary TypeLitSort where - put_ bh TypeLitSymbol = putByte bh 0 - put_ bh TypeLitNat = putByte bh 1 - get bh = do - tag <- getByte bh + put TypeLitSymbol = putByte 0 + put TypeLitNat = putByte 1 + get = do + tag <- getByte case tag of 0 -> pure TypeLitSymbol 1 -> pure TypeLitNat _ -> fail "Binary.putTypeLitSort: invalid tag" -putTypeRep :: BinHandle -> TypeRep a -> IO () +putTypeRep :: TypeRep a -> Put () -- Special handling for TYPE, (->), and RuntimeRep due to recursive kind -- relations. -- See Note [Mutually recursive representations of primitive types] -putTypeRep bh rep +putTypeRep rep | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type) - = put_ bh (0 :: Word8) -putTypeRep bh (Con' con ks) = do - put_ bh (1 :: Word8) - put_ bh con - put_ bh ks -putTypeRep bh (App f x) = do - put_ bh (2 :: Word8) - putTypeRep bh f - putTypeRep bh x -putTypeRep bh (Fun arg res) = do - put_ bh (3 :: Word8) - putTypeRep bh arg - putTypeRep bh res - -getSomeTypeRep :: BinHandle -> IO SomeTypeRep -getSomeTypeRep bh = do - tag <- get bh :: IO Word8 + = put (0 :: Word8) +putTypeRep (Con' con ks) = do + put (1 :: Word8) + put con + put ks +putTypeRep (App f x) = do + put (2 :: Word8) + putTypeRep f + putTypeRep x +putTypeRep (Fun arg res) = do + put (3 :: Word8) + putTypeRep arg + putTypeRep res + +getSomeTypeRep :: Get SomeTypeRep +getSomeTypeRep = do + tag <- get :: Get Word8 case tag of 0 -> return $ SomeTypeRep (typeRep :: TypeRep Type) - 1 -> do con <- get bh :: IO TyCon - ks <- get bh :: IO [SomeTypeRep] + 1 -> do con <- get :: Get TyCon + ks <- get :: Get [SomeTypeRep] return $ SomeTypeRep $ mkTrCon con ks - 2 -> do SomeTypeRep f <- getSomeTypeRep bh - SomeTypeRep x <- getSomeTypeRep bh + 2 -> do SomeTypeRep f <- getSomeTypeRep + SomeTypeRep x <- getSomeTypeRep case typeRepKind f of Fun arg res -> case arg `eqTypeRep` typeRepKind x of @@ -960,8 +584,8 @@ getSomeTypeRep bh = do [ " Applied type: " ++ show f , " To argument: " ++ show x ] - 3 -> do SomeTypeRep arg <- getSomeTypeRep bh - SomeTypeRep res <- getSomeTypeRep bh + 3 -> do SomeTypeRep arg <- getSomeTypeRep + SomeTypeRep res <- getSomeTypeRep if | App argkcon _ <- typeRepKind arg , App reskcon _ <- typeRepKind res @@ -979,9 +603,9 @@ getSomeTypeRep bh = do ++ map (" "++) info instance Typeable a => Binary (TypeRep (a :: k)) where - put_ = putTypeRep - get bh = do - SomeTypeRep rep <- getSomeTypeRep bh + put = putTypeRep + get = do + SomeTypeRep rep <- getSomeTypeRep case rep `eqTypeRep` expected of Just HRefl -> pure rep Nothing -> fail $ unlines @@ -992,431 +616,273 @@ instance Typeable a => Binary (TypeRep (a :: k)) where where expected = typeRep :: TypeRep a instance Binary SomeTypeRep where - put_ bh (SomeTypeRep rep) = putTypeRep bh rep + put (SomeTypeRep rep) = putTypeRep rep get = getSomeTypeRep -- ----------------------------------------------------------------------------- --- Lazy reading/writing - -lazyPut :: Binary a => BinHandle -> a -> IO () -lazyPut bh a = do - -- output the obj with a ptr to skip over it: - pre_a <- tellBin bh - put_ bh pre_a -- save a slot for the ptr - put_ bh a -- dump the object - q <- tellBin bh -- q = ptr to after object - putAt bh pre_a q -- fill in slot before a with ptr to q - seekBin bh q -- finally carry on writing at q - -lazyGet :: Binary a => BinHandle -> IO a -lazyGet bh = do - p <- get bh -- a BinPtr - p_a <- tellBin bh - a <- unsafeInterleaveIO $ do - -- NB: Use a fresh off_r variable in the child thread, for thread - -- safety. - off_r <- newFastMutInt - getAt bh { _off_r = off_r } p_a - seekBin bh p -- skip over the object for now - return a - --- ----------------------------------------------------------------------------- --- UserData +-- Other instances -- ----------------------------------------------------------------------------- --- | Information we keep around during interface file --- serialization/deserialization. Namely we keep the functions for serializing --- and deserializing 'Name's and 'FastString's. We do this because we actually --- use serialization in two distinct settings, --- --- * When serializing interface files themselves --- --- * When computing the fingerprint of an IfaceDecl (which we computing by --- hashing its Binary serialization) --- --- These two settings have different needs while serializing Names: --- --- * Names in interface files are serialized via a symbol table (see Note --- [Symbol table representation of names] in BinIface). --- --- * During fingerprinting a binding Name is serialized as the OccName and a --- non-binding Name is serialized as the fingerprint of the thing they --- represent. See Note [Fingerprinting IfaceDecls] for further discussion. --- -data UserData = - UserData { - -- for *deserialising* only: - ud_get_name :: BinHandle -> IO Name, - ud_get_fs :: BinHandle -> IO FastString, - - -- for *serialising* only: - ud_put_nonbinding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a non-binding 'Name' (e.g. a reference to another - -- binding). - ud_put_binding_name :: BinHandle -> Name -> IO (), - -- ^ serialize a binding 'Name' (e.g. the name of an IfaceDecl) - 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 - } - -noUserData :: a -noUserData = undef "UserData" - -undef :: String -> a -undef s = panic ("Binary.UserData: no " ++ s) - ---------------------------------------------------------- --- The Dictionary ---------------------------------------------------------- - -type Dictionary = Array Int FastString -- The dictionary - -- Should be 0-indexed - -putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () -putDictionary bh sz dict = do - put_ bh sz - mapM_ (putFS bh) (elems (array (0,sz-1) (nonDetEltsUFM dict))) - -- It's OK to use nonDetEltsUFM here because the elements have indices - -- that array uses to create order - -getDictionary :: BinHandle -> IO Dictionary -getDictionary bh = do - sz <- get bh - elems <- sequence (take sz (repeat (getFS bh))) - return (listArray (0,sz-1) elems) - ---------------------------------------------------------- --- The Symbol Table ---------------------------------------------------------- - --- On disk, the symbol table is an array of IfExtName, when --- reading it in we turn it into a SymbolTable. - -type SymbolTable = Array Int Name - ---------------------------------------------------------- --- Reading and writing FastStrings ---------------------------------------------------------- - -putFS :: BinHandle -> FastString -> IO () -putFS bh fs = putBS bh $ bytesFS fs - -getFS :: BinHandle -> IO FastString -getFS bh = do - l <- get bh :: IO Int - getPrim bh l (\src -> pure $! mkFastStringBytes src l ) - -putBS :: BinHandle -> ByteString -> IO () -putBS bh bs = - BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do - put_ bh l - putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) - -getBS :: BinHandle -> IO ByteString -getBS bh = do - l <- get bh :: IO Int - BS.create l $ \dest -> do - getPrim bh l (\src -> BS.memcpy dest src l) - -instance Binary ByteString where - put_ bh f = putBS bh f - get bh = getBS bh - -instance Binary FastString where - put_ bh f = - case getUserData bh of - UserData { ud_put_fs = put_fs } -> put_fs bh f - - get bh = - case getUserData bh of - UserData { ud_get_fs = get_fs } -> get_fs bh - --- Here to avoid loop instance Binary LeftOrRight where - put_ bh CLeft = putByte bh 0 - put_ bh CRight = putByte bh 1 + put CLeft = putByte 0 + put CRight = putByte 1 - get bh = do { h <- getByte bh - ; case h of - 0 -> return CLeft - _ -> return CRight } + get = do { h <- getByte + ; case h of + 0 -> return CLeft + _ -> return CRight } instance Binary PromotionFlag where - put_ bh NotPromoted = putByte bh 0 - put_ bh IsPromoted = putByte bh 1 + put NotPromoted = putByte 0 + put IsPromoted = putByte 1 - get bh = do - n <- getByte bh + get = do + n <- getByte case n of 0 -> return NotPromoted 1 -> return IsPromoted _ -> fail "Binary(IsPromoted): fail)" instance Binary Fingerprint where - put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2 - get h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) + put (Fingerprint w1 w2) = do put w1; put w2 + get = do w1 <- get ; w2 <- get; return (Fingerprint w1 w2) instance Binary FunctionOrData where - put_ bh IsFunction = putByte bh 0 - put_ bh IsData = putByte bh 1 - get bh = do - h <- getByte bh + put IsFunction = putByte 0 + put IsData = putByte 1 + get = do + h <- getByte case h of 0 -> return IsFunction 1 -> return IsData _ -> panic "Binary FunctionOrData" instance Binary TupleSort where - put_ bh BoxedTuple = putByte bh 0 - put_ bh UnboxedTuple = putByte bh 1 - put_ bh ConstraintTuple = putByte bh 2 - get bh = do - h <- getByte bh + put BoxedTuple = putByte 0 + put UnboxedTuple = putByte 1 + put ConstraintTuple = putByte 2 + get = do + h <- getByte case h of 0 -> do return BoxedTuple 1 -> do return UnboxedTuple _ -> do return ConstraintTuple instance Binary Activation where - put_ bh NeverActive = do - putByte bh 0 - put_ bh AlwaysActive = do - putByte bh 1 - put_ bh (ActiveBefore src aa) = do - putByte bh 2 - put_ bh src - put_ bh aa - put_ bh (ActiveAfter src ab) = do - putByte bh 3 - put_ bh src - put_ bh ab - get bh = do - h <- getByte bh + put NeverActive = do + putByte 0 + put AlwaysActive = do + putByte 1 + put (ActiveBefore src aa) = do + putByte 2 + put src + put aa + put (ActiveAfter src ab) = do + putByte 3 + put src + put ab + get = do + h <- getByte case h of 0 -> do return NeverActive 1 -> do return AlwaysActive - 2 -> do src <- get bh - aa <- get bh + 2 -> do src <- get + aa <- get return (ActiveBefore src aa) - _ -> do src <- get bh - ab <- get bh + _ -> do src <- get + ab <- get return (ActiveAfter src ab) instance Binary InlinePragma where - put_ bh (InlinePragma s a b c d) = do - put_ bh s - put_ bh a - put_ bh b - put_ bh c - put_ bh d - - get bh = do - s <- get bh - a <- get bh - b <- get bh - c <- get bh - d <- get bh + put (InlinePragma s a b c d) = do + put s + put a + put b + put c + put d + + get = do + s <- get + a <- get + b <- get + c <- get + d <- get return (InlinePragma s a b c d) instance Binary RuleMatchInfo where - put_ bh FunLike = putByte bh 0 - put_ bh ConLike = putByte bh 1 - get bh = do - h <- getByte bh + put FunLike = putByte 0 + put ConLike = putByte 1 + get = do + h <- getByte if h == 1 then return ConLike else return FunLike instance Binary InlineSpec where - put_ bh NoUserInline = 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 NoUserInline - 1 -> return Inline - 2 -> return Inlinable - _ -> return NoInline + put NoUserInline = putByte 0 + put Inline = putByte 1 + put Inlinable = putByte 2 + put NoInline = putByte 3 + + get = do h <- getByte + case h of + 0 -> return NoUserInline + 1 -> return Inline + 2 -> return Inlinable + _ -> return NoInline instance Binary RecFlag where - put_ bh Recursive = do - putByte bh 0 - put_ bh NonRecursive = do - putByte bh 1 - get bh = do - h <- getByte bh + put Recursive = do + putByte 0 + put NonRecursive = do + putByte 1 + get = do + h <- getByte case h of 0 -> do return Recursive _ -> do return NonRecursive instance Binary OverlapMode where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - get bh = do - h <- getByte bh + put (NoOverlap s) = putByte 0 >> put s + put (Overlaps s) = putByte 1 >> put s + put (Incoherent s) = putByte 2 >> put s + put (Overlapping s) = putByte 3 >> put s + put (Overlappable s) = putByte 4 >> put s + get = do + h <- getByte case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s + 0 -> NoOverlap <$> get + 1 -> Overlaps <$> get + 2 -> Incoherent <$> get + 3 -> Overlapping <$> get + 4 -> Overlappable <$> get _ -> panic ("get OverlapMode" ++ show h) instance Binary OverlapFlag where - put_ bh flag = do put_ bh (overlapMode flag) - put_ bh (isSafeOverlap flag) - get bh = do - h <- get bh - b <- get bh + put flag = do put (overlapMode flag) + put (isSafeOverlap flag) + get = do + h <- get + b <- get return OverlapFlag { overlapMode = h, isSafeOverlap = b } instance Binary FixityDirection where - put_ bh InfixL = do - putByte bh 0 - put_ bh InfixR = do - putByte bh 1 - put_ bh InfixN = do - putByte bh 2 - get bh = do - h <- getByte bh - case h of - 0 -> do return InfixL - 1 -> do return InfixR - _ -> do return InfixN - -instance Binary Fixity where - put_ bh (Fixity src aa ab) = do - put_ bh src - put_ bh aa - put_ bh ab - get bh = do - src <- get bh - aa <- get bh - ab <- get bh + put InfixL = do + putByte 0 + put InfixR = do + putByte 1 + put InfixN = do + putByte 2 + get = do + h <- getByte + case h of + 0 -> do return InfixL + 1 -> do return InfixR + _ -> do return InfixN + +instance Binary BasicTypes.Fixity where + put (Fixity src aa ab) = do + put src + put aa + put ab + get = do + src <- get + aa <- get + ab <- get return (Fixity src aa ab) instance Binary WarningTxt where - put_ bh (WarningTxt s w) = do - putByte bh 0 - put_ bh s - put_ bh w - put_ bh (DeprecatedTxt s d) = do - putByte bh 1 - put_ bh s - put_ bh d - - get bh = do - h <- getByte bh + put (WarningTxt s w) = do + putByte 0 + put s + put w + put (DeprecatedTxt s d) = do + putByte 1 + put s + put d + + get = do + h <- getByte case h of - 0 -> do s <- get bh - w <- get bh + 0 -> do s <- get + w <- get return (WarningTxt s w) - _ -> do s <- get bh - d <- get bh + _ -> do s <- get + d <- get return (DeprecatedTxt s d) instance Binary StringLiteral where - put_ bh (StringLiteral st fs) = do - put_ bh st - put_ bh fs - get bh = do - st <- get bh - fs <- get bh + put (StringLiteral st fs) = do + put st + put fs + get = do + st <- get + fs <- get return (StringLiteral st fs) instance Binary a => Binary (Located a) where - put_ bh (L l x) = do - put_ bh l - put_ bh x + put (L l x) = do + put l + put x - get bh = do - l <- get bh - x <- get bh + get = do + l <- get + x <- get return (L l x) instance Binary RealSrcSpan where - put_ bh ss = do - put_ bh (srcSpanFile ss) - put_ bh (srcSpanStartLine ss) - put_ bh (srcSpanStartCol ss) - put_ bh (srcSpanEndLine ss) - put_ bh (srcSpanEndCol ss) - - get bh = do - f <- get bh - sl <- get bh - sc <- get bh - el <- get bh - ec <- get bh - return (mkRealSrcSpan (mkRealSrcLoc f sl sc) - (mkRealSrcLoc f el ec)) + put ss = do + put (srcSpanFile ss) + put (srcSpanStartLine ss) + put (srcSpanStartCol ss) + put (srcSpanEndLine ss) + put (srcSpanEndCol ss) + + get = do f <- get + sl <- get + sc <- get + el <- get + ec <- get + return (mkRealSrcSpan (mkRealSrcLoc f sl sc) + (mkRealSrcLoc f el ec)) instance Binary SrcSpan where - put_ bh (RealSrcSpan ss) = do - putByte bh 0 - put_ bh ss + put (RealSrcSpan ss) = do + putByte 0 + put ss - put_ bh (UnhelpfulSpan s) = do - putByte bh 1 - put_ bh s + put (UnhelpfulSpan s) = do + putByte 1 + put s - get bh = do - h <- getByte bh + get = do + h <- getByte case h of - 0 -> do ss <- get bh + 0 -> do ss <- get return (RealSrcSpan ss) - _ -> do s <- get bh + _ -> do s <- get return (UnhelpfulSpan s) instance Binary Serialized where - put_ bh (Serialized the_type bytes) = do - put_ bh the_type - put_ bh bytes - get bh = do - the_type <- get bh - bytes <- get bh + put (Serialized the_type bytes) = do + put the_type + put bytes + get = do + the_type <- get + bytes <- get return (Serialized the_type bytes) instance Binary SourceText where - put_ bh NoSourceText = putByte bh 0 - put_ bh (SourceText s) = do - putByte bh 1 - put_ bh s + put NoSourceText = putByte 0 + put (SourceText s) = do + putByte 1 + put s - get bh = do - h <- getByte bh + get = do + h <- getByte case h of 0 -> return NoSourceText 1 -> do - s <- get bh + s <- get return (SourceText s) _ -> panic $ "Binary SourceText:" ++ show h diff --git a/compiler/utils/Binary/Internal.hs b/compiler/utils/Binary/Internal.hs new file mode 100755 index 0000000000..581b4be63c --- /dev/null +++ b/compiler/utils/Binary/Internal.hs @@ -0,0 +1,394 @@ +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns, ScopedTypeVariables, CPP #-}
+
+module Binary.Internal (
+
+ -- Safe parts of `Binary.Unsafe`:
+
+ Bin, BinData,
+
+ Put, runPut, runPutIO,
+ Get, runGet, runGetIO,
+
+ writeBinData, readBinData, withBinBuffer,
+
+ UserDataP(..), UserDataG(..),
+ userDataP , userDataG,
+ writeState , readState,
+
+ tellP, seekP,
+ tellG, seekG, interleaveG, getSlice,
+
+ -- Primitives:
+
+ Dictionary,
+ putDictionary, getDictionary,
+
+ SymbolTable,
+
+ putWord8 , getWord8,
+ putWord16, getWord16,
+ putWord32, getWord32,
+ putWord64, getWord64,
+
+ putInt8 , getInt8,
+ putInt16, getInt16,
+ putInt32, getInt32,
+ putInt64, getInt64,
+
+ putULEB128, getULEB128,
+ putSLEB128, getSLEB128,
+
+ putByte, getByte,
+
+ putByteString, getByteString,
+ putFS, getFS,
+ putAFastString, getAFastString,
+
+ putNonBindingName, putBindingName,
+ getAName,
+
+ putBin, getBin,
+
+ putInt, getInt,
+
+) where
+
+import Binary.Unsafe
+
+import FastString
+import GhcPrelude
+import {-# SOURCE #-} Name (Name)
+
+#if defined(DEBUG)
+import PlainPanic
+#endif
+
+import Control.Monad
+
+import Data.Array
+import UniqFM
+
+import Foreign
+import Data.ByteString as BS
+import Data.ByteString.Internal
+import Data.ByteString.Unsafe
+
+-- -----------------------------------------------------------------------------
+-- Byte
+-- -----------------------------------------------------------------------------
+
+putByte :: Word8 -> Put ()
+putByte !w = putWord8 w
+
+getByte :: Get Word8
+getByte = getWord8
+
+-- -----------------------------------------------------------------------------
+-- Word
+-- -----------------------------------------------------------------------------
+
+putWord8 :: Word8 -> Put ()
+putWord8 !w = putPrim 1 (\op -> poke op w)
+
+getWord8 :: Get Word8
+getWord8 = getPrim 1 peek
+
+putWord16 :: Word16 -> Put ()
+putWord16 w = putPrim 2 (\op -> do
+ pokeElemOff op 0 (fromIntegral (w `shiftR` 8))
+ pokeElemOff op 1 (fromIntegral (w .&. 0xFF))
+ )
+
+getWord16 :: Get Word16
+getWord16 = getPrim 2 (\op -> do
+ w0 <- fromIntegral <$> peekElemOff op 0
+ w1 <- fromIntegral <$> peekElemOff op 1
+ return $! w0 `shiftL` 8 .|. w1
+ )
+
+putWord32 :: Word32 -> Put ()
+putWord32 w = putPrim 4 (\op -> do
+ pokeElemOff op 0 (fromIntegral (w `shiftR` 24))
+ pokeElemOff op 1 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
+ pokeElemOff op 2 (fromIntegral ((w `shiftR` 8) .&. 0xFF))
+ pokeElemOff op 3 (fromIntegral (w .&. 0xFF))
+ )
+
+getWord32 :: Get Word32
+getWord32 = getPrim 4 (\op -> do
+ w0 <- fromIntegral <$> peekElemOff op 0
+ w1 <- fromIntegral <$> peekElemOff op 1
+ w2 <- fromIntegral <$> peekElemOff op 2
+ w3 <- fromIntegral <$> peekElemOff op 3
+
+ return $! (w0 `shiftL` 24) .|.
+ (w1 `shiftL` 16) .|.
+ (w2 `shiftL` 8) .|.
+ w3
+ )
+
+putWord64 :: Word64 -> Put ()
+putWord64 w = putPrim 8 (\op -> do
+ pokeElemOff op 0 (fromIntegral (w `shiftR` 56))
+ pokeElemOff op 1 (fromIntegral ((w `shiftR` 48) .&. 0xFF))
+ pokeElemOff op 2 (fromIntegral ((w `shiftR` 40) .&. 0xFF))
+ pokeElemOff op 3 (fromIntegral ((w `shiftR` 32) .&. 0xFF))
+ pokeElemOff op 4 (fromIntegral ((w `shiftR` 24) .&. 0xFF))
+ pokeElemOff op 5 (fromIntegral ((w `shiftR` 16) .&. 0xFF))
+ pokeElemOff op 6 (fromIntegral ((w `shiftR` 8) .&. 0xFF))
+ pokeElemOff op 7 (fromIntegral (w .&. 0xFF))
+ )
+
+getWord64 :: Get Word64
+getWord64 = getPrim 8 (\op -> do
+ w0 <- fromIntegral <$> peekElemOff op 0
+ w1 <- fromIntegral <$> peekElemOff op 1
+ w2 <- fromIntegral <$> peekElemOff op 2
+ w3 <- fromIntegral <$> peekElemOff op 3
+ w4 <- fromIntegral <$> peekElemOff op 4
+ w5 <- fromIntegral <$> peekElemOff op 5
+ w6 <- fromIntegral <$> peekElemOff op 6
+ w7 <- fromIntegral <$> peekElemOff op 7
+
+ return $! (w0 `shiftL` 56) .|.
+ (w1 `shiftL` 48) .|.
+ (w2 `shiftL` 40) .|.
+ (w3 `shiftL` 32) .|.
+ (w4 `shiftL` 24) .|.
+ (w5 `shiftL` 16) .|.
+ (w6 `shiftL` 8) .|.
+ w7
+ )
+
+-- -----------------------------------------------------------------------------
+-- Fixed-size Ints
+-- -----------------------------------------------------------------------------
+
+putInt8 :: Int8 -> Put ()
+putInt8 = putWord8 . fromIntegral
+
+getInt8 :: Get Int8
+getInt8 = (fromIntegral $!) <$> getWord8
+
+putInt16 :: Int16 -> Put ()
+putInt16 = putSLEB128
+
+getInt16 :: Get Int16
+getInt16 = getSLEB128
+
+putInt32 :: Int32 -> Put ()
+putInt32 = putSLEB128
+
+getInt32 :: Get Int32
+getInt32 = getSLEB128
+
+putInt64 :: Int64 -> Put ()
+putInt64 = putSLEB128
+
+getInt64 :: Get Int64
+getInt64 = getSLEB128
+
+-- -----------------------------------------------------------------------------
+-- Bin
+-- -----------------------------------------------------------------------------
+
+putBin :: Bin a -> Put ()
+putBin (BinPtr !p) = putWord32 (fromIntegral p :: Word32)
+
+getBin :: Get (Bin a)
+getBin = BinPtr . fromIntegral <$> getWord32
+
+-- -----------------------------------------------------------------------------
+-- ByteString
+-- -----------------------------------------------------------------------------
+
+putByteString :: ByteString -> Put ()
+putByteString bs = do
+ let len = BS.length bs
+ putInt len
+ putPrim len $ \op ->
+ unsafeUseAsCString bs $ \ptr ->
+ memcpy op (castPtr ptr) len
+
+getByteString :: Get ByteString
+getByteString = do
+ len <- getInt
+ let l = fromIntegral len
+ getPrim l $ \src ->
+ create l $ \dest ->
+ memcpy dest src l
+
+-- -----------------------------------------------------------------------------
+-- FastString and Name
+-- -----------------------------------------------------------------------------
+
+putAFastString :: FastString -> Put ()
+putAFastString fs = put_fs <$!> userDataP >>= ($! fs)
+
+getAFastString :: Get FastString
+getAFastString = get_fs =<< userDataG
+
+putFS :: FastString -> Put ()
+putFS = putByteString . bytesFS
+
+getFS :: Get FastString
+getFS = do
+ l <- getInt
+ getPrim l (\src -> pure $! mkFastStringBytes src l)
+
+putNonBindingName :: Name -> Put ()
+putNonBindingName n = put_nonbinding_name <$> userDataP >>= ($ n)
+
+putBindingName :: Name -> Put ()
+putBindingName n = put_binding_name <$> userDataP >>= ($ n)
+
+getAName :: Get Name
+getAName = get_name =<< userDataG
+
+-- -----------------------------------------------------------------------------
+-- Signed and unsigned LEB128
+-- -----------------------------------------------------------------------------
+
+{-# SPECIALISE putULEB128 :: Word -> Put () #-}
+{-# SPECIALISE putULEB128 :: Word64 -> Put () #-}
+{-# SPECIALISE putULEB128 :: Word32 -> Put () #-}
+{-# SPECIALISE putULEB128 :: Word16 -> Put () #-}
+{-# SPECIALISE putULEB128 :: Int -> Put () #-}
+{-# SPECIALISE putULEB128 :: Int64 -> Put () #-}
+{-# SPECIALISE putULEB128 :: Int32 -> Put () #-}
+{-# SPECIALISE putULEB128 :: Int16 -> Put () #-}
+putULEB128 :: forall a. (Integral a, FiniteBits a) => a -> Put ()
+putULEB128 w =
+#if defined(DEBUG)
+ (if w < 0 then panic "putULEB128: Signed number" else id) $
+#endif
+ go w
+ where
+ go :: a -> Put ()
+ go w
+ | w <= (127 :: a)
+ = putByte (fromIntegral w :: Word8)
+ | otherwise = do
+ -- bit 7 (8th bit) indicates more to come.
+ let !byte = setBit (fromIntegral w) 7 :: Word8
+ putByte byte
+ go (w `unsafeShiftR` 7)
+
+{-# SPECIALISE getULEB128 :: Get Word #-}
+{-# SPECIALISE getULEB128 :: Get Word64 #-}
+{-# SPECIALISE getULEB128 :: Get Word32 #-}
+{-# SPECIALISE getULEB128 :: Get Word16 #-}
+{-# SPECIALISE getULEB128 :: Get Int #-}
+{-# SPECIALISE getULEB128 :: Get Int64 #-}
+{-# SPECIALISE getULEB128 :: Get Int32 #-}
+{-# SPECIALISE getULEB128 :: Get Int16 #-}
+getULEB128 :: forall a. (Integral a, FiniteBits a) => Get a
+getULEB128 =
+ go 0 0
+ where
+ go :: Int -> a -> Get a
+ go shift w = do
+ b <- getByte
+ let !hasMore = testBit b 7
+ let !val = w .|. ((clearBit (fromIntegral b) 7) `unsafeShiftL` shift) :: a
+ if hasMore
+ then do
+ go (shift+7) val
+ else
+ return $! val
+
+{-# SPECIALISE putSLEB128 :: Word -> Put () #-}
+{-# SPECIALISE putSLEB128 :: Word64 -> Put () #-}
+{-# SPECIALISE putSLEB128 :: Word32 -> Put () #-}
+{-# SPECIALISE putSLEB128 :: Word16 -> Put () #-}
+{-# SPECIALISE putSLEB128 :: Int -> Put () #-}
+{-# SPECIALISE putSLEB128 :: Int64 -> Put () #-}
+{-# SPECIALISE putSLEB128 :: Int32 -> Put () #-}
+{-# SPECIALISE putSLEB128 :: Int16 -> Put () #-}
+putSLEB128 :: forall a. (Integral a, FiniteBits a) => a -> Put ()
+putSLEB128 initial = go initial
+ where
+ go :: a -> Put ()
+ go val = do
+ let !byte = fromIntegral (clearBit val 7) :: Word8
+ let !val' = val `unsafeShiftR` 7
+ let !signBit = testBit byte 6
+ let !done =
+ -- Unsigned value, val' == 0 and and last value can
+ -- be discriminated from a negative number.
+ ((val' == 0 && not signBit) ||
+ -- Signed value,
+ (val' == -1 && signBit))
+
+ let !byte' = if done then byte else setBit byte 7
+ putByte byte'
+
+ unless done $ go val'
+
+{-# SPECIALISE getSLEB128 :: Get Word #-}
+{-# SPECIALISE getSLEB128 :: Get Word64 #-}
+{-# SPECIALISE getSLEB128 :: Get Word32 #-}
+{-# SPECIALISE getSLEB128 :: Get Word16 #-}
+{-# SPECIALISE getSLEB128 :: Get Int #-}
+{-# SPECIALISE getSLEB128 :: Get Int64 #-}
+{-# SPECIALISE getSLEB128 :: Get Int32 #-}
+{-# SPECIALISE getSLEB128 :: Get Int16 #-}
+getSLEB128 :: forall a. (Integral a, FiniteBits a) => Get a
+getSLEB128 = do
+ (val,shift,signed) <- go 0 0
+ if signed && (shift < finiteBitSize val)
+ then return $! ((complement 0 `unsafeShiftL` shift) .|. val)
+ else return val
+ where
+ go :: Int -> a -> Get (a, Int, Bool)
+ go shift val = do
+ byte <- getByte
+ let !byteVal = fromIntegral (clearBit byte 7) :: a
+ let !val' = val .|. (byteVal `unsafeShiftL` shift)
+ let !more = testBit byte 7
+ let !shift' = shift+7
+ if more
+ then go (shift') val'
+ else do
+ let !signed = testBit byte 6
+ return (val',shift',signed)
+
+-- -----------------------------------------------------------------------------
+-- Standard types
+-- -----------------------------------------------------------------------------
+
+putInt :: Int -> Put ()
+putInt i = putSLEB128 (fromIntegral i :: Int64)
+
+getInt :: Get Int
+getInt = (fromIntegral $!) <$> (getSLEB128 :: Get Int64)
+
+--------------------------------------------------------------------------------
+-- The Dictionary
+--------------------------------------------------------------------------------
+
+type Dictionary = Array Int FastString -- The dictionary
+ -- Should be 0-indexed
+
+putDictionary :: Int -> UniqFM (Int,FastString) -> Put ()
+putDictionary sz dict = do
+ putInt sz
+ mapM_ putFS (elems (array (0,sz-1) (nonDetEltsUFM dict)))
+ -- It's OK to use nonDetEltsUFM here because the elements have indices
+ -- that array uses to create order
+
+getDictionary :: Get Dictionary
+getDictionary = do
+ sz <- getInt
+ elems <- sequence (GhcPrelude.take sz (repeat getFS))
+ return (listArray (0,sz-1) elems)
+
+--------------------------------------------------------------------------------
+-- The Symbol Table
+--------------------------------------------------------------------------------
+
+-- On disk, the symbol table is an array of IfExtName, when
+-- reading it in we turn it into a SymbolTable.
+
+type SymbolTable = Array Int Name
diff --git a/compiler/utils/Binary/Unsafe.hs b/compiler/utils/Binary/Unsafe.hs new file mode 100755 index 0000000000..61074f2972 --- /dev/null +++ b/compiler/utils/Binary/Unsafe.hs @@ -0,0 +1,303 @@ +{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns, CPP #-}
+
+module Binary.Unsafe where
+
+#if !MIN_VERSION_base(4,13,0)
+import Control.Monad.Fail (MonadFail)
+#endif
+
+import GhcPrelude
+
+import Control.Monad.Reader
+import Data.IORef
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Unsafe as BS
+import FastMutInt
+import FastString
+import Foreign
+import {-# SOURCE #-} Name (Name)
+import PlainPanic
+import System.IO
+import System.IO.Error
+import System.IO.Unsafe
+
+
+-- -----------------------------------------------------------------------------
+-- Arrays
+-- -----------------------------------------------------------------------------
+
+type BinArray = ForeignPtr Word8
+
+data BinData = BinData { binSize :: !Int, unarr :: !BinArray }
+
+newtype Bin a = BinPtr Int
+ deriving (Eq, Ord, Show, Bounded)
+
+castBin :: Bin a -> Bin b
+castBin (BinPtr !i) = BinPtr i
+
+-- | Get access to the underlying buffer.
+--
+-- It is quite important that no references to the 'ByteString' leak out of the
+-- continuation lest terrible things happen.
+withBinBuffer :: BinData -> (ByteString -> IO a) -> IO a
+withBinBuffer (BinData sz arr) action =
+ withForeignPtr arr $ \ptr ->
+ BS.unsafePackCStringLen (castPtr ptr, sz) >>= action
+
+-- -----------------------------------------------------------------------------
+-- Put
+-- -----------------------------------------------------------------------------
+
+newtype Put a = Put { unput :: ReaderT EnvP IO a }
+ deriving (Functor, Applicative, Monad, MonadFail)
+
+-- Internal reader data for `Put` monad.
+data EnvP
+ = EnvP {
+ put_user :: UserDataP,
+ put_offset :: !FastMutInt,
+ put_size :: !FastMutInt,
+ put_arr :: !(IORef BinArray)
+ }
+
+allocate :: Int -> IO EnvP
+allocate initialSize = do
+ arr <- mallocForeignPtrBytes initialSize
+ EnvP noUserData <$> initInt 0 <*> initInt initialSize <*> newIORef arr
+ where
+ initInt n = do
+ int <- newFastMutInt
+ writeFastMutInt int n
+ return int
+
+expand :: Int -> Put ()
+expand off = do
+ sz <- putSize
+ arr <- putArr
+ let !sz' = getSize sz
+ Put $ do
+ sz_r <- put_size <$> ask
+ arr_r <- put_arr <$> ask
+ liftIO $ do
+ arr' <- mallocForeignPtrBytes sz'
+ withForeignPtr arr $ \old ->
+ withForeignPtr arr' $ \new ->
+ copyBytes new old sz
+ writeFastMutInt sz_r sz'
+ writeIORef arr_r arr'
+ where
+ getSize !sz | sz >= off = sz
+ | otherwise = getSize (sz * 2)
+
+reallocate :: Put ()
+reallocate = expand . (2 *) =<< putSize
+
+runBuffer :: Int -> Put () -> IO BinData
+runBuffer initialSize (Put m) = do
+ bin <- runReaderT (m >> ask) =<< allocate initialSize
+ off <- readFastMutInt (put_offset bin)
+ BinData off <$> readIORef (put_arr bin)
+
+runPutIO :: Put () -> IO BinData
+runPutIO = runBuffer (1024 * 1024)
+
+runPut :: Put () -> BinData
+runPut = unsafePerformIO . runPutIO
+
+askP :: Put EnvP
+askP = Put ask
+
+putEnv :: (EnvP -> IO a) -> Put a
+putEnv f = Put $ liftIO . f =<< ask
+
+putOffset, putSize :: Put Int
+putOffset = putEnv (readFastMutInt . put_offset)
+putSize = putEnv (readFastMutInt . put_size )
+
+putArr :: Put BinArray
+putArr = putEnv (readIORef . put_arr)
+
+-- -----------------------------------------------------------------------------
+-- Putting
+-- -----------------------------------------------------------------------------
+
+putPrim :: Int -> (Ptr Word8 -> IO ()) -> Put ()
+putPrim n f = do
+ ix <- putOffset
+ sz <- putSize
+ when (ix + n > sz) (expand (ix + n))
+ arr <- putArr
+ Put $ do
+ ixr <- put_offset <$> ask
+ liftIO $ do
+ withForeignPtr arr $ \op -> f (op `plusPtr` ix)
+ writeFastMutInt ixr (ix + n)
+
+ioP :: IO a -> Put a
+ioP m = Put (liftIO m)
+
+userDataP :: Put UserDataP
+userDataP = Put $ put_user <$> ask
+
+offsetP :: Put Int
+offsetP = do EnvP _ off _ _ <- askP; Put . liftIO $ readFastMutInt off
+
+seekP :: Bin a -> Put ()
+seekP (BinPtr !i) = do
+ EnvP _ ixr _ _ <- askP
+ Put . liftIO $ writeFastMutInt ixr i
+
+tellP :: Put (Bin a)
+tellP = BinPtr <$> offsetP
+
+-- -----------------------------------------------------------------------------
+-- Get
+-- -----------------------------------------------------------------------------
+
+newtype Get a = Get { unget :: ReaderT EnvG IO a }
+ deriving (Functor, Applicative, Monad, MonadFail)
+
+-- Internal reader data for `Get` monad.
+data EnvG
+ = EnvG {
+ get_user :: UserDataG,
+ get_offset :: !FastMutInt,
+ get_end :: !Int,
+ get_arr :: !BinData
+ }
+
+runGetIO :: BinData -> Get a -> IO a
+runGetIO bd m = runReaderT (unget m) =<< mkEnvG bd
+
+runGet :: BinData -> Get a -> a
+runGet bd = unsafePerformIO . runGetIO bd
+
+askG :: Get EnvG
+askG = Get ask
+
+offsetG :: Get Int
+offsetG = do EnvG _ off _ _ <- askG; Get . liftIO $ readFastMutInt off
+
+seekG :: Bin a -> Get ()
+seekG (BinPtr !i) = do
+ EnvG _ ixr _ _ <- askG
+ Get . liftIO $ writeFastMutInt ixr i
+
+tellG :: Get (Bin a)
+tellG = BinPtr <$> offsetG
+
+getEnv :: (EnvG -> IO a) -> Get a
+getEnv f = Get $ liftIO . f =<< ask
+
+getOffset, getEnd :: Get Int
+getOffset = getEnv (readFastMutInt . get_offset)
+getEnd = Get $ get_end <$> ask
+
+getSize :: Get Int
+getSize = Get $ binSize . get_arr <$> ask
+
+getArr :: Get BinArray
+getArr = Get $ unarr . get_arr <$> ask
+
+mkEnvG :: BinData -> IO EnvG
+mkEnvG bd@(BinData size _) = do
+ i <- newFastMutInt
+ writeFastMutInt i 0
+ return $ EnvG noUserData i size bd
+
+-- -----------------------------------------------------------------------------
+-- Getting
+-- -----------------------------------------------------------------------------
+
+getPrim :: Int -> (Ptr Word8 -> IO a) -> Get a
+getPrim n f = do
+ ix <- getOffset
+ end <- getEnd
+ when (ix + n > end) $
+ ioG $ ioError (mkIOError eofErrorType "Binary.Internal.getPrim" Nothing Nothing)
+ arr <- getArr
+ do
+ ixr <- get_offset <$> askG
+ ioG $ do
+ w <- withForeignPtr arr $ \op -> f (op `plusPtr` ix)
+ writeFastMutInt ixr (ix + n)
+ return w
+
+interleaveG :: Get a -> Get a
+interleaveG m = do
+ env <- askG
+ ioG $ unsafeInterleaveIO . runReaderT (unget m) =<< dup env
+ where
+ dup :: EnvG -> IO EnvG
+ dup (EnvG dat off end arr) = do
+ off' <- newFastMutInt
+ writeFastMutInt off' =<< readFastMutInt off
+ return $ EnvG dat off' end arr
+
+getSlice :: Bin b -> Get a -> Get a
+getSlice (BinPtr !end) (Get m) = Get $ local (\x -> x {get_end = end}) m
+
+ioG :: IO a -> Get a
+ioG m = Get (liftIO m)
+
+userDataG :: Get UserDataG
+userDataG = Get $ get_user <$> ask
+
+-- -----------------------------------------------------------------------------
+-- File IO
+-- -----------------------------------------------------------------------------
+
+writeBinData :: BinData -> FilePath -> IO ()
+writeBinData (BinData sz arr) fp =
+ withBinaryFile fp WriteMode $ \h ->
+ withForeignPtr arr $ \p ->
+ hPutBuf h p sz
+
+readBinData :: FilePath -> IO BinData
+readBinData fp =
+ withBinaryFile fp ReadMode $ \h -> do
+ sz <- fromIntegral <$> hFileSize h
+ arr <- mallocForeignPtrBytes sz
+ count <- withForeignPtr arr $ \p -> hGetBuf h p sz
+ when (count /= sz) $
+ error ("Binary.Internal.readBinMem: only read " ++ show count ++ " bytes")
+ return $ BinData sz arr
+
+-- -----------------------------------------------------------------------------
+-- User Data
+-- -----------------------------------------------------------------------------
+
+data UserDataP
+ = UserDataP {
+ put_nonbinding_name :: Name -> Put (),
+ put_binding_name :: Name -> Put (),
+ put_fs :: FastString -> Put ()
+ }
+
+writeState :: (Name -> Put ())
+ -> (Name -> Put ())
+ -> (FastString -> Put ())
+ -> Put a
+ -> Put a
+writeState nonbind bind fs (Put m) = Put $ local setWriteState m
+ where
+ setWriteState env = env { put_user = UserDataP nonbind bind fs }
+
+data UserDataG
+ = UserDataG {
+ get_name :: Get Name,
+ get_fs :: Get FastString
+ }
+
+noUserData :: a
+noUserData = panic "Binary.UserData not defined"
+
+readState :: Get Name
+ -> Get FastString
+ -> Get a
+ -> Get a
+readState name fs (Get m) = Get $ local setReadState m
+ where
+ setReadState env = env { get_user = UserDataG name fs }
diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs index a42bb90a1c..bca606cd9c 100644 --- a/compiler/utils/BooleanFormula.hs +++ b/compiler/utils/BooleanFormula.hs @@ -248,15 +248,15 @@ pprBooleanFormulaNormal = go ---------------------------------------------------------------------- instance Binary a => Binary (BooleanFormula a) where - put_ bh (Var x) = putByte bh 0 >> put_ bh x - put_ bh (And xs) = putByte bh 1 >> put_ bh xs - put_ bh (Or xs) = putByte bh 2 >> put_ bh xs - put_ bh (Parens x) = putByte bh 3 >> put_ bh x + put (Var x) = putByte 0 >> put x + put (And xs) = putByte 1 >> put xs + put (Or xs) = putByte 2 >> put xs + put (Parens x) = putByte 3 >> put x - get bh = do - h <- getByte bh + get = do + h <- getByte case h of - 0 -> Var <$> get bh - 1 -> And <$> get bh - 2 -> Or <$> get bh - _ -> Parens <$> get bh + 0 -> Var <$> get + 1 -> And <$> get + 2 -> Or <$> get + _ -> Parens <$> get diff --git a/ghc/Main.hs b/ghc/Main.hs index b66f567d2f..75b0080651 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -68,7 +68,8 @@ import LoadIface ( loadUserInterface ) import Module ( mkModuleName ) import Finder ( findImportedModule, cannotFindModule ) import TcRnMonad ( initIfaceCheck ) -import Binary ( openBinMem, put_ ) +import Binary ( put ) +import Binary.Unsafe ( runBuffer ) import BinFingerprint ( fingerprintBinMem ) -- Standard Haskell libraries @@ -920,12 +921,12 @@ abiHash strs = do let get_iface modl = loadUserInterface False (text "abiHash") modl ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods - bh <- openBinMem (3*1024) -- just less than a block - put_ bh hiVersion + bd <- runBuffer (3*1024) $ do -- just less than a block + put hiVersion -- package hashes change when the compiler version changes (for now) -- see #5328 - mapM_ (put_ bh . mi_mod_hash . mi_final_exts) ifaces - f <- fingerprintBinMem bh + mapM_ (put . mi_mod_hash . mi_final_exts) ifaces + f <- fingerprintBinMem bd putStrLn (showPpr dflags f) diff --git a/libraries/exceptions b/libraries/exceptions -Subproject 0a1f9ff0f407da360fc9405a07d5d06d28e6c07 +Subproject ed98b644973430e26b93a4d12f75ad963c7afd2 diff --git a/utils/haddock b/utils/haddock -Subproject f4298e24044cf01890ff6a257d387ee9a7f13d8 +Subproject e91c892a2532ff6abc6d7639db6bad66278b1c0 diff --git a/utils/hsc2hs b/utils/hsc2hs -Subproject fff335b68958c05efe2b33ef2c56a1664596d02 +Subproject 748cdd6ad6f93063149ff416c9bf76dee1e6c41 |