diff --git a/Hardware/KansasLava/Boards/Spartan3e.hs b/Hardware/KansasLava/Boards/Spartan3e.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/Boards/Spartan3e.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Hardware.KansasLava.Boards.Spartan3e ( + -- * Class for the methods of the Spartan3e + Spartan3e(..) + -- * Initialization, and global settings. + , clockRate + , writeUCF + -- * Data structures + , Serial(..) + -- * Utilities for Board and Simulation use + , switchesP + , buttonsP + , ledsP + ) where + + +import Language.KansasLava as KL +import Hardware.KansasLava.LCD.ST7066U +import Hardware.KansasLava.RS232 +import Hardware.KansasLava.Rate +import Hardware.KansasLava.Boards.UCF + +import Data.Sized.Unsigned +import Data.Sized.Ix hiding (all) +import Data.Sized.Matrix hiding (all) +import Data.Char +import System.IO +import Control.Applicative +import Control.Monad.Fix + +------------------------------------------------------------ +-- The Spartan3e class +------------------------------------------------------------ + +class MonadFix fabric => Spartan3e fabric where + ---------------------------------------------------------------------------- + + -- | 'board_init' sets up the use of the clock. + -- Always call 'board_init' first. [Required]. + board_init :: fabric () + + -- | 'rot_as_reset' sets up the rotary dial as a reset switch. + rot_as_reset :: fabric () + + ---------------------------------------------------------------------------- + + -- | 'mm_lcdP' gives a memory mappped (mm) API to the LCD. + -- Disables the StrataFlash (for now). + mm_lcdP :: FabricPatch fabric + (Seq (Enabled ((X2,X16),U8))) () + (Seq Ack) () + + -- | 'rs232_txP' gives a patch level API for transmission of bytes + -- over one of the serial links. + rs232_txP :: Serial -- ^ port + -> Integer -- ^ baud rate + -> FabricPatch fabric + (Seq (Enabled U8)) () + (Seq Ack) () + + -- | 'rs232_rxP' gives a patch level API for reception of bytes + -- over one of the serial links. Note there is no hand-shaking + -- because the (implied) UART does no buffering; you better be + -- ready. + rs232_rxP :: Serial -- ^ port + -> Integer -- ^ baud rate + -> FabricPatch fabric + () (Seq (Enabled U8)) + () () + + ---------------------------------------------------------------------------- + + -- | 'tickTock' generates 'n' pulses per second, + -- based on the expected simulation, or clockrate on the board. + -- The purpose is for controlling real-time sampling, or for animations. + -- + tickTock :: (Size w) => Witness w -> Integer -> fabric (Seq Bool) + + ---------------------------------------------------------------------------- + +-- -- | 'lcd' give raw access to the lcd bus. Disables the StrataFlash (for now). +-- lcd :: Seq U1 -> Seq U4 -> Seq Bool -> fabric () + + -- | 'switches' gives raw access to the position of the toggle switches. + switches :: fabric (Matrix X4 (Seq Bool)) + + -- | 'buttons' gives raw access to the state of the buttons. + buttons :: fabric (Matrix X4 (Seq Bool)) + + -- | 'leds' drives the leds + leds :: Matrix X8 (Seq Bool) -> fabric () + + -- | 'dial_button' gives raw access to the state of the dial button + dial_button :: fabric (Seq Bool) + + -- | 'dial_rot' gives Enabled packets when dial is rotated, + -- and if the rotation was clockwise + dial_rot :: fabric (Seq (Enabled Bool)) + +{- + -- | 'mm_vgaP' gives a memory mapped API to the VGA port. + -- Each charactor has an extra attribute + mm_vgaP :: Patch (Seq (Enabled ((X40,X80),(VGA.Attr,U7)))) (fabric ()) + (Seq Ack) () +-} + +------------------------------------------------------------ +-- initialization +------------------------------------------------------------ + +-- | The clock rate on the Spartan3e (50MHz), in hertz. +clockRate :: Integer +clockRate = 50 * 1000 * 1000 + +-- | show out a suggested UCF file for Spartan3e, for a specific circuit. +writeUCF :: FilePath -> KLEG -> IO () +writeUCF = copyUCF "Spartan3e.ucf" + +------------------------------------------------------------ +-- instance +------------------------------------------------------------ + +instance Spartan3e Fabric where + board_init = do + -- we need to name and pull in the clock + theClk "CLK_50MHZ" + + rot_as_reset = theRst "ROT_CENTER" + + ------------------------------------------------------------ + -- Patches + ------------------------------------------------------------ + + mm_lcdP = patchF (mm_LCD_Inst $$ init_LCD $$ phy_Inst_4bit_LCD) |$| buildF (\ (bus,_) -> do + let (rs,sf_d,e) = unpack bus + lcd rs sf_d e + return ((),())) + where lcd rs sf_d e = do + outStdLogic "LCD_RS" rs + outStdLogicVector "SF_D" (appendS (0 :: Seq (U8)) sf_d :: Seq U12) + outStdLogic "LCD_E" e + outStdLogic "LCD_RW" low + outStdLogic "SF_CE0" high + + rs232_txP serial baud = patchF (rs232out baud clockRate) |$| buildF (\ (bus,_) -> do + outStdLogic ("RS232_" ++ show serial ++ "_TX") bus + return ((),())) + + rs232_rxP serial baud = buildF (\ ~(_,_) -> do + inp :: Seq Bool <- inStdLogic ("RS232_" ++ show serial ++ "_RX") + let (_,out) = execP (rs232in baud clockRate) (inp,()) + return ((),out)) + + ------------------------------------------------------------ + -- RAW APIs + ------------------------------------------------------------ + + + + switches = do + inp <- inStdLogicVector "SW" :: Fabric (Seq (Matrix X4 Bool)) + return (unpack inp) + + + buttons = do + i0 <- inStdLogic "BTN_WEST" + i1 <- inStdLogic "BTN_NORTH" + i2 <- inStdLogic "BTN_EAST" + i3 <- inStdLogic "BTN_SOUTH" + return (matrix [i0,i1,i2,i3]) + + leds inp = outStdLogicVector "LED" (pack inp :: Seq (Matrix X8 Bool)) + + dial_button = + inStdLogic "ROT_CENTER" + + dial_rot = error "dial_rot is not (yet) supported in the hardware" + + + tickTock wit hz = do + return (rate wit (1 / (fromIntegral clockRate / fromIntegral hz))) + + +------------------------------------------------------------- +-- data structures +------------------------------------------------------------- + +data Serial = DCE | DTE deriving (Eq, Ord, Show) + +------------------------------------------------------------- +-- Utilites that can be shared +------------------------------------------------------------- + +-- | 'switchesP' gives a patch-level API for the toggle switches. +switchesP :: (Spartan3e fabric) => + fabric (Patch () (Matrix X4 (Seq Bool)) + () (Matrix X4 ())) +switchesP = do + sws <- switches + return (outputP sws $$ + backwardP (\ _mat -> ()) $$ + matrixStackP (pure emptyP)) + + +-- | 'buttonsP' gives a patch-level API for the toggle switches. +buttonsP :: (Spartan3e fabric) => + fabric (Patch () (Matrix X4 (Seq Bool)) + () (Matrix X4 ())) +buttonsP = do + sws <- buttons + return (outputP sws $$ + backwardP (\ _mat -> ()) $$ + matrixStackP (pure emptyP)) + +-- | 'ledP' gives a patch-level API for the leds. +ledsP :: (Spartan3e fabric) => + Patch (Matrix X8 (Seq Bool)) (fabric ()) + (Matrix X8 ()) () +ledsP = + backwardP (\ () -> pure ()) $$ + forwardP leds + + + diff --git a/Hardware/KansasLava/Boards/UCF.hs b/Hardware/KansasLava/Boards/UCF.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/Boards/UCF.hs @@ -0,0 +1,44 @@ +module Hardware.KansasLava.Boards.UCF (copyUCF) where + +import Language.KansasLava as KL +import System.IO +import Data.Char + +import Paths_kansas_lava_cores + +copyUCF :: FilePath -> FilePath -> KLEG -> IO () +copyUCF src dest kleg = do + let inputs = theSrcs kleg + let findMe = concat + [ case toStdLogicType ty of + SL -> [ nm ] + SLV n -> [ nm ++ "<" ++ show i ++ ">" + | i <- [0..(n-1)] + ] + | (nm,ty) <- (theSrcs kleg) ++ map (\ (a,b,c) -> (a,b)) (theSinks kleg) + ] + + let isComment ('#':_) = True + isComment xs | all isSpace xs = True + isComment _ = False + + let getName xs | take 5 xs == "NET \"" + = Just (takeWhile (/= '"') (drop 5 xs)) + getName _ = Nothing + + let hdr = unlines + [ "# Generated automatically by kansas-lava-cores" + , "#" ++ show findMe + ] + + filename <- getDataFileName ("UCF/" ++ src) + big_ucf <- readFile filename + let lns = unlines + [ let allow = case getName ln of + Nothing -> True + Just nm -> nm `elem` findMe + in (if allow then "" else "# -- ") ++ ln + | ln <- lines big_ucf + ] + + writeFile dest (hdr ++ lns) diff --git a/Hardware/KansasLava/Chunker.hs b/Hardware/KansasLava/Chunker.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/Chunker.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, NoMonomorphismRestriction, Rank2Types, TypeOperators #-} + +module Hardware.KansasLava.Chunker where -- (chunker, dechunker) where + +import Data.Sized.Unsigned +import Data.Sized.Signed +import Data.Sized.Arith +import Data.Sized.Ix +import Data.Sized.Matrix as M + +import Language.KansasLava +import qualified Language.KansasLava as KL +import Data.Maybe as Maybe +import Data.Char as Char +import Control.Monad +import Data.Default +import Data.Word +import Debug.Trace + +import Hardware.KansasLava.FIFO + + +-- | We use network byte order +-- http://en.wikipedia.org/wiki/Endianness#Endianness_in_networking +{- + +----+----+--------+ + | HI | LO | DATA | + +----+----+--------+ + + The idea is that a chunk can be transmitted *without* needing any extra inputs or stimuli. + Like an atomic unit of data. + +-} + +waitForIt :: forall c sig a b t x y . + ( Clock c, sig ~ Signal c + , Rep a + , b ~ Unsigned x, Size x + , Size t + ) => b -- ^ The maximum size of chunk + -> Witness t -- ^ 2^t is the timeout time between elements + -> Patch (sig (Enabled a)) (sig (Enabled b)) + (sig Ack) (sig Ack) +waitForIt maxCounter Witness ~(inp,outAck) = (toAck tick,out) + where + -- triggers + ready :: sig Bool + ready = state .==. 0 + + send :: sig Bool + send = state .==. 1 .&&. fromAck outAck + + tick :: sig Bool + tick = state .==. 0 .&&. isEnabled inp + + -- the state + state :: sig X2 + state = register 0 + $ cASE [ (tick .&&. counter0 .==. fromIntegral maxCounter, 1) + -- if reached max, then tick + , (timer .==. 0 .&&. counter0 .>. 0, 1) -- please send the size next time round + , (send .&&. fromAck outAck, 0) -- sent the size out + ] state + + counter0, counter1 :: sig b + counter0 = cASE [ (tick, counter1 + 1) + , (send, 0) + ] counter1 + counter1 = register 0 counter0 + + out = packEnabled (state .==. 1) counter1 + + -- in the background, we wait for a timeout event. + timer :: sig (Unsigned t) + timer = register 1 + $ cASE [ (state .==. 1, 1) + -- only dec if there *is* some data + , (counter1 .>. 0, timer + 1) + ] timer + + +-- | Count a (fixed-sized) header with 1's, and a payload with 0's. +-- The fixed sized header counting is done before reading the payload size. +chunkCounter :: forall c sig x y . (Clock c, sig ~ Signal c, Size x, Num x, Rep x, Size y, Rep y, Num y) + => Witness x -- number of 1's on the front + -> Patch (sig (Enabled (Unsigned y))) (sig (Enabled Bool)) + (sig Ack) (sig Ack) +chunkCounter w = ackToReadyBridge $$ chunkCounter' w $$ readyToAckBridge where + chunkCounter' Witness ~(inp,outReady) = (toReady ready,control) + where + -- triggers + send_one = state .==. 0 .&&. fromReady outReady + recv_count = state .==. 1 .&&. isEnabled inp + + state :: sig X3 + state = register 0 + $ cASE [ (send_one .&&. ones0 .==. 0, 1) + , (recv_count .&&. enabledVal inp .==. 0, 0) -- do not issue *any* zeros for '0'. + , (recv_count, 2) + , (state .==. 2 .&&. counter0 .==. 0, 0) + ] state + + -- send out x 1's. + ones0 :: sig x + ones0 = cASE [ (send_one, loopingDecS ones1) ] + ones1 + + ones1 = register (0 :: x) ones0 + + ready :: sig Bool + ready = state .==. 1 + + counter0 :: sig (Unsigned y) + counter0 = cASE [ (recv_count, enabledVal inp) + , (state .==. 2 .&&. fromReady outReady, counter1 - 1) + ] counter1 + + counter1 = register 0 counter0 + + control :: sig (Enabled Bool) + control = cASE [ (state .==. 0 .&&. fromReady outReady, enabledS high) + , (state .==. 2 .&&. fromReady outReady, enabledS low) + ] disabledS + + +chunkJoinHeader :: forall c sig x y a . + (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x, Rep y, Size y, Num y) + => (forall comb . Signal comb (Matrix x a) -> Signal comb (Unsigned y)) + -> Patch (sig (Enabled (Matrix x a)) :> sig (Enabled a)) (sig (Enabled a)) + (sig Ack :> sig Ack) (sig Ack) + +chunkJoinHeader f = patch1 $$ patch2 $$ patch3 + where + patch1 = stackP (dupP $$ + stackP (forwardP (mapEnabled f) $$ + fifo1 $$ + chunkCounter (Witness :: Witness x)) + (fifo1 $$ matrixToElementsP $$ fifo1) + ) + fifo1 + patch2 = forwardP (\ ((a :> b) :> c) -> a :> b :> c) $$ + backwardP (\ (a :> b :> c) -> (a :> b) :> c) + patch3 = muxP + +chunkSplitHeader :: forall c sig x y a . + (Clock c, sig ~ Signal c, Rep a, Rep x, Size x, Num x, Enum x, Rep y, Size y, Num y) + => (forall comb . Signal comb (Matrix x a) -> Signal comb (Unsigned y)) + -> Patch (sig (Enabled a)) (sig (Enabled (Matrix x a)) :> sig (Enabled a)) + (sig Ack) (sig Ack :> sig Ack) +chunkSplitHeader f = + loopP $ + (fifo1 `stackP` fifo1) $$ + deMuxP $$ + (fstP (fifo1 $$ matrixFromElementsP $$ dupP $$ fstP clicker)) $$ + reorg + where + clicker = forwardP (mapEnabled f) $$ + fifo1 $$ + chunkCounter (Witness :: Witness x) + reorg = forwardP (\ ((a :> b) :> c) -> a :> b :> c) $$ + backwardP (\ (a :> b :> c) -> (a :> b) :> c) + +-- TODO: generalize to Non-X1 headers, and use witness for max chunk size (so that the fifo size can be driven). +chunker :: forall c sig t w . (Size t, Clock c, sig ~ Signal c) + => Unsigned X8 -- max chunk size + -> Witness t -- 2^t is the timeout for a chunk + -> (forall comb . Signal comb (Matrix X1 U8) -> Signal comb U8) -- interprete the header + -> (forall comb . Signal comb (Unsigned X8) -> Signal comb (Matrix X1 U8)) -- constructing the header + -> Patch (sig (Enabled U8)) (sig (Enabled U8)) + (sig Ack) (sig Ack) +chunker mx wit f g = dupP $$ stackP waiting stalling $$ chunkJoinHeader f + where + waiting = waitForIt mx wit $$ + mapP g + + stalling = fifo (Witness :: Witness X256) low + +rdByteHeader :: Signal comb (Matrix X1 U8) -> Signal comb U8 +rdByteHeader sz = unpack sz ! 0 + +mkByteHeader :: forall comb . Signal comb U8 -> Signal comb (Matrix X1 U8) +mkByteHeader sz = pack (matrix [sz] :: Matrix X1 (Signal comb U8)) + +--twoByteHeader :: Signal comb U16 -> Signal comb (Matrix X2 U8) +--twoByteHeader sz = pack (matrix [sz] :: Matrix X2 U8) diff --git a/Hardware/KansasLava/FIFO.hs b/Hardware/KansasLava/FIFO.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/FIFO.hs @@ -0,0 +1,352 @@ +{-# LANGUAGE TypeFamilies, ExistentialQuantification, FlexibleInstances, UndecidableInstances, FlexibleContexts, + ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies,ParallelListComp, + RankNTypes, TypeOperators #-} + +module Hardware.KansasLava.FIFO where + +import Control.Concurrent +import Control.Monad +import Data.Maybe as Maybe +import Data.Sized.Arith as Arith +import Data.Sized.Ix as X +import Data.Word +import Data.Sized.Unsigned + +import Language.KansasLava + +import System.IO + + +------------------------------------------------------------------------------ + +-- | Make a sequence obey the given reset signal, returning given value on a reset. +resetable :: forall a c. (Clock c, Rep a) => Signal c Bool -> a -> Signal c a -> Signal c a +resetable rst val x = mux rst (x,pureS val) + +fifoFE :: forall c a counter ix sig . + (Size counter + , Size ix + , counter ~ ADD ix X1 + , Rep a + , Rep counter + , Rep ix + , Num counter + , Num ix + , Clock c + , sig ~ Signal c + ) + => Witness ix + -- ^ depth of FIFO + -> Signal c Bool + -- ^ hard reset option + -> Patch (sig (Enabled a)) (sig (Enabled (ix,a)) :> sig Bool) + (sig Ack) (sig Ready :> sig counter) + -- ^ input, and Seq trigger of how much to decrement the counter, + -- ^ backedge for input, internal counter, and write request for memory. +fifoFE w rst = ackToReadyBridge $$ fifoFE' w rst where + fifoFE' Witness rst ~(inp,mem_ready :> dec_by) = (toReady inp_ready, wr :> inp_done0) + where + inp_try0 :: Signal c Bool + inp_try0 = inp_ready `and2` isEnabled inp -- `and2` fromReady mem_ready + + wr :: Signal c (Enabled (ix,a)) + wr = packEnabled (inp_try0) + (pack (wr_addr,enabledVal inp)) + + inp_done0 :: Signal c Bool + inp_done0 = isEnabled wr `and2` fromReady mem_ready + + wr_addr :: Signal c ix + wr_addr = resetable rst 0 + $ register 0 + $ mux inp_done0 (wr_addr,loopingIncS wr_addr) + + in_counter0 :: Signal c counter + in_counter0 = resetable rst 0 + $ in_counter1 + + (unsigned) inp_done0 + - dec_by + + in_counter1 :: Signal c counter + in_counter1 = register 0 in_counter0 + + -- TODO: make this happen on the clock edge + inp_ready :: Signal c Bool + inp_ready = (in_counter1 .<. fromIntegral (size (error "witness" :: ix))) + `and2` + (bitNot rst) + `and2` + (fromReady mem_ready) + +fifoBE :: forall a c counter ix sig . + (Size counter + , Size ix + , counter ~ ADD ix X1 + , Rep a + , Rep counter + , Rep ix + , Num counter + , Num ix + , Clock c + , sig ~ Signal c + ) + => Witness ix + -> Signal c Bool -- ^ reset +-- -> (Signal comb Bool -> Signal comb counter -> Signal comb counter) +-- -> Seq (counter -> counter) + -> Patch (sig (Enabled a) :> sig counter) (sig (Enabled a)) + (sig (Enabled ix) :> sig Bool) (sig Ack) + +{- + -> (Signal c counter,Signal c (Enabled a)) + -- inc from FE + -- input from Memory read + -> Signal c Ack + -> ((Signal c ix, Signal c Bool, Signal c counter), Signal c (Enabled a)) +-} + -- address for Memory read + -- dec to FE + -- internal counter, and + -- output for HandShaken +fifoBE Witness rst (mem_rd :> inc_by, out_ready) = + let + rd_addr0 :: Signal c ix + rd_addr0 = resetable rst 0 + $ mux out_done0 (rd_addr1,loopingIncS rd_addr1) + + rd_addr1 = register 0 + $ rd_addr0 + + -- technically, ack should never happen if isEnabled out is not set + out_done0 :: Signal c Bool + out_done0 = fromAck out_ready `and2` (isEnabled out) + + out :: Signal c (Enabled a) + out = packEnabled ((out_counter1 .>. 0) `and2` bitNot rst `and2` isEnabled mem_rd) (enabledVal mem_rd) + + out_counter0 :: Signal c counter + out_counter0 = resetable rst 0 + $ out_counter1 + + inc_by + - (unsigned) out_done0 + + out_counter1 = register 0 out_counter0 + in + (enabledS rd_addr0 :> out_done0, out) + +-- This remains 'ready', because it is a reasonable use of ready. +-- TODO: Consider +fifoMem :: forall a c1 c2 counter ix sig1 sig2 . + (Size counter + , Size ix + , counter ~ ADD ix X1 + , Rep a + , Rep counter + , Rep ix + , Num counter + , Num ix + , Clock c1 + , Clock c2 + , sig1 ~ Signal c1 + , sig2 ~ Signal c2 + , c1 ~ c2 + ) + => Witness ix + -> Patch (sig1 (Enabled (ix,a)) :> sig1 Bool) (sig2 (Enabled a) :> sig2 counter) + (sig1 Ready :> sig1 counter) (sig2 (Enabled ix) :> sig2 Bool) +fifoMem Witness ~(~(wr_in :> wr_in_done),~(rd_addr :> sent)) = (toReady high :> dec_fe,mem_val :> inc_be) + where + -- This is the memory. + mem_val = packEnabled (register False (isEnabled rd_addr)) + $ syncRead (writeMemory wr_in) + (enabledVal rd_addr) + + -- Saying Here is some space to write to. + dec_fe = (unsigned) sent + + -- This needs a two-cycle delay, to provide time for the memory read + inc_be = (unsigned) $ register False $ register False $ wr_in_done + + +fifoCounter :: forall counter . (Num counter, Rep counter) => Seq Bool -> Seq Bool -> Seq Bool -> Seq counter +fifoCounter rst inc dec = counter1 + where + counter0 :: Seq counter + counter0 = resetable rst 0 + $ counter1 + + (unsigned) inc + - (unsigned) dec + + counter1 = register 0 counter0 + +fifoCounter' :: forall counter . (Num counter, Rep counter) => Seq Bool -> Seq counter -> Seq counter -> Seq counter +fifoCounter' rst inc dec = counter1 + where + counter0 :: Seq counter + counter0 = resetable rst 0 + $ counter1 + + inc -- mux2 inc (1,0) + - dec -- mux2 dec (1,0) + + counter1 = register 0 counter0 + +fifo :: forall a c counter ix . + (Size counter + , Size ix + , counter ~ ADD ix X1 + , Rep a + , Rep counter + , Rep ix + , Num counter + , Num ix + , Clock c + ) + => Witness ix + -> Signal c Bool + -> Patch (Signal c (Enabled a)) (Signal c (Enabled a)) + (Signal c Ack) (Signal c Ack) + +fifo w_ix rst = fifo_patch + where + fifo_patch = fifoFE w_ix rst $$ fifoMem w_ix $$ fifoBE w_ix rst + + +{- +fifo w_ix rst (inp,out_ready) = + let + wr :: Signal c (Maybe (ix, a)) + inp_ready :: Signal c Ready + (inp_ready, counter_fe, wr) = fifoFE w_ix rst (inp,dec_by) + + inp_done2 :: Signal c Bool + inp_done2 = resetable rst low $ register False $ resetable rst low $ register False $ resetable rst low $ isEnabled wr + + mem :: Signal c ix -> Signal c (Enabled a) + mem = enabledS . pipeToMemory wr + + (rd_addr0 :> out_done0,counter_be,out) = fifoBE w_ix rst (mem rd_addr0 :> inc_by, out_ready) + + dec_by = (unsigned) out_done0 + inc_by = (unsigned) inp_done2 + in + (inp_ready, counter_fe, out) +-} +{- +fifoZ :: forall a c counter ix . + (Size counter + , Size ix + , counter ~ ADD ix X1 + , Rep a + , Rep counter + , Rep ix + , Num counter + , Num ix + , Clock c + ) + => Witness ix + -> Signal c Bool + -> I (Signal c (Enabled a)) (Signal c Ack) + -> O (Signal c Ready) (Signal c (Enabled a),Signal c counter) +fifoZ w_ix rst (inp,out_ready) = + let + wr :: Signal c (Maybe (ix, a)) + inp_ready :: Signal c Ready + (inp_ready, counter, wr) = fifoFE w_ix rst (inp,dec_by) + + inp_done2 :: Signal c Bool + inp_done2 = resetable rst low $ register False $ resetable rst low $ register False $ resetable rst low $ isEnabled wr + + mem :: Signal c ix -> Signal c (Enabled a) + mem = enabledS . pipeToMemory wr + + ((rd_addr0,out_done0,_),out) = fifoBE w_ix rst (inc_by,mem rd_addr0) out_ready + + dec_by = liftS1 (\ b -> mux2 b (1,0)) out_done0 + inc_by = liftS1 (\ b -> mux2 b (1,0)) inp_done2 + in + (inp_ready, (out,counter)) +-} + +{- +fifoToMatrix :: forall a counter counter2 ix iy iz c . + (Size counter + , Size ix + , Size counter2, Rep counter2, Num counter2 + , counter ~ ADD ix X1 + , counter2 ~ ADD iy X1 + , Rep a + , Rep counter + , Rep ix + , Num counter + , Num ix + , Size iy + , Rep iy, StdLogic ix, StdLogic iy, StdLogic a, + WIDTH ix ~ ADD (WIDTH iz) (WIDTH iy), + StdLogic counter, StdLogic counter2, + StdLogic iz, Size iz, Rep iz, Num iy + , WIDTH counter ~ ADD (WIDTH iz) (WIDTH counter2) + , Num iz + , Clock c + ) + => Witness ix + -> Witness iy + -> Signal c Bool + -> HandShaken c (Signal c (Enabled a)) + -> HandShaken c (Signal c (Enabled (M.Matrix iz a))) +fifoToMatrix w_ix@Witness w_iy@Witness rst hs = HandShaken $ \ out_ready -> + let + wr :: Signal c (Maybe (ix, a)) + wr = fifoFE w_ix rst (hs,dec_by) + + inp_done2 :: Signal c Bool + inp_done2 = resetable rst low + $ register False + $ resetable rst low + $ register False + $ resetable rst low + $ isEnabled wr + + mem :: Signal c (Enabled (M.Matrix iz a)) + mem = enabledS + $ pack + $ fmap (\ f -> f rd_addr0) + $ fmap pipeToMemory + $ splitWrite + $ mapEnabled (mapPacked $ \ (a,d) -> (unappendS a,d)) + $ wr + + ((rd_addr0,out_done0),out) = fifoBE w_iy rst (inc_by,mem) <~~ out_ready + + dec_by = mulBy (Witness :: Witness iz) out_done0 + inc_by = divBy (Witness :: Witness iz) rst inp_done2 + in + out + +-- Move into a Commute module? +-- classical find the implementation problem. +splitWrite :: forall a a1 a2 d c . (Rep a1, Rep a2, Rep d, Size a1) => Signal c (Pipe (a1,a2) d) -> M.Matrix a1 (Signal c (Pipe a2 d)) +splitWrite inp = M.forAll $ \ i -> let (g,v) = unpackEnabled inp + (a,d) = unpack v + (a1,a2) = unpack a + in packEnabled (g .&&. (a1 .==. pureS i)) + (pack (a2,d)) + +-} +mulBy :: forall x sz c . (Clock c, Size sz, Num sz, Num x, Rep x) => Witness sz -> Signal c Bool -> Signal c x +mulBy Witness trig = mux trig (pureS 0,pureS $ fromIntegral $ size (error "witness" :: sz)) + +divBy :: forall x sz c . (Clock c, Size sz, Num sz, Rep sz, Num x, Rep x) => Witness sz -> Signal c Bool -> Signal c Bool -> Signal c x +divBy Witness rst trig = mux issue (0,1) + where + issue = trig .&&. (counter1 .==. (pureS $ fromIntegral (size (error "witness" :: sz) - 1))) + + counter0 :: Signal c sz + counter0 = cASE [ (rst,0) + , (trig,counter1 + 1) + ] counter1 + counter1 :: Signal c sz + counter1 = register 0 + $ mux issue (counter0,0) + + + diff --git a/Hardware/KansasLava/LCD/ST7066U.hs b/Hardware/KansasLava/LCD/ST7066U.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/LCD/ST7066U.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, TypeOperators, OverloadedStrings, TemplateHaskell #-} +module Hardware.KansasLava.LCD.ST7066U + ( phy_Inst_4bit_LCD + , init_LCD + , mm_LCD_Inst + -- * Instruction Set + , LCDInstruction(..) + , setDDAddr + , writeChar + -- * For testing only + , phy_4bit_LCD + ) where + +import Language.KansasLava as KL +import Data.Sized.Unsigned +import Data.Sized.Ix +import Data.Sized.Matrix as M +import Control.Applicative +import Data.Char +import qualified Data.Bits as B + +import Hardware.KansasLava.Text as F + +---------------------------------------------------------------------- +-- Example usage +---------------------------------------------------------------------- + +-- example_lcd_driver = init_LCD $$ phy_Inst_4bit_LCD + +-- The Sitronix ST7066U is compatible with Samsung X60069X, Samsung KS0066U, +-- Hitachi HD44780, and SMOS SED1278. + +---------------------------------------------------------------------- +-- Controller datastructure& bit formats + +---------------------------------------------------------------------- +data LCDInstruction + = ClearDisplay + | ReturnHome + | EntryMode { moveRight :: Bool, displayShift :: Bool } + | SetDisplay { displayOn :: Bool, cursorOn :: Bool, blinkingCursor :: Bool } + | SetShift { displayShift :: Bool, rightShift :: Bool } + | FunctionSet { eightBit :: Bool, twoLines :: Bool, fiveByEleven :: Bool } + | SetCGAddr { cg_addr :: U6 } + | SetDDAddr { dd_addr :: U7 } + | ReadBusyAddr + | ReadRam + | WriteChar { char :: U8 } + deriving (Eq, Ord, Show) + +$(repBitRep ''LCDInstruction 9) + +setDDAddr :: Signal comb U7 -> Signal comb LCDInstruction +setDDAddr = funMap (return . SetDDAddr) + +writeChar :: Signal comb U8 -> Signal comb LCDInstruction +writeChar = funMap (return . WriteChar) + +-- 9-bit version; am okay with making it 10-bit +instance BitRep LCDInstruction where + -- TODO: complete + bitRep = + -- LCD_RS & DB(7 downto 0) + [ (ClearDisplay, "00000001") ] ++ + [ (ReturnHome, "0000001X") ] ++ + [ (EntryMode (bool a) + (bool b), "000001" & a & b) + | a <- every + , b <- every + ] ++ + [ (SetDisplay (bool a) + (bool b) + (bool c), "00001" & a & b & c) + | a <- every + , b <- every + , c <- every + ] ++ + [ (FunctionSet (bool a) + (bool b) + (bool c), "0010" & a & b & c & ("XX" :: BitPat X2)) + | a <- every + , b <- every + , c <- every + ] ++ + [ (SetCGAddr (fromIntegral addr), "001" & addr) + | addr <- every :: [BitPat X6] + ] ++ -- + [ (SetDDAddr (fromIntegral addr), "01" & addr) + | addr <- every :: [BitPat X7] + ] ++ -- + [ (WriteChar (fromIntegral c), "1" & c) + | c <- every :: [BitPat X8] + ] + +---------------------------------------------------------------------- +-- Low level 4-bit physical driver +---------------------------------------------------------------------- + +-- The physical driver for the LCD patch +-- input: RS+nibble (5bits) and pause length in cycles +-- output: RS, SF_D[11:8], LCD_E +-- assuming LCD_RW is set always low +-- assuming 50Mhz clock + +phy_4bit_LCD :: forall c sig . (Clock c, sig ~ Signal c) + => Patch (sig (Enabled (U5,U18))) (sig (U1,U4,Bool)) + (sig Ack) () +phy_4bit_LCD ~(inp,_) = (toAck inAck,out) + where + + (inAck,out) = runRTL $ do + state <- newReg (5 :: X6) + pause <- newReg (0 :: U18) + counter <- newReg (0 :: U20) + ack <- newReg False + rs <- newReg (0 :: U1) + sf_d <- newReg (0 :: U4) + lcd_e <- newReg False + + let wait = waitFor counter + + let firstWait = 750000 + + + CASE [ IF (reg state .==. 0 .&&. isEnabled inp) $ do + -- waiting for input + ack := pureS True + let (cmd' :: sig U5,pause' :: sig U18) = unpack (enabledVal inp) + let (sf_d':: sig U4,rs' :: sig U1) = unappendS cmd' + pause := pause' + rs := rs' + sf_d := sf_d' + state := 1 + , IF (reg state .==. 1) $ do + wait 2 $ state := 2 + , IF (reg state .==. 2) $ do + lcd_e := commentS "lcd_e := high" high + wait 12 $ state := 3 + , IF (reg state .==. 3) $ do + lcd_e := commentS "lcd_e := low" low + state := 4 + wait 1 $ state := 4 + , IF (reg state .==. 4) $ do + wait ((unsigned) (reg pause)) $ state := 0 + , IF (reg state .==. 5) $ do + wait firstWait $ state := 0 + ] + + -- Ack for one cycle only + CASE [ IF (reg ack .==. high) $ do + ack := pureS False + ] + +-- DEBUG "state" state +{- + wait 750000 $ state := 1 + , IF (reg state .==. 1) $ do + output := pureS (Just + ] +-} + return (commentS "ack" (var ack),pack (reg rs,reg sf_d,commentS "lcd_e" $ reg lcd_e)) + +waitFor :: (Rep b, Num b) => Reg s c b -> Signal c b -> RTL s c () -> RTL s c () +waitFor counter count nextOp = do + CASE [ IF (reg counter ./=. count) $ do + counter := reg counter + 1 + , OTHERWISE $ do + counter := 0 + nextOp + ] + +---------------------------------------------------------------------- +-- Instruction-based driver(s) +---------------------------------------------------------------------- + +-- | 'phy_4bit_Inst' gives a instruction-level interface, in terms of the 4-bit interface. +phy_Inst_4bit_LCD :: forall c sig . (Clock c, sig ~ Signal c) + => Patch (sig (Enabled LCDInstruction)) (sig (U1,U4,Bool)) + (sig Ack) () +phy_Inst_4bit_LCD = toCmds $$ prependP bootCmds $$ phy_4bit_LCD + where + toCmds = mapP splitCmd $$ matrixToElementsP + + bootCmds :: Matrix X4 (U5,U18) + bootCmds = matrix + [ (0x3, 205000) + , (0x3, 5000) + , (0x3, 2000) + , (0x2, 2000) + ] + +splitCmd :: forall comb . Signal comb LCDInstruction -> Signal comb (Matrix X2 (U5,U18)) +splitCmd cmd = pack $ matrix + [ pack ( high_op `appendS` mode + , smallGap + ) + , pack ( low_op `appendS` mode + , mux ((bitwise) cmd .<=. (0x03 :: Signal comb U9)) (bigGap,hugeGap) + ) + ] + where + (op :: Signal comb U8, mode :: Signal comb U1) = unappendS ((bitwise) cmd :: Signal comb U9) + (low_op :: Signal comb U4, high_op :: Signal comb U4) = unappendS op + + smallGap = 50 -- between nibbles + bigGap = 2000 -- between commands + hugeGap = 100000 -- after clear display or return cursor home + +---------------------------------------------------------------------- +-- initialization instructions +---------------------------------------------------------------------- + +init_LCD :: forall c sig . (Clock c, sig ~ Signal c) + => Patch (sig (Enabled LCDInstruction)) (sig (Enabled LCDInstruction)) + (sig Ack) (sig Ack) +init_LCD = prependP initCmds + where + initCmds :: Matrix X4 LCDInstruction + initCmds = matrix [ FunctionSet { eightBit = False, twoLines = True, fiveByEleven = False } + , EntryMode { moveRight = True, displayShift = False } + , SetDisplay { displayOn = True, cursorOn = False, blinkingCursor = False } + , ClearDisplay + ] + +---------------------------------------------------------------------- +-- Memory Mapped version +---------------------------------------------------------------------- + +mm_LCD_Inst :: forall c sig . (Clock c, sig ~ Signal c) + => Patch (sig (Enabled ((X2,X16),U8))) (sig (Enabled LCDInstruction)) + (sig Ack) (sig Ack) + +mm_LCD_Inst = mapP toInsts $$ matrixToElementsP + where + toInsts :: forall comb . Signal comb ((X2,X16),U8) -> Signal comb (Matrix X2 LCDInstruction) + toInsts wr = pack (matrix [ setDDAddr dd_addr, writeChar ch ] :: Matrix X2 (Signal comb LCDInstruction)) + where + (addr,ch) = unpack wr + (row,col) = unpack addr + + dd_addr :: Signal comb U7 + dd_addr = mux (row .==. 0) (0x40 + (unsigned)col,0x00 + (unsigned)col) + diff --git a/Hardware/KansasLava/RS232.hs b/Hardware/KansasLava/RS232.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/RS232.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, NoMonomorphismRestriction, Rank2Types, TemplateHaskell #-} + +module Hardware.KansasLava.RS232 (rs232out, rs232in) where -- , liftWithUART) where + +import Data.Ratio + +import Data.Sized.Unsigned +import Data.Sized.Signed +import Data.Sized.Ix +import Data.Sized.Unsigned as U +import Data.Sized.Matrix as M + +import Hardware.KansasLava.Rate +import Hardware.KansasLava.FIFO(fifo) + +import Language.KansasLava +import qualified Language.KansasLava as KL +import Data.Maybe as Maybe +import Data.Char as Char +import Control.Monad +import Data.Default +import Data.Word +import Debug.Trace + + +-- Lava implementation of RS232 + +type SAMPLE_RATE = X16 + +data RS232_TX + = TX_Idle + | TX_Send X10 + deriving (Show,Eq,Ord) + +isTX_Idle :: (sig ~ Signal c) => sig RS232_TX -> sig Bool +isTX_Idle = funMap $ \ tx -> return $ tx == TX_Idle + +withTX_Send :: (sig ~ Signal c) => sig RS232_TX -> sig (Enabled X10) +withTX_Send = funMap $ \ tx -> return $ case tx of + TX_Send i -> Just i + _ -> Nothing + + +instance BitRep RS232_TX where + bitRep = + [ (TX_Idle, 0) ] ++ + [ (TX_Send v, fromIntegral $ fromIntegral v + 1) | v <- [0..9] ] + + +$(repBitRep ''RS232_TX 4) + +{- +-- Template Haskell would help here. +fromRS232_TX :: RS232_TX -> X11 +fromRS232_TX TX_Idle = 0 +fromRS232_TX (TX_Send n) = fromIntegral n + 1 + +toRS232_TX :: X11 -> RS232_TX +toRS232_TX 0 = TX_Idle +toRS232_TX n = TX_Send (fromIntegral (n - 1)) + +instance Rep RS232_TX where + data X RS232_TX = X_RS232_TX (Maybe RS232_TX) + type W RS232_TX = X4 + unX (X_RS232_TX v) = v + optX b = X_RS232_TX b + repType Witness = repType (Witness :: Witness X11) + toRep (X_RS232_TX v) = toRep (optX (fmap fromRS232_TX v)) + fromRep v = X_RS232_TX (fmap toRS232_TX (unX (fromRep v))) + showRep (X_RS232_TX v) = show v +-} + +(.*&.) :: (sig ~ Signal c, Rep a) => sig (Enabled a) -> sig Bool -> sig (Enabled a) +(.*&.) en_a bool = packEnabled (en .&&. bool) a + where + (en,a) = unpackEnabled en_a + +resize :: (sig ~ Signal c, Integral x, Rep x, Num y, Rep y) => sig x -> sig y +resize = funMap $ \ x -> return (fromIntegral x) + +findBit :: forall sig c . (sig ~ Signal c) => (Num (sig X10)) => sig U8 -> sig X10 -> sig Bool +findBit byte x = (bitwise) byte .!. ((unsigned) (loopingDecS x) :: sig X8) + +rs232out :: forall clk sig a . (Clock clk, sig a ~ Signal clk a) + => Integer -- ^ Baud Rate. + -> Integer -- ^ Clock rate, in Hz. + -> Patch (sig (Enabled U8)) (sig Bool) + (sig Ack) () +rs232out baudRate clkRate ~(inp0,()) = (toAck (ready .&&. in_en),out) + where + -- at the baud rate for transmission + fastTick :: Signal clk Bool + fastTick = rate (Witness :: Witness X16) $ +-- accurateTo + (fromIntegral baudRate / fromIntegral clkRate) +-- 0.99 + + (in_en,in_val) = unpack inp0 + + (ready,out) = runRTL $ do +-- readVal <- newArr (Witness :: Witness X10) + state <- newReg (TX_Idle :: RS232_TX) + char <- newReg (0 :: U8) + output <- newReg (True :: Bool) -- RS232, SPACE => high + +-- DEBUG "state" state + + let ready = isTX_Idle (reg state) + + CASE [ IF (ready .&&. in_en) $ do + state := pureS (TX_Send 0) -- causes full to be set on next clock + char := in_val + ] + + WHEN fastTick $ CASE + [ match (withTX_Send (reg state)) $ \ ix -> do + CASE [ IF (ix .==. maxBound) $ do + state := pureS TX_Idle + , OTHERWISE $ do + state := funMap (\ x -> if x == maxBound + then return (TX_Send 0) + else return (TX_Send (x + 1))) ix + ] + CASE [ IF (ix .==. 0) $ do + output := low -- start bit + , IF (ix .==. 9) $ do + output := high -- stop bit + , OTHERWISE $ do + output := findBit (reg char) ix + ] + ] + + -- We need to use 'var accept', because we need to accept the + -- the on *this* cycle, not next cycle. + return (ready,reg output) + + +-- | rs232in accepts data from UART line, and turns it into bytes. +-- There is no Ack or Ready, because there is no way to pause the 232. +-- For the same reason, this does not use a Patch. + +rs232in :: forall clk sig a . (Clock clk, sig a ~ Signal clk a) + => Integer -- ^ Baud Rate. + -> Integer -- ^ Clock rate, in Hz. + -> Patch (sig Bool) (sig (Enabled U8)) + () () +rs232in baudRate clkRate ~(in_val0,()) = ((),out) + where + -- 16 times the baud rate for transmission, + -- so we can spot the start bit's edge. + fastTick :: Signal clk Bool + fastTick = rate (Witness :: Witness X16) $ +-- accurateTo + (16 * fromIntegral baudRate / fromIntegral clkRate) +-- 0.99 + + + -- the filter, currently length 4 +-- in_vals = in_val0 : map (register True) (take 4 in_vals) + + -- if 4 highs (lows) then go high (low), otherwise as you were. + + inp = in_val0 +{- + inp = register True + (cASE [ (foldr1 (.&&.) in_vals, high) + , (foldr1 (.&&.) (map bitNot in_vals), low) + ] + inp) +-} + findByte :: [sig Bool] -> sig U8 + findByte xs = bitwise (pack (matrix xs :: M.Matrix X8 (sig Bool)) :: sig (M.Matrix X8 Bool)) + + out = runRTL $ do + reading <- newReg False + theByte <- newArr (Witness :: Witness X16) + outVal <- newReg (Nothing :: Enabled U8) + ready <- newReg (False :: Bool) + counter <- newReg (0 :: U8) + + let lowCounter, highCounter :: sig U4 + (lowCounter,highCounter) = unappendS (reg counter) + + WHEN fastTick $ do + CASE [ IF ((reg reading .==. low) .&&. (inp .==. low)) $ do + counter := 0 + reading := high + -- check to see the edge *is* an edge +-- , IF ((reg counter .>. 0) .&&. (reg counter .<. 8) .&&. (inp .==. high)) $ do +-- counter := 0 +-- reading := low + , OTHERWISE $ do + counter := reg counter + 1 + ] + + -- We have a 3 sample average, so we wait an aditional 5 + -- to be in the middle of the 16-times super-sample. + -- So, 5 is 16 / 2 - 3 + WHEN ((reg reading .==. high) .&&. (lowCounter .==. 8)) $ CASE + [ IF (highCounter .<. 9) $ do + theByte ((unsigned) highCounter) := inp + , IF ((highCounter .==. 9) .&&. + (reg (theByte 0) .==. low) .&&. + (inp .==. high) + ) $ do + -- This should be the stop bit + outVal := enabledS + $ findByte [ reg (theByte (fromIntegral i)) + | i <- [1..8] + ] + -- start looking for the start bit now + counter := 0 + reading := low + , OTHERWISE $ do + -- restart; should never happen with good signals + counter := 0 + reading := low + ] + + -- If you send something out, then do not do so on the next cycle. + WHEN (isEnabled (reg outVal)) $ do + outVal := pureS Nothing + + return $ (reg outVal) + diff --git a/Hardware/KansasLava/Random.hs b/Hardware/KansasLava/Random.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/Random.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE TypeFamilies, ScopedTypeVariables, NoMonomorphismRestriction, Rank2Types #-} + +module Hardware.KansasLava.Random (randomBytes) where + +import Language.KansasLava +import Data.Sized.Unsigned + +-- Provides a pseudorandom stream of values. The distinction between the +-- pseudorandomsmall and the pseudorandom versions is the maximum output size. +-- The pseudorandom can output up to 32-bits, whereas the pseudorandomsmall +-- can output a maximum of 8-bits. This is a Lehmer Random Number Generator, +-- which is defined by: +-- X(k+1) = [g * X(k)] mod n +-- +-- The modulus n should be a prime or power of a prime, the multiplier g +-- should be of high multiplicative order modulo n, and the seed X(0) should +-- be coprime to modulus n. The values we used for multiplier g and modulus +-- n are given below. +-- g = 127 +-- n = 257 +-- +-- For more info, see: +-- http://en.wikipedia.org/wiki/Lehmer_random_number_generator +-- + +-- | Provides a pseudorandom stream of values. +-- On a test using the first 100K bytes, all 256 values occurred with +-- the same probability (390 or 391 times). + +randomBytes :: forall c sig . (Clock c, Signal c ~ sig) => sig U8 +randomBytes = (unsigned) rs + where + rs :: sig U16 + rs = iterateS (\ x -> (127 * x) `mod` 257) 127 + diff --git a/Hardware/KansasLava/Rate.hs b/Hardware/KansasLava/Rate.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/Rate.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE RankNTypes, TypeFamilies, ScopedTypeVariables #-} +-- | The 'Clock' module provides a utility function for simulating clock rate +-- downsampling. +module Hardware.KansasLava.Rate(rate, powerOfTwoRate, rateP, throttleP) where + +import Data.Ratio + +import Data.Sized.Unsigned +import Data.Sized.Signed +import Data.Sized.Ix + +import Language.KansasLava + +-- | 'rate' constructs a stream of enable bits used for clock-rate +-- downsampling. For example, with a rate of n=1/2, every other value in the +-- output stream will be True. If 1/n is not a integer, then the function uses +-- http://en.wikipedia.org/wiki/Bresenham%27s_line_algorithm to approximate the +-- given rate. +rate :: forall x clk . (Clock clk, Size x) => Witness x -> Rational -> (Signal clk Bool) +rate Witness n + | step > 2^sz = error $ "bit-size " ++ show sz ++ " too small for punctuate Witness " ++ show n + | n <= 0 = error "can not have rate less than or equal zero" + | n > 1 = error $ "can not have rate greater than 1, requesting " ++ show n + + -- for power of two, a simple counter works + | num == 1 && step == 2^sz = runRTL $ do + count <- newReg (0 :: (Unsigned x)) + count := reg count + 1 + return (reg count .==. 0) + + | num == 1 = runRTL $ do + count <- newReg (0 :: (Unsigned x)) + CASE [ IF (reg count .<. (fromIntegral step - 1)) $ + count := reg count + 1 + , OTHERWISE $ do + count := 0 + ] + return (reg count .==. 0) + + -- inexact reciprocal, so use Bresenham's to approximate things. + | otherwise = runRTL $ do + count <- newReg (0 :: (Unsigned x)) + cut <- newReg (0 :: (Unsigned x)) + err <- newReg (0 :: (Signed x)) + CASE [ IF (reg count .<. (fromIntegral step + reg cut - 1)) $ + count := reg count + 1 + , OTHERWISE $ do + count := 0 + CASE [ IF (reg err .>. 0) $ do + cut := 1 + err := reg err + fromIntegral nerr + , OTHERWISE $ do + cut := 0 + err := reg err + fromIntegral perr + ] + + ] + return (reg count .==. 0) + + where sz :: Integer + sz = fromIntegral (size (error "witness" :: x)) + num = numerator n + dom = denominator n + step = floor (1 / n) + perr = dom - step * num + nerr = dom - (step + 1) * num + +-- | 'powerOfTwoRate' generates a pulse every 2^n cycles, which is often good enough for polling, timeouts, etc. +powerOfTwoRate :: forall x clk . (Clock clk, Size x) => Witness x -> Signal clk Bool +powerOfTwoRate Witness = rate (Witness :: Witness x) (1/(2^(fromIntegral (size (error "Witness" :: x))))) + +-- | 'rateP' takes a result from rate, and generates token, one per pulse, with +-- unused tokens being discared. +rateP :: forall c sig . (Clock c, sig ~ Signal c) + => sig Bool + -> Patch () (sig (Enabled ())) + () (sig Ack) +rateP r = outputP (packEnabled r $ pureS ()) $$ enabledToAckBox + +-- | 'throttleP' throttles input based on a given rate counter. +throttleP :: forall sig c a x . (sig ~ Signal c, Clock c, Rep a) + => sig Bool + -> Patch (sig (Enabled a)) (sig (Enabled a)) + (sig Ack) (sig Ack) +throttleP in_pred + = openP $$ + (top `stackP` emptyP) $$ + zipP $$ + mapP (\ ab -> snd (unpack ab)) + where + top = outputP (packEnabled in_pred (pureS ())) $$ + enabledToAckBox + +{- +-- Wrong, omit for this release. +-- +-- | 'accurateTo' rounds up/down a number within a range, +-- in an attempt to be a integral reciprical (and therefore cheaper to implement in hardware). +--accurateTo :: Rational -> Rational -> Rational +accurateTo n ac + | diff > (1-ac) = error $ "can not find tolerance for " + ++ show n ++ " : need " ++ show (fromRational (1 - diff) :: Float) + | otherwise = nR + where + reci = 1 / n + nR = 1 / (fromInteger $ round reci) + diff = abs (n - nR) +-} + + diff --git a/Hardware/KansasLava/Simulators/Polyester.hs b/Hardware/KansasLava/Simulators/Polyester.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/Simulators/Polyester.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs, DeriveDataTypeable #-} +-- | * Remember to call init_board for your specific board. + +module Hardware.KansasLava.Simulators.Polyester ( + -- * The (abstract) Fake Fabric Monad + Polyester -- abstract + -- * The Polyester non-proper morphisms + , outPolyester + , outPolyesterEvents + , outPolyesterCount + , writeSocketPolyester + , inPolyester + , readSocketPolyester + , getPolyesterExecMode + , getPolyesterClkSpeed + , getPolyesterSimSpeed + -- * Running the Fake Polyester + , runPolyester + , ExecMode(..) + -- * Support for building fake Boards + , generic_init + -- * Support for the (ANSI) Graphics + , ANSI(..) + , Color(..) -- from System.Console.ANSI + , Graphic(..) + ) where + +import System.Console.ANSI +import System.IO +import Data.Typeable +import Control.Exception +import Control.Concurrent +import Control.Monad +import Data.Char +import Control.Monad.Fix +import Data.Word +import System.IO.Unsafe (unsafeInterleaveIO) +import Control.Concurrent +import Network +import System.Directory + +----------------------------------------------------------------------- +-- Monad +----------------------------------------------------------------------- + +-- | The simulator uses its own 'Fabric', which connects not to pins on the chip, +-- but rather an ASCII picture of the board. + +data PolyesterEnv = PolyesterEnv + { pExecMode :: ExecMode + , pFindSocket :: String -> IO Handle + , pClkSpeed :: Integer -- clock speed, in Hz + , pSimSpeed :: Integer -- how many cycles are we *actually* doing a second + } + +data Polyester a = Polyester ([Maybe Char] + -> PolyesterEnv + -> IO (a,[Stepper])) + + +instance Monad Polyester where + return a = Polyester $ \ _ _ -> return (a,[]) + (Polyester f) >>= k = Polyester $ \ inp st -> do + (a,s1) <- f inp st + let Polyester g = k a + (b,s2) <- g inp st + return (b,s1 ++ s2) + fail msg = error msg + +instance MonadFix Polyester where + -- TODO: check this + mfix f = Polyester $ \ inp st -> + mfix (\ r -> let (Polyester g) = f (fst r) + in g inp st) + +getPolyesterExecMode :: Polyester ExecMode +getPolyesterExecMode = Polyester $ \ _ st -> return (pExecMode st,[]) + +getPolyesterClkSpeed :: Polyester Integer +getPolyesterClkSpeed = Polyester $ \ _ st -> return (pClkSpeed st,[]) + +getPolyesterSimSpeed :: Polyester Integer +getPolyesterSimSpeed = Polyester $ \ _ st -> return (pSimSpeed st,[]) + +----------------------------------------------------------------------- +-- Ways out outputing from the Polyester +----------------------------------------------------------------------- + +-- | Checks an input list for diffences between adjacent elements, +-- and for changes, maps a graphical event onto the internal stepper. +-- The idea is that sending a graphical event twice should be +-- idempotent, but internally the system only writes events +-- when things change. +outPolyester :: (Eq a, Graphic g) => (a -> g) -> [a] -> Polyester () +outPolyester f = outPolyesterEvents . map (fmap f) . changed + +changed :: (Eq a) => [a] -> [Maybe a] +changed (a:as) = Just a : f a as + where + f x (y:ys) | x == y = Nothing : f x ys + | otherwise = Just y : f y ys + f _ [] = [] + +-- | Turn a list of graphical events into a 'Polyester', without processing. +outPolyesterEvents :: (Graphic g) => [Maybe g] -> Polyester () +outPolyesterEvents ogs = Polyester $ \ _ _ -> return ((),[stepper ogs]) + +-- | creates single graphical events, based on the number of Events, +-- when the first real event is event 1, and there is a beginning of time event 0. +-- Example of use: count the number of bytes send or recieved on a device. +outPolyesterCount :: (Graphic g) => (Integer -> g) -> [Maybe a] -> Polyester () +outPolyesterCount f = outPolyester f . loop 0 + where + loop n (Nothing:xs) = n : loop n xs + loop n (Just _:xs) = n : loop (succ n) xs + +-- | write a socket from a clocked list input. Example of use is emulating +-- RS232 (which only used empty or singleton strings), for the inside of a list. + +writeSocketPolyester :: String -> [Maybe String] -> Polyester () +writeSocketPolyester filename contents = Polyester $ \ _ st -> do + h <- pFindSocket st filename + return ((),[ ioStepper (map (f h) contents) ]) + where + f :: Handle -> Maybe String -> IO () + f _ Nothing = return () + f h (Just bs) = do + hPutStr h bs + hFlush h + +{- +writeSocketPolyester :: String -> [Maybe String] -> Polyester () +writeSocketPolyester socketname contents = Polyester $ \ _ _ -> do +-} + +----------------------------------------------------------------------- +-- Ways out inputting to the Polyester +----------------------------------------------------------------------- + +-- | Turn an observation of the keyboard into a list of values. +inPolyester :: a -- ^ initial 'a' + -> (Char -> a -> a) -- ^ how to interpreate a key press + -> Polyester [a] +inPolyester a interp = Polyester $ \ inp _ -> do + let f' a' Nothing = a' + f' a' (Just c) = interp c a' + vals = scanl f' a inp + return (vals,[]) + + +-- | 'readSocketPolyester' reads from a socket. +-- The stream is on-demand, and is not controlled by any clock +-- inside the function. Typically would be read one cons per +-- clock, but slower reading is acceptable. +-- This does not make any attempt to register +-- what is being observed on the screen; another +-- process needs to do this. +readSocketPolyester :: String -> Polyester [Maybe Word8] +readSocketPolyester filename = Polyester $ \ inp st -> do + h <- pFindSocket st filename + ss <- hGetContentsStepwise h + return (map (fmap (fromIntegral . ord)) ss,[]) + +----------------------------------------------------------------------- +-- Running the Polyester +----------------------------------------------------------------------- + +data ExecMode + = Fast -- ^ run as fast as possible, and do not display the clock + | Friendly -- ^ run in friendly mode, with 'threadDelay' to run slower, to be CPU friendly. + deriving (Eq, Show) + +-- | 'runPolyester' executes the Polyester, never returns, and ususally replaces 'reifyPolyester'. +runPolyester :: ExecMode -> Integer -> Integer -> Polyester () -> IO () +runPolyester mode clkSpeed simSpeed f = do + + setTitle "Kansas Lava" + putStrLn "[Booting Spartan3e simulator]" + hSetBuffering stdin NoBuffering + hSetEcho stdin False + + -- create the virtual device directory + createDirectoryIfMissing True "dev" + + inputs <- hGetContentsStepwise stdin + +-- let -- clockOut | mode == Fast = return () +-- clockOut | mode == Friendly = +-- outPolyester clock [0..] + + let extras = do + quit <- inPolyester False (\ c _ -> c == 'q') + outPolyester (\ b -> if b + then error "Simulation Quit" + else return () :: ANSI ()) quit + + let Polyester h = (do extras ; f) + sockDB <- newMVar [] + let findSock :: String -> IO Handle + findSock nm = do + sock_map <- takeMVar sockDB + case lookup nm sock_map of + Just h -> do + putMVar sockDB sock_map + return h + Nothing -> do + h <- finally + (do sock <- listenOn $ UnixSocket nm + putStrLn $ "* Waiting for client for " ++ nm + (h,_,_) <- accept sock + putStrLn $ "* Found client for " ++ nm + return h) + (removeFile nm) + hSetBuffering h NoBuffering + putMVar sockDB $ (nm,h) : sock_map + return h + + (_,steps) <- h inputs $ PolyesterEnv + { pExecMode = mode + , pFindSocket = findSock + , pClkSpeed = clkSpeed + , pSimSpeed = simSpeed + } + putStrLn "[Starting simulation]" + putStr "\ESC[2J\ESC[1;1H" + + let slowDown | mode == Fast = [] + | mode == Friendly = + [ ioStepper [ threadDelay (20 * 1000) + | _ <- [(0 :: Integer)..] ]] + + runSteppers (steps ++ slowDown) + +----------------------------------------------------------------------- +-- Utils for building boards +----------------------------------------------------------------------- + +-- | 'generic_init' builds a generic board_init, including +-- setting up the drawing of the board, and printing the (optional) clock. + +generic_init :: (Graphic g1,Graphic g2) => g1 -> (Integer -> g2) -> Polyester () +generic_init board clock = do + -- a bit of a hack; print the board on the first cycle + outPolyester (\ _ -> board) [()] + mode <- getPolyesterExecMode + when (mode /= Fast) $ do + outPolyester (clock) [0..] + return () + +----------------------------------------------------------------------- +-- Abstaction for output (typically the screen) +----------------------------------------------------------------------- + +class Graphic g where + drawGraphic :: g -> ANSI () + +----------------------------------------------------------------------- +-- Internal: The Stepper abstraction, which is just the resumption monad +----------------------------------------------------------------------- + +-- The idea in the future is we can common up the changes to the +-- screen, removing needless movement of the cursor, allowing +-- a slight pause before updating, etc. + +-- Do something, and return. +data Stepper = Stepper (IO (Stepper)) + +runStepper :: Stepper -> IO Stepper +runStepper (Stepper m) = m + +-- | 'runSteppers' runs several steppers concurrently. +runSteppers :: [Stepper] -> IO () +runSteppers ss = do + ss' <- sequence [ runStepper m + | m <- ss + ] +-- threadDelay (10 * 1000) + runSteppers ss' + +-- Stepper could be written in terms of ioStepper +stepper :: (Graphic g) => [Maybe g] -> Stepper +stepper = ioStepper + . map (\ o -> case o of + Nothing -> return () + Just g -> showANSI (drawGraphic g)) + +ioStepper :: [IO ()] -> Stepper +ioStepper (m:ms) = Stepper (do m ; return (ioStepper ms)) +ioStepper other = Stepper (return $ ioStepper other) + +----------------------------------------------------------------------- +-- Helpers for printing to the screen +----------------------------------------------------------------------- + +data ANSI a where + REVERSE :: ANSI () -> ANSI () + COLOR :: Color -> ANSI () -> ANSI () + PRINT :: String -> ANSI () + AT :: ANSI () -> (Int,Int) -> ANSI () + BIND :: ANSI b -> (b -> ANSI a) -> ANSI a + RETURN :: a -> ANSI a + +instance Monad ANSI where + return a = RETURN a + m >>= k = BIND m k + +showANSI :: ANSI a -> IO a +showANSI (REVERSE ascii) = do + setSGR [SetSwapForegroundBackground True] + showANSI ascii + setSGR [] + hFlush stdout +showANSI (COLOR col ascii) = do + setSGR [SetColor Foreground Vivid col] + showANSI ascii + setSGR [] + hFlush stdout +showANSI (PRINT str) = putStr str +showANSI (AT ascii (row,col)) = do + setCursorPosition row col + showANSI ascii + setCursorPosition 24 0 + hFlush stdout +showANSI (RETURN a) = return a +showANSI (BIND m k) = do + a <- showANSI m + showANSI (k a) + +-- | Rather than use a data-structure for each action, +-- ANSI can be used instead. Not recommended, but harmless. +instance Graphic (ANSI a) where + drawGraphic g = do g ; return () + +----------------------------------------------------------------------- +-- Steping version of hGetContent, never blocks, returning +-- a stream of nothing after the end file. +----------------------------------------------------------------------- + +hGetContentsStepwise :: Handle -> IO [Maybe Char] +hGetContentsStepwise h = do + opt_ok <- try (hReady h) + case opt_ok of + Right ok -> do + out <- if ok then do + ch <- hGetChar h + return (Just ch) + else do + return Nothing + rest <- unsafeInterleaveIO $ hGetContentsStepwise h + return (out : rest) + Left (e :: IOException) -> return (repeat Nothing) + + +----------------------------------------------------------------------- +-- Exception Magic +----------------------------------------------------------------------- + +data PolyesterException = PolyesterException String + deriving Typeable + +instance Show PolyesterException where + show (PolyesterException msg) = msg + +instance Exception PolyesterException diff --git a/Hardware/KansasLava/Simulators/Spartan3e.hs b/Hardware/KansasLava/Simulators/Spartan3e.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/Simulators/Spartan3e.hs @@ -0,0 +1,319 @@ +-- | This API mirrors 'Hardware.KansasLava.Boards.Spartan3e' via a class +-- abstaction. The other API also contains some Board specific utilties +-- that can also be used for simulation. + +module Hardware.KansasLava.Simulators.Spartan3e + ( Spartan3e(..) + , Graphic(..) + ) where + +import qualified Hardware.KansasLava.Boards.Spartan3e as Board +import Hardware.KansasLava.Boards.Spartan3e -- (board_init, rot_as_reset) +import qualified Data.ByteString as B + +import Data.Sized.Ix +import Data.Sized.Unsigned +import Data.Sized.Matrix as M +import Language.KansasLava +import qualified Language.KansasLava as KL +import System.IO +import Control.Monad +import Data.List as List +import Data.Char as Char +import Control.Concurrent +import System.IO.Unsafe +import Data.Maybe + +import Hardware.KansasLava.Rate + +import Hardware.KansasLava.Simulators.Polyester + +------------------------------------------------------------ +-- initialization +------------------------------------------------------------ + +-- | 'board_init' sets up the use of the clock. +-- Always call 'board_init' first. +-- Required. +instance Board.Spartan3e Polyester where + + board_init = do + generic_init BOARD CLOCK + + -- we now grab the input streams, and display any change of switches. + sw <- switches + sequence_ + [ outPolyester (TOGGLE i) (map fromJust (fromS (sw ! i))) + | i <- [0..3] + ] + sw <- buttons + sequence_ + [ outPolyester (BUTTON i) (map fromJust (fromS (sw ! i))) + | i <- [0..3] + ] + + ss <- ll_dial + outPolyester DIAL ss + + + -- This does nothing on the simulator, because the shallow circuits + -- can not do a hard reset. + rot_as_reset = return () + + --tickTock :: (Size w) => Witness w -> Integer -> fabric (Seq Bool) + tickTock wit hz = do + simSpeed <- getPolyesterSimSpeed + return (rate wit (1 / ((fromIntegral simSpeed) / fromIntegral hz))) + + ----------------------------------------------------------------------- + -- Patches + ----------------------------------------------------------------------- + +-- (Seq (Enabled ((X2,X16),U8))) () +-- (Seq Ack) () + + mm_lcdP = patchF fromAckBox |$| buildF (\ ~(inp_lhs,_) -> do + outPolyesterEvents $ map (just $ \ ((x,y),ch) -> Just (LCD (x,y) (Char.chr (fromIntegral ch)))) inp_lhs + return ((),())) + where + just :: (a -> Maybe b) -> Maybe a -> Maybe b + just _ Nothing = Nothing + just k (Just a) = k a + + rs232_txP port baud = patchF (shallowSlowDownAckBoxP slow_count $$ fromAckBox) |$| buildF fab + where + -- 10 bits per byte + slow_count = 10 * Board.clockRate `div` baud + fab ~(inp,_) = do + writeSocketPolyester ("dev/" ++ serialName port) + $ map (fmap (\ i -> [chr (fromIntegral i)])) inp + outPolyesterCount (RS232 TX port) inp + return ((),()) + + rs232_rxP port baud = buildF (\ ~(_,_) -> do + -- 10 bits per byte + clkSpeed <- getPolyesterClkSpeed + let slow_count = 10 * clkSpeed `div` baud + ss0 <- readSocketPolyester ("dev/" ++ serialName port) + let ss = concatMap (\ x -> x : replicate (fromIntegral slow_count) Nothing) ss0 + outPolyesterCount (RS232 RX port) ss + return ((), toS (map (fmap fromIntegral) ss))) + + ----------------------------------------------------------------------- + -- Native APIs + ----------------------------------------------------------------------- + + switches = do + ms <- sequence [ do ss <- inPolyester False (sw i) + return ss + | i <- [0..3] + ] + return (matrix (map toS ms)) + where + sw i ch old | key ! i == ch = not old -- flip + | otherwise = old -- leave + + key :: Matrix X4 Char + key = matrix "lkjh" + + buttons = do + ms <- sequence [ do ss <- inPolyester False (sw i) + return ss + | i <- [0..3] + ] + return (matrix (map toS ms)) + where + sw i ch old | key ! i == ch = not old -- flip + | otherwise = old -- leave + + key :: Matrix X4 Char + key = matrix "aegx" + + leds m = do + sequence_ [ outPolyester (LED (fromIntegral i)) (fromS (m ! i)) + | i <- [0..7] + ] + +{- + mm_vgaP = fromAckBox $$ forwardP fab + where + fab :: [Maybe ((X40, X80), (VGA.Attr, U7))] -> Polyester () + fab inp = do + writeFilePolyester ("dev/vga") + ((Just $ VGA.init_VCG_ANSI) : map (fmap (VGA.show_VCG_ANSI)) inp) +-} + + dial_button = do + st <- ll_dial + return $ toS $ map (\ (Dial b _) -> b) $ st + + + dial_rot = do + st <- ll_dial + return $ toS $ rot $ map (\ (Dial _ p) -> p) $ st + where + rot xs = map f $ List.zipWith (-) (0:xs) xs + + f 0 = Nothing + f 1 = Just False + f 2 = error "turned dial twice in one cycle?" + f 3 = Just True + +----------------------------------------------------------------------- +-- Utilities uses in the class defintion. +----------------------------------------------------------------------- + +serialName :: Serial -> String +serialName DCE = "dce" +serialName DTE = "dte" + +data Dial = Dial Bool U2 + deriving Eq + + +ll_dial :: Polyester [Dial] +ll_dial = do + ss <- inPolyester (Dial False 0) switch + return ss + where + switch 'd' (Dial b p) = Dial (not b) p + switch 's' (Dial b p) = Dial b (pred p) + switch 'f' (Dial b p) = Dial b (succ p) + switch _ other = other + +shallowSlowDownAckBoxP :: + Integer -> Patch (Seq (Enabled U8)) (Seq (Enabled U8)) + (Seq Ack) (Seq Ack) +shallowSlowDownAckBoxP slow ~(inp,ack) = (toAck (toS ack_out),packEnabled (toS good) (enabledVal inp)) + where + ack_in :: [Bool] + ack_in = [ x | Just x <- fromS (fromAck ack) ] + + inp_in :: [Bool] + inp_in = [ x | Just x <- fromS (isEnabled inp) ] + + good :: [Bool] + good = f 0 inp_in + + f 0 (False:is) = False : f 0 is + f 0 (True:is) = True : f slow is + f other (_:is) = False : f (pred other) is + + ack_out :: [Bool] + ack_out = ack_in + + +-- | The clock rate on the Spartan3e (50MHz), in hertz. +clockRate :: Integer +clockRate = Board.clockRate + +----------------------------------------------------------------------- +-- +----------------------------------------------------------------------- + + +boardASCII = unlines + [ " _||_____|VGA|_____|X|__|232 DCE|__|232 DTE|__" + , " |o|| |_" + , " | | |" + , " | +----+ | |" + , " ----+ DIGILENT |FPGA| | |" + , " RJ45| ## | | SPARTAN-3E | |" + , " ----+ ## +----+ \\ / | |" + , " _|_ \\ / () | |" + , " USB| +--+ \\ / |_|" + , " ---' |##| +----+ FPGA |_" + , " |+--+ +--+ |####| oooooooo | |" + , " ||##| +----------------+ 76543210 |_|" + , " |+--+ (e) | | |_" + , " | (a) (|) (g) | | : : : : | |" + , " | (x) +----------------+ * * * * |_|" + , " +---------------------------------------------+" + , "" + , " Keyboard Commands:" + , " a, e, g, x - press buttons" + , " d - press dial" + , " s, f - turn dial counter-clock/clockwise" + , " h,j,k,l - toggle switches" + , " q - quit" + ] + + + +----------------------------------------------------------------------- +-- Output To Screen Driver +----------------------------------------------------------------------- + +data Output + = LED X8 (Maybe Bool) + | TOGGLE X4 Bool + | CLOCK Integer + | LCD (X2,X16) Char + | BOARD + | BUTTON X4 Bool + | DIAL Dial + | QUIT Bool + | RS232 DIR Serial Integer + +data DIR = RX | TX + +at = AT + +instance Graphic Output where + drawGraphic (LED x st) = + opt_green $ PRINT [ledASCII st] `at` (11,46 - fromIntegral x) + where + opt_green = if st == Just True then COLOR Green else id + + ledASCII :: Maybe Bool -> Char + ledASCII Nothing = '?' + ledASCII (Just True) = '@' + ledASCII (Just False) = '.' + + drawGraphic (TOGGLE x b) = do + PRINT [up] `at` (14,46 - 2 * fromIntegral x) + PRINT [down] `at` (15,46 - 2 * fromIntegral x) + where + ch = "lkjh" !! fromIntegral x + + up = if b then ch else ':' + down = if b then ':' else ch + drawGraphic (CLOCK n) = + PRINT ("clk: " ++ show n) `at` (5,35) + drawGraphic (LCD (row,col) ch) = + PRINT [ch] `at` (13 + fromIntegral row,20 + fromIntegral col) + drawGraphic BOARD = do + PRINT boardASCII `at` (1,1) + COLOR Red $ PRINT ['o'] `at` (2,4) + drawGraphic (BUTTON x b) = + (if b then REVERSE else id) $ + PRINT [snd (buttons !! fromIntegral x)] `at` + (fst (buttons !! fromIntegral x)) + where + buttons = + [ ((14,7),'a') + , ((13,11),'e') + , ((14,15),'g') + , ((15,11),'x') + ] + drawGraphic (DIAL (Dial b p)) = + (if b then REVERSE else id) $ + PRINT ["|/-\\" !! fromIntegral p] `at` (14,11) + drawGraphic (QUIT b) + | b = do PRINT "" `at` (25,1) + error "Simulation Quit" + | otherwise = return () + drawGraphic (RS232 dir port val) + | val > 0 = PRINT (prefix ++ show val) `at` (col,row) + | otherwise = PRINT (prefix ++ "-") `at` (col,row) + where + row = case port of + DCE -> 27 + DTE -> 38 + + prefix = case dir of + RX -> "rx " + TX -> "tx " + col = case dir of + RX -> 3 + TX -> 2 diff --git a/Hardware/KansasLava/Text.hs b/Hardware/KansasLava/Text.hs new file mode 100644 --- /dev/null +++ b/Hardware/KansasLava/Text.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE TypeFamilies, ExistentialQuantification, FlexibleInstances, UndecidableInstances, FlexibleContexts, + ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies,ParallelListComp, + RankNTypes, TypeOperators, NoMonomorphismRestriction #-} + +module Hardware.KansasLava.Text where + +import Language.KansasLava as KL +import Data.Sized.Unsigned +import Data.Sized.Ix +import Data.Sized.Arith +import Data.Sized.Matrix as M +import Control.Applicative +import Data.Char +import qualified Data.Bits as B +import Data.Maybe as Maybe + +-- | 'mm_text_driver' is a memory-mapped driver for a (small) display. +-- It gets passed the background "image", and the mapping from +-- active location number to row,col on the screen. +-- It outputs values sutable for input into the LCD mm drivers. +mm_text_driver :: forall c sig row col loc . + ( Clock c, sig ~ Signal c + , Rep loc, Rep row, Rep col + , Size row, Size col + , Rep (MUL row col) + , Num (MUL row col) + , Size (MUL row col) + ) + => Matrix (row,col) U8 -- backscreen + -> (loc -> (row,col)) -- active content mapping + -> Patch (sig (Enabled (loc,U8))) (sig (Enabled ((row,col),U8))) + (sig Ack) (sig Ack) +mm_text_driver m f = + mapP g $$ + prependP (matrix (M.toList m') :: Matrix (MUL row col) ((row,col),U8)) + where + m' :: Matrix (row,col) ((row,col),U8) + m' = forEach m $ \ addr ix -> (addr,ix) + g :: forall comb . Signal comb (loc,U8) -> Signal comb ((row,col),U8) + g arg = pack (funMap (return . f) addr,u8) + where (addr,u8) = unpack arg + +{- +joinWrites :: (Clock clk, sig ~ Signal clk) + => Patch (Matrix x (sig (Enabled (loc,U8)))) (sig (Enabled (loc,U8))) + (Matrix x (sig Ack)) (sig Ack) +joinWrites = undefined +-} +-- | Simple digit counter. +aliveGlyph :: forall c sig . (Clock c, sig ~ Signal c) + => Patch (sig (Enabled ())) (sig (Enabled (X1,U8))) + (sig Ack) (sig Ack) +aliveGlyph + = openP $$ + fstP (cycleP (matrix $ map ordU8 ".oOo" :: Matrix X4 U8) $$ + mapP (\ x -> pack (0,x)) + ) $$ + zipP $$ + mapP (\ ab -> let (a,b) = unpack ab in a) + + +-- | In a scrollbar, what ever you write appears on the right hand side, pushing everything to the left. + +scrollBar :: forall c sig x comb . (Clock c, sig ~ Signal c, Size x, Bounded x, Num x, Enum x, Rep x) + => Patch (sig (Enabled U8)) (sig (Enabled (x,U8))) + (sig Ack) (sig Ack) +scrollBar = + prependP (matrix [32] :: Matrix X1 U8) $$ + loopP patch $$ + mapP wt_cmds $$ + matrixToElementsP + where + patch = + zipP $$ + mapP fn $$ + fifo1 $$ + dupP $$ + fstP (prependP (matrix [pure 32] :: Matrix X1 (Matrix x U8))) + + fn :: forall comb . Signal comb (Matrix x U8,U8) -> Signal comb (Matrix x U8) + fn ab = let (a:: Signal comb (Matrix x U8),b :: Signal comb U8) = unpack ab + a' = unpack a :: Matrix x (Signal comb U8) + in pack $ matrix ([ a' ! x + | x <- [1..maxBound] + ] ++ [b]) + + wt_cmds :: forall comb . Signal comb (Matrix x U8) -> Signal comb (Matrix x (x,U8)) + wt_cmds = pack . (\ m -> forAll $ \ i -> pack (pureS i,m M.! i)) . unpack + + + +-- show a hex number +hexForm :: forall c sig w . + ( Clock c, sig ~ Signal c, Size (MUL X4 w), Integral (MUL X4 w) + , Integral w, Bounded w, Rep w, Size w + ) => + Patch (sig (Enabled (Unsigned (MUL X4 w)))) (sig (Enabled (w,U8))) + (sig Ack) (sig Ack) +hexForm + = matrixDupP $$ + matrixStackP (forAll $ \ i -> + mapP (\ v -> witnessS (Witness :: Witness U4) $ (unsigned) (v `B.shiftR` (fromIntegral (maxBound - i) * 4))) $$ + mapP (funMap (\ x -> if x >= 0 && x <= 9 + then return (0x30 + fromIntegral x) + else return (0x41 + fromIntegral x - 10))) $$ + mapP (\ ch -> pack (pureS i,ch))) $$ + matrixMergeP PriorityMerge + + +-- | ord for U8. +ordU8 :: Char -> U8 +ordU8 = fromIntegral . ord + +-- | chr for U8. +chrU8 :: U8 -> Char +chrU8 = chr . fromIntegral + +-- | Turn a string into a 1D matrix +rowU8 :: (Size x) => String -> Matrix x U8 +rowU8 = matrix . fmap ordU8 + +-- | Turn a string into a 2D matrix, ready for background. +boxU8 :: forall x row col . (Size x, Size row,Num row, Enum row, Size col, Num col, Enum col, x ~ MUL row col) + => [String] + -> Matrix x ((row,col),U8) +boxU8 inp = matrix + [ ((row,col),ch) + | (chs,row) <- zip (fmap (fmap ordU8) inp) [0..] + , (ch,col) <- zip chs [0..] + ] + +boxU8' :: forall row col . (Size row,Num row, Enum row, Size col, Num col, Enum col) + => [String] + -> Matrix (row,col) U8 +boxU8' = matrix . concat . fmap (fmap ordU8) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2011 The University of Kansas +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The names of the authors may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,2 @@ +FPGA Cores Written in Kansas Lava, including testing frameworks. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UCF/Spartan3e.ucf b/UCF/Spartan3e.ucf new file mode 100644 --- /dev/null +++ b/UCF/Spartan3e.ucf @@ -0,0 +1,46 @@ +# +# Adapted from the Spatan3e documentation, +# with input from the Ken Chapman's example ucf file. +# +NET "CLK_50MHZ" PERIOD = 20.0ns HIGH 50%; +# +NET "CLK_50MHZ" LOC = "C9" | IOSTANDARD = LVTTL; +#NET "CLK_50MHZ" LOC = C9 | IOSTANDARD = "LVCMOS33"; +# The push buttons +NET "BTN_NORTH" LOC = "V4" | IOSTANDARD = LVTTL | PULLDOWN; +NET "BTN_EAST" LOC = "H13" | IOSTANDARD = LVTTL | PULLDOWN; +NET "BTN_SOUTH" LOC = "K17" | IOSTANDARD = LVTTL | PULLDOWN; +NET "BTN_WEST" LOC = "D18" | IOSTANDARD = LVTTL | PULLDOWN; +# THE TOGGLE SWITCHES +NET "SW<0>" LOC = "L13" | IOSTANDARD = LVTTL | PULLUP; +NET "SW<1>" LOC = "L14" | IOSTANDARD = LVTTL | PULLUP; +NET "SW<2>" LOC = "H18" | IOSTANDARD = LVTTL | PULLUP; +NET "SW<3>" LOC = "N17" | IOSTANDARD = LVTTL | PULLUP; +# THE LEDS +NET "LED<0>" LOC = "F12" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 4; +NET "LED<1>" LOC = "E12" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 4; +NET "LED<2>" LOC = "E11" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 4; +NET "LED<3>" LOC = "F11" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 4; +NET "LED<4>" LOC = "C11" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 4; +NET "LED<5>" LOC = "D11" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 4; +NET "LED<6>" LOC = "E9" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 4; +NET "LED<7>" LOC = "F9" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 4; +# The RS232 connections +NET "RS232_DCE_RX" LOC = "R7" | IOSTANDARD = LVTTL; +NET "RS232_DCE_TX" LOC = "M14" | IOSTANDARD = LVTTL | DRIVE = 8 | SLEW = SLOW; +NET "RS232_DTE_RX" LOC = "U8" | IOSTANDARD = LVTTL ; +NET "RS232_DTE_TX" LOC = "M13" | IOSTANDARD = LVTTL | DRIVE = 8 | SLEW = SLOW ; +# LCD bus +NET "LCD_E" LOC = "M18" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 2; +NET "LCD_RS" LOC = "L18" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 2; +NET "LCD_RW" LOC = "L17" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 2; +NET "SF_D<8>" LOC = "R15" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 2; +NET "SF_D<9>" LOC = "R16" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 2; +NET "SF_D<10>" LOC = "P17" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 2; +NET "SF_D<11>" LOC = "M15" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 2; +NET "SF_CE0" LOC = "D16" | IOSTANDARD = LVTTL | SLEW = SLOW | DRIVE = 2; +# rotary dial +NET "ROT_CENTER" LOC = "V16" | IOSTANDARD = LVTTL | PULLDOWN ; +# +# End of File +# diff --git a/examples/Spartan3e/Main.hs b/examples/Spartan3e/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Spartan3e/Main.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, NoMonomorphismRestriction, DeriveDataTypeable, RankNTypes, ImpredicativeTypes #-} +module Main where + +import qualified Language.KansasLava as KL +import Language.KansasLava hiding (Fabric) +import Hardware.KansasLava.RS232 +import Hardware.KansasLava.FIFO +import Hardware.KansasLava.LCD.ST7066U +import Hardware.KansasLava.Text +import Hardware.KansasLava.Rate +--import qualified Hardware.KansasLava.VGA as VGA +--import Hardware.KansasLava.VGA (Attr(..), fg, bg) + +import Control.Applicative +import Data.Bits +import Data.Sized.Ix +import Data.Sized.Unsigned +import Data.Sized.Arith +import Data.Sized.Matrix as M +import qualified Data.Default as Default +import System.CPUTime +import Data.Char as C +import Control.Concurrent + +import System.Console.CmdArgs as CmdArgs + +import qualified Hardware.KansasLava.Boards.Spartan3e as Board + +import qualified Hardware.KansasLava.Simulators.Polyester as Sim + +import Hardware.KansasLava.Boards.Spartan3e +import Hardware.KansasLava.Simulators.Spartan3e + + + +data Opts = Opts { demoFabric :: String, fastSim :: Bool, beat :: Integer, vhdl :: Bool } + deriving (Show, Data, Typeable) + +options = Opts { demoFabric = "lcd_inputs" &= help "demo fabric to be executed or built" + , fastSim = False &= help "if running board at full speed" + , beat = (50 * 1000 * 1000) &= help "approx number of clicks a second" + , vhdl = False &= help "generate VDHL" + + } + &= summary "spartan3e-demo: run different examples for Spartan3e" + &= program "spartan3e-demo" + + +main = do + opts <- cmdArgs options + let fab :: (Spartan3e fabric) => fabric () + fab = do + board_init + fabric opts (demoFabric opts) + + case vhdl opts of + True -> vhdlUseFabric opts fab + False -> simUseFabric opts fab + + +-- The simulator's use of the Fabric +simUseFabric :: Opts -> Sim.Polyester () -> IO () +simUseFabric opts fab = + Sim.runPolyester (case fastSim opts of + True -> Sim.Fast + False -> Sim.Friendly) + (2 * 1000 * 1000) + (case fastSim opts of + True -> 1000 + False -> 50) + $ fab + +-- The VHDL generators use of the Fabric +vhdlUseFabric :: Opts -> KL.Fabric () -> IO () +vhdlUseFabric opts fab = do + kleg <- reifyFabric fab + Board.writeUCF "main.ucf" kleg + KL.writeVhdlCircuit "main" "main.vhd" kleg + return () + +-- Should be in sized types lib! +matrixOf :: (Size x) => x -> [a] -> Matrix x a +matrixOf _ = matrix + +------------------------------------------------------------------------------ +-- Sample fabrics + +fabric :: (Spartan3e fabric) => Opts -> String -> fabric () +fabric _ "leds" = do + sw <- switches + bu <- buttons + leds (sw `M.append` bu) + +{- +fabric _ "dial" = do + d <- dial_button + r <- dial_rot + let val :: Seq U4 + val = register 0 $ val + cASE + [ (isEnabled r .&&. enabledVal r, 1) + , (isEnabled r .&&. bitNot (enabledVal r), -1) + ] 0 + let ms :: Matrix X4 (Seq Bool) + ms = unpack ((bitwise) val :: Seq (Matrix X4 Bool)) + + leds (matrix $ [d, low] ++ M.toList ms ++ [low,low]) +-} + +fabric _ "lcd" = do + ticks <- tickTock (Witness :: Witness X24) 4 + runF $ patchF (neverAckP $$ prependP msg $$ throttleP ticks) |$| mm_lcdP + where + msg :: Matrix X32 ((X2,X16),U8) + msg = boxU8 ["Example of Using", " the LCD driver "] + +fabric _ "lcd_inputs" = do + sw <- switches + bu <- buttons + runF $ patchF (patch sw bu) |$| mm_lcdP + where + patch sw bu = emptyP + $$ forwardP (\ () -> pure ()) + $$ backwardP (const ()) + $$ matrixStackP (forAll $ \ (i::X4) -> + (outputP (changeS (sw M.! i))) + $$ enabledToAckBox + $$ mapP (\ s -> pack (pureS (fromIntegral i + 0), mux s (33,34))) + ) + $$ matrixMergeP RoundRobinMerge + $$ mm_text_driver msg active + + msg :: Matrix (X2,X16) U8 + msg = boxU8' [" "," "] + + active :: X4 -> (X2,X16) + active x = (0,fromIntegral x) + +fabric _ "rs232out" = do + runF $ patchF (cycleP msg) |$| rs232_txP DCE 115200 + where + msg :: Matrix X95 U8 + msg = matrix [ i + | i <- [32..126] + ] + +fabric _ "rs232in" = do + ticks <- tickTock (Witness :: Witness X24) 4 + rot_as_reset + runF $ rs232_rxP DCE 115200 + |$| patchF ( + enabledToAckBox + $$ fifo (Witness :: Witness X256) low + $$ matrixDupP + $$ matrixStackP (matrixOf (0 :: X3) + [ hexchain $$ mapP (startAt 0) + , count $$ mapP (startAt 16) + , asciichain $$ mapP (startAt 24) + ]) + $$ matrixMergeP RoundRobinMerge + $$ mm_text_driver msg active + $$ witnessP (Witness :: Witness (Enabled ((X2,X16),U8)))) + |$| mm_lcdP + where + startAt :: (Size w, Rep w, Rep a, a ~ U8) => Signal clk X32 -> Signal clk (w,a) -> Signal clk (X32,a) + startAt pos inp = pack (pos + (unsigned) w,a) + where + (w,a) = unpack inp + + hexchain :: Patch (Seq (Enabled U8)) (Seq (Enabled (X16,U8))) + (Seq Ack) (Seq Ack) + hexchain = + (mapP (\ ch -> packMatrix (matrixOf (0 :: X2) [hexVal ((unsigned) (ch `shiftR` 4)),hexVal ((unsigned) ch)])) + $$ matrixToElementsP + $$ scrollBar + $$ witnessP (Witness :: Witness (Enabled (X16,U8))) + ) + + asciichain :: Patch (Seq (Enabled U8)) (Seq (Enabled (X8,U8))) + (Seq Ack) (Seq Ack) + asciichain = + (mapP (\ ch -> mux (ch .>=. 32 .&&. ch .<=. 126) ((unsigned) $ pureS (ord '.'),ch)) + $$ scrollBar + $$ witnessP (Witness :: Witness (Enabled (X8,U8))) + ) + + count :: Patch (Seq (Enabled U8)) (Seq (Enabled (X6,U8))) + (Seq Ack) (Seq Ack) + count = stateP adder (0 :: U24) + $$ witnessP (Witness :: Witness (Enabled U24)) + $$ hexForm + $$ witnessP (Witness :: Witness (Enabled (X6,U8))) + + adder :: forall clk . (Signal clk U24,Signal clk U8) -> (Signal clk U24,Signal clk U24) + adder (a,_) = (a + 1,a + 1) + + hexVal :: Signal clk U4 -> Signal clk U8 + hexVal = funMap (\ x -> if x >= 0 && x <= 9 + then return (0x30 + fromIntegral x) + else return (0x41 + fromIntegral x - 10)) + + witnessP :: (Witness w) -> Patch (Seq w) (Seq w) + (Seq a) (Seq a) + witnessP _ = emptyP + + msg :: Matrix (X2,X16) U8 + msg = boxU8' [" "," "] + + active :: X32 -> (X2,X16) + active x = (fromIntegral (x `div` 16),fromIntegral (x `mod` 16)) + +-- Remember when a value changes. +changeS :: forall c sig a . (Clock c, sig ~ Signal c, Eq a, Rep a) => sig a -> sig (Enabled a) +changeS sig = mux (start .||. diff) (disabledS,enabledS sig) + where + start :: sig Bool + start = probeS "start" $ register True low + + diff :: sig Bool + diff = probeS "diff" $ sig ./=. delay sig + +--------------------------------------------------------------------------------- + +-- later, this will use a sub-Clock. + +stateP :: forall clk a b c sig . + (Rep a, Rep b, Rep c, Clock clk, sig ~ Signal clk) + => (forall sig' clk' . (sig' ~ Signal clk') => (sig' a,sig' b) -> (sig' a,sig' c)) + -> a + -> Patch (sig (Enabled b)) (sig (Enabled c)) + (sig Ack) (sig Ack) +stateP st a = + loopP $ + fstP (prependP (matrixOf (0 :: X1) [a])) + $$ zipP + $$ mapP st' + $$ unzipP + $$ fstP (fifo1) + where + st' :: forall clk' . Signal clk' (a,b) -> Signal clk' (a,c) + st' s = pack (st (unpack s) :: (Signal clk' a, Signal clk' c)) + + diff --git a/kansas-lava-cores.cabal b/kansas-lava-cores.cabal new file mode 100644 --- /dev/null +++ b/kansas-lava-cores.cabal @@ -0,0 +1,124 @@ +Name: kansas-lava-cores +Version: 0.1.2 +Synopsis: FPGA Cores Written in Kansas Lava. +Description: + Kansas Lava Cores is a collection of libraries, written in Kansas Lava, + that describe specific hardware components, as well as a Spartan3e + board monad and simulator, and testing framework. + +Category: Hardware +License: BSD3 +License-file: LICENSE +Author: Andy Gill +Maintainer: Andy Gill +Copyright: (c) 2011 The University of Kansas +Homepage: http://ittc.ku.edu/csdl/fpg/Tools/KansasLava +Stability: alpha +build-type: Simple +Cabal-Version: >= 1.10 +Data-files: + UCF/*.ucf +extra-source-files: + tests/Makefile + README + +Flag all + Description: Enable full development tree + Default: False + +Flag unit + Description: Enable unit tests for every core + Default: False + +Flag spartan3e + Description: Enable demo spartan3 program + Default: False + +Library + Build-Depends: + base >= 4 && < 5, + kansas-lava == 0.2.4, + sized-types >= 0.3.4, + ansi-terminal >= 0.5.5, + data-default, + directory, + bytestring, + network + + Exposed-modules: + Hardware.KansasLava.FIFO + Hardware.KansasLava.Random + Hardware.KansasLava.Rate + Hardware.KansasLava.RS232 + Hardware.KansasLava.Chunker + Hardware.KansasLava.Text + + Hardware.KansasLava.LCD.ST7066U + Hardware.KansasLava.Boards.UCF + Hardware.KansasLava.Boards.Spartan3e + Hardware.KansasLava.Simulators.Spartan3e + Hardware.KansasLava.Simulators.Polyester + Other-modules: + Paths_kansas_lava_cores + +-- Hs-Source-Dirs: ., ../kansas-lava + Other-modules: + Ghc-Options: -fcontext-stack=100 + default-language: Haskell2010 + +Executable spartan3e-demo + if flag(spartan3e) || flag(all) + Build-Depends: + base >= 4 && < 5, + kansas-lava == 0.2.4, + sized-types >= 0.3.4, + ansi-terminal >= 0.5.5, + data-default, + directory, + bytestring, + network, + random, + cmdargs==0.8 + buildable: True + else + Build-depends: base + buildable: False + Main-Is: Main.hs + Hs-Source-Dirs: ., examples/Spartan3e + Ghc-Options: -fcontext-stack=100 + -threaded -rtsopts + default-language: Haskell2010 + +Executable kansas-lava-cores-tests + if flag(unit) || flag(all) + Build-Depends: + base >= 4 && < 5, + kansas-lava == 0.2.4, + sized-types >= 0.3.4, + ansi-terminal >= 0.5.5, + data-default, + directory, + bytestring, + network, + random + buildable: True + Other-modules: + Chunker + FIFO + LCD + Main + RS232 + Rate + else + Build-depends: base + buildable: False + Main-Is: Main.hs + Hs-Source-Dirs: ., tests + Ghc-Options: -fcontext-stack=100 + -threaded -rtsopts +-- -Wall -Werror + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/ku-fpg/kansas-lava-cores.git diff --git a/tests/Chunker.hs b/tests/Chunker.hs new file mode 100644 --- /dev/null +++ b/tests/Chunker.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts #-} +module Chunker (tests) where + +import Language.KansasLava +import Language.KansasLava.Test +import Hardware.KansasLava.Chunker + +import Data.Sized.Unsigned +import Data.Sized.Signed +import Data.Sized.Arith +import Data.Sized.Matrix (Matrix,(!), matrix) +import Data.Sized.Ix +import Data.Ratio +import System.Random +--import Data.Maybe +import Debug.Trace +import Data.Word +import Data.List as L + +tests :: TestSeq -> IO () +tests test = do + -- testing Chunker + + let waitForItTest :: (Size x, Size y, Rep w, Show w) => Unsigned x -> Witness y -> StreamTest w (Unsigned x) + waitForItTest mx w = StreamTest + { theStream = waitForIt mx w + , correctnessCondition = \ ins outs -> +-- trace (show ("cc",length ins,length outs)) $ +-- trace (show ("ins",map show (take 100 ins))) $ +-- trace (show ("outs",map show (take 100 outs))) $ + case (length ins, sum $ map fromIntegral outs) of + (i,o) | maximum outs > mx + -> Just ("packet to large " ++ show (outs,mx)) + | any (== 0) outs + -> Just ("found empty packet " ++ show outs) + | i == o -> Nothing + | otherwise -> Just ("found " ++ show i ++ " elements, tagged " ++ show o ++ show (ins,outs)) + , theStreamTestCount = count + , theStreamTestCycles = count * 100 + , theStreamName = "chunker/waitForIt" + } + count = 1000 + + -- Need to think about 0. + let t :: forall w . (Size w) => Witness w -> IO () + t w = sequence_ [ + testStream test ("U4/" ++ show n ++ "/" ++ show (size (undefined :: w))) + (waitForItTest n w :: StreamTest S11 U4) + | n <- [1,2,3,4,8,15] ] + + t (Witness :: Witness X1) + t (Witness :: Witness X2) + t (Witness :: Witness X3) + t (Witness :: Witness X4) + t (Witness :: Witness X5) + t (Witness :: Witness X10) + + let chunkCounterTest :: forall x y . + (Size x, Size y, Rep y, Rep x, Num y, Num x) + => Witness x -> StreamTest (Unsigned y) Bool + chunkCounterTest w = StreamTest + { theStream = chunkCounter w + , correctnessCondition = \ ins outs -> + let msgs = fn outs + x = size (undefined :: x) + +-- fn xs | trace (show $ take 10 xs) False = undefined + fn [] = [] + fn xs | L.all (== True) (take x xs) = n : fn (drop n xs') + where n = length (takeWhile (== False) xs') + xs' = drop x xs + fn _ = error "bad stream from chunkCounter" + + ins' = ins ++ [0] -- always will have a zero, because of the pre-issue + in case () of + _ | msgs /= map fromIntegral ins' -> Just $ + "bad length of lows " ++ show (msgs,ins') + _ | otherwise -> Nothing + , theStreamTestCount = count + , theStreamTestCycles = count * 500 + , theStreamName = "chunker/chunkCounter" + } + count = 20 + + let t :: forall x . (Rep x, Size x, Num x) => Witness x -> IO () + t w = testStream test ("U4/" ++ show (size (undefined :: x))) + (chunkCounterTest w :: StreamTest U4 Bool) + + t (Witness :: Witness X1) + t (Witness :: Witness X2) + t (Witness :: Witness X3) + t (Witness :: Witness X4) + t (Witness :: Witness X5) + t (Witness :: Witness X6) + + let chunkSplitJoinTest :: StreamTest U4 U4 + chunkSplitJoinTest = StreamTest + { theStream = chunkSplitHeader f $$ + -- here we + -- (1) Turn header ABC into headder CBA, where B is the length; + -- (2) Add one to every member of the payload. + stackP (forwardP (mapEnabled + (\ ms -> let m = unpack ms + in pack (matrix [m ! 2,m ! 1,m ! 0])))) + (forwardP (mapEnabled (+1))) $$ + chunkJoinHeader f + , correctnessCondition = \ ins outs -> +-- trace (show ("cc",length ins,length outs)) $ +-- trace (show ("ins",map show (take 100 ins))) $ +-- trace (show ("outs",map show (take 100 outs))) $ + let readPackets (a:b:c:d) = (a,b,c,take (fromIntegral b) d) + : readPackets (drop (fromIntegral b) d) + readPackets [] = [] -- hack + readPackets _ = error "bad packet!" + + xs = map (\(a,b,c,d) -> (c,b,a,map (+1) d)) $ readPackets (take (length outs) ins) + ys = readPackets outs + in case () of +-- _ | trace (show xs) False -> Nothing +-- _ | trace (show ys) False -> Nothing + _ | length xs < 100 -> Just $ "too few packets ???" ++ show (length xs) + _ | length xs /= length ys -> Just $ "# of packets different " ++ show ( length xs, length ys ) + _ | xs /= ys -> Just $ "bad join + split: " ++ show (zip xs ys) + _ | otherwise -> Nothing + + , theStreamTestCount = count + , theStreamTestCycles = count * 4 + , theStreamName = "chunker/join-split" + } + + f :: forall comb . Signal comb (Matrix X3 U4) -> Signal comb U4 + f m = (unpack m :: Matrix X3 (Signal comb U4)) ! 1 + + count = 2000 + + testStream test ("U4") + (chunkSplitJoinTest) + + return () diff --git a/tests/FIFO.hs b/tests/FIFO.hs new file mode 100644 --- /dev/null +++ b/tests/FIFO.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts #-} +module FIFO (tests) where + +import Language.KansasLava +import Language.KansasLava.Test +import Hardware.KansasLava.FIFO (fifo) + +import Data.Sized.Unsigned +import Data.Sized.Arith +import Data.Sized.Ix +import System.Random +import Data.Ratio +--import Data.Maybe +import Debug.Trace + +tests :: TestSeq -> IO () +tests test = do + -- testing FIFOs + + + let fifoTest :: forall w sz . (Rep (ADD sz X1), + Rep sz, + Rep w, + Eq w, + Size sz, + Size (ADD sz X1), + Num sz, + Num (ADD sz X1)) => Witness sz -> StreamTest w w + fifoTest wit = StreamTest + { theStream = fifo wit low + , correctnessCondition = \ ins outs -> -- trace (show ("cc",length ins,length outs)) $ + case () of + () | outs /= take (length outs) ins -> return "in/out differences" + () | length outs < fromIntegral count + -> return ("to few transfers: " ++ show (length outs)) + () | length ins - length outs > size (undefined :: sz) + -> return ("missing items?" ++ show (length ins,length outs,size (undefined :: sz))) + | otherwise -> Nothing + + , theStreamTestCount = count + , theStreamTestCycles = + if size (undefined :: sz) <= 2 + then 40000 + else 30000 + , theStreamName = "fifo/" ++ show (size (error "witness" :: sz)) + } + where + count = 1000 + + let t :: forall w sz sz1 . + (Eq w, Rep w, Show w, + Size (W w), + sz1 ~ ADD sz X1, + Size (ADD (W w) X1), --- Hmm + Size sz, Size sz1, + Rep sz, Rep sz1, + Num w, Num sz, Num sz1) + => String -> Witness w -> Witness sz -> IO () + t str arb w = testStream test str (fifoTest w :: StreamTest w w) + + t "U5" (Witness :: Witness U5) (Witness :: Witness X1) + t "U5" (Witness :: Witness U5) (Witness :: Witness X2) + t "U5" (Witness :: Witness U5) (Witness :: Witness X3) + t "U5" (Witness :: Witness U5) (Witness :: Witness X4) + t "U5" (Witness :: Witness U5) (Witness :: Witness X5) + t "U5" (Witness :: Witness U5) (Witness :: Witness X6) + t "U5" (Witness :: Witness U5) (Witness :: Witness X7) + t "U5" (Witness :: Witness U5) (Witness :: Witness X8) + + + return () + + return () diff --git a/tests/LCD.hs b/tests/LCD.hs new file mode 100644 --- /dev/null +++ b/tests/LCD.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts #-} +module LCD (tests) where + +import Language.KansasLava +import Language.KansasLava.Test +import Hardware.KansasLava.FIFO (fifo) +--import Hardware.KansasLava.LCD (lcdBootP) + +import Data.Sized.Unsigned +import Data.Sized.Arith +import Data.Sized.Ix +import Data.Ratio +import System.Random +--import Data.Maybe +import Debug.Trace +import Data.Word + +tests :: TestSeq -> IO () +tests _test = do + + return () +{- + -- testing The LCD + + let f n = [ (g (n' `div` 16),50) + , (g (n' `mod` 16), + if n <= 0x03 then 100000 else 2000) + ] + where n' = n `mod` 256 + g m = if n > 0xff then (16 + fromIntegral m) + else (0 + fromIntegral m) + + -- What the boot sequence is + let bootSeq = + [ (0x3,205000) + , (0x3, 5000) + , (0x3, 2000) + , (0x2, 2000) + ] ++ concatMap f + [ 0x28, 0x06, 0x0C, 0x1 + ] + + -- Test boot sequence generator + let lcdTest1 :: StreamTest U9 (U5,U18) + lcdTest1 = StreamTest + { theStream = + lcdBootP + , correctnessCondition = \ ins outs -> +-- trace (show ("cc",length ins,length outs)) $ +-- trace (show ("ins",map show (take 100 ins))) $ +-- trace (show ("outs",map show (take 100 outs))) $ + case () of + () | length outs <= 0 -> + return ("sequence out too short") + | take (length bootSeq) outs /= bootSeq -> + return ("sequence problem " ++ + show (zip outs bootSeq)) + | concatMap f ins /= drop (length bootSeq) outs -> + return ("proceeded sequence problem " ++ + show (zip (concatMap f ins) + (drop (length bootSeq) outs))) + | otherwise -> Nothing + , theStreamTestCount = count + , theStreamTestCycles = 1000 + , theStreamName = "lcdBootP1" + } + count = 100 + + testStream test + "lcd" + lcdTest1 + + + runlcdBootP test + + return () + +runlcdBootP :: TestSeq -> IO () +runlcdBootP (TestSeq test _) = do + let cir :: Seq (Enabled U9) -> Seq (Enabled (U5,U18)) + cir ins = out + where + (_,out) = enabledToAckBox $$ + lcdBootP $$ + unitClockP $$ + ackBoxToEnabled $ (ins,()) + + driver = do + outStdLogicVector "i0" (disabledS :: Seq (Enabled U9)) + + dut = do + i0 <- inStdLogicVector "i0" + let o0 = cir i0 + outStdLogicVector "o0" o0 + + -- Shallow always passes, but builds a reference + test "runlcdBootP" 1000000 dut $ do + driver + inStdLogicVector "o0" :: Fabric (Seq (U5,U18)) + return (const Nothing) + + return () + +-} diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Main (main) where + +import Language.KansasLava +import Language.KansasLava.Test +import Data.Default + +import Rate as Rate +import FIFO as FIFO +import RS232 as RS232 +import Chunker as Chunker +import LCD as LCD + +main :: IO () +main = do + let opt = def { verboseOpt = 4 -- 4 == show cases that failed + } + testDriver opt $ take 5 $ drop 0 + [ Rate.tests + , FIFO.tests + , RS232.tests + , Chunker.tests + , LCD.tests + ] + diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1,20 @@ +DIR := sims +# default to 2-core +N := 2 + +test: + ../dist/build/kansas-lava-cores-tests/kansas-lava-cores-tests +RTS -N$(N) -RTS $(ARGS) + +simulate: + $(DIR)/runsims + +report: + kansas-lava-testreport $(DIR) + +clean: + mv sims sims.X + rm -Rf sims.X + +init: +# Create a symbolic link to the Prelude directory + ln -s ../../kansas-lava KansasLava diff --git a/tests/RS232.hs b/tests/RS232.hs new file mode 100644 --- /dev/null +++ b/tests/RS232.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, FlexibleContexts #-} +module RS232 (tests) where + +import Language.KansasLava +import Language.KansasLava.Test +import Hardware.KansasLava.FIFO (fifo) +import Hardware.KansasLava.RS232 (rs232in,rs232out) + +import Data.Sized.Unsigned +import Data.Sized.Arith +import Data.Sized.Ix +import Data.Ratio +import System.Random +--import Data.Maybe +import Debug.Trace +import Data.Word + +tests :: TestSeq -> IO () +tests test = do + -- testing RS232s + + let clockRate = 50 * 1000 + + let rs232Test :: Integer -> Rational -> StreamTest U8 U8 + rs232Test baud scale = StreamTest + { theStream = + rs232out baud clockRate $$ + forwardP noise $$ + rs232in baud (floor (toRational clockRate * scale)) $$ + enabledToAckBox $$ + fifo (Witness :: Witness X16) low + , correctnessCondition = \ ins outs -> +-- trace (show ("cc",length ins,length outs)) $ +-- trace (show ("ins",map show (take 100 ins))) $ +-- trace (show ("outs",map show (take 100 outs))) $ + case () of + () | outs /= take (length outs) ins -> return ("in/out differences: " + ++ show ins ++ show outs) + () | length outs < count -> return $ "to few transfers (" ++ show (length outs) ++ ")" + | otherwise -> Nothing + , theStreamTestCount = count + , theStreamTestCycles = floor ((fromIntegral clockRate / 4) * (1000 / fromIntegral baud)) + , theStreamName = "rs232" + } + count = 20 + + noise = id +-- . fromS +-- . toS + + + let t :: String -> Integer -> IO () + t str baud = sequence_ + [ testStream test (str ++ "/" ++ wib) (rs232Test baud scale) + | (wib,scale) <- [ ("1",1), ("0.99",0.99), ("1.01",1.01) ] + ] + + t "100" 100 + t "200" 200 + t "300" 300 + + return () diff --git a/tests/Rate.hs b/tests/Rate.hs new file mode 100644 --- /dev/null +++ b/tests/Rate.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Rate (tests) where + +import Language.KansasLava +import Language.KansasLava.Test +import Hardware.KansasLava.Rate (rate) +import Data.Sized.Ix +import Data.Maybe +--import Debug.Trace + +tests :: TestSeq -> IO () +tests test = do + let t1 :: (Size w) => String -> Witness w -> Rational -> Rational -> IO () + t1 str = testRate test str + + t1 "0.01" (Witness :: Witness X16) 0.01 0.0 + t1 "0.05" (Witness :: Witness X16) 0.05 0.0 + t1 "0.1" (Witness :: Witness X16) 0.1 0.0 + t1 "0.2" (Witness :: Witness X16) 0.2 0.0 + t1 "0.3" (Witness :: Witness X16) 0.3 0.0 + t1 "0.33" (Witness :: Witness X16) 0.33 0.0 + t1 "0.4" (Witness :: Witness X16) 0.4 0.001 + t1 "0.5" (Witness :: Witness X16) 0.5 0.0 + t1 "0.6" (Witness :: Witness X16) 0.6 0.001 + t1 "0.66" (Witness :: Witness X16) 0.66 0.001 + t1 "0.7" (Witness :: Witness X16) 0.7 0.0 + t1 "0.8" (Witness :: Witness X16) 0.8 0.0 + t1 "0.9" (Witness :: Witness X16) 0.9 0.0 + t1 "0.95" (Witness :: Witness X16) 0.95 0.0 + t1 "1" (Witness :: Witness X16) 1 0.0 + + -- And some *real* examples. + t1 "baud" (Witness :: Witness X16) (115200 / (50 * 1000 * 1000)) 0.001 + + -- And others + t1 "1/16" (Witness :: Witness X16) (1/16) 0.001 + t1 "1/32" (Witness :: Witness X16) (1/32) 0.001 + t1 "1/64" (Witness :: Witness X16) (1/64) 0.001 + t1 "1/65" (Witness :: Witness X16) (1/65) 0.001 + t1 "2/65" (Witness :: Witness X16) (2/65) 0.001 + + -- And others + t1 "2/65@8" (Witness :: Witness X8) (2/65) 0.001 + t1 "2/65@7" (Witness :: Witness X7) (2/65) 0.001 + t1 "2/65@6" (Witness :: Witness X6) (2/65) 0.001 + + + + return () + +testRate :: forall w . + (Size w) + => TestSeq + -> String + -> Witness w + -> Rational + -> Rational + -> IO () +testRate (TestSeq test _) nm w r limit = do + let dut = do + let o0 :: Seq Bool + o0 = rate w r + outStdLogic "o0" (o0 :: Seq Bool) + driver = do + ans <- inStdLogic "o0" + let vs = fromS ans + return $ \ n -> + let sofar :: [Rational] + sofar = [ fromIntegral (length (filter (== Just True) (take i vs))) / fromIntegral i + | i <- [n `div` 10,n] + ] + delta :: [String] + delta = [ "testRate failure: " ++ show (s,r,abs(s-r),limit) + | s <- sofar + , abs (s - r) > limit + ] + in listToMaybe delta + + test ("rate/" ++ nm) 10000 dut driver +