Cheng Shao pushed to branch wip/bytecode-serialize-3 at Glasgow Haskell Compiler / GHC

Commits:

4 changed files:

Changes:

  • compiler/GHC/ByteCode/Serialize.hs
    1 
    +{-# LANGUAGE MultiWayIf #-}
    2 
    +{-# LANGUAGE RecordWildCards #-}
    3 
    +{-# OPTIONS_GHC -Wno-orphans #-}
    4 
    +
    5 
    +module GHC.ByteCode.Serialize (testBinByteCode) where
    6 
    +
    7 
    +import GHC.Prelude
    8 
    +import GHC.Utils.Binary
    9 
    +import GHC.ByteCode.Breakpoints
    10 
    +import GHC.ByteCode.Types
    11 
    +import GHC.Utils.Exception
    12 
    +import GHC.Data.FlatBag as FlatBag
    13 
    +import GHCi.FFI
    14 
    +import GHC.Builtin.PrimOps
    15 
    +import GHC.Driver.Env
    16 
    +import GHC.Types.Name
    17 
    +import Data.Proxy
    18 
    +import GHC.Data.FastString
    19 
    +import Data.IORef
    20 
    +import GHC.Types.Name.Cache
    21 
    +import GHC.Types.SrcLoc
    22 
    +import GHC.Types.SptEntry
    23 
    +import GHC.Builtin.Types
    24 
    +import GHC.Types.Id
    25 
    +import Data.Word
    26 
    +import qualified Data.ByteString.Lazy as LBS
    27 
    +import qualified Data.Binary as Binary
    28 
    +import GHCi.Message
    29 
    +import Data.Foldable
    30 
    +import Control.Monad
    31 
    +import GHC.Iface.Binary
    32 
    +import GHC.Utils.TmpFs
    33 
    +import System.FilePath
    34 
    +
    35 
    +testBinByteCode :: HscEnv -> CompiledByteCode -> IO CompiledByteCode
    36 
    +testBinByteCode hsc_env cbc = withSystemTempDirectory "ghc-bbc" $ \tmpdir -> do
    37 
    +  let f = tmpdir </> "ghc-bbc"
    38 
    +  roundtripBinByteCode hsc_env f cbc
    39 
    +
    40 
    +roundtripBinByteCode :: HscEnv -> FilePath -> CompiledByteCode -> IO CompiledByteCode
    41 
    +roundtripBinByteCode hsc_env f cbc = do
    42 
    +  writeBinByteCode f cbc
    43 
    +  readBinByteCode hsc_env f
    44 
    +
    45 
    +readBinByteCode :: HscEnv -> FilePath -> IO CompiledByteCode
    46 
    +readBinByteCode hsc_env f = do
    47 
    +  bh' <- readBinMem f
    48 
    +  bh <- addSerializableNameReader hsc_env bh'
    49 
    +  getWithUserData (hsc_NC hsc_env) bh
    50 
    +
    51 
    +writeBinByteCode :: FilePath -> CompiledByteCode -> IO ()
    52 
    +writeBinByteCode f cbc = do
    53 
    +  bh' <- openBinMem (1024*1024)
    54 
    +  bh <- addSerializableNameWriter bh'
    55 
    +  putWithUserData QuietBinIFace NormalCompression bh cbc
    56 
    +  writeBinMem bh f
    57 
    +
    58 
    +instance Binary CompiledByteCode where
    59 
    +  get bh = do
    60 
    +    bc_bcos <- get bh
    61 
    +    bc_itbls_len <- get bh
    62 
    +    bc_itbls <- replicateM bc_itbls_len $ do
    63 
    +      nm <- getViaSerializableName bh
    64 
    +      itbl <- get bh
    65 
    +      pure (nm, itbl)
    66 
    +    bc_strs_len <- get bh
    67 
    +    bc_strs <-
    68 
    +      replicateM bc_strs_len
    69 
    +        $ (,)
    70 
    +        <$> getViaSerializableName bh
    71 
    +        <*> get bh
    72 
    +    bc_breaks <- get bh
    73 
    +    bc_spt_entries <- get bh
    74 
    +    evaluate
    75 
    +      CompiledByteCode
    76 
    +        { bc_bcos,
    77 
    +          bc_itbls,
    78 
    +          bc_strs,
    79 
    +          bc_breaks,
    80 
    +          bc_spt_entries
    81 
    +        }
    82 
    +
    83 
    +  put_ bh CompiledByteCode {..} = do
    84 
    +    put_ bh bc_bcos
    85 
    +    put_ bh $ length bc_itbls
    86 
    +    for_ bc_itbls
    87 
    +      $ \(nm, itbl) -> do
    88 
    +        putViaSerializableName bh nm
    89 
    +        put_ bh itbl
    90 
    +    put_ bh $ length bc_strs
    91 
    +    for_ bc_strs
    92 
    +      $ \(nm, str) -> putViaSerializableName bh nm *> put_ bh str
    93 
    +    put_ bh bc_breaks
    94 
    +    put_ bh bc_spt_entries
    95 
    +
    96 
    +instance Binary InternalModBreaks where
    97 
    +  get bh = InternalModBreaks <$> get bh <*> get bh
    98 
    +
    99 
    +  put_ bh InternalModBreaks {..} = put_ bh imodBreaks_breakInfo *> put_ bh imodBreaks_modBreaks
    100 
    +
    101 
    +instance Binary ModBreaks where
    102 
    +  get bh = ModBreaks <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh
    103 
    +
    104 
    +  put_ bh ModBreaks {..} = put_ bh modBreaks_locs *> put_ bh modBreaks_vars *> put_ bh modBreaks_decls *> put_ bh modBreaks_ccs *> put_ bh modBreaks_module
    105 
    +
    106 
    +instance Binary SrcSpan where
    107 
    +  get bh = unBinSrcSpan <$> get bh
    108 
    +
    109 
    +  put_ bh = put_ bh . BinSrcSpan
    110 
    +
    111 
    +instance Binary CgBreakInfo where
    112 
    +  put_ bh CgBreakInfo {..} = put_ bh cgb_tyvars *> put_ bh cgb_vars *> put_ bh cgb_resty *> put_ bh cgb_tick_id
    113 
    +
    114 
    +  get bh = CgBreakInfo <$> get bh <*> get bh <*> get bh <*> get bh
    115 
    +
    116 
    +instance Binary ConInfoTable where
    117 
    +  get bh = Binary.decode . LBS.fromStrict <$> get bh
    118 
    +
    119 
    +  put_ bh = put_ bh . LBS.toStrict . Binary.encode
    120 
    +
    121 
    +
    122 
    +instance Binary UnlinkedBCO where
    123 
    +  get bh =
    124 
    +    UnlinkedBCO
    125 
    +      <$> getViaSerializableName bh
    126 
    +      <*> get bh
    127 
    +      <*> (Binary.decode . LBS.fromStrict <$> get bh)
    128 
    +      <*> (Binary.decode . LBS.fromStrict <$> get bh)
    129 
    +      <*> get bh
    130 
    +      <*> get bh
    131 
    +
    132 
    +  put_ bh UnlinkedBCO {..} = do
    133 
    +    putViaSerializableName bh unlinkedBCOName
    134 
    +    put_ bh unlinkedBCOArity
    135 
    +    put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOInstrs
    136 
    +    put_ bh $ LBS.toStrict $ Binary.encode unlinkedBCOBitmap
    137 
    +    put_ bh unlinkedBCOLits
    138 
    +    put_ bh unlinkedBCOPtrs
    139 
    +
    140 
    +instance Binary BCOPtr where
    141 
    +  get bh = do
    142 
    +    t <- getByte bh
    143 
    +    case t of
    144 
    +      0 -> BCOPtrName <$> getViaSerializableName bh
    145 
    +      1 -> BCOPtrPrimOp <$> get bh
    146 
    +      2 -> BCOPtrBCO <$> get bh
    147 
    +      _ -> BCOPtrBreakArray <$> get bh
    148 
    +
    149 
    +  put_ bh ptr = case ptr of
    150 
    +    BCOPtrName nm -> putByte bh 0 *> putViaSerializableName bh nm
    151 
    +    BCOPtrPrimOp op -> putByte bh 1 *> put_ bh op
    152 
    +    BCOPtrBCO bco -> putByte bh 2 *> put_ bh bco
    153 
    +    BCOPtrBreakArray info_mod -> putByte bh 3 *> put_ bh info_mod
    154 
    +
    155 
    +instance Binary BCONPtr where
    156 
    +  get bh = do
    157 
    +    t <- getByte bh
    158 
    +    case t of
    159 
    +      0 -> BCONPtrWord . fromIntegral <$> (get bh :: IO Word64)
    160 
    +      1 -> BCONPtrLbl <$> get bh
    161 
    +      2 -> BCONPtrItbl <$> getViaSerializableName bh
    162 
    +      3 -> BCONPtrAddr <$> getViaSerializableName bh
    163 
    +      4 -> BCONPtrStr <$> get bh
    164 
    +      5 -> BCONPtrFS <$> get bh
    165 
    +      6 -> BCONPtrFFIInfo <$> get bh
    166 
    +      _ -> BCONPtrCostCentre <$> get bh
    167 
    +
    168 
    +  put_ bh ptr = case ptr of
    169 
    +    BCONPtrWord lit -> putByte bh 0 *> put_ bh (fromIntegral lit :: Word64)
    170 
    +    BCONPtrLbl sym -> putByte bh 1 *> put_ bh sym
    171 
    +    BCONPtrItbl nm -> putByte bh 2 *> putViaSerializableName bh nm
    172 
    +    BCONPtrAddr nm -> putByte bh 3 *> putViaSerializableName bh nm
    173 
    +    BCONPtrStr str -> putByte bh 4 *> put_ bh str
    174 
    +    BCONPtrFS fs -> putByte bh 5 *> put_ bh fs
    175 
    +    BCONPtrFFIInfo ffi -> putByte bh 6 *> put_ bh ffi
    176 
    +    BCONPtrCostCentre ibi -> putByte bh 7 *> put_ bh ibi
    177 
    +
    178 
    +instance Binary InternalBreakLoc where
    179 
    +  get bh = InternalBreakLoc <$> get bh
    180 
    +
    181 
    +  put_ bh InternalBreakLoc {..} = put_ bh internalBreakLoc
    182 
    +
    183 
    +instance Binary BreakpointId where
    184 
    +  get bh = BreakpointId <$> get bh <*> get bh
    185 
    +
    186 
    +  put_ bh BreakpointId {..} = put_ bh bi_tick_mod *> put_ bh bi_tick_index
    187 
    +
    188 
    +instance Binary InternalBreakpointId where
    189 
    +  get bh = InternalBreakpointId <$> get bh <*> get bh
    190 
    +
    191 
    +  put_ bh InternalBreakpointId {..} = put_ bh ibi_info_mod *> put_ bh ibi_info_index
    192 
    +
    193 
    +instance Binary SptEntry where
    194 
    +  get bh = do
    195 
    +    nm <- getViaSerializableName bh
    196 
    +    fp <- get bh
    197 
    +    pure $ SptEntry (mkVanillaGlobal nm anyTy) fp
    198 
    +
    199 
    +  put_ bh (SptEntry nm fp) = putViaSerializableName bh (getName nm) *> put_ bh fp
    200 
    +
    201 
    +
    202 
    +newtype SerializableName = SerializableName {unSerializableName :: Name}
    203 
    +
    204 
    +getViaSerializableName :: ReadBinHandle -> IO Name
    205 
    +getViaSerializableName bh = case findUserDataReader Proxy bh of
    206 
    +  BinaryReader f -> unSerializableName <$> f bh
    207 
    +
    208 
    +putViaSerializableName :: WriteBinHandle -> Name -> IO ()
    209 
    +putViaSerializableName bh nm = case findUserDataWriter Proxy bh of
    210 
    +  BinaryWriter f -> f bh $ SerializableName nm
    211 
    +
    212 
    +addSerializableNameWriter :: WriteBinHandle -> IO WriteBinHandle
    213 
    +addSerializableNameWriter bh' =
    214 
    +  evaluate
    215 
    +    $ flip addWriterToUserData bh'
    216 
    +    $ BinaryWriter
    217 
    +    $ \bh
    218 
    +       ( SerializableName
    219 
    +           nm
    220 
    +         ) ->
    221 
    +        if
    222 
    +          | isExternalName nm -> do
    223 
    +              putByte bh 0
    224 
    +              put_ bh nm
    225 
    +          | otherwise -> do
    226 
    +              putByte bh 1
    227 
    +              put_ bh $ occNameFS (occName nm) `appendFS` mkFastString (show $ nameUnique nm)
    228 
    +
    229 
    +addSerializableNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
    230 
    +addSerializableNameReader HscEnv {..} bh' = do
    231 
    +  nc <- evaluate hsc_NC
    232 
    +  env_ref <- newIORef emptyOccEnv
    233 
    +  evaluate $ flip addReaderToUserData bh' $ BinaryReader $ \bh -> do
    234 
    +    t <- getByte bh
    235 
    +    case t of
    236 
    +      0 -> do
    237 
    +        nm <- get bh
    238 
    +        evaluate $ SerializableName nm
    239 
    +      _ -> do
    240 
    +        occ <- mkVarOccFS <$> get bh
    241 
    +        u <- takeUniqFromNameCache nc
    242 
    +        nm' <- evaluate $ mkInternalName u occ noSrcSpan
    243 
    +        fmap SerializableName
    244 
    +          $ atomicModifyIORef' env_ref
    245 
    +          $ \env -> case lookupOccEnv env occ of
    246 
    +            Just nm -> (env, nm)
    247 
    +            _ -> (extendOccEnv env occ nm', nm')
    248 
    +
    249 
    +instance Binary PrimOp where
    250 
    +  get bh = (allThePrimOps !!) <$> get bh
    251 
    +
    252 
    +  put_ bh = put_ bh . primOpTag
    253 
    +
    254 
    +instance Binary FFIInfo where
    255 
    +  get bh = FFIInfo <$> get bh <*> get bh
    256 
    +
    257 
    +  put_ bh FFIInfo {..} = put_ bh ffiInfoArgs *> put_ bh ffiInfoRet
    258 
    +
    259 
    +instance Binary FFIType where
    260 
    +  get bh = do
    261 
    +    t <- getByte bh
    262 
    +    evaluate $ case t of
    263 
    +      0 -> FFIVoid
    264 
    +      1 -> FFIPointer
    265 
    +      2 -> FFIFloat
    266 
    +      3 -> FFIDouble
    267 
    +      4 -> FFISInt8
    268 
    +      5 -> FFISInt16
    269 
    +      6 -> FFISInt32
    270 
    +      7 -> FFISInt64
    271 
    +      8 -> FFIUInt8
    272 
    +      9 -> FFIUInt16
    273 
    +      10 -> FFIUInt32
    274 
    +      _ -> FFIUInt64
    275 
    +
    276 
    +  put_ bh t = putByte bh $ case t of
    277 
    +    FFIVoid -> 0
    278 
    +    FFIPointer -> 1
    279 
    +    FFIFloat -> 2
    280 
    +    FFIDouble -> 3
    281 
    +    FFISInt8 -> 4
    282 
    +    FFISInt16 -> 5
    283 
    +    FFISInt32 -> 6
    284 
    +    FFISInt64 -> 7
    285 
    +    FFIUInt8 -> 8
    286 
    +    FFIUInt16 -> 9
    287 
    +    FFIUInt32 -> 10
    288 
    +    FFIUInt64 -> 11
    289 
    +
    290 
    +
    291 
    +instance (Binary a) => Binary (FlatBag a) where
    292 
    +  get bh = do
    293 
    +    xs <- get bh
    294 
    +    evaluate $ FlatBag.fromList (fromIntegral $ length xs) xs
    295 
    +
    296 
    +  put_ bh = put_ bh . FlatBag.elemsFlatBag

  • compiler/GHC/Driver/Main.hs
    ... ... @@ -305,6 +305,8 @@ import Data.Bifunctor
    305 305 
     import qualified GHC.Unit.Home.Graph as HUG
    306 306 
     import GHC.Unit.Home.PackageTable
    307 307
    308 
    +import GHC.ByteCode.Serialize
    309 
    +
    308 310 
     {- **********************************************************************
    309 311 
     %*                                                                      *
    310 312 
                     Initialisation
    ... ... @@ -2169,7 +2171,8 @@ generateByteCode :: HscEnv
    2169 2171 
       -> ModLocation
    2170 2172 
       -> IO (CompiledByteCode, [FilePath])
    2171 2173 
     generateByteCode hsc_env cgguts mod_location = do
    2172 
    -  (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location
    2174 
    +  (hasStub, comp_bc') <- hscInteractive hsc_env cgguts mod_location
    2175 
    +  comp_bc <- testBinByteCode hsc_env comp_bc'
    2173 2176 
       compile_for_interpreter hsc_env $ \ i_env -> do
    2174 2177 
         stub_o <- traverse (compileForeign i_env LangC) hasStub
    2175 2178 
         foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)

  • compiler/GHC/Utils/Binary.hs
    ... ... @@ -929,6 +929,12 @@ instance Binary Char where
    929 929 
         put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
    930 930 
         get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
    931 931
    932 
    +instance Binary Word where
    933 
    +    put_ bh i = put_ bh (fromIntegral i :: Word64)
    934 
    +    get  bh = do
    935 
    +        x <- get bh
    936 
    +        return $! (fromIntegral (x :: Word64))
    937 
    +
    932 938 
     instance Binary Int where
    933 939 
         put_ bh i = put_ bh (fromIntegral i :: Int64)
    934 940 
         get  bh = do

  • compiler/ghc.cabal.in
    ... ... @@ -228,6 +228,7 @@ Library
    228 228 
             GHC.ByteCode.InfoTable
    229 229 
             GHC.ByteCode.Instr
    230 230 
             GHC.ByteCode.Linker
    231 
    +        GHC.ByteCode.Serialize
    231 232 
             GHC.ByteCode.Types
    232 233 
             GHC.Cmm
    233 234 
             GHC.Cmm.BlockId

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help