Merge pull request #3916 from urbit/pp/mug

king: Rationalize implementation of mug

pkg/hs/urbit-king/lib/Urbit/Vere/Ames/Packet.hs

@@ -53,9 +53,7 @@ instance Serialize Packet where
     lookAhead $ do
       len  <- remaining
       body <- getBytes len
-      -- XX mug (marked "TODO") is implemented as "slowMug" in U.N.Tree. Ominous
+      let chk = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
-      -- Also, toNoun will copy the bytes into an atom. We probably want a mugBS
-      let chk = fromIntegral (mug $ toNoun $ MkBytes body) .&. (2 ^ 20 - 1)
       when (checksum /= chk) $
         fail ("checksum mismatch: expected " <> show checksum
            <> "; got " <> show chk)
@@ -84,8 +82,7 @@ instance Serialize Packet where
     let (sndR, putSndr) = putShipGetRank pktSndr
     let (rcvR, putRcvr) = putShipGetRank pktRcvr
     let body = runPut (putSndr <> putRcvr <> putByteString load)
-    -- XX again maybe mug can be made better here
+    let chek = fromIntegral (mugBS body) .&. (2 ^ 20 - 1)
-    let chek = fromIntegral (mug $ toNoun $ MkBytes body) .&. (2 ^ 20 - 1)
     let encr = pktEncrypted
     let vers = fromIntegral pktVersion .&. 0b111
     let head =        vers

pkg/hs/urbit-king/test/HoonMapSetTests.hs

@@ -70,7 +70,7 @@ treeRTMug inp = do
     non <- cueBSExn byt
     tee <- fromNounExn non
     mug <- evaluate $ mug $ toNoun $ treeTestsIdentity tee
-    pure $ Text.Lazy.Encoding.encodeUtf8 $ tlshow (mug :: Natural)
+    pure $ Text.Lazy.Encoding.encodeUtf8 $ tlshow mug
 
 goldenPill
     :: TestName

pkg/hs/urbit-noun-core/lib/Urbit/Noun/Core.hs

@@ -14,11 +14,13 @@ module Urbit.Noun.Core
   , pattern Cell, pattern Atom
   , pattern C, pattern A
   , textToUtf8Atom, utf8AtomToText
+  , mug
   ) where
 
 import ClassyPrelude hiding (hash)
 
 import Urbit.Atom
+import Urbit.Noun.Mug
 
 import Data.Bits                 (xor)
 import Data.Function             ((&))
@@ -34,8 +36,8 @@ import qualified Data.Char as C
 -- Types -----------------------------------------------------------------------
 
 data Noun
-    = NCell Int Word !Noun !Noun
+    = NCell ~Mug Word Noun Noun
-    | NAtom Int !Atom
+    | NAtom ~Mug Atom
 
 pattern Cell :: Noun -> Noun -> Noun
 pattern Atom :: Atom -> Noun
@@ -57,10 +59,9 @@ pattern A a   <- NAtom _ a     where A = mkAtom
 --------------------------------------------------------------------------------
 
 instance Hashable Noun where
