Rework BufEcho demo to SpramReverse (#37)

exe/Main.hs

@@ -36,7 +36,11 @@ parseDemo = asum
   , flag' Hello $ long "Hello" <> help "Hello demo"
   , flag' Echo $ long "Echo" <> help "Echo demo"
   , flag' LedCtrl $ long "LedCtrl" <> help "Control Led IP through UART"
-  , flag' BufEcho $ long "BufEcho" <> help "BufEcho demo"
+  , flag' SpramReverse $ mconcat
+    [ long "SpramReverse"
+    , help "SpramReverse demo: Send bytes to UART, buffer them in SPRAM, then \
+           \read the bytes LIFO."
+    ]
   ]
 
 parseProve :: Parser Prove

lib/Bayeux.hs

@@ -43,13 +43,13 @@ app = \case
 
 getDemo :: Demo -> File
 getDemo = \case
-  FiatLux    -> fiatLux
-  RgbCounter -> rgbCounter
-  RgbCycle   -> rgbCycle
-  Hello      -> handleErr $ compile hello
-  Echo       -> handleErr $ compile echo
-  LedCtrl    -> handleErr $ compile ledCtrl
-  BufEcho    -> handleErr $ compile bufEcho
+  FiatLux      -> fiatLux
+  RgbCounter   -> rgbCounter
+  RgbCycle     -> rgbCycle
+  Hello        -> handleErr $ compile hello
+  Echo         -> handleErr $ compile echo
+  LedCtrl      -> handleErr $ compile ledCtrl
+  SpramReverse -> handleErr $ compile spramReverse
 
 rgbCounter :: File
 rgbCounter = handleErr $ compile prog

lib/Bayeux/Cell.hs

@@ -4,6 +4,7 @@
 module Bayeux.Cell
   ( -- * Unary
     inc
+  , dec
   , logicNot
   , not
   , -- * Binary
@@ -60,6 +61,9 @@ import Prelude hiding (and, div, mod, not, or)
 inc :: Encode a => Width a => MonadSignal m => Sig a -> m (Sig a)
 inc a = binary addC a $ sig True
 
+dec :: Encode a => Width a => MonadSignal m => Sig a -> m (Sig a)
+dec a = binary subC a $ sig True
+
 logicNot :: MonadSignal m => Sig Bool -> m (Sig Bool)
 logicNot = unary logicNotC
 

lib/Bayeux/Cli.hs

@@ -22,7 +22,7 @@ data Demo = FiatLux
           | Hello
           | Echo
           | LedCtrl
-          | BufEcho
+          | SpramReverse
   deriving (Eq, Read, Show)
 
 data Prove = Prove

lib/Bayeux/Ice40/Spram.hs

@@ -5,9 +5,12 @@
 
 module Bayeux.Ice40.Spram
   ( spramC
-  , Addr14(..)
+  , Word14(..)
   , Word4(..)
   , MonadSpram(..)
+  , Req(..)
+  , rSig
+  , wSig
   , memory
   ) where
 
@@ -51,14 +54,14 @@ spramC name a din maskWrEn wren cs clk sb slp pwrOff dout = Cell
   ]
   CellEndStmt
 
-newtype Addr14 = Addr14{ unAddr14 :: Array (Finite 14) Bool }
+newtype Word14 = Word14{ unWord14 :: Array (Finite 14) Bool }
   deriving (Encode, Eq, Read, Show, Width)
 
 newtype Word4 = Word4{ unWord4 :: Array (Finite 4) Bool }
   deriving (Encode, Eq, Read, Show, Width)
 
 class MonadSpram m where
-  spram :: Sig Addr14     -- ^ address
+  spram :: Sig Word14     -- ^ address
         -> Sig Word16     -- ^ data in
         -> Sig Word4      -- ^ mask write enable
         -> Sig Bool       -- ^ write enable
@@ -86,8 +89,8 @@ instance MonadSpram Rtl where
       dout]
     return $ Sig dout
 
-data Req = R Addr14
-         | W Addr14 Word16 Word4
+data Req = R Word14
+         | W Word14 Word16 Word4
   deriving (Eq, Read, Show)
 
 instance Width Req where
@@ -101,7 +104,7 @@ instance Encode Req where
 sliceWrEn :: Sig Req -> Sig Bool
 sliceWrEn = slice 34 34
 
