diff --git a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs index f59c2941d..655c55e23 100644 --- a/pkg/hs-urbit/lib/Noun/Cue/Fast.hs +++ b/pkg/hs-urbit/lib/Noun/Cue/Fast.hs @@ -2,7 +2,6 @@ module Noun.Cue.Fast where -import ClassyPrelude import ClassyPrelude import Noun import Noun.Atom @@ -44,6 +43,23 @@ cue :: Atom -> Either DecodeExn Noun cue = cueBS . view atomBS +-- Debugging ------------------------------------------------------------------- + +{-# INLINE debugM #-} +debugM :: Monad m => String -> m () +debugM _ = pure () + +{-# INLINE debugMId #-} +debugMId :: (Monad m, Show a) => String -> m a -> m a +debugMId _ a = a + +-- debugMId tag m = do + -- r <- m + -- debugM (tag <> ": " <> show r) + -- pure r + + + -- Types ----------------------------------------------------------------------- {-| @@ -69,7 +85,7 @@ data DecodeExn deriving (Show, Eq, Ord) data GetResult a = GetResult {-# UNPACK #-} !S !a - deriving Functor + deriving (Show, Functor) newtype Get a = Get { runGet :: Ptr Word @@ -125,7 +141,7 @@ instance Monad Get where runGet (f x') end tbl s' {-# INLINE (>>=) #-} - fail msg = Get $ \end tbl s -> + fail msg = Get $ \end tbl s -> do badEncoding end s msg {-# INLINE fail #-} @@ -146,18 +162,20 @@ insRef pos now = Get \_ tbl s -> do pure $ GetResult s () getRef :: Word -> Get Noun -getRef ref = Get \_ tbl s -> do +getRef ref = Get \x tbl s -> do H.lookup tbl ref >>= \case - Nothing -> fail "Invalid Reference" + 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 + debugM ("advance: " <> show n) let newUsed = n + usedBits s newS = s { pos = pos s + n , usedBits = newUsed `mod` 64 , currPtr = plusPtr (currPtr s) - (fromIntegral $ newUsed `div` 64) + (8 * (fromIntegral (newUsed `div` 64))) } pure (GetResult newS ()) @@ -166,20 +184,25 @@ advance n = Get \_ _ s -> do -- TODO Should this be (>= end) or (> end)? peekCurWord :: Get Word -peekCurWord = Get \end _ s -> +peekCurWord = Get \end _ s -> do + debugMId "peekCurWord" $ do if ptrToWordPtr (currPtr s) >= ptrToWordPtr end then pure (GetResult s 0) else GetResult s <$> peek (currPtr s) -- TODO Same question as above. peekNextWord :: Get Word -peekNextWord = Get \end _ s -> - if ptrToWordPtr (currPtr s) > ptrToWordPtr end +peekNextWord = Get \end _ s -> do + debugMId "peekNextWord" $ do + let pTarget = currPtr s `plusPtr` 8 + if ptrToWordPtr pTarget >= ptrToWordPtr end then pure (GetResult s 0) - else GetResult s <$> peek (currPtr s `plusPtr` 1) + else GetResult s <$> peek pTarget peekUsedBits :: Get Word -peekUsedBits = Get \_ _ s -> pure (GetResult s (usedBits s)) +peekUsedBits = + debugMId "peekUsedBits" $ do + Get \_ _ s -> pure (GetResult s (usedBits s)) {-| Get a bit. @@ -190,16 +213,18 @@ peekUsedBits = Get \_ _ s -> pure (GetResult s (usedBits s)) -} dBit :: Get Bool dBit = do - wor <- peekCurWord - use <- fromIntegral <$> peekUsedBits - advance 1 - pure (0 /= shiftR wor use .&. 1) + debugMId "dBit" $ do + wor <- peekCurWord + use <- fromIntegral <$> peekUsedBits + advance 1 + pure (0 /= shiftR wor use .&. 1) dWord :: Get Word dWord = do - res <- peekWord - advance 64 - pure res + debugMId "dWord" $ do + res <- peekWord + advance 64 + pure res {-| Get n bits, where n > 64: @@ -211,13 +236,14 @@ dWord = do - Construct a bit-vector using the buffer*length*offset. -} dAtomBits :: Word -> Get Atom -dAtomBits (fromIntegral -> bits) = - fmap (view $ from atomWords) $ - VP.generateM bufSize \i -> - if (i == lastIdx && numExtraBits /= 0) - then dWordBits (fromIntegral numExtraBits) - else dWord - +dAtomBits (fromIntegral -> bits) = do + debugMId ("dAtomBits(" <> show bits <> ")") $ do + fmap (view $ from atomWords) $ + VP.generateM bufSize \i -> do + debugM (show i) + if (i == lastIdx && numExtraBits /= 0) + then dWordBits (fromIntegral numExtraBits) + else dWord where bufSize = numFullWords + min 1 numExtraBits lastIdx = bufSize - 1 @@ -241,27 +267,22 @@ dAtomBits (fromIntegral -> bits) = -} peekWord :: Get Word peekWord = do + debugMId "peekWord" $ do off <- peekUsedBits cur <- peekCurWord - if off == 0 then pure cur else - do - nex <- peekNextWord - advance 64 - pure (dropLowBits off cur .|. dropHighBits off nex) + nex <- peekNextWord + let res = swiz off (cur, nex) + debugM ("\t" <> (take 10 $ reverse $ printf "%b" (fromIntegral res :: Integer)) <> "..") + pure res -dropLowBits :: Word -> Word -> Word -dropLowBits bits wor = shiftR wor (fromIntegral bits :: Int) +swiz :: Word -> (Word, Word) -> Word +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 -takeHighBits :: Word -> Word -> Word -takeHighBits off wor = dropLowBits (64-off) wor - -dropHighBits :: Word -> Word -> Word -dropHighBits off wor = takeLowBits (64-off) wor - {-| Make a word from the next n bits (where n <= 64). @@ -272,8 +293,10 @@ dropHighBits off wor = takeLowBits (64-off) wor -} dWordBits :: Word -> Get Word dWordBits n = do + debugMId ("dWordBits(" <> show n <> ")") $ do w <- peekWord advance n + debugM ("dWordBits: " <> show (takeLowBits n w)) pure (takeLowBits n w) @@ -290,27 +313,32 @@ dWordBits n = do -} dExp :: Get Word dExp = do + debugMId "dExp" $ do W# w <- peekWord let res = W# (ctz# w) - advance res + advance (res+1) pure res dAtomLen :: Get Word dAtomLen = do - e <- dExp - p <- dWordBits (e-1) - pure (2^e .|. p) + debugMId "dAtomLen" $ do + dExp >>= \case + 0 -> pure 0 + e -> do p <- dWordBits (e-1) + pure (2^(e-1) .|. p) dRef :: Get Word -dRef = dAtomLen >>= dWordBits +dRef = debugMId "dRef" (dAtomLen >>= dWordBits) dAtom :: Get Atom dAtom = do - n <- dAtomLen - dAtomBits n + debugMId "dAtom" $ do + dAtomLen >>= \case + 0 -> pure 0 + n -> dAtomBits n dCell :: Get Noun -dCell = Cell <$> dNoun <*> dNoun +dCell = debugMId "dCell" $ Cell <$> dNoun <*> dNoun {-| Get a Noun. @@ -323,12 +351,16 @@ dCell = Cell <$> dNoun <*> dNoun -} dNoun :: Get Noun dNoun = do + debugMId "dNoun" $ do p <- getPos let yield r = insRef p r >> pure r dBit >>= \case - False -> (Atom <$> dAtom) >>= yield + False -> do debugM "It's an atom" + (Atom <$> dAtom) >>= yield True -> dBit >>= \case - False -> dCell >>= yield - True -> dRef >>= getRef + False -> do debugM "It's a cell" + dCell >>= yield + True -> do debugM "It's a backref" + dRef >>= getRef diff --git a/pkg/hs-urbit/lib/Noun/Jam.hs b/pkg/hs-urbit/lib/Noun/Jam.hs index 4a2b3bef8..49f73c9c4 100644 --- a/pkg/hs-urbit/lib/Noun/Jam.hs +++ b/pkg/hs-urbit/lib/Noun/Jam.hs @@ -222,6 +222,9 @@ prop_fastJamSlow n = x == y || (bitWidth y <= bitWidth x && cue y == cue x) prop_fastRub :: Atom -> Bool prop_fastRub a = Right (Atom a) == Cue.cue (jam (Atom a)) +prop_fastCue :: Noun -> Bool +prop_fastCue n = Right n == Cue.cue (jam n) + prop_fastJam :: Noun -> Bool prop_fastJam n = Just n == cue (Jam.jam n) @@ -252,3 +255,9 @@ matSz' a = length s - 1 s :: String s = printf "%b" $ fromIntegral @Atom @Integer $ jam $ Atom a +(a, c) = (Atom, Cell) + +printJam :: Noun -> IO () +printJam n = do + j <- evaluate (force (fromIntegral $ jam n)) + printf "0b%b\n" (j :: Integer) diff --git a/pkg/hs-urbit/lib/Noun/Lens.hs b/pkg/hs-urbit/lib/Noun/Lens.hs index 7e504b796..6bc71ba53 100644 --- a/pkg/hs-urbit/lib/Noun/Lens.hs +++ b/pkg/hs-urbit/lib/Noun/Lens.hs @@ -8,25 +8,42 @@ import Noun import Noun.Atom import Control.Lens import Noun.Jam.Fast (jam, jamBS) -import Noun.Jam (cue) +import Noun.Cue.Fast (cue, cueBS) -------------------------------------------------------------------------------- +eitherToMaybe (Left _) = Nothing +eitherToMaybe (Right x) = Just x + _CueBytes :: Prism' ByteString Noun -_CueBytes = prism' jamBS unJamBS - where unJamBS = preview (from pillBS . from pill . _Cue) +_CueBytes = prism' jamBS (eitherToMaybe . cueBS) _Cue :: Prism' Atom Noun -_Cue = prism' jam cue +_Cue = prism' jam (eitherToMaybe . cue) loadNoun :: FilePath -> IO (Maybe Noun) -loadNoun = fmap (preview $ from pillBS . from pill . _Cue) . readFile +loadNoun = fmap (preview _CueBytes) . readFile dumpJam :: FilePath -> Noun -> IO () -dumpJam fp = writeFile fp . view (re _Cue . pill . pillBS) +dumpJam fp = writeFile fp . view (re _CueBytes) tryCuePill :: PillFile -> IO () tryCuePill pill = loadNoun (show pill) >>= \case Nothing -> print "nil" Just (Atom _) -> print "atom" _ -> 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) + + bs <- evaluate (force (jamBS n)) + + print ("jam size: " <> show (length bs)) diff --git a/pkg/hs-urbit/lib/Noun/Pill.hs b/pkg/hs-urbit/lib/Noun/Pill.hs index 6e17210fb..501943a29 100644 --- a/pkg/hs-urbit/lib/Noun/Pill.hs +++ b/pkg/hs-urbit/lib/Noun/Pill.hs @@ -177,9 +177,6 @@ pillWords = iso toVec fromVec toVec = view (pillBS . to bsToWords) fromVec = view (to wordsToBytes . bytesBS . from pillBS) --- _CueBytes :: Prism' ByteString Noun --- _CueBytes = from pillBS . from pill . _Cue - -------------------------------------------------------------------------------- {- @@ -208,9 +205,6 @@ atomBS = pill . pillBS -------------------------------------------------------------------------------- --- _Cue :: Prism' Atom Noun --- _Cue = prism' jam cue - _Tall :: Flat a => Prism' ByteString a _Tall = prism' flat (eitherToMaybe . unflat) where @@ -226,9 +220,6 @@ loadPill = fmap Pill . readFile loadAtom :: FilePath -> IO Atom loadAtom = fmap (view $ from pillBS . from pill) . readFile --- loadNoun :: FilePath -> IO (Maybe Noun) --- loadNoun = fmap (preview $ from pillBS . from pill . _Cue) . readFile - loadFlat :: Flat a => FilePath -> IO (Either Text a) loadFlat = fmap (mapLeft tshow . unflat) . readFile @@ -240,9 +231,6 @@ dumpPill fp = writeFile fp . view pillBS dumpAtom :: FilePath -> Atom -> IO () dumpAtom fp = writeFile fp . view (pill . pillBS) --- dumpJam :: FilePath -> Noun -> IO () --- dumpJam fp = writeFile fp . view (re _Cue . pill . pillBS) - dumpFlat :: Flat a => FilePath -> a -> IO () dumpFlat fp = writeFile fp . flat @@ -270,12 +258,6 @@ tryPackPill pf = do atm <- tryLoadPill pf print $ length (atm ^. pill . pillBS) --- tryCuePill :: PillFile -> IO () --- tryCuePill pill = - -- loadNoun (show pill) >>= \case Nothing -> print "nil" - -- Just (Atom _) -> print "atom" - -- _ -> print "cell" - -- Tests ----------------------------------------------------------------------- instance Arbitrary ByteString where diff --git a/pkg/hs-vere/app/uterm/Main.hs b/pkg/hs-vere/app/uterm/Main.hs index 56808d30e..b354e0b24 100644 --- a/pkg/hs-vere/app/uterm/Main.hs +++ b/pkg/hs-vere/app/uterm/Main.hs @@ -9,20 +9,20 @@ import Noun.Lens main :: IO () main = do - print "load brass" >> void getLine + print "load brass" -- void getLine tryLoadPill Brass - print "load ivory" >> void getLine + print "load ivory" -- void getLine tryLoadPill Ivory - print "load solid" >> void getLine + print "load solid" -- void getLine tryLoadPill Solid - print "cue brass" >> void getLine - tryCuePill Brass + print "cue brass" -- void getLine + tryCueJamPill Brass - print "cue ivory" >> void getLine - tryCuePill Ivory + print "cue ivory" -- void getLine + tryCueJamPill Ivory - print "cue solid" >> void getLine - tryCuePill Solid + print "cue solid" -- void getLine + tryCueJamPill Solid