[Git][ghc/ghc][wip/js-staging] 2 commits: GHC.Utils.Binary: BinDictionary -> FSTable
doyougnu (@doyougnu)
gitlab at gitlab.haskell.org
Tue Sep 13 08:46:45 UTC 2022
doyougnu pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
7dc26712 by doyougnu at 2022-09-12T05:56:42-04:00
GHC.Utils.Binary: BinDictionary -> FSTable
Rename to avoid naming conflict with haddock.
- - - - -
08fec920 by doyougnu at 2022-09-13T04:43:37-04:00
JS.Prim: More IndexByteAAs primops
- - - - -
4 changed files:
- compiler/GHC/Iface/Binary.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/StgToJS/Prim.hs
- compiler/GHC/Utils/Binary.hs
Changes:
=====================================
compiler/GHC/Iface/Binary.hs
=====================================
@@ -235,7 +235,7 @@ putWithTables bh put_payload = do
, bin_symtab_map = symtab_map
}
- (bh_fs, bin_dict, put_dict) <- initBinDictionary bh
+ (bh_fs, bin_dict, put_dict) <- initFSTable bh
(fs_count,(name_count,r)) <- forwardPut bh (const put_dict) $ do
@@ -331,7 +331,7 @@ serialiseName bh name _ = do
-- See Note [Symbol table representation of names]
-putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
+putName :: FSTable -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName _dict BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next }
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -205,7 +205,7 @@ putObject bh mod_name deps os = do
-- object in an archive.
put_ bh (moduleNameString mod_name)
- (bh_fs, _bin_dict, put_dict) <- initBinDictionary bh
+ (bh_fs, _bin_dict, put_dict) <- initFSTable bh
forwardPut_ bh (const put_dict) $ do
put_ bh_fs deps
=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1046,20 +1046,6 @@ genPrim prof ty op = case op of
])
(mconcat [r1 |= null_, r2 |= one_])
]
- -- PrimInline $ jVar \t -> mconcat
- -- [-- grab the "array" property
- -- t |= a .^ "arr"
- -- -- make sure we have a non-empty array
- -- , ifBlockS (t .&&. t .! i)
- -- -- we do, r1 is the ArrayBuffer, r2 is the payload offset
- -- [ r1 |= t
- -- , r2 |= dv_u32 t i
- -- ]
- -- -- we don't
- -- [ r1 |= null_
- -- , r2 |= zero_
- -- ]
- -- ]
IndexByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ r |= dv_f32 a i
IndexByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ r |= dv_f32 a i
IndexByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] ->
@@ -1071,7 +1057,7 @@ genPrim prof ty op = case op of
IndexByteArrayOp_Word8AsInt32 -> \[r] [a,i] -> PrimInline $ r |= dv_i32 a i
IndexByteArrayOp_Word8AsInt64 -> \[h,l] [a,i] ->
PrimInline $ mconcat
- [ h |= dv_u32 a (Add i (Int 4))
+ [ h |= dv_i32 a (Add i (Int 4))
, l |= dv_u32 a i
]
IndexByteArrayOp_Word8AsInt -> \[r] [a,i] -> PrimInline $ r |= dv_i32 a i
@@ -1095,20 +1081,6 @@ genPrim prof ty op = case op of
])
(mconcat [r1 |= null_, r2 |= one_])
]
- -- PrimInline $ jVar \t -> mconcat
- -- [-- grab the "array" property
- -- t |= a .^ "arr"
- -- -- make sure we have a non-empty array
- -- , ifBlockS (t .&&. t .! i)
- -- -- we do, r1 is the ArrayBuffer, r2 is the payload offset
- -- [ r1 |= t
- -- , r2 |= dv_u32 t i
- -- ]
- -- -- we don't
- -- [ r1 |= null_
- -- , r2 |= zero_
- -- ]
- -- ]
ReadByteArrayOp_Word8AsFloat -> \[r] [a,i] -> PrimInline $ r |= dv_f32 a i
ReadByteArrayOp_Word8AsDouble -> \[r] [a,i] -> PrimInline $ r |= dv_f32 a i
ReadByteArrayOp_Word8AsStablePtr -> \[r1,r2] [a,i] ->
@@ -1141,15 +1113,6 @@ genPrim prof ty op = case op of
, a .^ "arr" .! (i .<<. two_) |= ValExpr (JList [e1, e2])
]
- -- PrimInline $ mconcat
- -- [ ifS (Not (a .^ "arr"))
- -- -- if we don't have the "arr" property then make it with length 8
- -- -- bytes, 4 for the Addr, 4 for the offset
- -- (newByteArray (a .^ "arr") (Int 8))
- -- -- else noop
- -- mempty
- -- , dv_s_i32 (a .^ "arr") i (ValExpr (JList [e1, e2]))
- -- ]
WriteByteArrayOp_Word8AsFloat -> \[] [a,i,e] -> PrimInline $ dv_s_f32 a i e
WriteByteArrayOp_Word8AsDouble -> \[] [a,i,e] -> PrimInline $ dv_s_f32 a i e
WriteByteArrayOp_Word8AsStablePtr -> \[] [a,i,_e1,e2] -> PrimInline $ dv_s_i32 a i e2
@@ -1158,8 +1121,8 @@ genPrim prof ty op = case op of
WriteByteArrayOp_Word8AsInt64 -> \[] [a,i,h,l] ->
-- JS Numbers are little-endian and 32-bit, so write the lower 4 bytes at i
-- then write the higher 4 bytes to i+4
- PrimInline $ mconcat [ dv_s_i32 a (Add i (Int 4)) h
- , dv_s_i32 a i l
+ PrimInline $ mconcat [ dv_s_i32 a (Add i (Int 4)) (i32 h)
+ , dv_s_u32 a i l
]
-- it is probably strange to be using dv_s_i32, and dv_s_i16 when dv_s_u16 and
-- dv_s_u32 exist. Unfortunately this is a infelicity of the JS Backend. u32_
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -77,7 +77,7 @@ module GHC.Utils.Binary
-- * String table ("dictionary")
putDictionary, getDictionary, putFS,
- BinDictionary, initBinDictionary, getDictFastString, putDictFastString,
+ FSTable, initFSTable, getDictFastString, putDictFastString,
) where
import GHC.Prelude
@@ -1143,13 +1143,13 @@ getDictFastString dict bh = do
return $! (dict ! fromIntegral (j :: Word32))
-initBinDictionary :: BinHandle -> IO (BinHandle, BinDictionary, IO Int)
-initBinDictionary bh = do
+initFSTable :: BinHandle -> IO (BinHandle, FSTable, IO Int)
+initFSTable bh = do
dict_next_ref <- newFastMutInt 0
dict_map_ref <- newIORef emptyUFM
- let bin_dict = BinDictionary
- { bin_dict_next = dict_next_ref
- , bin_dict_map = dict_map_ref
+ let bin_dict = FSTable
+ { fs_tab_next = dict_next_ref
+ , fs_tab_map = dict_map_ref
}
let put_dict = do
fs_count <- readFastMutInt dict_next_ref
@@ -1164,12 +1164,13 @@ initBinDictionary bh = do
return (bh_fs,bin_dict,put_dict)
-putDictFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
+putDictFastString :: FSTable -> BinHandle -> FastString -> IO ()
putDictFastString dict bh fs = allocateFastString dict fs >>= put_ bh
-allocateFastString :: BinDictionary -> FastString -> IO Word32
-allocateFastString BinDictionary { bin_dict_next = j_r,
- bin_dict_map = out_r} f = do
+allocateFastString :: FSTable -> FastString -> IO Word32
+allocateFastString FSTable { fs_tab_next = j_r
+ , fs_tab_map = out_r
+ } f = do
out <- readIORef out_r
let !uniq = getUnique f
case lookupUFM_Directly out uniq of
@@ -1180,9 +1181,10 @@ allocateFastString BinDictionary { bin_dict_next = j_r,
writeIORef out_r $! addToUFM_Directly out uniq (j, f)
return (fromIntegral j :: Word32)
-data BinDictionary = BinDictionary {
- bin_dict_next :: !FastMutInt, -- The next index to use
- bin_dict_map :: !(IORef (UniqFM FastString (Int,FastString)))
+-- FSTable is an exact copy of Haddock.InterfaceFile.BinDictionary. We rename to
+-- avoid a collision and copy to avoid a dependency.
+data FSTable = FSTable { fs_tab_next :: !FastMutInt -- The next index to use
+ , fs_tab_map :: !(IORef (UniqFM FastString (Int,FastString)))
-- indexed by FastString
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee6f41ddb1d8ad45959d0fec5d7f61f1fd0141cd...08fec920f375a1eb8fb88872c569ec47047f0f71
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/ee6f41ddb1d8ad45959d0fec5d7f61f1fd0141cd...08fec920f375a1eb8fb88872c569ec47047f0f71
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220913/58a3a2ac/attachment-0001.html>
More information about the ghc-commits
mailing list