-sliceAddr :: Sig Req -> Sig Addr14
+sliceAddr :: Sig Req -> Sig Word14
 sliceAddr = slice 33 20
 
 sliceDataIn :: Sig Req -> Sig Word16
@@ -110,6 +113,12 @@ sliceDataIn = slice 19 4
 sliceMaskWrEn :: Sig Req -> Sig Word4
 sliceMaskWrEn = slice 3 0
 
+rSig :: Sig Word14 -> Sig Req
+rSig a = Sig $ (spec . sig) False <> spec a <> fromString ("20'" <> replicate 20 '0')
+
+wSig :: Sig Word14 -> Sig Word16 -> Sig Word4 -> Sig Req
+wSig a d m = Sig $ (spec . sig) True <> spec a <> spec d <> spec m
+
 memory
   :: Monad       m
   => MonadSignal m

lib/Bayeux/Uart.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE OverloadedLists     #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -7,29 +8,33 @@ module Bayeux.Uart
   ( MonadUart(..)
   , hello
   , echo
-  , bufEcho
+  , spramReverse
   ) where
 
 import Bayeux.Buffer
 import Bayeux.Cell
 import Bayeux.Encode
+import Bayeux.Ice40.Spram
 import Bayeux.Rtl hiding (at, binary, mux, process, shift, shr, unary)
 import Bayeux.Signal
 import Bayeux.Width
 import Control.Monad
+import Control.Monad.Writer
 import Data.Array
 import Data.Bits hiding (shift)
-import Data.Finite
+import Data.Char
+import Data.Finite hiding (sub)
 import Data.Proxy
 import Data.Word
 
 class MonadUart m where
-  transmit :: Word16 -- ^ baud
+  transmit :: Word16                -- ^ baud
            -> Sig (Maybe Word8)
-           -> m ()
-  receive :: Word16   -- ^ baud
-          -> Sig Bool -- ^ rx
-          -> m (Sig (Maybe Word8))
+           -> m (Sig Bool)          -- ^ busy=True, idle=False
+
+  receive  :: Word16                -- ^ baud
+           -> Sig Bool              -- ^ rx
+           -> m (Sig (Maybe Word8))
 
 data Fsm = Idle | Start | Recv | Stop
   deriving (Enum, Eq, Read, Show)
@@ -41,7 +46,7 @@ instance Encode Fsm where
   encode = encode . finiteProxy (Proxy :: Proxy 4) . fromIntegral . fromEnum
 
 instance MonadUart Rtl where
