urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-20 09:21:42 +03:00
Code Issues Packages Projects Releases Wiki Activity

Separate FatNoun type into FatNoun+FatAtom.

Browse Source
This commit is contained in:
Benjamin Summers 2019-07-09 14:57:48 -07:00
parent 0d057747cc
commit 3a379f4a0a
4 changed files with 91 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkg/hs-urbit/lib/Noun/Cue/Fast.hs
View File

@ -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 wid wor = (2^wid - 1) .&. wor
takeLowBits 64 !wor = 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

76
pkg/hs-urbit/lib/Noun/Fat.hs
View File

@ -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(..)
, fatSize, fatHash
module Noun.Fat ( FatNoun(..), FatAtom(..)
, 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
!Word
!FatNoun
!FatNoun
| FatWord {-# UNPACK #-} !Word
| FatAtom {-# UNPACK #-} !Int
{-# UNPACK #-} !BigNat
= FatCell !Int !Word !FatNoun !FatNoun
| FatAtom !FatAtom
--------------------------------------------------------------------------------
instance Hashable FatNoun where
hash = fatHash
instance Hashable FatAtom where
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 ) ->
w1==w2
(FatAtom x1 a1, FatAtom x2 a2 ) ->
x1==x2 && a1==a2
(FatAtom a1, FatAtom a2) ->
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 #-}
fatHash :: FatNoun -> Int
fatHash = \case
{-# INLINE atomHash #-}
atomHash :: FatAtom -> Int
atomHash = \case
FatBigN h _ -> h
FatWord w -> hash w
{-# INLINE nounHash #-}
nounHash :: FatNoun -> Int
nounHash = \case
FatCell h _ _ _ -> h
FatAtom h _ -> h
FatWord w -> hash w
FatAtom a -> hash a
{-# INLINE fatAtom #-}
fatAtom :: Atom -> FatNoun
fatAtom = \case
MkAtom (NatS# wd) -> FatWord (W# wd)
MkAtom n@(NatJ# bn) -> FatAtom (hash bn) bn
MkAtom (NatS# wd) -> FatAtom $ FatWord (W# wd)
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)
FatWord w -> Atom (fromIntegral w)
FatCell _ _ h t -> Cell (go h) (go t)
FatAtom (FatBigN _ a) -> Atom (MkAtom $ NatJ# a)
FatAtom (FatWord w) -> Atom (fromIntegral w)
-- Stolen from Hashable Library ------------------------------------------------

57
pkg/hs-urbit/lib/Noun/Jam/Fast.hs
View File

@ -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)
byteSz = fromIntegral (sz `divUp` 8)
divUp = \x y -> (x `div` y) + (if x `mod` y == 0 then 0 else 1)
!wordSz = fromIntegral (sz `divUp` 64)
!byteSz = fromIntegral (sz `divUp` 8)
!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)
FatWord (W# w) -> writeAtom (MkAtom $ NatS# w)
FatCell _ _ h t -> writeCell h t
Nothing -> case n of FatAtom (FatBigN _ n) -> writeAtom(MkAtom $ NatJ# n)
FatAtom (FatWord (W# w)) -> writeAtom(MkAtom $ NatS# w)
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
n@(FatAtom _ a) -> pure $ atomSz (MkAtom (NatJ# a))
FatWord w -> pure (jamWordSz w)
proc !pos = \case
FatAtom atm -> case atm of
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
FatWord w | rs < atomSz (fromIntegral w) -> doRef
FatAtom _ a | rs < atomSz (MkAtom (NatJ# a)) -> doRef
_ -> noRef
FatCell _ _ _ _ -> doRef
FatAtom (FatWord w) | rs < atomSz (fromIntegral w) -> doRef
FatAtom (FatBigN _ a) | rs < atomSz (MkAtom (NatJ# a)) -> doRef
_ -> 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

11
pkg/hs-urbit/lib/Noun/Lens.hs
View File

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