Separate FatNoun type into FatNoun+FatAtom.

pkg/hs-urbit/lib/Noun/Cue/Fast.hs

@@ -158,7 +158,7 @@ instance Monad Get where
 --------------------------------------------------------------------------------
 
 badEncoding :: Ptr Word -> S -> String -> IO a
-badEncoding endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg
+badEncoding !endPtr s msg = throwIO $ BadEncoding (endPtr,s) msg
 
 --------------------------------------------------------------------------------
 
@@ -167,19 +167,19 @@ getPos = Get $ \_ _ s ->
   pure (GetResult s (pos s))
 
 insRef :: Word -> FatNoun -> Get ()
-insRef pos now = Get \_ tbl s -> do
+insRef !pos !now = Get \_ tbl s -> do
   H.insert tbl pos now
   pure $ GetResult s ()
 
 getRef :: Word -> Get FatNoun
-getRef ref = Get \x tbl s -> do
+getRef !ref = Get \x tbl s -> do
   H.lookup tbl ref >>= \case
     Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s
     Just no -> pure (GetResult s no)
 
 advance :: Word -> Get ()
 advance 0 = debugM "advance: 0" >> pure ()
-advance n = Get \_ _ s -> do
+advance !n = Get \_ _ s -> do
   debugM ("advance: " <> show n)
   let newUsed = n + usedBits s
       newS    = s { pos      = pos s + n
@@ -246,7 +246,7 @@ dWord = do
     - Construct a bit-vector using the buffer*length*offset.
 -}
 dAtomBits :: Word -> Get Atom
-dAtomBits (fromIntegral -> bits) = do
+dAtomBits !(fromIntegral -> bits) = do
     debugMId ("dAtomBits(" <> show bits <> ")") $ do
       fmap (view $ from atomWords) $
         VP.generateM bufSize \i -> do
@@ -286,12 +286,12 @@ peekWord = do
   pure res
 
 swiz :: Word -> (Word, Word) -> Word
-swiz (fromIntegral -> off) (low, hig) =
+swiz !(fromIntegral -> off) (!low, !hig) =
   (.|.) (shiftR low off) (shiftL hig (64-off))
 
 takeLowBits :: Word -> Word -> Word
-takeLowBits 64  wor = wor
+takeLowBits 64   !wor = wor
-takeLowBits wid wor = (2^wid - 1) .&. wor
+takeLowBits !wid !wor = (2^wid - 1) .&. wor
 
 {-|
   Make a word from the next n bits (where n <= 64).
@@ -302,7 +302,7 @@ takeLowBits wid wor = (2^wid - 1) .&. wor
   - Return the word.
 -}
 dWordBits :: Word -> Get Word
-dWordBits n = do
+dWordBits !n = do
  debugMId ("dWordBits(" <> show n <> ")") $ do
   w <- peekWord
   advance n

pkg/hs-urbit/lib/Noun/Fat.hs

@@ -2,11 +2,12 @@
     Nouns with Pre-Computed Hash for each node.
 -}
 
-{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MagicHash, Strict #-}
 {-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-}
+{-# OPTIONS_GHC -funbox-strict-fields #-}
 
-module Noun.Fat ( FatNoun(..)
+module Noun.Fat ( FatNoun(..), FatAtom(..)
-                , fatSize, fatHash
+                , fatSize
                 , fatCell, fatAtom
                 , toFatNoun, fromFatNoun
                 ) where
@@ -25,66 +26,85 @@ import Noun                      (Noun(Atom, Cell))
 
 --------------------------------------------------------------------------------
 
+data FatAtom
+    = FatWord !Word
+    | FatBigN !Int !BigNat
+
 data FatNoun
-    = FatCell {-# UNPACK #-} !Int
+    = FatCell !Int !Word !FatNoun !FatNoun
-              !Word
+    | FatAtom !FatAtom
-              !FatNoun
-              !FatNoun
-    | FatWord {-# UNPACK #-} !Word
-    | FatAtom {-# UNPACK #-} !Int
-              {-# UNPACK #-} !BigNat
 
 
 --------------------------------------------------------------------------------
 
-instance Hashable FatNoun where
+instance Hashable FatAtom where
-  hash = fatHash
+  hash = atomHash
   {-# INLINE hash #-}
   hashWithSalt = defaultHashWithSalt
   {-# INLINE hashWithSalt #-}
 
+instance Hashable FatNoun where
+  hash = nounHash
+  {-# INLINE hash #-}
+  hashWithSalt = defaultHashWithSalt
+  {-# INLINE hashWithSalt #-}
+
+instance Eq FatAtom where
+  (==) x y =
+    case reallyUnsafePtrEquality# x y of
+      1# -> True
+      _  -> case (x, y) of
+              (FatWord w1,    FatWord w2      ) -> w1==w2
+              (FatBigN x1 a1, FatBigN x2 a2   ) -> x1==x2 && a1==a2
+              _                                 -> False
+  {-# INLINE (==) #-}
+
 instance Eq FatNoun where
   (==) x y =
     case reallyUnsafePtrEquality# x y of
       1# -> True
       _  -> case (x, y) of
-              (FatWord w1,       FatWord w2      ) ->
+              (FatAtom a1, FatAtom a2) ->
-                  w1==w2
+                  a1 == a2
-              (FatAtom x1 a1,    FatAtom x2 a2   ) ->
-                  x1==x2 && a1==a2
               (FatCell x1 s1 h1 t1, FatCell x2 s2 h2 t2) ->
                   s1==s2 && x1==x2 && h1==h2 && t1==t2
-              (_,                _               ) ->
+              _ ->
                   False
   {-# INLINE (==) #-}
 
 
 --------------------------------------------------------------------------------
 
+{-# INLINE fatSize #-}
 fatSize :: FatNoun -> Word
 fatSize = \case
   FatCell _ s _ _ -> s
   _               -> 1
 
-{-# INLINE fatHash #-}
+{-# INLINE atomHash #-}
-fatHash :: FatNoun -> Int
+atomHash :: FatAtom -> Int
-fatHash = \case
+atomHash = \case
+  FatBigN h _ -> h
+  FatWord w   -> hash w
+
+{-# INLINE nounHash #-}
+nounHash :: FatNoun -> Int
+nounHash = \case
   FatCell h _ _ _ -> h
-  FatAtom h _     -> h
+  FatAtom a       -> hash a
-  FatWord w       -> hash w
 
 {-# INLINE fatAtom #-}
 fatAtom :: Atom -> FatNoun
 fatAtom = \case
-  MkAtom   (NatS# wd) -> FatWord (W# wd)
+  MkAtom   (NatS# wd) -> FatAtom $ FatWord (W# wd)
-  MkAtom n@(NatJ# bn) -> FatAtom (hash bn) bn
+  MkAtom n@(NatJ# bn) -> FatAtom $ FatBigN (hash bn) bn
 
 {-# INLINE fatCell #-}
 fatCell :: FatNoun -> FatNoun -> FatNoun
 fatCell h t = FatCell has siz h t
   where
     siz = fatSize h + fatSize t
-    has = fatHash h `combine` fatHash t
+    has = nounHash h `combine` nounHash t
 
 {-# INLINE toFatNoun #-}
 toFatNoun :: Noun -> FatNoun
@@ -97,9 +117,9 @@ toFatNoun = go
 fromFatNoun :: FatNoun -> Noun
 fromFatNoun = go
   where go = \case
-          FatAtom _ a     -> Atom (MkAtom $ NatJ# a)
+          FatCell _ _ h t       -> Cell (go h) (go t)
-          FatCell _ _ h t -> Cell (go h) (go t)
+          FatAtom (FatBigN _ a) -> Atom (MkAtom $ NatJ# a)
-          FatWord w       -> Atom (fromIntegral w)
+          FatAtom (FatWord w)   -> Atom (fromIntegral w)
 
 
 -- Stolen from Hashable Library ------------------------------------------------

pkg/hs-urbit/lib/Noun/Jam/Fast.hs

@@ -4,13 +4,13 @@
 module Noun.Jam.Fast (jam, jamBS, jamFat, jamFatBS) where
 
 import ClassyPrelude hiding (hash)
+import Noun.Fat
 
 import Control.Lens              (view, to, from)
 import Data.Bits                 (shiftL, shiftR, setBit, clearBit, xor, (.|.))
 import Noun.Atom                 (Atom(MkAtom), toAtom, bitWidth, takeBitsWord)
 import Noun.Atom                 (wordBitWidth, wordBitWidth# , atomBitWidth#)
 import Noun                      (Noun(Atom, Cell))
-import Noun.Fat
 import Noun.Pill                 (bigNatWords, atomBS)
 import Data.Vector.Primitive     ((!))
 import Foreign.Marshal.Alloc     (callocBytes, free)
@@ -192,7 +192,7 @@ writeAtomWord (W# w) = writeAtomWord# w
 -}
 {-# INLINE writeAtomBigNat #-}
 writeAtomBigNat :: BigNat -> Put ()
-writeAtomBigNat (view bigNatWords -> words) = do
+writeAtomBigNat !(view bigNatWords -> words) = do
   let lastIdx = VP.length words - 1
   for_ [0..(lastIdx-1)] \i ->
       writeWord (words ! i)
@@ -243,16 +243,16 @@ instance Monad Put where
 --------------------------------------------------------------------------------
 
 doPut :: H.CuckooHashTable Word Word -> Word -> Put () -> ByteString
-doPut tbl sz m =
+doPut !tbl !sz m =
     unsafePerformIO $ do
         -- traceM "doPut"
         buf <- callocBytes (fromIntegral (wordSz*8))
         _   <- runPut (m >> mbFlush) tbl (S buf 0 0 0)
         BS.unsafePackCStringFinalizer (castPtr buf) byteSz (free buf)
   where
-    wordSz = fromIntegral (sz `divUp` 64)
+    !wordSz = fromIntegral (sz `divUp` 64)
-    byteSz = fromIntegral (sz `divUp` 8)
+    !byteSz = fromIntegral (sz `divUp` 8)
-    divUp  = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1)
+    !divUp  = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1)
 
     mbFlush :: Put ()
     mbFlush = do
@@ -266,12 +266,12 @@ doPut tbl sz m =
     TODO Handle back references
 -}
 writeNoun :: FatNoun -> Put ()
-writeNoun n =
+writeNoun !n =
   getRef >>= \case
     Just bk -> writeBackRef bk
-    Nothing -> case n of FatAtom _ n     -> writeAtom (MkAtom $ NatJ# n)
+    Nothing -> case n of FatAtom (FatBigN _ n)    -> writeAtom(MkAtom $ NatJ# n)
-                         FatWord (W# w)  -> writeAtom (MkAtom $ NatS# w)
+                         FatAtom (FatWord (W# w)) -> writeAtom(MkAtom $ NatS# w)
-                         FatCell _ _ h t -> writeCell h t
+                         FatCell _ _ h t          -> writeCell h t
 
 {-# INLINE writeMat #-}
 writeMat :: Atom -> Put ()
@@ -286,7 +286,7 @@ writeMat atm = do
 
 {-# INLINE writeCell #-}
 writeCell :: FatNoun -> FatNoun -> Put ()
-writeCell h t = do
+writeCell !h !t = do
     writeBit True
     writeBit False
     writeNoun h
@@ -294,13 +294,13 @@ writeCell h t = do
 
 {-# INLINE writeAtom #-}
 writeAtom :: Atom -> Put ()
-writeAtom a = do
+writeAtom !a = do
     writeBit False
     writeMat a
 
 {-# INLINE writeBackRef #-}
 writeBackRef :: Word -> Put ()
-writeBackRef a = do
+writeBackRef !a = do
     p <- pos <$> getS
     writeBit True
     writeBit True
@@ -311,7 +311,7 @@ writeBackRef a = do
 
 {-# INLINE matSz #-}
 matSz :: Atom -> Word
-matSz a = W# (matSz# a)
+matSz !a = W# (matSz# a)
 
 {-# INLINE matSz# #-}
 matSz# :: Atom -> Word#
@@ -323,11 +323,11 @@ matSz# a = preW `plusWord#` preW `plusWord#` atmW
 
 {-# INLINE atomSz #-}
 atomSz :: Atom -> Word
-atomSz = (1+) . matSz
+atomSz !w = 1 + matSz w
 
 {-# INLINE refSz #-}
 refSz :: Word -> Word
-refSz = (1+) . jamWordSz
+refSz !w = 1 + jamWordSz w
 
 {-# INLINE jamWordSz #-}
 jamWordSz :: Word -> Word
@@ -338,25 +338,26 @@ jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW)
     preW = wordBitWidth# atmW
 
 compress :: FatNoun -> IO (Word, H.CuckooHashTable Word Word)
-compress top = do
+compress !top = do
     let sz = max 50
            $ min 10_000_000
-           $ 2 * (10 ^ (floor $ logBase 600 (fromIntegral $ fatSize top)))
+           $ (2*) $ (10^) $ floor $ logBase 600 $ fromIntegral $ fatSize top
 
     nodes :: H.BasicHashTable  FatNoun Word <- H.newSized sz
     backs :: H.CuckooHashTable Word    Word <- H.newSized sz
 
     let proc :: Word -> FatNoun -> IO Word
-        proc pos = \case
+        proc !pos = \case
-            n@(FatAtom _ a) -> pure $ atomSz (MkAtom (NatJ# a))
+            FatAtom atm -> case atm of
-            FatWord w       -> pure (jamWordSz w)
+                n@(FatBigN _ a) -> pure $ atomSz $ MkAtom $ NatJ# a
+                FatWord w       -> pure (jamWordSz w)
             FatCell _ _ h t -> do
                 !hSz <- go (pos+2) h
                 !tSz <- go (pos+2+hSz) t
                 pure (2+hSz+tSz)
 
         go :: Word -> FatNoun -> IO Word
-        go p inp = do
+        go !p !inp = do
             H.lookup nodes inp >>= \case
                 Nothing -> do
                     H.insert nodes inp p
@@ -366,10 +367,10 @@ compress top = do
                         doRef = H.insert backs p bak $> rs
                         noRef = proc p inp
                     case inp of
-                        FatCell _ _ _ _                              -> doRef
+                        FatCell _ _ _ _                                        -> doRef
-                        FatWord w   | rs < atomSz (fromIntegral w)   -> doRef
+                        FatAtom (FatWord w)   | rs < atomSz (fromIntegral w)   -> doRef
-                        FatAtom _ a | rs < atomSz (MkAtom (NatJ# a)) -> doRef
+                        FatAtom (FatBigN _ a) | rs < atomSz (MkAtom (NatJ# a)) -> doRef
-                        _                                            -> noRef
+                        _                                                      -> noRef
 
     res <- go 0 top
 
@@ -380,8 +381,8 @@ compress top = do
 
 {-# INLINE combine #-}
 combine :: Int -> Int -> Int
-combine h1 h2 = (h1 * 16777619) `xor` h2
+combine !h1 !h2 = (h1 * 16777619) `xor` h2
 
 {-# INLINE defaultHashWithSalt #-}
 defaultHashWithSalt :: Hashable a => Int -> a -> Int
-defaultHashWithSalt salt x = salt `combine` Hash.hash x
+defaultHashWithSalt !salt !x = salt `combine` Hash.hash x

pkg/hs-urbit/lib/Noun/Lens.hs

@@ -38,16 +38,15 @@ dumpJam fp = writeFile fp . view (re _CueFatBytes)
 
 tryCuePill :: PillFile -> IO ()
 tryCuePill pill =
-    loadNoun (show pill) >>= \case Nothing            -> print "nil"
+    loadNoun (show pill) >>= \case Nothing          -> print "nil"
-                                   Just (FatAtom _ _) -> print "atom"
+                                   Just (FatAtom _) -> print "atom"
-                                   Just (FatWord _)   -> print "word"
+                                   _                -> print "cell"
-                                   _                  -> print "cell"
 
 tryCueJamPill :: PillFile -> IO ()
 tryCueJamPill pill = do
   n <- loadNoun (show pill) >>= \case
-         Nothing                  -> print "failure" >> pure (FatWord 0)
+         Nothing                  -> print "failure" >> pure (FatAtom $ FatWord 0)
-         Just n@(FatAtom _ _)     -> print "atom"    >> pure n
+         Just n@(FatAtom _)       -> print "atom"    >> pure n
          Just n@(FatCell _ _ _ _) -> print "cell"    >> pure n
 
   bs <- evaluate (force (jamFatBS n))