blob: e1a0f8177f9ddcefab140f90411dca49bda58685 (
plain)
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
|
{-# LANGUAGE CPP #-}
-- | Computing fingerprints of values serializeable with GHC's "Binary" module.
module BinFingerprint
( -- * Computing fingerprints
fingerprintBinMem
, computeFingerprint
, putNameLiterally
) where
#include "HsVersions.h"
import GhcPrelude
import Fingerprint
import Binary
import Binary.Unsafe (runBuffer)
import Name
import PlainPanic
import Util
fingerprintBinMem :: BinData -> 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)
=> (Name -> Put ())
-> a
-> IO Fingerprint
computeFingerprint put_nonbinding_name a = do
bd <- runBuffer (3 * 1024) (setUserData (put a)) -- just less than a block
fingerprintBinMem bd
where
setUserData =
writeState 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 :: Name -> Put ()
putNameLiterally name = ASSERT( isExternalName name ) do
put $! nameModule name
put $! nameOccName name
|
