Sync the typeable fingerprinting with GHC
[packages/base.git] / GHC / Fingerprint.hs
1 {-# LANGUAGE NoImplicitPrelude
2 , BangPatterns
3 , ForeignFunctionInterface
4 , EmptyDataDecls
5 #-}
6 -- ----------------------------------------------------------------------------
7 --
8 -- (c) The University of Glasgow 2006
9 --
10 -- Fingerprints for recompilation checking and ABI versioning, and
11 -- implementing fast comparison of Typeable.
12 --
13 -- ----------------------------------------------------------------------------
14
15 module GHC.Fingerprint (
16 Fingerprint(..), fingerprint0,
17 fingerprintData,
18 fingerprintString,
19 fingerprintFingerprints
20 ) where
21
22 import GHC.IO
23 import GHC.Base
24 import GHC.Num
25 import GHC.List
26 import GHC.Real
27 import Foreign
28 import Foreign.C
29
30 import GHC.Fingerprint.Type
31
32 -- for SIZEOF_STRUCT_MD5CONTEXT:
33 #include "HsBaseConfig.h"
34
35 -- XXX instance Storable Fingerprint
36 -- defined in Foreign.Storable to avoid orphan instance
37
38 fingerprint0 :: Fingerprint
39 fingerprint0 = Fingerprint 0 0
40
41 fingerprintFingerprints :: [Fingerprint] -> Fingerprint
42 fingerprintFingerprints fs = unsafeDupablePerformIO $
43 withArrayLen fs $ \len p -> do
44 fingerprintData (castPtr p) (len * sizeOf (head fs))
45
46 fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
47 fingerprintData buf len = do
48 allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
49 c_MD5Init pctxt
50 c_MD5Update pctxt buf (fromIntegral len)
51 allocaBytes 16 $ \pdigest -> do
52 c_MD5Final pdigest pctxt
53 peek (castPtr pdigest :: Ptr Fingerprint)
54
55 -- This is duplicated in compiler/utils/Fingerprint.hsc
56 fingerprintString :: String -> Fingerprint
57 fingerprintString str = unsafeDupablePerformIO $
58 withArrayLen word8s $ \len p ->
59 fingerprintData p len
60 where word8s = concatMap f str
61 f c = let w32 :: Word32
62 w32 = fromIntegral (ord c)
63 in [fromIntegral (w32 `shiftR` 24),
64 fromIntegral (w32 `shiftR` 16),
65 fromIntegral (w32 `shiftR` 8),
66 fromIntegral w32]
67
68 data MD5Context
69
70 foreign import ccall unsafe "MD5Init"
71 c_MD5Init :: Ptr MD5Context -> IO ()
72 foreign import ccall unsafe "MD5Update"
73 c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
74 foreign import ccall unsafe "MD5Final"
75 c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO ()