| ... |
... |
@@ -47,9 +47,11 @@ import qualified Data.ByteString as BS |
|
47
|
47
|
import Data.Traversable
|
|
48
|
48
|
import GHC.Utils.Logger
|
|
49
|
49
|
import GHC.Linker.Types
|
|
50
|
|
-import System.IO.Unsafe (unsafeInterleaveIO)
|
|
|
50
|
+import System.IO.Unsafe (unsafeInterleaveIO, unsafePerformIO)
|
|
51
|
51
|
import GHC.Utils.Outputable
|
|
52
|
|
-import GHC.Utils.Fingerprint (Fingerprint, fingerprintByteString)
|
|
|
52
|
+import GHC.Utils.Fingerprint (Fingerprint)
|
|
|
53
|
+import GHC.Types.Name.Env
|
|
|
54
|
+import GHC.Iface.Recomp.Binary (putNameLiterally, fingerprintBinMem)
|
|
53
|
55
|
|
|
54
|
56
|
{- Note [Overview of persistent bytecode]
|
|
55
|
57
|
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| ... |
... |
@@ -289,12 +291,8 @@ writeBinByteCode f cbc = do |
|
289
|
291
|
|
|
290
|
292
|
fingerprintModuleByteCodeContents :: Module -> CompiledByteCode -> [FilePath] -> IO Fingerprint
|
|
291
|
293
|
fingerprintModuleByteCodeContents modl cbc foreign_files = do
|
|
292
|
|
- bh' <- openBinMem (1024 * 1024)
|
|
293
|
|
- bh <- addBinNameWriter bh'
|
|
294
|
294
|
foreign_contents <- readObjectFiles foreign_files
|
|
295
|
|
- putWithUserData QuietBinIFace NormalCompression bh
|
|
296
|
|
- (modl, cbc, foreign_contents)
|
|
297
|
|
- withBinBuffer bh (pure . fingerprintByteString)
|
|
|
295
|
+ pure $ computeFingerprint2 putNameLiterally (modl, cbc, foreign_contents)
|
|
298
|
296
|
|
|
299
|
297
|
instance Binary CompiledByteCode where
|
|
300
|
298
|
get bh = do
|
| ... |
... |
@@ -397,8 +395,30 @@ putViaBinName :: WriteBinHandle -> Name -> IO () |
|
397
|
395
|
putViaBinName bh nm = case findUserDataWriter Proxy bh of
|
|
398
|
396
|
BinaryWriter f -> f bh $ BinName nm
|
|
399
|
397
|
|
|
|
398
|
+data BytecodeNameEnv = ByteCodeNameEnv { _bytecode_next_id :: !Word64
|
|
|
399
|
+ , _bytecode_name_subst :: NameEnv Word64
|
|
|
400
|
+ }
|
|
|
401
|
+
|
|
|
402
|
+
|
|
|
403
|
+computeFingerprint2 :: (Binary a)
|
|
|
404
|
+ => (WriteBinHandle -> Name -> IO ())
|
|
|
405
|
+ -> a
|
|
|
406
|
+ -> Fingerprint
|
|
|
407
|
+computeFingerprint2 put_nonbinding_name a = unsafePerformIO $ do
|
|
|
408
|
+ bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block
|
|
|
409
|
+ bh' <- addBinNameWriter bh
|
|
|
410
|
+ put_ bh' a
|
|
|
411
|
+ fingerprintBinMem bh'
|
|
|
412
|
+ where
|
|
|
413
|
+ set_user_data bh = setWriterUserData bh $ mkWriterUserData
|
|
|
414
|
+ [ mkSomeBinaryWriter $ mkWriter put_nonbinding_name
|
|
|
415
|
+ , mkSomeBinaryWriter $ simpleBindingNameWriter $ mkWriter putNameLiterally
|
|
|
416
|
+ , mkSomeBinaryWriter $ mkWriter putFS
|
|
|
417
|
+ ]
|
|
|
418
|
+
|
|
400
|
419
|
addBinNameWriter :: WriteBinHandle -> IO WriteBinHandle
|
|
401
|
|
-addBinNameWriter bh' =
|
|
|
420
|
+addBinNameWriter bh' = do
|
|
|
421
|
+ env_ref <- newIORef (ByteCodeNameEnv 0 emptyNameEnv)
|
|
402
|
422
|
evaluate
|
|
403
|
423
|
$ flip addWriterToUserData bh'
|
|
404
|
424
|
$ BinaryWriter
|
| ... |
... |
@@ -409,10 +429,17 @@ addBinNameWriter bh' = |
|
409
|
429
|
put_ bh nm
|
|
410
|
430
|
| otherwise -> do
|
|
411
|
431
|
putByte bh 1
|
|
412
|
|
- put_ bh
|
|
413
|
|
- $ occNameFS (occName nm)
|
|
414
|
|
- `appendFS` mkFastString
|
|
415
|
|
- (show $ nameUnique nm)
|
|
|
432
|
+ key <- getBinNameKey env_ref nm
|
|
|
433
|
+ -- Delimit the OccName from the deterministic counter to keep the
|
|
|
434
|
+ -- encoding injective, avoiding collisions like "foo1" vs "foo#1".
|
|
|
435
|
+ put_ bh (occNameFS (occName nm) `appendFS` mkFastString ('#' : show key))
|
|
|
436
|
+ where
|
|
|
437
|
+ -- Find a deterministic key for local names. This
|
|
|
438
|
+ getBinNameKey ref name = do
|
|
|
439
|
+ atomicModifyIORef ref (\b@(ByteCodeNameEnv next subst) ->
|
|
|
440
|
+ case lookupNameEnv subst name of
|
|
|
441
|
+ Just idx -> (b, idx)
|
|
|
442
|
+ Nothing -> (ByteCodeNameEnv (next + 1) (extendNameEnv subst name next), next))
|
|
416
|
443
|
|
|
417
|
444
|
addBinNameReader :: HscEnv -> ReadBinHandle -> IO ReadBinHandle
|
|
418
|
445
|
addBinNameReader HscEnv {..} bh' = do
|
| ... |
... |
@@ -438,9 +465,6 @@ addBinNameReader HscEnv {..} bh' = do |
|
438
|
465
|
|
|
439
|
466
|
-- Note [Serializing Names in bytecode]
|
|
440
|
467
|
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
441
|
|
--- NOTE: This approach means that bytecode objects are not deterministic.
|
|
442
|
|
--- We need to revisit this in order to make the output deterministic.
|
|
443
|
|
---
|
|
444
|
468
|
-- The bytecode related types contain various Names which we need to
|
|
445
|
469
|
-- serialize. Unfortunately, we can't directly use the Binary instance
|
|
446
|
470
|
-- of Name: it is only meant to be used for serializing external Names
|
| ... |
... |
@@ -448,9 +472,8 @@ addBinNameReader HscEnv {..} bh' = do |
|
448
|
472
|
--
|
|
449
|
473
|
-- We also need to maintain the invariant that: any pair of internal
|
|
450
|
474
|
-- Names with equal/different uniques must also be deserialized to
|
|
451
|
|
--- have the same equality. So normally uniques aren't supposed to be
|
|
452
|
|
--- serialized, but for this invariant to work, we do append uniques to
|
|
453
|
|
--- OccNames of internal Names, so that they can be uniquely identified
|
|
454
|
|
--- by OccName alone. When deserializing, we check a global cached
|
|
455
|
|
--- mapping from OccName to Unique, and create the real Name with the
|
|
456
|
|
--- right Unique if it's already deserialized at least once. |
|
|
475
|
+-- have the same equality. Therefore when we write the names to the interface, we
|
|
|
476
|
+-- use an incrementing counter to give each local name it's own unique number. A substitution
|
|
|
477
|
+-- is maintained to give each occurence of the Name the same unique key. When the interface
|
|
|
478
|
+-- is read, a reverse mapping is used from these unique keys to a Name.
|
|
|
479
|
+-- |