├── .gitignore ├── LICENSE ├── README.md └── src ├── DemoDebug.hs ├── DemoMultipleSprockells.hs ├── DemoRandomOrder.hs ├── Sprockell ├── Components.hs ├── Sprockell.hs ├── System.hs └── TypesEtc.hs └── Tests.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 University of Twente 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Sprockell 2 | Sprockell is a **S**imple **Proc**essor in Has**kell**. It was originally written by Jan Kuper at the University of Twente. It has later been extended to allow multiple Sprockells to be run at once, communicating via shared memory. This version is internally been dubbed Smockell :-) 3 | 4 | # Features 5 | * Simple arithmetic 6 | * Memory mapped I/O 7 | * Branches / jumps 8 | * Stack 9 | * Local memory 10 | * Shared memory 11 | 12 | # Documentation 13 | See the [wiki](https://github.com/martijnbastiaan/sprockell/wiki). 14 | 15 | # Running 16 | Clone the repository, compile `System.hs` using `ghc` and run it from the command line. A (really) simple program runs and terminates. 17 | 18 | Of course, you can compile your own program: 19 | 20 | ```haskell 21 | import Sprockell.System 22 | 23 | prog = [ Const 6 RegA 24 | , Const 7 RegB 25 | , Compute Mul RegA RegB RegC 26 | , EndProg 27 | ] 28 | 29 | main = run 1 prog 30 | ``` 31 | 32 | Where `1` is the amount of Sprockells you want to deploy. 33 | 34 | ```bash 35 | ghc Program.hs 36 | ./Program 37 | ``` 38 | 39 | (Of course, this simple program doesn't produce any output. You can use ```Write RegC stdio``` for that.) 40 | 41 | # Debugging 42 | See the wiki on [debugging](https://github.com/martijnbastiaan/sprockell/wiki/debugging). 43 | -------------------------------------------------------------------------------- /src/DemoDebug.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | import Sprockell.System 3 | 4 | -- Note that it never prints "First shared memaddr equals 5": all sprockells 5 | -- are terminated before the shared memory gets a chance to write it. 6 | prog :: [Instruction] 7 | prog = [ 8 | Const 78 RegA 9 | , Const 10 RegB 10 | , Const 5 RegC 11 | , Write RegA (Addr 0x1000000) -- write to stdout using explicit address 12 | , Write RegB stdio -- or using the alias 13 | , Write RegC (Addr 0) 14 | -- If we add some Nop's to delay the EndProg 15 | -- then the shared memory has time to handle all the writes. 16 | -- And the debug message will be printed. 17 | --, Nop,Nop,Nop,Nop,Nop,Nop,Nop,Nop,Nop,Nop 18 | , EndProg 19 | ] 20 | 21 | debug :: SystemState -> String 22 | debug SysState{..} | (sharedMem !!! 0) == 5 = "First shared memaddr equals 5.\n" 23 | debug _ = "Not 5\n" 24 | 25 | main = runDebug debug 3 prog 26 | -------------------------------------------------------------------------------- /src/DemoMultipleSprockells.hs: -------------------------------------------------------------------------------- 1 | import Sprockell.System 2 | 3 | {- 4 | This program demonstrates how to run multiple sprockells at once, each executing 5 | their own subprogram. 6 | 7 | The Sprockells holding SPID > 0 will read from their respective memory addresses 8 | until they find a value which is not equal to zero. If it finds such a value, it 9 | jumps to that memory address. (This example will let them jump to EndProg.) 10 | -} 11 | 12 | prog :: [Instruction] 13 | prog = [ 14 | Branch SPID (Rel 5) 15 | , Const 11 RegC 16 | , Write RegC (Addr 1) -- Sprockell 1 must jump to second end 17 | , Write RegC (Addr 2) -- Sprockell 2 must jump to second end 18 | , Jump (Abs 10) -- Sprockell 0 jumps to first end 19 | -- BEGIN: loop 20 | , Read (Deref SPID) 21 | , Receive RegA 22 | , Compute Equal RegA Zero RegB 23 | , Branch RegB (Rel (-3)) 24 | -- END: loop 25 | , Jump (Ind RegA) 26 | 27 | -- 10: 28 | , EndProg 29 | 30 | -- 11: Sprockells 1 and 2 are sent here 31 | , EndProg 32 | ] 33 | 34 | 35 | main = runDebug debugEndProg 3 prog >> putChar '\n' 36 | 37 | -- This debug function show a message when a Sprockell reaches an EndProg instruction. 38 | debugEndProg SysState{sprs=sprs,instrs=instrs} = concat $ map isHalting sprs 39 | where 40 | isHalting SprState{regbank=regs,halted=halted} 41 | | not halted && instrs!pc == EndProg 42 | = "EndProg on Sprockell " ++ show spid ++ " at addr " ++ show pc ++ "\n" 43 | | otherwise = "" 44 | where 45 | pc = regs ! PC 46 | spid = regs ! SPID 47 | -------------------------------------------------------------------------------- /src/DemoRandomOrder.hs: -------------------------------------------------------------------------------- 1 | import Sprockell.System 2 | 3 | {- 4 | This program demonstrates how the ordering of access to the shared memory can vary. 5 | 6 | All the sprockells try to write their own letter to the screen at the same time. 7 | They will all be succeed, but the order in which this happens is undefined. 8 | -} 9 | 10 | loopCount = 10 11 | 12 | prog :: [Instruction] 13 | prog = [ 14 | Const (ord 'A') RegA 15 | , Const (ord 'a' - ord 'A') RegE 16 | 17 | , Compute Add RegA SPID RegB -- sprockell id as ascii character (uppercase) 18 | , Compute Add RegB RegE RegC -- (lowercase) 19 | 20 | , Const loopCount RegD 21 | , Const 1 RegE 22 | 23 | , Write RegB stdio -- write uppercase letter 24 | , Write RegC stdio -- write lowercase letter 25 | , Compute Sub RegD RegE RegD 26 | , Branch RegD (Rel (-3)) 27 | 28 | --, Read (Addr 0x0) -- dummy read to ensure that 29 | --, Receive RegA -- all write request are done 30 | , EndProg 31 | ] 32 | 33 | 34 | main = run 4 prog >> putChar '\n' 35 | 36 | -------------------------------------------------------------------------------- /src/Sprockell/Components.hs: -------------------------------------------------------------------------------- 1 | module Sprockell.Components where 2 | 3 | -- This module contains a collection of basic hardware structures such as memories and buffers 4 | -- Goal of this version is supporting (memory) efficient simulation (don't mind the implementation details). 5 | -- An alternative implementation of this module could support synthesis to a FPGA (using Clash). 6 | 7 | import Data.Int (Int32) 8 | import Data.Maybe (fromMaybe) 9 | import Data.List (foldl') 10 | import qualified Data.IntMap.Strict as IM 11 | import qualified Data.Map.Strict as M 12 | import Data.Array (Ix) 13 | import qualified Data.Array.IArray as IA 14 | import System.Random 15 | import qualified Data.Char as Char 16 | 17 | class MemoryStructure m where 18 | (!) :: (Ord i, Ix i, Show i) => m i a -> i -> a 19 | (<~) :: (Ord i, Ix i) => m i a -> (i, a) -> m i a 20 | 21 | (<<~~) :: (Ord i, Ix i, MemoryStructure m) => m i a -> [(i, a)] -> m i a 22 | (<<~~) = foldl' (<~) 23 | 24 | newtype Memory a = Memory (IM.IntMap a) 25 | 26 | initMemory :: Memory a 27 | initMemory = Memory IM.empty 28 | 29 | (!!!) :: Num a => Memory a -> Int32 -> a 30 | (Memory m) !!! i = fromMaybe 0 (IM.lookup (fromIntegral i) m) 31 | 32 | (<~=) :: Memory a -> (Int32, a) -> Memory a 33 | (Memory m) <~= (i,x) = Memory (IM.insert (fromIntegral i) x m) 34 | 35 | newtype RegFile r a = RegFile (M.Map r a) 36 | 37 | initRegFile :: (Ord r, Enum r, Bounded r) => a -> RegFile r a 38 | initRegFile = RegFile . M.fromList . zip [minBound..maxBound] . repeat 39 | 40 | instance MemoryStructure RegFile where 41 | (RegFile r) ! i = r M.! i 42 | (RegFile r) <~ (i,x) = RegFile (M.insert i x r) 43 | 44 | data LookupTable i e = LookupTable String !(IA.Array i e) 45 | 46 | initLookupTable :: (Num i, IA.Ix i) => String -> [e] -> LookupTable i e 47 | initLookupTable n xs = LookupTable n $ IA.listArray (0, fromIntegral (length xs) - 1) xs 48 | 49 | instance MemoryStructure LookupTable where 50 | (<~) = error "read only lookup table" 51 | (LookupTable n xs) ! i 52 | | i < lo || i > hi = error ("index " ++ show i ++ " out of bounds for " ++ n) 53 | | otherwise = xs IA.! i 54 | where (lo, hi) = IA.bounds xs 55 | 56 | newtype Buffer a = Buffer [a] 57 | 58 | initBuffer :: Int -> a -> Buffer a 59 | initBuffer n x = Buffer (replicate n x) 60 | 61 | (<+) :: Buffer a -> a -> Buffer a 62 | (Buffer xs) <+ x = Buffer (drop 1 xs ++ [x]) 63 | 64 | peek :: Buffer a -> a 65 | peek (Buffer (x:xs)) = x 66 | 67 | newtype Fifo a = Fifo [a] 68 | 69 | initFifo :: Fifo a 70 | initFifo = Fifo [] 71 | 72 | enQueue :: a -> Fifo a -> Fifo a 73 | enQueue x (Fifo xs) = Fifo (xs ++ [x]) 74 | 75 | catQueue :: Fifo a -> [a] -> Fifo a 76 | catQueue (Fifo xs) ys = Fifo (xs ++ ys) 77 | 78 | deQueue :: Fifo a -> (Fifo a, Maybe a) 79 | deQueue (Fifo [] ) = (Fifo [], Nothing) 80 | deQueue (Fifo (x:xs)) = (Fifo xs, Just x) 81 | 82 | isEmptyQueue :: Fifo a -> Bool 83 | isEmptyQueue (Fifo []) = True 84 | isEmptyQueue _ = False 85 | 86 | type Seed = Int 87 | newtype RngState = RngState StdGen 88 | 89 | initRng :: Seed -> RngState 90 | initRng seed = RngState (mkStdGen seed) 91 | 92 | nextRandom :: Random a => RngState -> (a, RngState) 93 | nextRandom (RngState rs) = fmap RngState $ random rs 94 | 95 | pickSeed :: IO Seed 96 | pickSeed = getStdRandom $ randomR (0, maxBound) 97 | 98 | 99 | ord :: Integral i => Char -> i 100 | ord = fromIntegral . Char.ord 101 | chr :: Integral i => i -> Char 102 | chr = Char.chr . fromIntegral 103 | -------------------------------------------------------------------------------- /src/Sprockell/Sprockell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Sprockell.Sprockell where 4 | 5 | import Data.Bits 6 | import Data.Maybe 7 | import Debug.Trace 8 | import Sprockell.Components 9 | import Sprockell.TypesEtc 10 | 11 | {------------------------------------------------------------- 12 | | SPROCKELL: Simple PROCessor in hasKELL :-) 13 | | 14 | | Initial definition: October 2012, Jan Kuper (j.kuper@utwente.nl) 15 | | Extensions: June 2015, Martijn Bastiaan, Arjan Boeijink, Jan Kuper, Leon Schoorl 16 | -------------------------------------------------------------} 17 | 18 | 19 | {------------------------------------------------------------- 20 | | some constants 21 | -------------------------------------------------------------} 22 | 23 | initSprockell :: Int -> Value -> SprockellState 24 | initSprockell dataMemSize ident = SprState 25 | { regbank = initRegFile 0 <<~~ [(SPID, ident), (SP, fromIntegral dataMemSize)] 26 | , localMem = initMemory 27 | , halted = False 28 | } 29 | 30 | nullcode :: MachCode 31 | nullcode = MachCode 32 | { ldCode = LdImm 33 | , stCode = StNone 34 | , aguCode = AguImm 35 | , aluCode = Or 36 | , condCode = CFalse 37 | , target = TRel 38 | , ioCode = IONone 39 | , immValue = 0 40 | , inputX = Zero 41 | , inputY = Zero 42 | , result = Zero 43 | , loadReg = Zero 44 | , addrImm = 0 45 | , deref = Zero 46 | } 47 | 48 | {------------------------------------------------------------- 49 | | The actual Sprockell 50 | -------------------------------------------------------------} 51 | sprockell :: InstructionMem -> SprockellState -> Maybe Reply -> (SprockellState, Maybe Request) 52 | sprockell instrs SprState{..} reply = (sprState, request) 53 | where 54 | pc = regbank!PC 55 | MachCode{..} = decode (instrs!pc) 56 | 57 | regX = regbank!inputX 58 | regY = regbank!inputY 59 | aluOutput = alu aluCode regX regY 60 | 61 | regAddr = regbank!deref 62 | address = agu aguCode addrImm regAddr 63 | 64 | loadValue = loadUnit localMem ldCode address reply immValue 65 | localMem' = storeUnit localMem stCode address regY 66 | 67 | request = sendOut ioCode address regY 68 | 69 | cond = condition condCode regX (isJust reply) 70 | jumpTarget = targetPC target pc regY immValue 71 | nextPC = if cond then jumpTarget else pc + 1 72 | 73 | regbank' = regbank <<~~ [(result, aluOutput), (loadReg, loadValue), (PC, nextPC), (Zero, 0)] 74 | 75 | sHalted = condCode == CTrue && target == TRel && immValue == 0 76 | sprState = SprState {localMem=localMem' ,regbank=regbank', halted=sHalted} 77 | 78 | 79 | -- ============================ 80 | decode :: Instruction -> MachCode 81 | decode instr = case instr of 82 | Nop -> nullcode 83 | Compute c rx ry res -> nullcode {aluCode=c, inputX=rx, inputY=ry, result=res} 84 | Const n r -> nullcode {ldCode=LdImm, immValue=n, loadReg=r} 85 | 86 | Branch cr (Abs n) -> nullcode {condCode=CReg, inputX=cr, target=TAbs, immValue=n} 87 | Branch cr (Rel n) -> nullcode {condCode=CReg, inputX=cr, target=TRel, immValue=n} 88 | Branch cr (Ind i) -> nullcode {condCode=CReg, inputX=cr, target=TInd, inputY=i} 89 | Jump (Abs n) -> nullcode {condCode=CTrue, target=TAbs, immValue=n} 90 | Jump (Rel n) -> nullcode {condCode=CTrue, target=TRel, immValue=n} 91 | Jump (Ind i) -> nullcode {condCode=CTrue, target=TInd, inputY=i} 92 | 93 | Load (Addr a) r -> nullcode {ldCode=LdMem, aguCode=AguImm, addrImm=a, loadReg=r} 94 | Load (Deref p) r -> nullcode {ldCode=LdMem, aguCode=AguDeref, deref=p, loadReg=r} 95 | Store r (Addr a) -> nullcode {stCode=StMem, inputY=r, aguCode=AguImm, addrImm=a} 96 | Store r (Deref p) -> nullcode {stCode=StMem, inputY=r, aguCode=AguDeref, deref=p} 97 | 98 | Push r -> nullcode {stCode=StMem, inputY=r, aguCode=AguDown, deref=SP, aluCode=Decr, inputX=SP, result=SP} 99 | Pop r -> nullcode {ldCode=LdMem, loadReg=r, aguCode=AguDeref, deref=SP, aluCode=Incr, inputX=SP, result=SP} 100 | 101 | Receive r -> nullcode {ldCode=LdInp, loadReg=r, condCode=CWait, target=TRel, immValue=0} 102 | Read (Addr a) -> nullcode {ioCode=IORead, aguCode=AguImm, addrImm=a} 103 | Read (Deref p) -> nullcode {ioCode=IORead, aguCode=AguDeref, deref=p} 104 | TestAndSet (Addr a) -> nullcode {ioCode=IOTest, aguCode=AguImm, addrImm=a} 105 | TestAndSet (Deref p) -> nullcode {ioCode=IOTest, aguCode=AguDeref, deref=p} 106 | Write r (Addr a) -> nullcode {ioCode=IOWrite, aguCode=AguImm, addrImm=a, inputY=r} 107 | Write r (Deref p) -> nullcode {ioCode=IOWrite, aguCode=AguDeref, deref=p, inputY=r} 108 | 109 | EndProg -> nullcode {condCode=CTrue, target=TRel, immValue=0} 110 | Debug _ -> nullcode 111 | 112 | 113 | -- ============================ 114 | alu :: Operator -> Value -> Value -> Value 115 | alu opCode x y = case opCode of 116 | Incr -> x + 1 117 | Decr -> x - 1 118 | Add -> x + y 119 | Sub -> x - y 120 | Mul -> x * y 121 | Div -> x `div` y 122 | Mod -> x `mod` y 123 | Equal -> intBool (x == y) 124 | NEq -> intBool (x /= y) 125 | Gt -> intBool (x > y) 126 | GtE -> intBool (x >= y) 127 | Lt -> intBool (x < y) 128 | LtE -> intBool (x <= y) 129 | And -> x .&. y 130 | Or -> x .|. y 131 | LShift -> shiftL x (fromIntegral y) 132 | RShift -> shiftR x (fromIntegral y) 133 | Xor -> x `xor` y 134 | 135 | intBool :: Bool -> Value 136 | intBool True = 1 137 | intBool False = 0 138 | 139 | -- ============================ 140 | agu :: AguCode -> Address -> Value -> Address 141 | agu aguCode addr derefAddr = case aguCode of 142 | AguImm -> addr 143 | AguDeref -> derefAddr 144 | AguDown -> derefAddr - 1 145 | 146 | -- ============================ 147 | loadUnit :: LocalMem -> LdCode -> Address -> Maybe Reply -> Value -> Value 148 | loadUnit mem ldCode address reply immval = case (ldCode, reply) of 149 | (LdImm, Nothing) -> immval 150 | (LdMem, Nothing) -> mem !!! address 151 | (LdInp, Just rx) -> rx 152 | (LdInp, Nothing) -> 0 153 | (_ , Just rx) -> error ("Sprockell ignored a system response of value: " ++ show rx) 154 | 155 | -- ============================ 156 | storeUnit :: LocalMem -> StCode -> Address -> Value -> LocalMem 157 | storeUnit mem stCode address value = case stCode of 158 | StNone -> mem 159 | StMem -> mem <~= (address, value) 160 | 161 | -- ============================ 162 | condition :: CondCode -> Value -> Bool -> Bool 163 | condition cCode cReg hasInput = case cCode of 164 | CFalse -> False 165 | CTrue -> True 166 | CReg -> cReg /= 0 167 | CWait -> not hasInput 168 | 169 | targetPC :: TargetCode -> CodeAddr -> Value -> Value -> CodeAddr 170 | targetPC tCode pc fromind immval = case tCode of 171 | TAbs -> immval 172 | TRel -> pc + immval 173 | TInd -> fromind 174 | 175 | -- ============================ 176 | sendOut :: IOCode -> Address -> Value -> Maybe Request 177 | sendOut ioCode address value = case ioCode of 178 | IONone -> Nothing 179 | IORead -> Just (address, ReadReq) 180 | IOWrite -> Just (address, WriteReq value) 181 | IOTest -> Just (address, TestReq) 182 | -------------------------------------------------------------------------------- /src/Sprockell/System.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving #-} 2 | module Sprockell.System 3 | ( module Sprockell.Components 4 | , module Sprockell.TypesEtc 5 | , module Sprockell.Sprockell 6 | , module Sprockell.System 7 | ) where 8 | 9 | import Control.Monad 10 | import System.IO 11 | import Data.Maybe 12 | import Data.Bits 13 | import Debug.Trace 14 | import Sprockell.Components 15 | import Sprockell.TypesEtc 16 | import Sprockell.Sprockell 17 | 18 | data SystemConfig = SysConf 19 | { bufferDelay :: Int -- bufferDelay > 0, also impacts maximum number of outstanding read requests 20 | , dataMemSize :: Int -- local data memory size 21 | , coreCount :: Int -- number of sprockells in the system 22 | , multiplier :: Int -- multiplier > 0, factor of 'clockspeed' between system and sprockells 23 | } 24 | 25 | defaultConfig :: SystemConfig 26 | defaultConfig = SysConf 27 | { bufferDelay = 4 28 | , dataMemSize = 128 29 | , coreCount = 4 30 | , multiplier = 2 31 | } 32 | 33 | type SharedMem = Memory Value 34 | 35 | data SystemState = SysState 36 | { instrs :: !InstructionMem 37 | , sprs :: ![SprockellState] 38 | , sReqFifos :: ![Fifo Request] 39 | , repBuffers :: ![Buffer (Maybe Reply)] 40 | , sharedMem :: !SharedMem 41 | , rngState :: !RngState 42 | , cycleCount :: !Int 43 | } 44 | 45 | -- =========================================================================================== 46 | -- IO Devices 47 | -- =========================================================================================== 48 | stdio = Addr stdioAddr 49 | stdioAddr = 0x1000000 50 | 51 | type IODevice = SharedMem -> Request -> IO (SharedMem, Maybe Reply) 52 | 53 | memDevice :: IODevice 54 | memDevice mem (addr, ReadReq) = return (mem, Just (mem !!! addr)) 55 | memDevice mem (addr, WriteReq value) = return (mem <~= (addr, value), Nothing) 56 | memDevice mem (addr, TestReq) = return (mem <~= (addr, 1), Just test) 57 | where test = intBool $ not $ testBit (mem !!! addr) 0 58 | 59 | stdDevice :: IODevice 60 | stdDevice mem (_, WriteReq value) = putChar (chr value) >> return (mem, Nothing) 61 | stdDevice _ (a, TestReq) = error ("TestAndSet not supported on address: " ++ show a) 62 | stdDevice mem (_, ReadReq) = fmap ((,) mem . Just) $ do 63 | rdy <- hReady stdin 64 | if rdy 65 | then fmap ord getChar 66 | else return (-1) 67 | 68 | -- =========================================================================================== 69 | -- =========================================================================================== 70 | withDevice :: Address -> IODevice 71 | withDevice addr | addr < stdioAddr = memDevice 72 | | otherwise = stdDevice 73 | 74 | processRequest :: Maybe Request -> SharedMem -> IO (SharedMem, Maybe Reply) 75 | processRequest Nothing mem = return (mem, Nothing) 76 | processRequest (Just out) mem = withDevice (fst out) mem out 77 | 78 | updateElemWith :: (a -> (a,b)) -> Int -> [a] -> ([a],b) 79 | updateElemWith f n xs = (take n xs ++ x' : drop (n + 1) xs, y) 80 | where (x', y) = f (xs !! n) 81 | 82 | system :: SystemConfig -> SystemState -> IO SystemState 83 | system SysConf{..} SysState{..} = do 84 | let (sprs', sprReqs) = unzip $ zipWith (sprockell instrs) sprs $ map peek repBuffers -- let all sprockells run a step 85 | 86 | let (rnd, rngState') = nextRandom rngState 87 | let rsid = rnd `mod` length sprs' 88 | 89 | let (sReqFifos', req) = if (cycleCount `mod` multiplier) == 0 -- once every multiplier cycles pick a request 90 | then updateElemWith deQueue rsid sReqFifos -- from a random fifo to be processed by system 91 | else (sReqFifos, Nothing) 92 | 93 | (mem', reply) <- processRequest req sharedMem 94 | let replies = map (\i -> if i == rsid then reply else Nothing) [0..] 95 | 96 | let sReqFifos'' = zipWith (maybe id enQueue) sprReqs sReqFifos' 97 | let repBuffers' = zipWith (<+) repBuffers replies 98 | 99 | length repBuffers' `seq` length sReqFifos'' `seq` return () -- workaround to prevents space leaks 100 | 101 | return (SysState instrs sprs' sReqFifos'' repBuffers' mem' rngState' (succ cycleCount)) 102 | 103 | -- =========================================================================================== 104 | -- =========================================================================================== 105 | -- "Simulates" sprockells by recursively calling them over and over again 106 | simulate :: SystemConfig -> (SystemState -> String) -> SystemState -> IO SystemState 107 | simulate sysConf debugFunc sysState@SysState{..} 108 | | all halted sprs && all isEmptyQueue sReqFifos = return sysState 109 | | otherwise = do 110 | sysState' <- system sysConf sysState 111 | putStr (debugFunc sysState') 112 | simulate sysConf debugFunc sysState' 113 | 114 | -- =========================================================================================== 115 | -- =========================================================================================== 116 | -- Initialise SystemState for N sprockells 117 | initSystemState :: SystemConfig -> [Instruction] -> Seed -> SystemState 118 | initSystemState SysConf{..} is seed = SysState 119 | { instrs = initLookupTable "InstructionMemory" is 120 | , sprs = map (initSprockell dataMemSize) $ take coreCount [0..] 121 | , sReqFifos = replicate coreCount initFifo 122 | , repBuffers = replicate coreCount (initBuffer bufferDelay Nothing) 123 | , sharedMem = initMemory 124 | , rngState = initRng seed 125 | , cycleCount = 0 126 | } 127 | 128 | run :: Int -> [Instruction] -> IO SystemState 129 | run n instrs = runDebug (const "") n instrs 130 | 131 | runDebug :: (SystemState -> String) -> Int -> [Instruction] -> IO SystemState 132 | runDebug debugFunc n instrs = do 133 | seed <- pickSeed 134 | runDebugWithSeed seed debugFunc n instrs 135 | 136 | runWithSeed :: Seed -> Int -> [Instruction] -> IO SystemState 137 | runWithSeed seed = runDebugWithSeed seed (const "") 138 | 139 | runDebugWithSeed :: Seed -> (SystemState -> String) -> Int -> [Instruction] -> IO SystemState 140 | runDebugWithSeed seed debugFunc n instrs = do 141 | let sysConf = defaultConfig {coreCount = n} 142 | hPutStrLn stderr ("Starting with random seed: " ++ show seed) 143 | simulate sysConf debugFunc (initSystemState sysConf instrs seed) 144 | -------------------------------------------------------------------------------- /src/Sprockell/TypesEtc.hs: -------------------------------------------------------------------------------- 1 | module Sprockell.TypesEtc where 2 | 3 | import Data.Int (Int32) 4 | import Data.Array (Ix) 5 | import Sprockell.Components 6 | 7 | -- ========================================================================================================== 8 | 9 | -- Sprockell instructions 10 | data Instruction = 11 | Compute Operator Reg Reg Reg -- Compute opCode r0 r1 r2: go to "alu", 12 | -- do "opCode" on regs r0, r1, and put result in reg r2 13 | | Const Value Reg -- Const v r: put value v in register r 14 | 15 | | Branch Reg Target -- Branch r t: conditional jump, depending on register r 16 | | Jump Target -- Jump t: jump to target t (absolute, relative, indirect) 17 | 18 | | Load MemAddr Reg -- Load (Addr a) r : from "memory a" to "regbank r" 19 | -- Load (Deref p) r : from memory indexed by register p to "r" 20 | | Store Reg MemAddr -- Store (Addr r) a: from "regbank r" to "memory a" 21 | -- Store (Deref p) r: from "r" to memory indexed by registers p 22 | | Push Reg -- push a value on the stack 23 | | Pop Reg -- pop a value from the stack 24 | 25 | | Read MemAddr -- Send read request for an external address 26 | | Receive Reg -- Wait for a reply of a request and save it in register 27 | | Write Reg MemAddr -- Write content of reg to an external address 28 | | TestAndSet MemAddr -- Request a test on address for 0 and sets it to 1 if it is. 29 | -- Reply will contain 1 on success, and 0 on failure. 30 | -- This is an atomic operation; it might therefore be 31 | -- used to implement locks or synchronisation. 32 | 33 | | EndProg -- end of program, deactivates Sprockell. If all sprockells are at 34 | -- this instruction, the simulation will halt. 35 | | Nop -- "No operation". 36 | | Debug String -- No real instruction, for debug purposes. 37 | deriving (Eq,Show,Read) 38 | 39 | data Reg = Zero -- Read only zero value 40 | | PC -- Program counter 41 | | SP -- Stack pointer used by Push and Pop 42 | | SPID -- Sprockell identifier 43 | | RegA 44 | | RegB 45 | | RegC 46 | | RegD 47 | | RegE 48 | deriving (Eq,Show,Read,Ord,Enum,Bounded,Ix) 49 | 50 | data MemAddr = Addr Address 51 | | Deref Reg 52 | deriving (Eq,Show,Read) 53 | 54 | data Target = Abs CodeAddr 55 | | Rel CodeAddr 56 | | Ind Reg 57 | deriving (Eq,Show,Read) 58 | 59 | data Operator = Add | Sub | Mul | Div | Mod 60 | -- comparision operations 61 | | Equal | NEq | Gt | Lt | GtE | LtE 62 | -- logical/binary operations 63 | | And | Or | Xor | LShift | RShift 64 | -- Internal 65 | | Decr | Incr 66 | deriving (Eq,Show,Read) 67 | 68 | -- type synonyms for clarity 69 | type Value = Int32 70 | type Address = Int32 71 | type CodeAddr = Int32 72 | 73 | -- ========================================================================================================== 74 | -- Internal Sprockell data structures 75 | 76 | data CondCode = CFalse 77 | | CTrue 78 | | CReg 79 | | CWait 80 | deriving (Eq,Show) 81 | 82 | data TargetCode = TAbs 83 | | TRel 84 | | TInd 85 | deriving (Eq,Show) 86 | 87 | data AguCode = AguImm 88 | | AguDeref 89 | | AguDown 90 | deriving (Eq,Show) 91 | 92 | data LdCode = LdImm 93 | | LdMem 94 | | LdInp 95 | deriving (Eq,Show) 96 | 97 | data StCode = StNone 98 | | StMem 99 | deriving (Eq,Show) 100 | 101 | data IOCode = IONone 102 | | IORead 103 | | IOWrite 104 | | IOTest 105 | deriving (Eq,Show) 106 | 107 | data MachCode = MachCode 108 | { ldCode :: LdCode -- source of load results 109 | , stCode :: StCode -- store command 110 | , aguCode :: AguCode -- address calculation 111 | , aluCode :: Operator -- arithmetic operation 112 | , ioCode :: IOCode -- communication with the rest of the system 113 | , immValue :: Value -- value from Immediate 114 | , inputX :: Reg -- first input register 115 | , inputY :: Reg -- seconde input register 116 | , result :: Reg -- alu result register 117 | , loadReg :: Reg -- where to load results are written to 118 | , addrImm :: Address -- address constant 119 | , deref :: Reg -- address register 120 | , condCode :: CondCode -- branching condition 121 | , target :: TargetCode -- branch target computation 122 | } deriving (Eq,Show) 123 | 124 | data SprockellState = SprState 125 | { regbank :: !RegBank -- register bank 126 | , localMem :: !LocalMem -- local data memory 127 | , halted :: !Bool 128 | } 129 | 130 | type InstructionMem = LookupTable CodeAddr Instruction 131 | type LocalMem = Memory Value 132 | type RegBank = RegFile Reg Value 133 | 134 | type Reply = Value 135 | type Request = (Address, RequestKind) 136 | data RequestKind = ReadReq 137 | | WriteReq Value 138 | | TestReq 139 | deriving (Eq,Show) 140 | -------------------------------------------------------------------------------- /src/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | import Sprockell.System 4 | import Debug.Trace 5 | 6 | type TestSuite = (String, Int, [Instruction], (SystemState -> String)) 7 | 8 | getRegs sysState spid regs = getRegs' (regbank ((sprs sysState) !! spid)) regs 9 | where getRegs' rs = map (rs !) 10 | 11 | -- Can we write to registers and does zero stay zero? -- 12 | writeRegProg = [Const 10 RegA, Const 11 RegB, Const 15 Zero, EndProg] 13 | writeRegSuite = ("RegTest", 1, writeRegProg, writeRegTest) 14 | 15 | writeRegTest sysState 16 | | getRegs sysState 0 [RegA, RegB, Zero] == [10, 11, 0] = "OK" 17 | 18 | -- Does computing work? -- 19 | computeProg = [Const 3 RegA, Const 2 RegB, Compute Mul RegA RegB RegC, EndProg] 20 | computeSuite = ("ComputeTest", 1, computeProg, computeTest) 21 | 22 | computeTest sysState 23 | | getRegs sysState 0 [RegA, RegB, RegC] == [3, 2, 6] = "OK" 24 | 25 | -- Indirect Load -- 26 | indirectLoadSuite = ("IndirectLoadTest", 1, indirectLoadProg, indirectLoadTest) 27 | indirectLoadProg = [ 28 | Const 2 RegA 29 | , Const 3 RegB 30 | , Store RegA (Addr 3) 31 | , Load (Deref RegB) RegC 32 | , EndProg 33 | ] 34 | 35 | indirectLoadTest sysState 36 | | getRegs sysState 0 [RegA, RegB, RegC] == [2, 3, 2] = "OK" 37 | 38 | -- Write to Zero 39 | writeZeroProg = [Const 2 Zero, Compute Add Zero RegA RegA, EndProg] 40 | writeZeroSuite = ("ZeroTest", 1, writeZeroProg, writeZeroTest) 41 | 42 | writeZeroTest sysState 43 | | getRegs sysState 0 [RegA, Zero] == [0, 0] = "OK" 44 | 45 | -- Indirect Store -- 46 | indirectStoreSuite = ("IndirectStoreTest", 1, indirectStoreProg, indirectStoreTest) 47 | indirectStoreProg = [ 48 | Const 2 RegA 49 | , Const 3 RegB 50 | , Store RegA (Deref RegB) 51 | , Load (Addr 3) RegC 52 | , EndProg 53 | ] 54 | 55 | indirectStoreTest sysState 56 | | getRegs sysState 0 [RegA, RegB, RegC] == [2, 3, 2] = "OK" 57 | 58 | -- Check the value of local mem which was not previously written to -- 59 | unwrittenLocalSuite = ("UnwrittenLocalTest", 1, unwrittenLocalProg, unwrittenLocalTest) 60 | unwrittenLocalProg = [ 61 | Const 2 RegA 62 | , Const 3 RegB 63 | , Load (Addr 0) RegA 64 | , Load (Deref RegB) RegB 65 | , EndProg 66 | ] 67 | unwrittenLocalTest sysState 68 | | getRegs sysState 0 [RegA, RegB] == [0, 0] = "OK" 69 | 70 | -- Check the value of shared mem which was not previously written to -- 71 | unwrittenSharedSuite = ("UnwrittenSharedTest", 1, unwrittenSharedProg, unwrittenSharedTest) 72 | unwrittenSharedProg = [ 73 | Const 2 RegA 74 | , Const 3 RegB 75 | , Read (Addr 0) 76 | , Receive RegA 77 | , Read (Deref RegB) 78 | , Receive RegB 79 | , EndProg 80 | ] 81 | unwrittenSharedTest sysState 82 | | getRegs sysState 0 [RegA, RegB] == [0, 0] = "OK" 83 | 84 | testAndSetSuite = ("TestAndSetTest", 1, testAndSetProg, testAndSetTest) 85 | testAndSetProg = [ 86 | TestAndSet (Addr 0) 87 | , Receive RegA 88 | , TestAndSet (Addr 0) 89 | , Receive RegB 90 | , EndProg 91 | ] 92 | testAndSetTest sysState@SysState{ .. } 93 | | (sharedMem !!! 0) == 1 && getRegs sysState 0 [RegA, RegB] == [1, 0] = "OK" 94 | | otherwise = "Fail" 95 | 96 | 97 | 98 | 99 | -- Running test logic -- 100 | runSuite :: TestSuite -> IO () 101 | runSuite (name, nSprockells, prog, test) = do 102 | putStr name >> putStr " (n=" >> putStr (show nSprockells) >> putStr "): " 103 | run nSprockells prog >>= return . test >>= putStr 104 | putChar '\n' 105 | return () 106 | 107 | main = do 108 | runSuite writeRegSuite 109 | runSuite computeSuite 110 | runSuite writeZeroSuite 111 | runSuite indirectLoadSuite 112 | runSuite indirectStoreSuite 113 | runSuite unwrittenLocalSuite 114 | runSuite unwrittenSharedSuite 115 | runSuite testAndSetSuite 116 | return () 117 | 118 | --------------------------------------------------------------------------------