Typeable overhaul (see #5275)
authorSimon Marlow <marlowsd@gmail.com>
Fri, 8 Jul 2011 09:39:24 +0000 (10:39 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 11 Jul 2011 09:26:27 +0000 (10:26 +0100)
Instances of Typeable used to call mkTyCon:

  mkTyCon :: String -> TyCon

which internally kept a table mapping Strings to Ints, so that each
TyCon could be given a unique Int for fast comparison.  This meant the
String has to be unique across all types in the program.  However,
derived instances of typeable used the qualified original
name (e.g. "GHC.Types.Int") which is not necessarily unique, is
non-portable, and exposes implementation details.

The String passed to mkTyCon is returned by

  tyConString :: TyCon -> String

which let the user get at this non-portable representation (also the
Show instance returns this String).

Now we store three Strings in TyCon.  The internal representation is
this:

data TyCon = TyCon {
   tyConHash    :: {-# UNPACK #-} !Fingerprint,
   tyConPackage :: String,
   tyConModule  :: String,
   tyConName    :: String
 }

(internal representations are now provided by Data.Typeable.Internal)

The fields of TyCon are not exposed via the public API.  Together the
three fields tyConPackage, tyConModule and tyConName uniquely identify
a TyCon, and the Fingerprint is a hash of the concatenation of these
three Strings (so no more internal cache to map strings to unique
Ids). tyConString now returns the value of tyConName only, so is
therefore portable (but the String returned does not uniquely
identify the TyCon).

I've measured the performance impact of this change, and performance
seems to be uniformly better.  This should improve things for SYB in
particular.  Also, the size of the code generated for deriving
Typeable is less than half as much as before.

== API changes ==

=== mkTyCon is DEPRECATED ==

mkTyCon is used by some hand-written instances of Typeable.  It still
works as before, but is deprecated in favour of...

=== Add mkTyCon3 ===

  mkTyCon3 :: String -> String -> String -> TyCon

mkTyCon3 takes the package, module, and name of the TyCon respectively.
Most users can just derive Typeable, there's no need to use mkTyCon3.

In due course we can rename mkTyCon3 back to mkTyCon.

=== typeRepKey changed ===

Previously we had

  typeRepKey :: TypeRep -> IO Int

but since we don't assign unique Ints to TypeReps any more, this is
difficult to implement.  Instead we provide an abstract key type which
is an instance of Eq and Ord, and internally is implemented by the
fingerprint:

  data TypeRepKey -- abstract, instance of Eq, Ord
  typeRepKey :: TypeRep -> IO TypeRepKey

typeRepKey is still in the IO monad, because the Ord instance is
implementation-defined.

13 files changed:
Data/Typeable.hs
Data/Typeable.hs-boot
Data/Typeable/Internal.hs [new file with mode: 0644]
Data/Typeable/Internal.hs-boot [new file with mode: 0644]
Foreign/C/Types.hs
GHC/Exception.lhs
GHC/Fingerprint.hs [new file with mode: 0644]
GHC/Fingerprint.hs-boot [new file with mode: 0644]
GHC/Fingerprint/Type.hs [new file with mode: 0644]
base.cabal
cbits/md5.c [new file with mode: 0644]
configure.ac
include/md5.h [new file with mode: 0644]

index 8180790..c8ad3cf 100644 (file)
@@ -49,11 +49,14 @@ module Data.Typeable
 
         -- * Type representations
         TypeRep,        -- abstract, instance of: Eq, Show, Typeable
-        TyCon,          -- abstract, instance of: Eq, Show, Typeable
         showsTypeRep,
 
+        TyCon,          -- abstract, instance of: Eq, Show, Typeable
+        tyConString,    -- :: TyCon   -> String
+
         -- * Construction of type representations
         mkTyCon,        -- :: String  -> TyCon
+        mkTyCon3,       -- :: String  -> String -> String -> TyCon
         mkTyConApp,     -- :: TyCon   -> [TypeRep] -> TypeRep
         mkAppTy,        -- :: TypeRep -> TypeRep   -> TypeRep
         mkFunTy,        -- :: TypeRep -> TypeRep   -> TypeRep
@@ -63,8 +66,8 @@ module Data.Typeable
         funResultTy,    -- :: TypeRep -> TypeRep   -> Maybe TypeRep
         typeRepTyCon,   -- :: TypeRep -> TyCon
         typeRepArgs,    -- :: TypeRep -> [TypeRep]
-        tyConString,    -- :: TyCon   -> String
-        typeRepKey,     -- :: TypeRep -> IO Int
+        typeRepKey,     -- :: TypeRep -> IO TypeRepKey
+        TypeRepKey,     -- abstract, instance of Eq, Ord
 
         -- * The other Typeable classes
         -- | /Note:/ The general instances are provided for GHC only.
@@ -91,6 +94,8 @@ module Data.Typeable
 
   ) where
 
+import Data.Typeable.Internal hiding (mkTyCon)
+
 import qualified Data.HashTable as HT
 import Data.Maybe
 import Data.Int
@@ -121,6 +126,13 @@ import GHC.Stable       ( StablePtr, newStablePtr, freeStablePtr,
                           castPtrToStablePtr )
 import GHC.Arr          ( Array, STArray )
 
+import GHC.Fingerprint.Type
+import {-# SOURCE #-} GHC.Fingerprint
+   -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
+   -- Better to break the loop here, because we want non-SOURCE imports
+   -- of Data.Typeable as much as possible so we can optimise the derived
+   -- instances.
+
 #endif
 
 #ifdef __HUGS__
@@ -145,30 +157,6 @@ import Array    ( Array )
 
 #include "Typeable.h"
 
-#ifndef __HUGS__
-
--------------------------------------------------------------
---
---              Type representations
---
--------------------------------------------------------------
-
--- | A concrete representation of a (monomorphic) type.  'TypeRep'
--- supports reasonably efficient equality.
-data TypeRep = TypeRep !Key TyCon [TypeRep] 
-
--- Compare keys for equality
-instance Eq TypeRep where
-  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
-
--- | An abstract representation of a type constructor.  'TyCon' objects can
--- be built using 'mkTyCon'.
-data TyCon = TyCon !Key String
-
-instance Eq TyCon where
-  (TyCon t1 _) == (TyCon t2 _) = t1 == t2
-#endif
-
 -- | Returns a unique integer associated with a 'TypeRep'.  This can
 -- be used for making a mapping with TypeReps
 -- as the keys, for example.  It is guaranteed that @t1 == t2@ if and only if
@@ -179,8 +167,8 @@ instance Eq TyCon where
 -- the equality property, not any actual key value.  The relative ordering
 -- of keys has no meaning either.
 --
-typeRepKey :: TypeRep -> IO Int
-typeRepKey (TypeRep (Key i) _ _) = return i
+typeRepKey :: TypeRep -> IO TypeRepKey
+typeRepKey (TypeRep f _ _) = return (TypeRepKey f)
 
         -- 
         -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
@@ -193,12 +181,19 @@ typeRepKey (TypeRep (Key i) _ _) = return i
         -- sequence of commas, e.g., (mkTyCon ",,,,") returns
         -- the 5-tuple tycon.
 
+newtype TypeRepKey = TypeRepKey Fingerprint
+  deriving (Eq,Ord)
+
 ----------------- Construction --------------------
 
 -- | Applies a type constructor to a sequence of types
 mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
-mkTyConApp tc@(TyCon tc_k _) args 
-  = TypeRep (appKeys tc_k arg_ks) tc args
+mkTyConApp tc@(TyCon tc_k _ _ _) []
+  = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
+                       -- end up here, and it helps generate smaller
+                       -- code for derived Typeable.
+mkTyConApp tc@(TyCon tc_k _ _ _) args
+  = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
   where
     arg_ks = [k | TypeRep k _ _ <- args]
 
@@ -225,7 +220,7 @@ funResultTy trFun trArg
 mkAppTy :: TypeRep -> TypeRep -> TypeRep
 mkAppTy (TypeRep tr_k tc trs) arg_tr
   = let (TypeRep arg_k _ _) = arg_tr
-     in  TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr])
+     in  TypeRep (fingerprintFingerprints [tr_k,arg_k]) tc (trs++[arg_tr])
 
 -- If we enforce the restriction that there is only one
 -- @TyCon@ for a type & it is shared among all its uses,
@@ -242,14 +237,22 @@ mkAppTy (TypeRep tr_k tc trs) arg_tr
 -- | Builds a 'TyCon' object representing a type constructor.  An
 -- implementation of "Data.Typeable" should ensure that the following holds:
 --
--- >  mkTyCon "a" == mkTyCon "a"
+-- >  A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
 --
 
-mkTyCon :: String       -- ^ the name of the type constructor (should be unique
-                        -- in the program, so it might be wise to use the
-                        -- fully qualified name).
+--
+mkTyCon3 :: String       -- ^ package name
+         -> String       -- ^ module name
+         -> String       -- ^ the name of the type constructor
+         -> TyCon        -- ^ A unique 'TyCon' object
+mkTyCon3 pkg modl name =
+  TyCon (fingerprintString (pkg++modl++name)) pkg modl name
+
+{-# DEPRECATED mkTyCon "use mkTyCon3 instead" #-}
+-- | Backwards-compatible API
+mkTyCon :: String       -- ^ unique string
         -> TyCon        -- ^ A unique 'TyCon' object
-mkTyCon str = TyCon (mkTyConKey str) str
+mkTyCon name = TyCon (fingerprintString name) "" "" name
 
 ----------------- Observation ---------------------
 
@@ -263,7 +266,7 @@ typeRepArgs (TypeRep _ _ args) = args
 
 -- | Observe string encoding of a type representation
 tyConString :: TyCon   -> String
-tyConString  (TyCon _ str) = str
+tyConString = tyConName
 
 ----------------- Showing TypeReps --------------------
 
@@ -287,11 +290,11 @@ showsTypeRep :: TypeRep -> ShowS
 showsTypeRep = shows
 
 instance Show TyCon where
-  showsPrec _ (TyCon _ s) = showString s
+  showsPrec _ t = showString (tyConName t)
 
 isTupleTyCon :: TyCon -> Bool
-isTupleTyCon (TyCon _ ('(':',':_)) = True
-isTupleTyCon _                     = False
+isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
+isTupleTyCon _                         = False
 
 -- Some (Show.TypeRep) helpers:
 
@@ -596,7 +599,7 @@ libraries/base/Data/Typeable.hs:589:1:
 -}
 instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
 funTc :: TyCon
-funTc = mkTyCon "->"
+funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
 #else
 INSTANCE_TYPEABLE2((->),funTc,"->")
 #endif
@@ -679,96 +682,7 @@ libraries/base/Data/Typeable.hs:674:1:
     In the stand-alone deriving instance for `Typeable RealWorld'
 -}
 realWorldTc :: TyCon; \
-realWorldTc = mkTyCon "GHC.Base.RealWorld"; \
+realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
 instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
 
 #endif
-
----------------------------------------------
---
---              Internals 
---
----------------------------------------------
-
-#ifndef __HUGS__
-newtype Key = Key Int deriving( Eq )
-#endif
-
-data KeyPr = KeyPr !Key !Key deriving( Eq )
-
-hashKP :: KeyPr -> Int32
-hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
-
-data Cache = Cache { next_key :: !(IORef Key),  -- Not used by GHC (calls genSym instead)
-                     tc_tbl   :: !(HT.HashTable String Key),
-                     ap_tbl   :: !(HT.HashTable KeyPr Key) }
-
-{-# NOINLINE cache #-}
-#ifdef __GLASGOW_HASKELL__
-foreign import ccall unsafe "RtsTypeable.h getOrSetTypeableStore"
-    getOrSetTypeableStore :: Ptr a -> IO (Ptr a)
-#endif
-
-cache :: Cache
-cache = unsafePerformIO $ do
-                empty_tc_tbl <- HT.new (==) HT.hashString
-                empty_ap_tbl <- HT.new (==) hashKP
-                key_loc      <- newIORef (Key 1) 
-                let ret = Cache {       next_key = key_loc,
-                                        tc_tbl = empty_tc_tbl, 
-                                        ap_tbl = empty_ap_tbl }
-#ifdef __GLASGOW_HASKELL__
-                mask_ $ do
-                        stable_ref <- newStablePtr ret
-                        let ref = castStablePtrToPtr stable_ref
-                        ref2 <- getOrSetTypeableStore ref
-                        if ref==ref2
-                                then deRefStablePtr stable_ref
-                                else do
-                                        freeStablePtr stable_ref
-                                        deRefStablePtr
-                                                (castPtrToStablePtr ref2)
-#else
-                return ret
-#endif
-
-newKey :: IORef Key -> IO Key
-#ifdef __GLASGOW_HASKELL__
-newKey _ = do i <- genSym; return (Key i)
-#else
-newKey kloc = do { k@(Key i) <- readIORef kloc ;
-                   writeIORef kloc (Key (i+1)) ;
-                   return k }
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-foreign import ccall unsafe "genSymZh"
-  genSym :: IO Int
-#endif
-
-mkTyConKey :: String -> Key
-mkTyConKey str 
-  = unsafePerformIO $ do
-        let Cache {next_key = kloc, tc_tbl = tbl} = cache
-        mb_k <- HT.lookup tbl str
-        case mb_k of
-          Just k  -> return k
-          Nothing -> do { k <- newKey kloc ;
-                          HT.insert tbl str k ;
-                          return k }
-
-appKey :: Key -> Key -> Key
-appKey k1 k2
-  = unsafePerformIO $ do
-        let Cache {next_key = kloc, ap_tbl = tbl} = cache
-        mb_k <- HT.lookup tbl kpr
-        case mb_k of
-          Just k  -> return k
-          Nothing -> do { k <- newKey kloc ;
-                          HT.insert tbl kpr k ;
-                          return k }
-  where
-    kpr = KeyPr k1 k2
-
-appKeys :: Key -> [Key] -> Key
-appKeys k ks = foldl appKey k ks
index da6142e..38ba334 100644 (file)
@@ -4,11 +4,8 @@ module Data.Typeable where
 
 import Data.Maybe
 import GHC.Base
+import {-# SOURCE #-} Data.Typeable.Internal
 
-data TypeRep
-data TyCon
-
-mkTyCon      :: String -> TyCon
 mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep
 
 cast :: (Typeable a, Typeable b) => a -> Maybe b
diff --git a/Data/Typeable/Internal.hs b/Data/Typeable/Internal.hs
new file mode 100644 (file)
index 0000000..1f4f644
--- /dev/null
@@ -0,0 +1,59 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Typeable.Internal
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2011
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- The representations of the types TyCon and TypeRep, and the
+-- function mkTyCon which is used by derived instances of Typeable to
+-- construct a TyCon.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE NoImplicitPrelude,
+             MagicHash #-}
+module Data.Typeable.Internal (
+    TypeRep(..),
+    TyCon(..),
+    mkTyCon
+  ) where
+
+import GHC.Base
+import GHC.Word
+import GHC.Fingerprint.Type
+
+-- | A concrete representation of a (monomorphic) type.  'TypeRep'
+-- supports reasonably efficient equality.
+data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep]
+
+-- Compare keys for equality
+instance Eq TypeRep where
+  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
+
+-- | An abstract representation of a type constructor.  'TyCon' objects can
+-- be built using 'mkTyCon'.
+data TyCon = TyCon {
+   tyConHash    :: {-# UNPACK #-} !Fingerprint,
+   tyConPackage :: String,
+   tyConModule  :: String,
+   tyConName    :: String
+ }
+
+instance Eq TyCon where
+  (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
+
+#include "MachDeps.h"
+
+-- mkTyCon is an internal function to make it easier for GHC to
+-- generate derived instances.  GHC precomputes the MD5 hash for the
+-- TyCon and passes it as two separate 64-bit values to mkTyCon.  The
+-- TyCon for a derived Typeable instance will end up being statically
+-- allocated.
+
+#if WORD_SIZE_IN_BITS < 64
+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
+#else
+mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
+#endif
+mkTyCon high# low# pkg modl name
+  = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
diff --git a/Data/Typeable/Internal.hs-boot b/Data/Typeable/Internal.hs-boot
new file mode 100644 (file)
index 0000000..7539eb0
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
+module Data.Typeable.Internal (
+    TypeRep,
+    TyCon,
+    mkTyCon
+  ) where
+
+import GHC.Base
+
+data TypeRep
+data TyCon
+
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS < 64
+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
+#else
+mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
+#endif
index c571049..9bb7642 100644 (file)
@@ -96,6 +96,8 @@ import Data.Bits        ( Bits(..) )
 import Data.Int         ( Int8,  Int16,  Int32,  Int64  )
 import Data.Word        ( Word8, Word16, Word32, Word64 )
 import {-# SOURCE #-} Data.Typeable
+  -- loop: Data.Typeable -> Data.List -> Data.Char -> GHC.Unicode
+  --            -> Foreign.C.Type
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
index 87d85d8..bffc35c 100644 (file)
@@ -25,6 +25,7 @@ module GHC.Exception where
 
 import Data.Maybe
 import {-# SOURCE #-} Data.Typeable (Typeable, cast)
+   -- loop: Data.Typeable -> GHC.Err -> GHC.Exception
 import GHC.Base
 import GHC.Show
 \end{code}
diff --git a/GHC/Fingerprint.hs b/GHC/Fingerprint.hs
new file mode 100644 (file)
index 0000000..9059e0d
--- /dev/null
@@ -0,0 +1,97 @@
+{-# LANGUAGE NoImplicitPrelude
+           , BangPatterns
+           , ForeignFunctionInterface
+           , EmptyDataDecls
+  #-}
+-- ----------------------------------------------------------------------------
+-- 
+--  (c) The University of Glasgow 2006
+--
+-- Fingerprints for recompilation checking and ABI versioning, and
+-- implementing fast comparison of Typeable.
+--
+-- ----------------------------------------------------------------------------
+
+module GHC.Fingerprint (
+        Fingerprint(..), fingerprint0, 
+        fingerprintData,
+        fingerprintString,
+        fingerprintFingerprints
+   ) where
+
+import GHC.IO
+import GHC.Base
+import GHC.Num
+import GHC.List
+import GHC.Real
+import Foreign
+import Foreign.C
+import GHC.IO.Encoding
+import GHC.Foreign
+
+import GHC.Fingerprint.Type
+
+-- for SIZEOF_STRUCT_MD5CONTEXT:
+#include "HsBaseConfig.h"
+
+fingerprint0 :: Fingerprint
+fingerprint0 = Fingerprint 0 0
+
+instance Storable Fingerprint where
+  sizeOf _ = 16
+  alignment _ = 8
+  peek = peekFingerprint
+  poke = pokeFingerprint
+
+-- peek/poke in fixed BIG-endian 128-bit format
+peekFingerprint :: Ptr Fingerprint -> IO Fingerprint
+peekFingerprint p = do
+      let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64
+          peekW64 _  0  !i = return i
+          peekW64 !p !n !i = do
+                w8 <- peek p
+                peekW64 (p `plusPtr` 1) (n-1) 
+                    ((i `shiftL` 8) .|. fromIntegral w8)
+
+      high <- peekW64 (castPtr p) 8 0
+      low  <- peekW64 (castPtr p `plusPtr` 8) 8 0
+      return (Fingerprint high low)
+
+pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO ()
+pokeFingerprint p (Fingerprint high low) = do
+      let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO ()
+          pokeW64 p 0  !i = return ()
+          pokeW64 p !n !i = do
+                pokeElemOff p (n-1) (fromIntegral i)
+                pokeW64 p (n-1) (i `shiftR` 8)
+
+      pokeW64 (castPtr p) 8 high
+      pokeW64 (castPtr p `plusPtr` 8) 8 low
+
+fingerprintFingerprints :: [Fingerprint] -> Fingerprint
+fingerprintFingerprints fs = unsafeDupablePerformIO $
+  withArrayLen fs $ \len p -> do
+    fingerprintData (castPtr p) (len * sizeOf (head fs))
+
+fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
+fingerprintData buf len = do
+  allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
+    c_MD5Init pctxt
+    c_MD5Update pctxt buf (fromIntegral len)
+    allocaBytes 16 $ \pdigest -> do
+      c_MD5Final pdigest pctxt
+      peekFingerprint (castPtr pdigest)
+
+fingerprintString :: String -> Fingerprint
+fingerprintString str = unsafeDupablePerformIO $
+  GHC.Foreign.withCStringLen utf8 str $ \(p,len) ->
+     fingerprintData (castPtr p) len
+
+data MD5Context
+
+foreign import ccall unsafe "MD5Init"
+   c_MD5Init   :: Ptr MD5Context -> IO ()
+foreign import ccall unsafe "MD5Update"
+   c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
+foreign import ccall unsafe "MD5Final"
+   c_MD5Final  :: Ptr Word8 -> Ptr MD5Context -> IO ()
diff --git a/GHC/Fingerprint.hs-boot b/GHC/Fingerprint.hs-boot
new file mode 100644 (file)
index 0000000..35fd354
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+module GHC.Fingerprint (
+        fingerprintString,
+        fingerprintFingerprints
+  ) where
+
+import GHC.Base
+import GHC.Fingerprint.Type
+
+fingerprintFingerprints :: [Fingerprint] -> Fingerprint
+fingerprintString :: String -> Fingerprint
+
diff --git a/GHC/Fingerprint/Type.hs b/GHC/Fingerprint/Type.hs
new file mode 100644 (file)
index 0000000..a0ca075
--- /dev/null
@@ -0,0 +1,19 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+-- ----------------------------------------------------------------------------
+-- 
+--  (c) The University of Glasgow 2006
+--
+-- Fingerprints for recompilation checking and ABI versioning, and
+-- implementing fast comparison of Typeable.
+--
+-- ----------------------------------------------------------------------------
+
+module GHC.Fingerprint.Type (Fingerprint(..)) where
+
+import GHC.Base
+import GHC.Word
+
+-- Using 128-bit MD5 fingerprints for now.
+
+data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
+  deriving (Eq, Ord)
index 3fb2af3..2897c65 100644 (file)
@@ -17,7 +17,7 @@ extra-tmp-files:
 extra-source-files:
                 config.guess config.sub install-sh
                 aclocal.m4 configure.ac configure
-                include/CTypes.h
+                include/CTypes.h include/md5.h
 
 source-repository head
     type:     git
@@ -51,6 +51,8 @@ Library {
             GHC.Err,
             GHC.Exception,
             GHC.Exts,
+            GHC.Fingerprint,
+            GHC.Fingerprint.Type,
             GHC.Float,
             GHC.Float.ConversionUtils,
             GHC.Float.RealFracMethods,
@@ -158,6 +160,7 @@ Library {
         Data.Traversable
         Data.Tuple,
         Data.Typeable,
+        Data.Typeable.Internal,
         Data.Unique,
         Data.Version,
         Data.Word,
@@ -218,6 +221,7 @@ Library {
         cbits/inputReady.c
         cbits/selectUtils.c
         cbits/primFloat.c
+        cbits/md5.c
     include-dirs: include
     includes:    HsBase.h
     install-includes:    HsBase.h HsBaseConfig.h EventConfig.h WCsubst.h consUtils.h Typeable.h
diff --git a/cbits/md5.c b/cbits/md5.c
new file mode 100644 (file)
index 0000000..0570cbb
--- /dev/null
@@ -0,0 +1,238 @@
+/*
+ * This code implements the MD5 message-digest algorithm.
+ * The algorithm is due to Ron Rivest.  This code was
+ * written by Colin Plumb in 1993, no copyright is claimed.
+ * This code is in the public domain; do with it what you wish.
+ *
+ * Equivalent code is available from RSA Data Security, Inc.
+ * This code has been tested against that, and is equivalent,
+ * except that you don't need to include two pages of legalese
+ * with every copy.
+ *
+ * To compute the message digest of a chunk of bytes, declare an
+ * MD5Context structure, pass it to MD5Init, call MD5Update as
+ * needed on buffers full of bytes, and then call MD5Final, which
+ * will fill a supplied 16-byte array with the digest.
+ */
+
+#include "HsFFI.h"
+#include "md5.h"
+#include <string.h>
+
+void MD5Init(struct MD5Context *context);
+void MD5Update(struct MD5Context *context, byte const *buf, int len);
+void MD5Final(byte digest[16], struct MD5Context *context);
+void MD5Transform(word32 buf[4], word32 const in[16]);
+
+
+/*
+ * Shuffle the bytes into little-endian order within words, as per the
+ * MD5 spec.  Note: this code works regardless of the byte order.
+ */
+void
+byteSwap(word32 *buf, unsigned words)
+{
+       byte *p = (byte *)buf;
+
+       do {
+               *buf++ = (word32)((unsigned)p[3] << 8 | p[2]) << 16 |
+                       ((unsigned)p[1] << 8 | p[0]);
+               p += 4;
+       } while (--words);
+}
+
+/*
+ * Start MD5 accumulation.  Set bit count to 0 and buffer to mysterious
+ * initialization constants.
+ */
+void
+MD5Init(struct MD5Context *ctx)
+{
+       ctx->buf[0] = 0x67452301;
+       ctx->buf[1] = 0xefcdab89;
+       ctx->buf[2] = 0x98badcfe;
+       ctx->buf[3] = 0x10325476;
+
+       ctx->bytes[0] = 0;
+       ctx->bytes[1] = 0;
+}
+
+/*
+ * Update context to reflect the concatenation of another buffer full
+ * of bytes.
+ */
+void
+MD5Update(struct MD5Context *ctx, byte const *buf, int len)
+{
+       word32 t;
+
+       /* Update byte count */
+
+       t = ctx->bytes[0];
+       if ((ctx->bytes[0] = t + len) < t)
+               ctx->bytes[1]++;        /* Carry from low to high */
+
+       t = 64 - (t & 0x3f);    /* Space available in ctx->in (at least 1) */
+       if ((unsigned)t > len) {
+               memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, len);
+               return;
+       }
+       /* First chunk is an odd size */
+       memcpy((byte *)ctx->in + 64 - (unsigned)t, buf, (unsigned)t);
+       byteSwap(ctx->in, 16);
+       MD5Transform(ctx->buf, ctx->in);
+       buf += (unsigned)t;
+       len -= (unsigned)t;
+
+       /* Process data in 64-byte chunks */
+       while (len >= 64) {
+               memcpy(ctx->in, buf, 64);
+               byteSwap(ctx->in, 16);
+               MD5Transform(ctx->buf, ctx->in);
+               buf += 64;
+               len -= 64;
+       }
+
+       /* Handle any remaining bytes of data. */
+       memcpy(ctx->in, buf, len);
+}
+
+/*
+ * Final wrapup - pad to 64-byte boundary with the bit pattern 
+ * 1 0* (64-bit count of bits processed, MSB-first)
+ */
+void
+MD5Final(byte digest[16], struct MD5Context *ctx)
+{
+       int count = (int)(ctx->bytes[0] & 0x3f); /* Bytes in ctx->in */
+       byte *p = (byte *)ctx->in + count;      /* First unused byte */
+
+       /* Set the first char of padding to 0x80.  There is always room. */
+       *p++ = 0x80;
+
+       /* Bytes of padding needed to make 56 bytes (-8..55) */
+       count = 56 - 1 - count;
+
+       if (count < 0) {        /* Padding forces an extra block */
+               memset(p, 0, count+8);
+               byteSwap(ctx->in, 16);
+               MD5Transform(ctx->buf, ctx->in);
+               p = (byte *)ctx->in;
+               count = 56;
+       }
+       memset(p, 0, count+8);
+       byteSwap(ctx->in, 14);
+
+       /* Append length in bits and transform */
+       ctx->in[14] = ctx->bytes[0] << 3;
+       ctx->in[15] = ctx->bytes[1] << 3 | ctx->bytes[0] >> 29;
+       MD5Transform(ctx->buf, ctx->in);
+
+       byteSwap(ctx->buf, 4);
+       memcpy(digest, ctx->buf, 16);
+       memset(ctx,0,sizeof(ctx));
+}
+
+
+/* The four core functions - F1 is optimized somewhat */
+
+/* #define F1(x, y, z) (x & y | ~x & z) */
+#define F1(x, y, z) (z ^ (x & (y ^ z)))
+#define F2(x, y, z) F1(z, x, y)
+#define F3(x, y, z) (x ^ y ^ z)
+#define F4(x, y, z) (y ^ (x | ~z))
+
+/* This is the central step in the MD5 algorithm. */
+#define MD5STEP(f,w,x,y,z,in,s) \
+        (w += f(x,y,z) + in, w = (w<<s | w>>(32-s)) + x)
+
+/*
+ * The core of the MD5 algorithm, this alters an existing MD5 hash to
+ * reflect the addition of 16 longwords of new data.  MD5Update blocks
+ * the data and converts bytes into longwords for this routine.
+ */
+
+void
+MD5Transform(word32 buf[4], word32 const in[16])
+{
+       register word32 a, b, c, d;
+
+       a = buf[0];
+       b = buf[1];
+       c = buf[2];
+       d = buf[3];
+
+       MD5STEP(F1, a, b, c, d, in[0] + 0xd76aa478, 7);
+       MD5STEP(F1, d, a, b, c, in[1] + 0xe8c7b756, 12);
+       MD5STEP(F1, c, d, a, b, in[2] + 0x242070db, 17);
+       MD5STEP(F1, b, c, d, a, in[3] + 0xc1bdceee, 22);
+       MD5STEP(F1, a, b, c, d, in[4] + 0xf57c0faf, 7);
+       MD5STEP(F1, d, a, b, c, in[5] + 0x4787c62a, 12);
+       MD5STEP(F1, c, d, a, b, in[6] + 0xa8304613, 17);
+       MD5STEP(F1, b, c, d, a, in[7] + 0xfd469501, 22);
+       MD5STEP(F1, a, b, c, d, in[8] + 0x698098d8, 7);
+       MD5STEP(F1, d, a, b, c, in[9] + 0x8b44f7af, 12);
+       MD5STEP(F1, c, d, a, b, in[10] + 0xffff5bb1, 17);
+       MD5STEP(F1, b, c, d, a, in[11] + 0x895cd7be, 22);
+       MD5STEP(F1, a, b, c, d, in[12] + 0x6b901122, 7);
+       MD5STEP(F1, d, a, b, c, in[13] + 0xfd987193, 12);
+       MD5STEP(F1, c, d, a, b, in[14] + 0xa679438e, 17);
+       MD5STEP(F1, b, c, d, a, in[15] + 0x49b40821, 22);
+
+       MD5STEP(F2, a, b, c, d, in[1] + 0xf61e2562, 5);
+       MD5STEP(F2, d, a, b, c, in[6] + 0xc040b340, 9);
+       MD5STEP(F2, c, d, a, b, in[11] + 0x265e5a51, 14);
+       MD5STEP(F2, b, c, d, a, in[0] + 0xe9b6c7aa, 20);
+       MD5STEP(F2, a, b, c, d, in[5] + 0xd62f105d, 5);
+       MD5STEP(F2, d, a, b, c, in[10] + 0x02441453, 9);
+       MD5STEP(F2, c, d, a, b, in[15] + 0xd8a1e681, 14);
+       MD5STEP(F2, b, c, d, a, in[4] + 0xe7d3fbc8, 20);
+       MD5STEP(F2, a, b, c, d, in[9] + 0x21e1cde6, 5);
+       MD5STEP(F2, d, a, b, c, in[14] + 0xc33707d6, 9);
+       MD5STEP(F2, c, d, a, b, in[3] + 0xf4d50d87, 14);
+       MD5STEP(F2, b, c, d, a, in[8] + 0x455a14ed, 20);
+       MD5STEP(F2, a, b, c, d, in[13] + 0xa9e3e905, 5);
+       MD5STEP(F2, d, a, b, c, in[2] + 0xfcefa3f8, 9);
+       MD5STEP(F2, c, d, a, b, in[7] + 0x676f02d9, 14);
+       MD5STEP(F2, b, c, d, a, in[12] + 0x8d2a4c8a, 20);
+
+       MD5STEP(F3, a, b, c, d, in[5] + 0xfffa3942, 4);
+       MD5STEP(F3, d, a, b, c, in[8] + 0x8771f681, 11);
+       MD5STEP(F3, c, d, a, b, in[11] + 0x6d9d6122, 16);
+       MD5STEP(F3, b, c, d, a, in[14] + 0xfde5380c, 23);
+       MD5STEP(F3, a, b, c, d, in[1] + 0xa4beea44, 4);
+       MD5STEP(F3, d, a, b, c, in[4] + 0x4bdecfa9, 11);
+       MD5STEP(F3, c, d, a, b, in[7] + 0xf6bb4b60, 16);
+       MD5STEP(F3, b, c, d, a, in[10] + 0xbebfbc70, 23);
+       MD5STEP(F3, a, b, c, d, in[13] + 0x289b7ec6, 4);
+       MD5STEP(F3, d, a, b, c, in[0] + 0xeaa127fa, 11);
+       MD5STEP(F3, c, d, a, b, in[3] + 0xd4ef3085, 16);
+       MD5STEP(F3, b, c, d, a, in[6] + 0x04881d05, 23);
+       MD5STEP(F3, a, b, c, d, in[9] + 0xd9d4d039, 4);
+       MD5STEP(F3, d, a, b, c, in[12] + 0xe6db99e5, 11);
+       MD5STEP(F3, c, d, a, b, in[15] + 0x1fa27cf8, 16);
+       MD5STEP(F3, b, c, d, a, in[2] + 0xc4ac5665, 23);
+
+       MD5STEP(F4, a, b, c, d, in[0] + 0xf4292244, 6);
+       MD5STEP(F4, d, a, b, c, in[7] + 0x432aff97, 10);
+       MD5STEP(F4, c, d, a, b, in[14] + 0xab9423a7, 15);
+       MD5STEP(F4, b, c, d, a, in[5] + 0xfc93a039, 21);
+       MD5STEP(F4, a, b, c, d, in[12] + 0x655b59c3, 6);
+       MD5STEP(F4, d, a, b, c, in[3] + 0x8f0ccc92, 10);
+       MD5STEP(F4, c, d, a, b, in[10] + 0xffeff47d, 15);
+       MD5STEP(F4, b, c, d, a, in[1] + 0x85845dd1, 21);
+       MD5STEP(F4, a, b, c, d, in[8] + 0x6fa87e4f, 6);
+       MD5STEP(F4, d, a, b, c, in[15] + 0xfe2ce6e0, 10);
+       MD5STEP(F4, c, d, a, b, in[6] + 0xa3014314, 15);
+       MD5STEP(F4, b, c, d, a, in[13] + 0x4e0811a1, 21);
+       MD5STEP(F4, a, b, c, d, in[4] + 0xf7537e82, 6);
+       MD5STEP(F4, d, a, b, c, in[11] + 0xbd3af235, 10);
+       MD5STEP(F4, c, d, a, b, in[2] + 0x2ad7d2bb, 15);
+       MD5STEP(F4, b, c, d, a, in[9] + 0xeb86d391, 21);
+
+       buf[0] += a;
+       buf[1] += b;
+       buf[2] += c;
+       buf[3] += d;
+}
+
index acfd48e..1db0c26 100644 (file)
@@ -167,6 +167,9 @@ FP_SEARCH_LIBS_PROTO(
     [AC_DEFINE([HAVE_LIBCHARSET], [1], [Define to 1 if you have libcharset.])
      EXTRA_LIBS="$EXTRA_LIBS $ac_lib"])
 
+# Hack - md5.h needs HsFFI.h.  Is there a better way to do this?
+CFLAGS="-I../../includes $CFLAGS"
+AC_CHECK_SIZEOF([struct MD5Context], ,[#include "include/md5.h"])
 
 AC_SUBST(EXTRA_LIBS)
 AC_CONFIG_FILES([base.buildinfo])
diff --git a/include/md5.h b/include/md5.h
new file mode 100644 (file)
index 0000000..8d375df
--- /dev/null
@@ -0,0 +1,24 @@
+/* MD5 message digest */
+#ifndef _MD5_H
+#define _MD5_H
+
+#include "HsFFI.h"
+
+typedef HsWord32 word32;
+typedef HsWord8  byte;
+
+struct MD5Context {
+       word32 buf[4];
+       word32 bytes[2];
+       word32 in[16];
+};
+
+void MD5Init(struct MD5Context *context);
+void MD5Update(struct MD5Context *context, byte const *buf, int len);
+void MD5Final(byte digest[16], struct MD5Context *context);
+void MD5Transform(word32 buf[4], word32 const in[16]);
+
+#endif /* _MD5_H */
+
+
+