From 221cb78c771bfe00105c356d5dcf8fe529443f1e Mon Sep 17 00:00:00 2001 From: Benjamin Summers Date: Wed, 3 Jul 2019 17:53:21 -0700 Subject: [PATCH] Jam and cue are both quite fast now! 5 seconds to load+jam+cue all three pills. --- pkg/hs-urbit/lib/Noun/Cue/Fast.hs | 29 ++- pkg/hs-urbit/lib/Noun/Fat.hs | 408 ++++++++++++++++++++++++++++++ pkg/hs-urbit/lib/Noun/Jam/Fast.hs | 107 +++----- pkg/hs-urbit/lib/Noun/Lens.hs | 40 +-- pkg/hs-vere/app/uterm/Main.hs | 12 +- pkg/hs-vere/package.yaml | 4 +- stack.yaml | 6 +- 7 files changed, 503 insertions(+), 103 deletions(-) create mode 100644 pkg/hs-urbit/lib/Noun/Fat.hs diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index 655c55e23..a92905f49 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -1,9 +1,10 @@ {-# LANGUAGE MagicHash #-} -module Noun.Cue.Fast where +module Noun.Cue.Fast (cueFatBS, cueFat, cueBS, cue) where import ClassyPrelude import Noun +import Noun.Fat import Noun.Atom import Noun.Poet import Data.Bits hiding (Bits) @@ -36,11 +37,17 @@ import Test.QuickCheck hiding ((.&.)) -------------------------------------------------------------------------------- +cueFatBS :: ByteString -> Either DecodeExn FatNoun +cueFatBS = doGet dNoun + +cueFat :: Atom -> Either DecodeExn FatNoun +cueFat = cueFatBS . view atomBS + cueBS :: ByteString -> Either DecodeExn Noun -cueBS = doGet dNoun +cueBS = fmap fromFatNoun . cueFatBS cue :: Atom -> Either DecodeExn Noun -cue = cueBS . view atomBS +cue = fmap fromFatNoun . cueFat -- Debugging ------------------------------------------------------------------- @@ -89,7 +96,7 @@ data GetResult a = GetResult {-# UNPACK #-} !S !a newtype Get a = Get { runGet :: Ptr Word - -> H.LinearHashTable Word Noun + -> H.BasicHashTable Word FatNoun -> S -> IO (GetResult a) } @@ -100,7 +107,7 @@ doGet :: Get a -> ByteString -> Either DecodeExn a doGet m bs = unsafePerformIO $ try $ BS.unsafeUseAsCStringLen bs \(ptr, len) -> do let endPtr = ptr `plusPtr` len - tbl <- H.new + tbl <- H.newSized 1000000 GetResult _ r <- runGet m endPtr tbl (S (castPtr ptr) 0 0) pure r @@ -156,12 +163,12 @@ getPos :: Get Word getPos = Get $ \_ _ s -> pure (GetResult s (pos s)) -insRef :: Word -> Noun -> Get () +insRef :: Word -> FatNoun -> Get () insRef pos now = Get \_ tbl s -> do H.insert tbl pos now pure $ GetResult s () -getRef :: Word -> Get Noun +getRef :: Word -> Get FatNoun getRef ref = Get \x tbl s -> do H.lookup tbl ref >>= \case Nothing -> runGet (fail ("Invalid Reference: " <> show ref)) x tbl s @@ -337,8 +344,8 @@ dAtom = do 0 -> pure 0 n -> dAtomBits n -dCell :: Get Noun -dCell = debugMId "dCell" $ Cell <$> dNoun <*> dNoun +dCell :: Get FatNoun +dCell = debugMId "dCell" $ fatCell <$> dNoun <*> dNoun {-| Get a Noun. @@ -349,7 +356,7 @@ dCell = debugMId "dCell" $ Cell <$> dNoun <*> dNoun - If it's zero, get a cell. - If it's one, get an atom. -} -dNoun :: Get Noun +dNoun :: Get FatNoun dNoun = do debugMId "dNoun" $ do p <- getPos @@ -358,7 +365,7 @@ dNoun = do dBit >>= \case False -> do debugM "It's an atom" - (Atom <$> dAtom) >>= yield + (fatAtom <$> dAtom) >>= yield True -> dBit >>= \case False -> do debugM "It's a cell" dCell >>= yield diff --git a/pkg/hs-urbit/lib/Noun/Fat.hs b/pkg/hs-urbit/lib/Noun/Fat.hs new file mode 100644 index 000000000..1e4a98356 --- /dev/null +++ b/pkg/hs-urbit/lib/Noun/Fat.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE MagicHash #-} +{-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} + +module Noun.Fat ( FatNoun(..), fatSize, fatHash + , fatCell, fatAtom + , toFatNoun, fromFatNoun + , jamWordSz + , atomSz + ) where + +import ClassyPrelude hiding (hash) + +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.Pill (bigNatWords, atomBS) +import Data.Vector.Primitive ((!)) +import Foreign.Marshal.Alloc (callocBytes, free) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Storable (poke) +import GHC.Integer.GMP.Internals (BigNat) +import GHC.Int (Int(I#)) +import GHC.Natural (Natural(NatS#, NatJ#)) +import GHC.Prim (Word#, plusWord#, word2Int#, reallyUnsafePtrEquality#) +import GHC.Word (Word(W#)) +import System.IO.Unsafe (unsafePerformIO) + +import qualified Data.ByteString.Unsafe as BS +import qualified Data.Hashable as Hash +import qualified Data.HashTable.IO as H +import qualified Data.Vector.Primitive as VP + + +-- Types ----------------------------------------------------------------------- + +{-| + The encoder state. + + - ptr: Pointer into the output buffer. + - reg: Next 64 bits of output, partially written. + - off: Number of bits already written into `reg` + - pos: Total number of bits written. +-} +data S = S + { ptr :: {-# UNPACK #-} !(Ptr Word) + , reg :: {-# UNPACK #-} !Word + , off :: {-# UNPACK #-} !Int + , pos :: {-# UNPACK #-} !Word + } deriving (Show,Eq,Ord) + +data PutResult a = PutResult {-# UNPACK #-} !S !a + deriving Functor + +newtype Put a = Put + { runPut :: H.LinearHashTable Word Word + -> S + -> IO (PutResult a) + } + +-------------------------------------------------------------------------------- + +{-# INLINE getRef #-} +getRef :: Put (Maybe Word) +getRef = Put \tbl s -> PutResult s <$> H.lookup tbl (pos s) + +{- + 1. Write the register to the output, and increment the output pointer. +-} +{-# INLINE flush #-} +flush :: Put () +flush = Put $ \tbl s@S{..} -> do + poke ptr reg + pure $ PutResult (s { ptr = ptr `plusPtr` 8 }) () + +{-# INLINE update #-} +update :: (S -> S) -> Put () +update f = Put \tbl s@S{..} -> pure (PutResult (f s) ()) + +{-# INLINE setRegOff #-} +setRegOff :: Word -> Int -> Put () +setRegOff r o = update \s@S{..} -> (s {reg=r, off=o}) + +{-# INLINE setReg #-} +setReg :: Word -> Put () +setReg r = update \s@S{..} -> (s { reg=r }) + +{-# INLINE getS #-} +getS :: Put S +getS = Put $ \tbl s -> pure (PutResult s s) + +{-# INLINE putS #-} +putS :: S -> Put () +putS s = Put $ \tbl _ -> pure (PutResult s ()) + +{- + To write a bit: + + | reg |= 1 << off + | off <- (off + 1) % 64 + | if (!off): + | buf[w++] <- reg + | reg <- 0 +-} +{-# INLINE writeBit #-} +writeBit :: Bool -> Put () +writeBit b = Put $ \tbl s@S{..} -> do + let s' = s { reg = (if b then setBit else clearBit) reg off + , off = (off + 1) `mod` 64 + , pos = pos + 1 + } + + if off == 63 + then runPut (flush >> setRegOff 0 0) tbl s' + else pure $ PutResult s' () + +{- + To write a 64bit word: + + | reg |= w << off + | buf[bufI++] = reg + | reg = w >> (64 - off) +-} +{-# INLINE writeWord #-} +writeWord :: Word -> Put () +writeWord wor = do + S{..} <- getS + setReg (reg .|. shiftL wor off) + flush + update \s -> s { pos = 64 + pos + , reg = shiftR wor (64 - off) + } + +{- + To write some bits (< 64) from a word: + + | wor = takeBits(wid, wor) + | reg = reg .|. (wor << off) + | off = (off + wid) % 64 + | + | if (off + wid >= 64) + | buf[w] = x + | reg = wor >> (wid - off) +-} +{-# INLINE writeBitsFromWord #-} +writeBitsFromWord :: Int -> Word -> Put () +writeBitsFromWord wid wor = do + wor <- pure (takeBitsWord wid wor) + + oldSt <- getS + + let newSt = oldSt { reg = reg oldSt .|. shiftL wor (off oldSt) + , off = (off oldSt + wid) `mod` 64 + , pos = fromIntegral wid + pos oldSt + } + + putS newSt + + when (wid + off oldSt >= 64) $ do + flush + setReg (shiftR wor (wid - off newSt)) +{- + Write all of the the signficant bits of a direct atom. +-} +{-# INLINE writeAtomWord# #-} +writeAtomWord# :: Word# -> Put () +writeAtomWord# w = do + writeBitsFromWord (I# (word2Int# (wordBitWidth# w))) (W# w) + +{-# INLINE writeAtomWord #-} +writeAtomWord :: Word -> Put () +writeAtomWord (W# w) = writeAtomWord# w + +{- + Write all of the the signficant bits of an indirect atom. + + TODO Use memcpy when the bit-offset of the output is divisible by 8. +-} +{-# INLINE writeAtomBigNat #-} +writeAtomBigNat :: BigNat -> Put () +writeAtomBigNat (view bigNatWords -> words) = do + let lastIdx = VP.length words - 1 + for_ [0..(lastIdx-1)] \i -> + writeWord (words ! i) + writeAtomWord (words ! lastIdx) + +{-# INLINE writeAtomBits #-} +writeAtomBits :: Atom -> Put () +writeAtomBits = \case MkAtom (NatS# wd) -> writeAtomWord# wd + MkAtom (NatJ# bn) -> writeAtomBigNat bn + + +-- Put Instances --------------------------------------------------------------- + +instance Functor Put where + fmap f g = Put $ \tbl s -> do + PutResult s' a <- runPut g tbl s + pure $ PutResult s' (f a) + {-# INLINE fmap #-} + +instance Applicative Put where + pure x = Put (\_ s -> return $ PutResult s x) + {-# INLINE pure #-} + + Put f <*> Put g = Put $ \tbl s1 -> do + PutResult s2 f' <- f tbl s1 + PutResult s3 g' <- g tbl s2 + return $ PutResult s3 (f' g') + {-# INLINE (<*>) #-} + + Put f *> Put g = Put $ \tbl s1 -> do + PutResult s2 _ <- f tbl s1 + g tbl s2 + {-# INLINE (*>) #-} + +instance Monad Put where + return = pure + {-# INLINE return #-} + + (>>) = (*>) + {-# INLINE (>>) #-} + + Put x >>= f = Put $ \tbl s -> do + PutResult s' x' <- x tbl s + runPut (f x') tbl s' + {-# INLINE (>>=) #-} + + +-------------------------------------------------------------------------------- + +doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString +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) + + mbFlush :: Put () + mbFlush = do + shouldFlush <- (/= 0) . off <$> getS + when shouldFlush flush + + +-------------------------------------------------------------------------------- + +{- + TODO Handle back references +-} +writeNoun :: Noun -> Put () +writeNoun n = + getRef >>= \case + Just bk -> writeBackRef bk + Nothing -> case n of Atom a -> writeAtom a + Cell h t -> writeCell h t + +{-# INLINE writeMat #-} +writeMat :: Atom -> Put () +writeMat 0 = writeBit True +writeMat atm = do + writeBitsFromWord (preWid+1) (shiftL 1 preWid) + writeBitsFromWord (preWid-1) atmWid + writeAtomBits atm + where + atmWid = bitWidth atm + preWid = fromIntegral (wordBitWidth atmWid) + +{-# INLINE writeCell #-} +writeCell :: Noun -> Noun -> Put () +writeCell h t = do + writeBit True + writeBit False + writeNoun h + writeNoun t + +{-# INLINE writeAtom #-} +writeAtom :: Atom -> Put () +writeAtom a = do + writeBit False + writeMat a + +{-# INLINE writeBackRef #-} +writeBackRef :: Word -> Put () +writeBackRef a = do + p <- pos <$> getS + writeBit True + writeBit True + writeMat (toAtom a) + + +-- Compute Hashes and Jam Size (with no backrefs) ------------------------------ + +data FatNoun + = FatCell {-# UNPACK #-} !Word + {-# UNPACK #-} !Int + !FatNoun + !FatNoun + | FatWord {-# UNPACK #-} !Word + | FatAtom {-# UNPACK #-} !Word + {-# UNPACK #-} !Int + {-# UNPACK #-} !BigNat + deriving (Show) + +{-# INLINE fatSize #-} +fatSize :: FatNoun -> Word +fatSize = \case + FatCell s _ _ _ -> s + FatAtom s _ _ -> s + FatWord w -> atomSz (fromIntegral w) + +{-# INLINE fatHash #-} +fatHash :: FatNoun -> Int +fatHash = \case + FatCell _ h _ _ -> h + FatAtom _ h _ -> h + FatWord w -> Hash.hash w + +instance Hashable FatNoun where + hash = fatHash + {-# INLINE hash #-} + hashWithSalt = defaultHashWithSalt + {-# INLINE hashWithSalt #-} + +instance Eq FatNoun where + (==) x y = + case reallyUnsafePtrEquality# x y of + 1# -> True + 0# -> case (x, y) of + (FatWord w1, FatWord w2 ) -> + w1==w2 + (FatAtom s1 x1 a1, FatAtom s2 x2 a2 ) -> + s1==s2 && x1==x2 && a1==a2 + (FatCell s1 x1 h1 t1, FatCell s2 x2 h2 t2) -> + s1==s2 && x1==x2 && h1==h2 && t1==t2 + (_, _ ) -> + False + {-# INLINE (==) #-} + + +-------------------------------------------------------------------------------- + +{-# INLINE fatAtom #-} +fatAtom :: Atom -> FatNoun +fatAtom = \case + a@(MkAtom (NatS# w)) -> FatWord (W# w) + a@(MkAtom n@(NatJ# bn)) -> FatAtom (atomSz a) (Hash.hash bn) bn + +{-# INLINE fatCell #-} +fatCell :: FatNoun -> FatNoun -> FatNoun +fatCell h t = FatCell siz has h t + where + siz = 2 + fatSize h + fatSize t + has = fatHash h `combine` fatHash t + +{-# INLINE jamWordSz #-} +jamWordSz :: Word -> Word +jamWordSz 0 = 2 +jamWordSz (W# w) = 1 + 2*(W# preW) + (W# atmW) + where + atmW = wordBitWidth# w + preW = wordBitWidth# atmW + +{-# INLINE atomSz #-} +atomSz :: Atom -> Word +atomSz = (1+) . matSz + +{-# INLINE matSz #-} +matSz :: Atom -> Word +matSz a = W# (matSz# a) + +{-# INLINE matSz# #-} +matSz# :: Atom -> Word# +matSz# 0 = 1## +matSz# a = preW `plusWord#` preW `plusWord#` atmW + where + atmW = atomBitWidth# a + preW = wordBitWidth# atmW + +{-# INLINE toFatNoun #-} +toFatNoun :: Noun -> FatNoun +toFatNoun = trace "toFatNoun" . go + where + go (Atom a) = fatAtom a + go (Cell h t) = fatCell (go h) (go t) + +{-# INLINE fromFatNoun #-} +fromFatNoun :: FatNoun -> Noun +fromFatNoun = trace "fromFatNoun" . go + where go = \case + FatAtom _ _ a -> Atom (MkAtom $ NatJ# a) + FatCell _ _ h t -> Cell (go h) (go t) + FatWord w -> Atom (fromIntegral w) + + +-- 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.hash x diff --git a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs index ee3d76dcc..7b0e41fcf 100644 --- a/pkg/hs-urbit/lib/Noun/Jam/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Jam/Fast.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MagicHash #-} {-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} -module Noun.Jam.Fast (jam, jamBS) where +module Noun.Jam.Fast (jam, jamBS, jamFat, jamFatBS) where import ClassyPrelude hiding (hash) @@ -10,6 +10,7 @@ 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) @@ -30,13 +31,19 @@ import qualified Data.Vector.Primitive as VP -- Exports --------------------------------------------------------------------- -jamBS :: Noun -> ByteString -jamBS n = doPut bt sz (writeNoun n) +jamFatBS :: FatNoun -> ByteString +jamFatBS n = doPut bt sz (writeNoun n) where - (sz, bt) = unsafePerformIO (compress $ toBigNoun n) + (sz, bt) = unsafePerformIO (compress n) + +jamFat :: FatNoun -> Atom +jamFat = view (from atomBS) . jamFatBS + +jamBS :: Noun -> ByteString +jamBS = jamFatBS . toFatNoun jam :: Noun -> Atom -jam = view (to jamBS . from atomBS) +jam = jamFat . toFatNoun -- Types ----------------------------------------------------------------------- @@ -60,7 +67,7 @@ data PutResult a = PutResult {-# UNPACK #-} !S !a deriving Functor newtype Put a = Put - { runPut :: H.LinearHashTable Word Word + { runPut :: H.CuckooHashTable Word Word -> S -> IO (PutResult a) } @@ -235,9 +242,10 @@ instance Monad Put where -------------------------------------------------------------------------------- -doPut :: H.LinearHashTable Word Word -> Word -> Put () -> ByteString +doPut :: H.CuckooHashTable Word Word -> Word -> Put () -> ByteString 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) @@ -257,12 +265,13 @@ doPut tbl sz m = {- TODO Handle back references -} -writeNoun :: Noun -> Put () +writeNoun :: FatNoun -> Put () writeNoun n = getRef >>= \case Just bk -> writeBackRef bk - Nothing -> case n of Atom a -> writeAtom a - Cell h t -> writeCell h t + Nothing -> case n of FatAtom _ _ n -> writeAtom (MkAtom $ NatJ# n) + FatWord (W# w) -> writeAtom (MkAtom $ NatS# w) + FatCell _ _ h t -> writeCell h t {-# INLINE writeMat #-} writeMat :: Atom -> Put () @@ -276,7 +285,7 @@ writeMat atm = do preWid = fromIntegral (wordBitWidth atmWid) {-# INLINE writeCell #-} -writeCell :: Noun -> Noun -> Put () +writeCell :: FatNoun -> FatNoun -> Put () writeCell h t = do writeBit True writeBit False @@ -298,45 +307,6 @@ writeBackRef a = do writeMat (toAtom a) --- Compute Hashes and Jam Size (with no backrefs) ------------------------------ - -data BigNoun - = BigCell { bSize :: {-# UNPACK #-} !Word - , bHash :: {-# UNPACK #-} !Int - , bHead :: BigNoun - , bTail :: BigNoun - } - | BigAtom { bSize :: {-# UNPACK #-} !Word - , bHash :: {-# UNPACK #-} !Int - , bAtom :: {-# UNPACK #-} !Atom - } - deriving (Show) - -instance Hashable BigNoun where - hash = bHash - {-# INLINE hash #-} - hashWithSalt = defaultHashWithSalt - {-# INLINE hashWithSalt #-} - -instance Eq BigNoun where - BigAtom s1 _ a1 == BigAtom s2 _ a2 = s1==s2 && a1==a2 - BigCell s1 _ h1 t1 == BigCell s2 _ h2 t2 = s1==s2 && h1==h2 && t1==t2 - _ == _ = False - {-# INLINE (==) #-} - -{-# INLINE toBigNoun #-} -toBigNoun :: Noun -> BigNoun -toBigNoun = go - where - go (Atom a) = BigAtom (1 + matSz a) (Hash.hash a) a - go (Cell h t) = BigCell siz has hed tel - where - hed = toBigNoun h - tel = toBigNoun t - siz = 2 + bSize hed + bSize tel - has = fromIntegral siz `combine` bHash hed `combine` bHash tel - - -- Calculate Jam Size and Backrefs --------------------------------------------- {-# INLINE matSz #-} @@ -351,36 +321,41 @@ matSz# a = preW `plusWord#` preW `plusWord#` atmW atmW = atomBitWidth# a preW = wordBitWidth# atmW -{-# INLINE refSz# #-} -refSz# :: Word# -> Word# -refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w))) +{-# INLINE refSz #-} +refSz :: Word -> Word +refSz w = 1 + (jamWordSz w) -compress :: BigNoun -> IO (Word, H.LinearHashTable Word Word) +compress :: FatNoun -> IO (Word, H.CuckooHashTable Word Word) compress top = do - nodes :: H.LinearHashTable BigNoun Word <- H.new - backs :: H.LinearHashTable Word Word <- H.new + traceM "" + nodes :: H.BasicHashTable FatNoun Word <- H.newSized 1000000 + backs :: H.CuckooHashTable Word Word <- H.newSized 1000000 - let proc :: Word -> BigNoun -> IO Word + let proc :: Word -> FatNoun -> IO Word proc pos = \case - BigAtom _ _ a -> pure (1 + matSz a) - BigCell _ _ h t -> do - hSz <- go (pos+2) h - tSz <- go (pos+2+hSz) t + n@(FatAtom s _ _) -> pure s + 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 -> BigNoun -> IO Word + go :: Word -> FatNoun -> IO Word go p inp = do H.lookup nodes inp >>= \case Nothing -> do H.insert nodes inp p proc p inp - Just bak@(W# bakRaw) -> do - let refSz = W# (refSz# bakRaw) - if (refSz < bSize inp) - then H.insert backs p bak $> refSz + Just bak -> do + let rs = refSz bak + if (rs < fatSize inp) + then do H.insert backs p bak + pure rs else proc p inp res <- go 0 top + traceM "" + print res pure (res, backs) diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 6bc71ba53..8c828cbee 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -4,46 +4,56 @@ module Noun.Lens where import ClassyPrelude import Noun.Pill +import Noun.Fat import Noun import Noun.Atom import Control.Lens -import Noun.Jam.Fast (jam, jamBS) -import Noun.Cue.Fast (cue, cueBS) +import Noun.Jam.Fast (jam, jamBS, jamFat, jamFatBS) +import Noun.Cue.Fast (cue, cueBS, cueFat, cueFatBS) -------------------------------------------------------------------------------- eitherToMaybe (Left _) = Nothing eitherToMaybe (Right x) = Just x +_CueFatBytes :: Prism' ByteString FatNoun +_CueFatBytes = prism' jamFatBS (eitherToMaybe . cueFatBS) + +_CueFat :: Prism' Atom FatNoun +_CueFat = prism' jamFat (eitherToMaybe . cueFat) + _CueBytes :: Prism' ByteString Noun _CueBytes = prism' jamBS (eitherToMaybe . cueBS) _Cue :: Prism' Atom Noun _Cue = prism' jam (eitherToMaybe . cue) -loadNoun :: FilePath -> IO (Maybe Noun) -loadNoun = fmap (preview _CueBytes) . readFile +-------------------------------------------------------------------------------- -dumpJam :: FilePath -> Noun -> IO () -dumpJam fp = writeFile fp . view (re _CueBytes) +loadNoun :: FilePath -> IO (Maybe FatNoun) +loadNoun = fmap (preview _CueFatBytes) . readFile + +dumpJam :: FilePath -> FatNoun -> IO () +dumpJam fp = writeFile fp . view (re _CueFatBytes) tryCuePill :: PillFile -> IO () tryCuePill pill = - loadNoun (show pill) >>= \case Nothing -> print "nil" - Just (Atom _) -> print "atom" - _ -> print "cell" + loadNoun (show pill) >>= \case Nothing -> print "nil" + Just (FatAtom _ _ _) -> print "atom" + Just (FatWord _) -> print "word" + _ -> print "cell" tryCueJamPill :: PillFile -> IO () tryCueJamPill pill = do n <- loadNoun (show pill) >>= \case Nothing -> do print "failure" - pure (Atom 0) - Just (Atom a) -> do print "atom" - pure (Atom a) - Just (Cell h t) -> do print "cell" - pure (Cell h t) + pure (FatWord 0) + Just n@(FatAtom _ _ _) -> do print "atom" + pure n + Just n@(FatCell _ _ _ _) -> do print "cell" + pure n - bs <- evaluate (force (jamBS n)) + bs <- evaluate (force (jamFatBS n)) print ("jam size: " <> show (length bs)) diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index b354e0b24..4341c96f7 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/pkg/hs-vere/app/uterm/Main.hs @@ -9,14 +9,14 @@ import Noun.Lens main :: IO () main = do - print "load brass" -- void getLine - tryLoadPill Brass + -- print "load brass" -- void getLine + -- tryLoadPill Brass - print "load ivory" -- void getLine - tryLoadPill Ivory + -- print "load ivory" -- void getLine + -- tryLoadPill Ivory - print "load solid" -- void getLine - tryLoadPill Solid + -- print "load solid" -- void getLine + -- tryLoadPill Solid print "cue brass" -- void getLine tryCueJamPill Brass diff --git a/pkg/hs-vere/package.yaml b/pkg/hs-vere/package.yaml index cbe718f9f..ba610bbb7 100644 --- a/pkg/hs-vere/package.yaml +++ b/pkg/hs-vere/package.yaml @@ -10,7 +10,7 @@ executables: ghc-options: - -threaded - -rtsopts - - "-with-rtsopts=-H128m" + - "-with-rtsopts=-H1024m" - -fwarn-incomplete-patterns - -O2 @@ -21,7 +21,7 @@ executables: ghc-options: - -threaded - -rtsopts - - "-with-rtsopts=-H128m" + - "-with-rtsopts=-H4096m" - -fwarn-incomplete-patterns - -O2 diff --git a/stack.yaml b/stack.yaml index 00bb63e7f..73308fae0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,10 +18,10 @@ nix: - SDL2_image - zlib -ghc-options: - urbit: '-fobject-code' +# ghc-options: +# urbit: '-fobject-code' # build: -# library-profiling: true # executable-profiling: true # executable-stripping: false +# library-profiling: true