Got fast cue working.

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

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)

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

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

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