-  transmit baud byte = void $ process $ \txFsm -> do
+  transmit baud byte = process $ \txFsm -> do
     isStart <- txFsm === sig False
     txCtr <- process $ \txCtr -> ifm
       [ (pure isStart .|| txCtr === sig baud) `thenm` val 0
@@ -111,18 +116,113 @@ instance MonadUart Rtl where
 hello :: Monad m => MonadUart m => MonadSignal m => m (Sig Word32)
 hello = process $ \timer -> do
   is5Sec <- timer === sig 60000000
-  transmit 624 $ toMaybeSig is5Sec $ sig 0x61
+  _ <- transmit 624 $ toMaybeSig is5Sec $ sig 0x61
   flip (mux is5Sec) (sig 0) =<< inc timer
 
-echo :: Monad m => MonadUart m => MonadSignal m => m ()
+echo :: Monad m => MonadUart m => MonadSignal m => m (Sig Bool)
 echo = transmit 624 =<< receive 624 =<< input "\\rx"
 
-bufEcho :: Monad m => MonadBuffer m => MonadSignal m => MonadUart m => m ()
-bufEcho = do
-  b <- buf =<< receive 624 =<< input "\\rx"
-  transmit 624 =<< cobuf b
+data ELFsm = Buffering | Cobuffering
+  deriving (Eq, Read, Show)
+
+instance Width ELFsm where
+  width _ = 1
+
+instance Encode ELFsm where
+  encode Buffering   = [B0]
+  encode Cobuffering = [B1]
+
+data EchoLine = EchoLine
+  { rwAddr :: Word14
+  , elFsm  :: ELFsm
+  }
+  deriving (Eq, Read, Show)
+
+instance Width EchoLine where
+  width _ = 15
+
+instance Encode EchoLine where
+  encode el = encode (rwAddr el) <> encode (elFsm el)
+
+sliceRWAddr :: Sig EchoLine -> Sig Word14
+sliceRWAddr = slice 14 1
+
+sliceELFsm :: Sig EchoLine -> Sig ELFsm
+sliceELFsm = slice 0 0
+
+spramReverse
+  :: Monad       m
+  => MonadBuffer m
+  => MonadRtl    m
+  => MonadSignal m
+  => MonadSpram  m
+  => MonadUart   m
+  => MonadWriter [ModuleBody] m
+  => m (Sig EchoLine)
+spramReverse = do
+  wM <- receive 624 =<< input "\\rx"
+  isNewline <- (sig . fromIntegral . ord) '\n' === sliceValue wM
+  notNewline <- logicNot isNewline
+  process $ \s -> do
+    let rwAddrSig = sliceRWAddr s
+        fsm = sliceELFsm s
+    rAddr <- rwAddrSig `sub` Sig "14'00000000000001"
+    isEmpty <- rAddr === (Sig "14'00000000000000")
+    txBusy <- (\txBusy -> do
+      txIdle <- logicNot txBusy
+      isWrite <- sliceValid wM `logicAnd` notNewline
+      pats fsm
+        [ Buffering ~~> toMaybeSig
+          isWrite
+          (wSig
+            rwAddrSig
+            (Sig $ "8'00000000" <> (spec . sliceValue) wM)
+            (Sig "4'0011")
+          )
+        , Cobuffering ~~> toMaybeSig txIdle (rSig rAddr)
+        ]) >-< (transmit 624 . repack <=< memory)
+    txIdle' <- process $ const $ logicNot txBusy
+    isWrite <- sliceValid wM `logicAnd` notNewline
+    isRead <- txBusy `logicAnd` txIdle' -- from idle to busy
+    rwAddrSig' <- patm fsm
+      [ Buffering ~> ifm
+        [ pure isWrite `thenm` (inc rwAddrSig)
+        , elsem $ pure rwAddrSig
+        ]
+      , Cobuffering ~> ifm
+        [ pure isRead `thenm` (dec rwAddrSig)
+        , elsem $ pure rwAddrSig
+        ]
+      ]
+    fsm' <- patm fsm
+      [ Buffering ~> patm wM
+        [ (Just . fromIntegral . ord) '\n' ~> val Cobuffering
+        , wildm $ pure fsm
+        ]
+      , Cobuffering ~> ifm
+        [ (isRead `logicAnd` isEmpty) `thenm` val Buffering
+        , elsem $ pure fsm
+        ]
+      ]
+    return $ Sig $ spec rwAddrSig' <> spec fsm'
   where
-    buf :: MonadBuffer m => Sig (Maybe Word8) -> m (Sig (Maybe (Array (Finite 1) Word8)))
-    buf = buffer
-    cobuf :: MonadBuffer m => Sig (Maybe (Array (Finite 1) Word8)) -> m (Sig (Maybe Word8))
-    cobuf = cobuffer
+    repack :: Sig (Maybe Word16) -> Sig (Maybe Word8)
+    repack s = Sig $ (spec . sliceValid) s <> (spec . slice 7 0 . sliceValue) s
+
+-- | Interconnect. Create a `Sig a`. Apply it to the first argument. Apply the result
+-- to the second argument. Connect the result to the `Sig a`.
+(>-<)
+  :: forall m a b
+   . Monad       m
+  => MonadRtl    m
+  => MonadSignal m
+  => MonadWriter [ModuleBody] m
+  => Width a
+  => (Sig a -> m (Sig b))
+  -> (Sig b -> m (Sig a))
+  -> m (Sig a)
+f >-< g = do
+  a  <- freshWire (width (undefined :: a))
+  a' <- g =<< f (Sig a)
+  tell [ModuleBodyConnStmt $ ConnStmt a (spec a')]
+  return $ Sig a

test/Test/Bayeux/Uart.hs

@@ -23,12 +23,12 @@ tests =
   [ testGroup "pretty"
       [ prettyTest "hello" $ handleErr $ compile hello
       , prettyTest "echo"  $ handleErr $ compile echo
-      , prettyTest "bufEcho" $ handleErr $ compile bufEcho
+      , prettyTest "spramReverse" $ handleErr $ compile spramReverse
       ]
   , testGroup "synth"
       [ synthTest "hello" $ handleErr $ compile hello
       , synthTest "echo"  $ handleErr $ compile echo
-      , synthTest "bufEcho" $ handleErr $ compile bufEcho
+      , synthTest "spramReverse" $ handleErr $ compile spramReverse
       ]
   ]