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