urbit/shrub
1
1
Fork 0
mirror of https://github.com/urbit/shrub.git synced 2024-12-01 06:35:32 +03:00
Code Issues Packages Projects Releases Wiki Activity

Jam and cue are both quite fast now! 5 seconds to load+jam+cue all three pills.

Browse Source
This commit is contained in:
Benjamin Summers 2019-07-03 17:53:21 -07:00
parent 8d5f537db8
commit 221cb78c77
7 changed files with 503 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

408
pkg/hs-urbit/lib/Noun/Fat.hs Normal file
View File

@ -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

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

@ -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 "<compress>"
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 "</compress>"
print res
pure (res, backs)

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

@ -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))

12
pkg/hs-vere/app/uterm/Main.hs
View File

@ -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

4
pkg/hs-vere/package.yaml
View File

@ -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

6
stack.yaml
View File

@ -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