[Git][ghc/ghc][wip/js-staging] 3 commits: Some changes to Binary after reviews
Sylvain Henry (@hsyl20)
gitlab at gitlab.haskell.org
Tue Oct 25 10:50:32 UTC 2022
Sylvain Henry pushed to branch wip/js-staging at Glasgow Haskell Compiler / GHC
Commits:
68dd22fc by Sylvain Henry at 2022-10-25T12:35:43+02:00
Some changes to Binary after reviews
- - - - -
a1a4c02d by Sylvain Henry at 2022-10-25T12:37:31+02:00
Rename back defaultUserData into noUserData
- - - - -
f78ed436 by Sylvain Henry at 2022-10-25T12:53:58+02:00
Revert backpack change
- - - - -
5 changed files:
- compiler/GHC/StgToJS/CodeGen.hs
- compiler/GHC/StgToJS/Object.hs
- compiler/GHC/Unit/Types.hs
- compiler/GHC/Utils/Binary.hs
- testsuite/tests/backpack/should_compile/all.T
Changes:
=====================================
compiler/GHC/StgToJS/CodeGen.hs
=====================================
@@ -60,6 +60,8 @@ import GHC.Utils.Outputable hiding ((<>))
import qualified Data.Set as S
import Data.Monoid
import Control.Monad
+import System.Directory
+import System.FilePath
-- | Code generator for JavaScript
stgToJS
@@ -94,6 +96,8 @@ stgToJS logger config stg_binds0 this_mod spt_entries foreign_stubs cccs output_
-- Write the object file
bh <- openBinMem (4 * 1024 * 1000) -- a bit less than 4kB
Object.putObject bh (moduleName this_mod) deps (map luObjUnit lus)
+
+ createDirectoryIfMissing True (takeDirectory output_fn)
writeBinMem bh output_fn
=====================================
compiler/GHC/StgToJS/Object.hs
=====================================
@@ -293,7 +293,7 @@ getObjectBody :: BinHandle -> ModuleName -> IO Object
getObjectBody bh0 mod_name = do
-- Read the string table
dict <- forwardGet bh0 (getDictionary bh0)
- let bh = setUserData bh0 $ defaultUserData { ud_get_fs = getDictFastString dict }
+ let bh = setUserData bh0 $ noUserData { ud_get_fs = getDictFastString dict }
deps <- get bh
idx <- forwardGet bh (get bh)
=====================================
compiler/GHC/Unit/Types.hs
=====================================
@@ -36,7 +36,6 @@ module GHC.Unit.Types
, Instantiations
, GenInstantiations
, mkInstantiatedUnit
- , mkInstantiatedUnitSorted
, mkInstantiatedUnitHash
, mkVirtUnit
, mapGenUnit
@@ -308,7 +307,17 @@ instance Binary InstantiatedUnit where
put_ bh indef = do
put_ bh (instUnitInstanceOf indef)
put_ bh (instUnitInsts indef)
- get bh = mkInstantiatedUnitSorted <$> get bh <*> get bh
+ get bh = do
+ cid <- get bh
+ insts <- get bh
+ let fs = mkInstantiatedUnitHash cid insts
+ return InstantiatedUnit {
+ instUnitInstanceOf = cid,
+ instUnitInsts = insts,
+ instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+ instUnitFS = fs,
+ instUnitKey = getUnique fs
+ }
instance IsUnitId u => Eq (GenUnit u) where
uid1 == uid2 = unitUnique uid1 == unitUnique uid2
@@ -378,30 +387,18 @@ moduleFreeHoles (Module u _ ) = unitFreeModuleHoles u
-- | Create a new 'GenInstantiatedUnit' given an explicit module substitution.
mkInstantiatedUnit :: IsUnitId u => u -> GenInstantiations u -> GenInstantiatedUnit u
-mkInstantiatedUnit cid insts = mkInstantiatedUnitSorted cid sorted_insts
+mkInstantiatedUnit cid insts =
+ InstantiatedUnit {
+ instUnitInstanceOf = cid,
+ instUnitInsts = sorted_insts,
+ instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),
+ instUnitFS = fs,
+ instUnitKey = getUnique fs
+ }
where
+ fs = mkInstantiatedUnitHash cid sorted_insts
sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts
--- | Like mkInstantiatedUnit but assumes that instatiations are sorted
---
--- Useful to make deserialization code faster by not sorting instantiations
--- (that are stored sorted).
---
-mkInstantiatedUnitSorted
- :: IsUnitId u
- => u
- -> [(ModuleName, GenModule (GenUnit u))]
- -> GenInstantiatedUnit u
-mkInstantiatedUnitSorted cid insts =
- let fs = mkInstantiatedUnitHash cid insts
- in InstantiatedUnit
- { instUnitInstanceOf = cid
- , instUnitInsts = insts
- , instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles . snd) insts)
- , instUnitFS = fs
- , instUnitKey = getUnique fs
- }
-
-- | Smart constructor for instantiated GenUnit
mkVirtUnit :: IsUnitId u => u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u
=====================================
compiler/GHC/Utils/Binary.hs
=====================================
@@ -34,7 +34,7 @@ module GHC.Utils.Binary
SymbolTable, Dictionary,
BinData(..), dataHandle, handleData,
- packBinBuffer, unpackBinBuffer, unsafeUnpackBinBuffer,
+ unsafeUnpackBinBuffer,
openBinMem,
-- closeBin,
@@ -74,7 +74,7 @@ module GHC.Utils.Binary
-- * User data
UserData(..), getUserData, setUserData,
- newReadState, newWriteState, defaultUserData,
+ newReadState, newWriteState, noUserData,
-- * String table ("dictionary")
putDictionary, getDictionary, putFS,
@@ -117,8 +117,6 @@ import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO.Error ( mkIOError, eofErrorType )
import GHC.Real ( Ratio(..) )
import Data.IntMap (IntMap)
-import System.Directory
-import System.FilePath
import qualified Data.IntMap as IntMap
#if MIN_VERSION_base(4,15,0)
import GHC.ForeignPtr ( unsafeWithForeignPtr )
@@ -160,7 +158,7 @@ dataHandle (BinData size bin) = do
ixr <- newFastMutInt 0
szr <- newFastMutInt size
binr <- newIORef bin
- return (BinMem defaultUserData ixr szr binr)
+ return (BinMem noUserData ixr szr binr)
handleData :: BinHandle -> IO BinData
handleData (BinMem _ ixr _ binr) = BinData <$> readFastMutInt ixr <*> readIORef binr
@@ -192,30 +190,12 @@ withBinBuffer (BinMem _ ix_r _ arr_r) action = do
ix <- readFastMutInt ix_r
action $ BS.fromForeignPtr arr 0 ix
-packBinBuffer :: BinHandle -> IO ByteString
-packBinBuffer bh@(BinMem _ ix_r _ _) = do
- l <- readFastMutInt ix_r
- here <- tellBin bh
- seekBin bh (BinPtr 0)
- b <- BS.create l $ \dest -> do
- getPrim bh l (\src -> BS.memcpy dest src l)
- seekBin bh here
- return b
-
-unpackBinBuffer :: Int -> ByteString -> IO BinHandle
-unpackBinBuffer n from = do
- bh <- openBinMem n
- BS.unsafeUseAsCString from $ \ptr -> do
- putPrim bh n (\op -> BS.memcpy op (castPtr ptr) n)
- seekBin bh (BinPtr 0)
- return bh
-
unsafeUnpackBinBuffer :: ByteString -> IO BinHandle
unsafeUnpackBinBuffer (BS.BS arr len) = do
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt len
- return (BinMem defaultUserData ix_r sz_r arr_r)
+ return (BinMem noUserData ix_r sz_r arr_r)
---------------------------------------------------------------
-- Bin
@@ -258,7 +238,7 @@ openBinMem size
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt size
- return (BinMem defaultUserData ix_r sz_r arr_r)
+ return (BinMem noUserData ix_r sz_r arr_r)
tellBin :: BinHandle -> IO (Bin a)
tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
@@ -280,7 +260,6 @@ seekBinNoExpand (BinMem _ ix_r sz_r _) (BinPtr !p) = do
writeBinMem :: BinHandle -> FilePath -> IO ()
writeBinMem (BinMem _ ix_r _ arr_r) fn = do
- createDirectoryIfMissing True (takeDirectory fn)
h <- openBinaryFile fn WriteMode
arr <- readIORef arr_r
ix <- readFastMutInt ix_r
@@ -312,7 +291,7 @@ readBinMem_ filesize h = do
arr_r <- newIORef arr
ix_r <- newFastMutInt 0
sz_r <- newFastMutInt filesize
- return (BinMem defaultUserData ix_r sz_r arr_r)
+ return (BinMem noUserData ix_r sz_r arr_r)
-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
@@ -1117,8 +1096,8 @@ newWriteState put_nonbinding_name put_binding_name put_fs
ud_put_fs = put_fs
}
-defaultUserData :: UserData
-defaultUserData = UserData
+noUserData :: UserData
+noUserData = UserData
{ ud_get_name = undef "get_name"
, ud_get_fs = undef "get_fs"
, ud_put_nonbinding_name = undef "put_nonbinding_name"
=====================================
testsuite/tests/backpack/should_compile/all.T
=====================================
@@ -23,7 +23,7 @@ test('bkp28', normal, backpack_compile, [''])
test('bkp29', normal, backpack_compile, [''])
test('bkp30', normal, backpack_compile, [''])
test('bkp31', normal, backpack_compile, [''])
-test('bkp32', js_skip, backpack_compile, [''])
+test('bkp32', normal, backpack_compile, [''])
test('bkp33', normal, backpack_compile, [''])
test('bkp34', normal, backpack_compile, [''])
test('bkp35', normal, backpack_compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/868b8760545189b6294159969c5f9766308f2cf1...f78ed4369a22262efbbffd3d96ecc4f8ff568260
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/868b8760545189b6294159969c5f9766308f2cf1...f78ed4369a22262efbbffd3d96ecc4f8ff568260
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/20221025/57fd240c/attachment-0001.html>
More information about the ghc-commits
mailing list