Loading pills works; initial work on jets for jam/cue.

pkg/hair/app/uterm/Main.hs

@@ -2,8 +2,26 @@ module Main where
 
 import ClassyPrelude
 import Control.Lens
+import Data.Noun.Pill hiding (main)
 
 --------------------------------------------------------------------------------
 
 main :: IO ()
-main = "Hello World" & putStrLn
+main = do
+  print "load brass" >> void getLine
+  tryLoadPill Brass
+
+  print "load ivory" >> void getLine
+  tryLoadPill Ivory
+
+  print "load solid" >> void getLine
+  tryLoadPill Solid
+
+  print "cue brass" >> void getLine
+  tryCuePill Brass
+
+  print "cue ivory" >> void getLine
+  tryCuePill Ivory
+
+  print "cue solid" >> void getLine
+  tryCuePill Solid

pkg/hair/lib/Data/Noun/Atom.hs

@@ -104,20 +104,22 @@ instance IsAtom Integer where
   TODO Support 32-bit archetectures.
 -}
 
-wordBitWidth :: Word# -> Word#
-wordBitWidth w = minusWord# 64## (clz# w)
+wordBitWidth# :: Word# -> Word#
+wordBitWidth# w = minusWord# 64## (clz# w)
 
-bigNatBitWidth :: BigNat -> Word#
-bigNatBitWidth nat =
+bigNatBitWidth# :: BigNat -> Word#
+bigNatBitWidth# nat =
     lswBits `plusWord#` ((int2Word# lastIdx) `timesWord#` 64##)
   where
     (# lastIdx, _ #) = subIntC# (sizeofBigNat# nat) 1#
-    lswBits          = wordBitWidth (indexBigNat# nat lastIdx)
+    lswBits          = wordBitWidth# (indexBigNat# nat lastIdx)
 
-bitWidth :: Atom -> Int
-bitWidth (MkAtom (NatS# gl)) = I# (word2Int# (wordBitWidth gl))
-bitWidth (MkAtom (NatJ# bn)) = I# (word2Int# (bigNatBitWidth bn))
+atomBitWidth# :: Atom -> Word#
+atomBitWidth# (MkAtom (NatS# gl)) = wordBitWidth# gl
+atomBitWidth# (MkAtom (NatJ# bn)) = bigNatBitWidth# bn
 
+bitWidth :: Num a => Atom -> a
+bitWidth a = fromIntegral (W# (atomBitWidth# a))
 
 --------------------------------------------------------------------------------
 

pkg/hair/lib/Data/Noun/Jam.hs

@@ -109,23 +109,23 @@ bufVal Nothing = "<nil>"
 bufVal (Just (Buf sz v)) = show v <> " [" <> show sz <> "]"
 
 rub :: Cursor -> Maybe Buf
-rub slc@(Cursor idx buf) = trace (bufVal res) res
-  where
-    res =
-      trace ("rub-" <> show idx) $
-      leadingZeros slc >>= \case
-        0      -> pure (Buf 1 0)
-        prefix -> pure (Buf sz val)
-          where
-            widIdx = idx + 1 + prefix
-            width  = fromSlice (Slice widIdx (prefix - 1) buf)
-            datIdx = widIdx + (prefix-1)
-            datWid = fromIntegral $ 2^(prefix-1) + width
-            sz     = datWid + (2*prefix)
-            val    = fromSlice (Slice datIdx datWid buf)
+rub slc@(Cursor idx buf) =
+  leadingZeros slc >>= \case
+    0      -> pure (Buf 1 0)
+    prefix -> pure (Buf sz val)
+      where
+        widIdx = idx + 1 + prefix
+        width  = fromSlice (Slice widIdx (prefix - 1) buf)
+        datIdx = widIdx + (prefix-1)
+        datWid = fromIntegral $ 2^(prefix-1) + width
+        sz     = datWid + (2*prefix)
+        val    = fromSlice (Slice datIdx datWid buf)
 
 -- Noun Serialization ----------------------------------------------------------
 
+-- bex can be implemented using
+--   `mpz_mul_2exp(a_mp, a_mp, a);
+
 jam :: Noun -> Atom
 jam = toAtom . fst . go 0 mempty
   where
@@ -166,7 +166,7 @@ cue buf = view _2 <$> go mempty 0
   where
     go :: Map Int Noun -> Int -> Maybe (Int, Noun, Map Int Noun)
     go tbl i =
-      trace ("go-" <> show i)
+      -- trace ("go-" <> show i)
       case (bitIdx i buf, bitIdx (i+1) buf) of
         (False, _     ) -> do Buf wid at <- rub (Cursor (i+1) buf)
                               let r = toNoun at
@@ -176,7 +176,7 @@ cue buf = view _2 <$> go mempty 0
                               let r = Cell lef rit
                               pure (2+lSz+rSz, r, insertMap i r tbl)
         (True,  True  ) -> do Buf wid at <- rub (Cursor (i+2) buf)
-                              traceM ("ref-" <> show at)
+                              -- traceM ("ref-" <> show at)
                               r <- lookup (fromIntegral at) tbl & \case
                                      Nothing -> error ("bad-ref-" <> show at)
                                      Just ix -> Just ix

pkg/hair/lib/Data/Noun/Jam/Fast.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE MagicHash #-}
+
+module Data.Noun.Jam.Fast where
+
+import ClassyPrelude
+import Data.Noun
+import Data.Noun.Atom
+import Data.Noun.Poet
+import Data.Bits
+import Control.Lens
+import Text.Printf
+import GHC.Prim
+import GHC.Word
+import GHC.Natural
+
+import Data.Map      (Map)
+import Control.Monad (guard)
+
+import Test.Tasty
+import Test.Tasty.TH
+import Test.Tasty.QuickCheck as QC
+import Test.QuickCheck
+
+-- High-Performance Jam --------------------------------------------------------
+
+matSz# :: Atom -> Word#
+matSz# 0 = 1##
+matSz# a = preW `plusWord#` preW `plusWord#` atmW
+  where
+    atmW = atomBitWidth# a
+    preW = wordBitWidth# atmW
+
+refSz# :: Word# -> Word#
+refSz# w = 2## `plusWord#` (matSz# (MkAtom (NatS# w)))
+
+nounSz# :: Noun -> Word#
+nounSz# (Atom a)   = 1## `plusWord#` (matSz# a)
+nounSz# (Cell l r) = 2## `plusWord#` (nounSz# l) `plusWord#` (nounSz# r)
+
+jamSz :: Noun -> Word
+jamSz = fst . go 0 mempty
+  where
+    insertNoun :: Noun -> Word -> Map Noun Word -> Map Noun Word
+    insertNoun n i tbl = lookup n tbl
+                       & maybe tbl (const $ insertMap n i tbl)
+
+    go :: Word -> Map Noun Word -> Noun -> (Word, Map Noun Word)
+    go off oldTbl noun =
+      let tbl = insertNoun noun off oldTbl in
+      case lookup noun oldTbl of
+        Nothing ->
+          case noun of
+            Atom atm ->
+              (1 + W# (matSz# atm), tbl)
+            Cell l r ->
+              let (lSz, tbl) = go (2+off)     tbl l in
+              let (rSz, tbl) = go (2+off+lSz) tbl r in
+              (2 + lSz + rSz, tbl)
+        Just (W# ref) ->
+          let refSz = W# (wordBitWidth# ref) in
+          case noun of
+            Atom atm ->
+              let worSz = W# (matSz# atm) in
+              if worSz > refSz
+              then (refSz, oldTbl)
+              else (1 + worSz, tbl)
+            Cell _ _ ->
+              (refSz, oldTbl)

pkg/hair/lib/Data/Noun/Pill.hs

@@ -19,8 +19,10 @@ import GHC.Int
 import GHC.Word
 import GHC.Exts (sizeofByteArray#)
 
+import qualified Data.Vector              as V
 import qualified Data.Primitive.ByteArray as Prim
 import qualified Data.Vector.Primitive    as VP
+import qualified Data.Vector.Unboxed      as VU
 import qualified Data.ByteString          as BS
 
 import Test.Tasty
@@ -43,23 +45,25 @@ stripTrailingZeros buf = take (len - go 0 (len - 1)) buf
 
 --------------------------------------------------------------------------------
 
-wordArrToBigNat :: VP.Vector Word -> BigNat
-wordArrToBigNat v@(VP.Vector off (I# len) (Prim.ByteArray buf)) =
+wordsToBigNat :: VP.Vector Word -> BigNat
+wordsToBigNat v@(VP.Vector off (I# len) (Prim.ByteArray buf)) =
   case VP.length v of
     0 -> zeroBigNat
     1 -> wordToBigNat (case VP.unsafeIndex v 0 of W# w -> w)
     n -> if off /= 0 then error "words2Nat: bad-vec" else
          byteArrayToBigNat# buf len
 
-wordsToBigNat :: [Word] -> BigNat
-wordsToBigNat = wordArrToBigNat . VP.fromList
+bigNatToWords :: BigNat -> VP.Vector Word
+bigNatToWords (BN# bArr) = VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8)
+                           $ Prim.ByteArray bArr
 
-bigNatToWords :: BigNat -> [Word]
-bigNatToWords (BN# bArr) =
-  stripTrailingZeros
-    $ VP.toList
-    $ VP.Vector 0 (I# (sizeofByteArray# bArr) `div` 8)
-    $ Prim.ByteArray bArr
+--------------------------------------------------------------------------------
+
+bigNatToBits :: BigNat -> VU.Vector Bool
+bigNatToBits = undefined
+
+bitsToBigNat :: BigNat -> VU.Vector Bool
+bitsToBigNat = undefined
 
 --------------------------------------------------------------------------------
 
@@ -67,12 +71,19 @@ naturalToBigNat :: Natural -> BigNat
 naturalToBigNat (NatS# w)  = wordToBigNat w
 naturalToBigNat (NatJ# bn) = bn
 
-wordsToNatural :: [Word] -> Natural
-wordsToNatural []  = 0
-wordsToNatural [w] = fromIntegral w
-wordsToNatural ws  = NatJ# (wordsToBigNat ws)
+bigNatToNatural :: BigNat -> Natural
+bigNatToNatural bn =
+    case sizeofBigNat# bn of
+      0# -> 0
+      1# -> NatS# (bigNatToWord bn)
+      _  -> NatJ# bn
 
-naturalToWords :: Natural -> [Word]
+--------------------------------------------------------------------------------
+
+wordsToNatural :: VP.Vector Word -> Natural
+wordsToNatural = bigNatToNatural . wordsToBigNat
+
+naturalToWords :: Natural -> VP.Vector Word
 naturalToWords = bigNatToWords . naturalToBigNat
 
 --------------------------------------------------------------------------------
@@ -85,13 +96,13 @@ dumbPackWord bs = go 0 0 (toList bs)
 
 -- TODO This assumes 64-bit words
 packWord :: ByteString -> Word
-packWord buf = go 0 0 (toList buf)
+packWord buf = go 0 0
   where
-    go acc idx []     = acc
-    go acc idx (x:xs) = go (acc .|. i idx (8*idx)) (idx+1) xs
+    top        = min 8 (length buf)
+    i idx off  = shiftL (fromIntegral $ BS.index buf idx) off
+    go acc idx = if idx >= top then acc else
+                 go (acc .|. i idx (8*idx)) (idx+1)
 
-    i :: Int -> Int -> Word
-    i idx off = shiftL (fromIntegral $ BS.index buf idx) off
 
 -- TODO This assumes 64-bit words
 unpackWord :: Word -> ByteString
@@ -102,38 +113,41 @@ unpackWord wor = reverse $ fromList $ go 0 []
 
 --------------------------------------------------------------------------------
 
-bytesToWords :: ByteString -> [Word]
-bytesToWords = go []
-  where
-    go :: [Word] -> ByteString -> [Word]
-    go acc buf | null buf  = reverse acc
-    go acc buf | otherwise = go (packWord buf : acc) (drop 8 buf)
+bytesToWords :: ByteString -> VP.Vector Word
+bytesToWords bytes =
+  VP.generate (1 + length bytes `div` 8) $ \i ->
+    packWord (BS.drop (i*8) bytes)
 
-wordsToBytes :: [Word] -> ByteString
-wordsToBytes = concat . fmap unpackWord
+fromPrimVec :: Prim a => VP.Vector a -> V.Vector a
+fromPrimVec vp = V.generate (VP.length vp) (VP.unsafeIndex vp)
+
+wordsToBytes :: VP.Vector Word -> ByteString
+wordsToBytes = stripTrailingZeros . concat . fmap unpackWord . fromPrimVec
 
 --------------------------------------------------------------------------------
 
-dumbUnpackAtom :: ByteString -> Atom
-dumbUnpackAtom bs = go 0 0 (toList bs)
+dumbPackAtom :: ByteString -> Atom
+dumbPackAtom bs = go 0 0 (toList bs)
   where
     go acc i []     = acc
     go acc i (x:xs) = go (acc .|. shiftL (fromIntegral x) (8*i)) (i+1) xs
 
-unpackAtom :: ByteString -> Atom
-unpackAtom = MkAtom . wordsToNatural . bytesToWords . stripTrailingZeros
+packAtom :: ByteString -> Atom
+packAtom = MkAtom . wordsToNatural . bytesToWords . stripTrailingZeros
+
+unpackAtom :: Atom -> ByteString
+unpackAtom (MkAtom a) = wordsToBytes (naturalToWords a)
+
+--------------------------------------------------------------------------------
 
 loadFile :: FilePath -> IO Atom
-loadFile = fmap unpackAtom . readFile
+loadFile = fmap packAtom . readFile
 
 loadJam :: FilePath -> IO (Maybe Noun)
 loadJam = fmap cue . loadFile
 
--- dumpJam :: FilePath -> Noun -> IO ()
--- dumpJam pat = writeFile pat . packAtom . jam
-
--- packAtom :: Atom -> ByteString
--- packAtom = undefined
+dumpJam :: FilePath -> Noun -> IO ()
+dumpJam pat = writeFile pat . unpackAtom . jam
 
 dumpFlat :: Flat a => FilePath -> a -> IO ()
 dumpFlat pat = writeFile pat . flat
@@ -145,16 +159,31 @@ loadFlat pat = do
 
 data Pill = Brass | Ivory | Solid
 
-tryPill :: Pill -> IO String
-tryPill pill =
-    loadJam pat <&> \case Nothing -> "nil"; Just (Atom _) -> "atom"; _ -> "cell"
-  where
-    pat = case pill of Brass -> "./bin/brass.pill"
-                       Solid -> "./bin/solid.pill"
-                       Ivory -> "./bin/ivory.pill"
+instance Show Pill where
+  show = \case
+    Brass -> "./bin/brass.pill"
+    Solid -> "./bin/solid.pill"
+    Ivory -> "./bin/ivory.pill"
+
+tryLoadPill :: Pill -> IO ()
+tryLoadPill pill = do
+    a@(MkAtom nat) <- loadFile (show pill)
+    putStrLn "loaded"
+    print (a > 0)
+    putStrLn "evaled"
+    print (take 10 $ VP.toList $ naturalToWords nat)
+
+tryCuePill :: Pill -> IO ()
+tryCuePill pill =
+    loadJam (show pill) >>= \case Nothing       -> print "nil"
+                                  Just (Atom _) -> print "atom"
+                                  _             -> print "cell"
 
 -- Tests -----------------------------------------------------------------------
 
+instance Arbitrary ByteString where
+  arbitrary = fromList <$> arbitrary
+
 instance Arbitrary BigNat where
   arbitrary = naturalToBigNat <$> arbitrary
 
@@ -162,7 +191,7 @@ instance Show BigNat where
   show = show . NatJ#
 
 roundTrip :: Eq a => (a -> b) -> (b -> a) -> (a -> Bool)
-roundTrip f g x = x == g (f x)
+roundTrip dump load x = x == load (dump x)
 
 equiv :: Eq b => (a -> b) -> (a -> b) -> (a -> Bool)
 equiv f g x = f x == g x
@@ -170,83 +199,33 @@ equiv f g x = f x == g x
 check :: Atom -> Atom
 check = toAtom . (id :: Integer -> Integer) . fromAtom
 
-prop_packWord       = equiv packWord dumbPackWord . fromList
-prop_unpackBigNat   = roundTrip bigNatToWords wordsToBigNat
-prop_packBigNat     = roundTrip wordsToBigNat bigNatToWords . stripTrailingZeros
-prop_unpackDumb     = equiv unpackAtom dumbUnpackAtom . fromList
-prop_packUnpackWord = roundTrip unpackWord packWord
-prop_explodeBytes   = roundTrip wordsToBytes bytesToWords
+clean :: IsSequence seq
+      => Int ~ Index seq
+      => (Eq (Element seq), Num (Element seq))
+      => seq -> seq
+clean = stripTrailingZeros
+
+prop_packWordSane = equiv packWord dumbPackWord . fromList
+prop_packWord     = roundTrip unpackWord packWord
+prop_unpackWord   = roundTrip packWord (clean . unpackWord) . clean . take 8
+
+prop_unpackBigNat = roundTrip bigNatToWords wordsToBigNat
+
+prop_packBigNat   = roundTrip (wordsToBigNat . VP.fromList)
+                              (clean . VP.toList . bigNatToWords)
+                  . clean
+
+prop_implodeBytes = roundTrip bytesToWords wordsToBytes . clean
+
+prop_explodeBytes = roundTrip (wordsToBytes . VP.fromList)
+                              (clean . VP.toList . bytesToWords)
+                  . clean
+
+prop_packAtomSane = equiv packAtom dumbPackAtom . fromList
+prop_unpackAtom   = roundTrip unpackAtom packAtom
+prop_packAtom     = roundTrip packAtom unpackAtom . clean
 
 --------------------------------------------------------------------------------
 
 main :: IO ()
 main = $(defaultMainGenerator)
-
-{-
-/* u3i_bytes():
-**
-**   Copy `a` bytes from `b` to an LSB first atom.
-*/
-u3_noun
-u3i_bytes(c3_w        a_w,
-            const c3_y* b_y)
-{
-  /* Strip trailing zeroes.
-  */
-  while ( a_w && !b_y[a_w - 1] ) {
-    a_w--;
-  }
-
-  /* Check for cat.
-  */
-  if ( a_w <= 4 ) {
-    if ( !a_w ) {
-      return 0;
-    }
-    else if ( a_w == 1 ) {
-      return b_y[0];
-    }
-    else if ( a_w == 2 ) {
-      return (b_y[0] | (b_y[1] << 8));
-    }
-    else if ( a_w == 3 ) {
-      return (b_y[0] | (b_y[1] << 8) | (b_y[2] << 16));
-    }
-    else if ( (b_y[3] <= 0x7f) ) {
-      return (b_y[0] | (b_y[1] << 8) | (b_y[2] << 16) | (b_y[3] << 24));
-    }
-  }
-
-  /* Allocate, fill, return.
-  */
-  {
-    c3_w        len_w = (a_w + 3) >> 2;
-    c3_w*       nov_w = u3a_walloc((len_w + c3_wiseof(u3a_atom)));
-    u3a_atom* nov_u = (void*)nov_w;
-
-    nov_u->mug_w = 0;
-    nov_u->len_w = len_w;
-
-    /* Clear the words.
-    */
-    {
-      c3_w i_w;
-
-      for ( i_w=0; i_w < len_w; i_w++ ) {
-        nov_u->buf_w[i_w] = 0;
-      }
-    }
-
-    /* Fill the bytes.
-    */
-    {
-      c3_w i_w;
-
-      for ( i_w=0; i_w < a_w; i_w++ ) {
-        nov_u->buf_w[i_w >> 2] |= (b_y[i_w] << ((i_w & 3) * 8));
-      }
-    }
-    return u3a_to_pug(u3a_outa(nov_w));
-  }
-}
--}

pkg/hair/package.yaml

@@ -13,6 +13,12 @@ executables:
     main: Main.hs
     source-dirs: app/uterm
     dependencies: ["vere"]
+    ghc-options:
+      - -threaded
+      - -rtsopts
+      - "-with-rtsopts=-H128m"
+      - -fwarn-incomplete-patterns
+      - -O2
 
   vere:
     main: Main.hs