1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
{-# LANGUAGE CPP #-}
-- | Computing fingerprints of values serializeable with GHC's \"Binary\" module.
module GHC.Iface.Recomp.Binary
( -- * Computing fingerprints
fingerprintBinMem
, computeFingerprint
, putNameLiterally
) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Utils.Fingerprint
import GHC.Utils.Binary
import GHC.Types.Name
import GHC.Utils.Panic.Plain
import GHC.Utils.Misc
fingerprintBinMem :: BinHandle -> IO Fingerprint
fingerprintBinMem bh = withBinBuffer bh f
where
f bs =
-- we need to take care that we force the result here
-- lest a reference to the ByteString may leak out of
-- withBinBuffer.
let fp = fingerprintByteString bs
in fp `seq` return fp
computeFingerprint :: (Binary a)
=> (BinHandle -> Name -> IO ())
-> a
-> IO Fingerprint
computeFingerprint put_nonbinding_name a = do
bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block
put_ bh a
fp <- fingerprintBinMem bh
return fp
where
set_user_data bh =
setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS
-- | Used when we want to fingerprint a structure without depending on the
-- fingerprints of external Names that it refers to.
putNameLiterally :: BinHandle -> Name -> IO ()
putNameLiterally bh name = ASSERT( isExternalName name ) do
put_ bh $! nameModule name
put_ bh $! nameOccName name
|
