Typeable overhaul (see #5275)
[ghc.git] / libraries / base / 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 import GHC.IO.Encoding
30 import GHC.Foreign
31
32 import GHC.Fingerprint.Type
33
34 -- for SIZEOF_STRUCT_MD5CONTEXT:
35 #include "HsBaseConfig.h"
36
37 fingerprint0 :: Fingerprint
38 fingerprint0 = Fingerprint 0 0
39
40 instance Storable Fingerprint where
41 sizeOf _ = 16
42 alignment _ = 8
43 peek = peekFingerprint
44 poke = pokeFingerprint
45
46 -- peek/poke in fixed BIG-endian 128-bit format
47 peekFingerprint :: Ptr Fingerprint -> IO Fingerprint
48 peekFingerprint p = do
49 let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64
50 peekW64 _ 0 !i = return i
51 peekW64 !p !n !i = do
52 w8 <- peek p
53 peekW64 (p `plusPtr` 1) (n-1)
54 ((i `shiftL` 8) .|. fromIntegral w8)
55
56 high <- peekW64 (castPtr p) 8 0
57 low <- peekW64 (castPtr p `plusPtr` 8) 8 0
58 return (Fingerprint high low)
59
60 pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO ()
61 pokeFingerprint p (Fingerprint high low) = do
62 let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO ()
63 pokeW64 p 0 !i = return ()
64 pokeW64 p !n !i = do
65 pokeElemOff p (n-1) (fromIntegral i)
66 pokeW64 p (n-1) (i `shiftR` 8)
67
68 pokeW64 (castPtr p) 8 high
69 pokeW64 (castPtr p `plusPtr` 8) 8 low
70
71 fingerprintFingerprints :: [Fingerprint] -> Fingerprint
72 fingerprintFingerprints fs = unsafeDupablePerformIO $
73 withArrayLen fs $ \len p -> do
74 fingerprintData (castPtr p) (len * sizeOf (head fs))
75
76 fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
77 fingerprintData buf len = do
78 allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
79 c_MD5Init pctxt
80 c_MD5Update pctxt buf (fromIntegral len)
81 allocaBytes 16 $ \pdigest -> do
82 c_MD5Final pdigest pctxt
83 peekFingerprint (castPtr pdigest)
84
85 fingerprintString :: String -> Fingerprint
86 fingerprintString str = unsafeDupablePerformIO $
87 GHC.Foreign.withCStringLen utf8 str $ \(p,len) ->
88 fingerprintData (castPtr p) len
89
90 data MD5Context
91
92 foreign import ccall unsafe "MD5Init"
93 c_MD5Init :: Ptr MD5Context -> IO ()
94 foreign import ccall unsafe "MD5Update"
95 c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
96 foreign import ccall unsafe "MD5Final"
97 c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO ()