kansas-lava-cores (empty) → 0.1.2
raw patch · 24 files changed
+3181/−0 lines, 24 filesdep +ansi-terminaldep +basedep +bytestringsetup-changed
Dependencies added: ansi-terminal, base, bytestring, cmdargs, data-default, directory, kansas-lava, network, random, sized-types
Files
- Hardware/KansasLava/Boards/Spartan3e.hs +225/−0
- Hardware/KansasLava/Boards/UCF.hs +44/−0
- Hardware/KansasLava/Chunker.hs +185/−0
- Hardware/KansasLava/FIFO.hs +352/−0
- Hardware/KansasLava/LCD/ST7066U.hs +243/−0
- Hardware/KansasLava/RS232.hs +225/−0
- Hardware/KansasLava/Random.hs +35/−0
- Hardware/KansasLava/Rate.hs +110/−0
- Hardware/KansasLava/Simulators/Polyester.hs +364/−0
- Hardware/KansasLava/Simulators/Spartan3e.hs +319/−0
- Hardware/KansasLava/Text.hs +135/−0
- LICENSE +25/−0
- README +2/−0
- Setup.hs +2/−0
- UCF/Spartan3e.ucf +46/−0
- examples/Spartan3e/Main.hs +242/−0
- kansas-lava-cores.cabal +124/−0
- tests/Chunker.hs +139/−0
- tests/FIFO.hs +73/−0
- tests/LCD.hs +104/−0
- tests/Main.hs +25/−0
- tests/Makefile +20/−0
- tests/RS232.hs +62/−0
- tests/Rate.hs +80/−0
+ Hardware/KansasLava/Boards/Spartan3e.hs view
@@ -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+++
+ Hardware/KansasLava/Boards/UCF.hs view
@@ -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)
+ Hardware/KansasLava/Chunker.hs view
@@ -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)
+ Hardware/KansasLava/FIFO.hs view
@@ -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)+++
+ Hardware/KansasLava/LCD/ST7066U.hs view
@@ -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)+
+ Hardware/KansasLava/RS232.hs view
@@ -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)+
+ Hardware/KansasLava/Random.hs view
@@ -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+
+ Hardware/KansasLava/Rate.hs view
@@ -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)+-}++
+ Hardware/KansasLava/Simulators/Polyester.hs view
@@ -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
+ Hardware/KansasLava/Simulators/Spartan3e.hs view
@@ -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
+ Hardware/KansasLava/Text.hs view
@@ -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)
+ LICENSE view
@@ -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.+
+ README view
@@ -0,0 +1,2 @@+FPGA Cores Written in Kansas Lava, including testing frameworks.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ UCF/Spartan3e.ucf view
@@ -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+#
+ examples/Spartan3e/Main.hs view
@@ -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))++
+ kansas-lava-cores.cabal view
@@ -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 <andygill@ku.edu>+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
+ tests/Chunker.hs view
@@ -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 ()
+ tests/FIFO.hs view
@@ -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 ()
+ tests/LCD.hs view
@@ -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 ()++-}
+ tests/Main.hs view
@@ -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+ ]+
+ tests/Makefile view
@@ -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
+ tests/RS232.hs view
@@ -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 ()
+ tests/Rate.hs view
@@ -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+