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

Commits:

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

  • 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