-  hash = \case NCell h _ _ _ -> h
+  hash = fromIntegral . mug
-               NAtom h _     -> h
   {-# INLINE hash #-}
-  hashWithSalt = defaultHashWithSalt
+  hashWithSalt salt x = salt `combine` hash x
   {-# INLINE hashWithSalt #-}
 
 textToUtf8Atom :: Text -> Noun
@@ -146,6 +147,10 @@ genAtom = do
     False -> genNatural
     True  -> (`mod` 16) <$> genNatural
 
+-- From http://hackage.haskell.org/package/hashable-1.2.7.0/docs/src/Data-Hashable-Class.html
+combine :: Int -> Int -> Int
+combine h1 h2 = (h1 * 16777619) `xor` h2
+
 --------------------------------------------------------------------------------
 
 {-# INLINE nounSize #-}
@@ -154,24 +159,18 @@ nounSize = \case
   NCell _ s _ _ -> s
   NAtom _ _     -> 1
 
+{-# INLINE mug #-}
+mug :: Noun -> Mug
+mug = \case NCell h _ _ _ -> h
+            NAtom h _     -> h
+
 {-# INLINE mkAtom #-}
 mkAtom :: Atom -> Noun
-mkAtom a = NAtom (hash a) a
+mkAtom a = NAtom (mugAtom a) a
 
 {-# INLINE mkCell #-}
 mkCell :: Noun -> Noun -> Noun
 mkCell h t = NCell has siz h t
   where
     siz = nounSize h + nounSize t
-    has = hash h `combine` hash t
+    has = mugBoth (mug h) (mug t)
-
-
--- Stolen from Hashable Library ------------------------------------------------
-
-{-# INLINE combine #-}
-combine :: Int -> Int -> Int
-combine h1 h2 = (h1 * 16777619) `xor` h2
-
-{-# INLINE defaultHashWithSalt #-}
-defaultHashWithSalt :: Hashable a => Int -> a -> Int
-defaultHashWithSalt salt x = salt `combine` hash x

pkg/hs/urbit-noun-core/lib/Urbit/Noun/Mug.hs

@@ -0,0 +1,32 @@
+{-# OPTIONS_GHC -O2 #-}
+
+module Urbit.Noun.Mug where
+
+import ClassyPrelude
+
+import Data.Bits
+import Urbit.Atom
+
+import Data.Hash.Murmur (murmur3)
+
+type Mug = Word32
+
+{-# INLINE mugBS #-}
+mugBS :: ByteString -> Word32
+mugBS = go 0xcafebabe
+  where
+    go seed buf =
+      let haz = murmur3 seed buf
+          ham = shiftR haz 31 `xor` (haz .&. 0x7fff_ffff)
+      in if ham == 0
+        then go (seed + 1) buf
+        else ham
+
+-- XX is there a way to do this without copy?
+{-# INLINE mugAtom #-}
+mugAtom :: Atom -> Word32
+mugAtom = mugBS . atomBytes
+
+{-# INLINE mugBoth #-}
+mugBoth :: Word32 -> Word32 -> Word32
+mugBoth m n = mugAtom $ fromIntegral $ m `xor` 0x7fff_ffff `xor` n

pkg/hs/urbit-noun-core/package.yaml

@@ -25,6 +25,7 @@ dependencies:
   - vector
   - integer-gmp
   - template-haskell
+  - murmur3
 
 default-extensions:
   - ApplicativeDo

pkg/hs/urbit-noun/lib/Urbit/Noun.hs

@@ -11,6 +11,7 @@ module Urbit.Noun
     , module Urbit.Noun.Core
     , module Urbit.Noun.Cue
     , module Urbit.Noun.Jam
+    , module Urbit.Noun.Mug
     , module Urbit.Noun.Tank
     , module Urbit.Noun.TH
     , module Urbit.Noun.Tree
@@ -29,6 +30,7 @@ import Urbit.Noun.Convert
 import Urbit.Noun.Core
 import Urbit.Noun.Cue
 import Urbit.Noun.Jam
+import Urbit.Noun.Mug
 import Urbit.Noun.Tank
 import Urbit.Noun.TH
 import Urbit.Noun.Tree

pkg/hs/urbit-noun/lib/Urbit/Noun/Conversions.hs

@@ -10,7 +10,7 @@ module Urbit.Noun.Conversions
   , BigTape(..), BigCord(..)
   , Wain(..), Wall, Each(..)
   , UD(..), UV(..), UW(..), cordToUW
-  , Mug(..), Path(..), EvilPath(..), Ship(..)
+  , Path(..), EvilPath(..), Ship(..)
   , Lenient(..), pathToFilePath, filePathToPath
   , showUD, tshowUD
   , textAsTa
@@ -639,11 +639,6 @@ filePathToPath fp = Path path
       ('.':xs) -> xs
       x        -> x
 
--- Mug -------------------------------------------------------------------------
-
-newtype Mug = Mug Word32
-  deriving newtype (Eq, Ord, Show, Num, ToNoun, FromNoun)
-
 
 -- Bool ------------------------------------------------------------------------
 

pkg/hs/urbit-noun/lib/Urbit/Noun/Tree.hs

@@ -7,22 +7,16 @@
 module Urbit.Noun.Tree
     ( HoonSet, setToHoonSet, setFromHoonSet
     , HoonMap, mapToHoonMap, mapFromHoonMap
-    , mug
     ) where
 
 import ClassyPrelude
 import Control.Lens  hiding (non)
 
-import Urbit.Atom
 import Urbit.Noun.Conversions ()
 import Urbit.Noun.Convert
 import Urbit.Noun.Core
 import Urbit.Noun.TH
 
-import Data.Bits        (shiftR, xor)
-import Data.Hash.Murmur (murmur3)
-import GHC.Natural      (Natural)
-
 
 -- Types -----------------------------------------------------------------------
 
@@ -79,67 +73,6 @@ instance FromNoun a => FromNoun (HoonTree a) where
 deriveNoun ''HoonTreeNode
 
 
--- Mug -------------------------------------------------------------------------
-
-type Nat = Natural
-
-slowMug :: Noun -> Nat
-slowMug = trim 0xcafe_babe . \case
-    A a   -> a
-    C h t -> mix (slowMug h) $ mix 0x7fff_ffff (slowMug t)
-  where
-    trim :: Nat -> Nat -> Nat
-    trim syd key =
-        if 0/=ham then ham else trim (succ syd) key
-      where
-        haz = muk syd (met 3 key) key
-        ham = mix (rsh 0 31 haz) (end 0 31 haz)
-
-mix :: Nat -> Nat -> Nat
-mix = xor
-
--- Murmur3
-muk :: Nat -> Nat -> Nat -> Nat
-muk seed len =
-    fromIntegral . murmur3 (word32 seed) . resize . atomBytes
-  where
-    resize :: ByteString -> ByteString
-    resize buf =
-      case compare (length buf) (int len) of
-          EQ -> buf
-          LT -> error "bad-muk"
-          GT -> error "bad-muk"
---        LT -> buf <> replicate (len - length buf) 0
---        GT -> take len buf
-
-int :: Integral i => i -> Int
-int = fromIntegral
-
-word32 :: Integral i => i -> Word32
-word32 = fromIntegral
-
-bex :: Nat -> Nat
-bex = (2^)
-
-end :: Nat -> Nat -> Nat -> Nat
-end blockSize blocks n =
-  n `mod` (bex (bex blockSize * blocks))
-
-rsh :: Nat -> Nat -> Nat -> Nat
-rsh blockSize blocks n =
-    shiftR n $ fromIntegral $ (bex blockSize * blocks)
-
-met :: Nat -> Nat -> Nat
-met bloq = go 0
-  where
-    go c 0 = c
-    go c n = go (succ c) (rsh bloq 1 n)
-
--- XX TODO
-mug :: Noun -> Nat
-mug = slowMug
-
-
 -- Order -----------------------------------------------------------------------
 
 {-
@@ -148,8 +81,8 @@ mug = slowMug
 mor :: Noun -> Noun -> Bool
 mor a b = if c == d then dor a b else c < d
   where
-    c = mug $ A $ mug a
+    c = mug $ A $ fromIntegral $ mug a
-    d = mug $ A $ mug b
+    d = mug $ A $ fromIntegral $ mug b
 
 {-
     Orders in ascending tree depth.