ghc/tests/programs/jeff-bug/Devices.hs

   1 module Devices where
   2
   3 import List
   4 import TransSig
   5 import qualified Trans as T
   6 import qualified PreludeSig as Signaled
   7 import Signal
   8 import Words
   9 import Register
  10 import Arithmetic
  11 import Cell
  12 import Memory
  13 import Utilities
  14
  15 import LazyST
  16 import Instruction
  17
  18 import Array
  19 import Monad
  20 import StateArray
  21 import Ix
  22
  23
  24
  25 -- Begin Signature -------------------------------------------------------
  26 {-
  27    Devices defines common circuits (for example ,instruction
  28    and data memory or alus)
  29 -}
  30
  31
  32 -- flush k x b s , when b then return x for k cycles, otherwise s
  33 -- flush 2 10 <False,False,True,False,False,False,False .. > <1 .. 7 .. >
  34 --        = <1,2,10,10,5,6,7 .. >
  35 flush       :: Int -> a -> Signal Bool -> Signal a -> Signal a
  36
  37 -- latch x b xs. return the value of xs when last b occurred.  initialize
  38 -- with x
  39 latch       :: a -> Signal Bool -> Signal a -> Signal a
  40
  41
  42
  43 regFile     :: Ix i  => (i,i) ->      -- Register addresses
  44                         [a] ->                   -- Initial contents
  45                         [(Signal Bool,           -- Write enables
  46                         (Signal i,Signal a))] -> -- Write ports
  47                         [Signal i] ->            -- Read ports
  48                         [Signal a]               -- Read port contents
  49
  50
  51 dataMemory :: (Word a, Word b) => a -> ArrayDesc a b ->
  52               Signal LoadStoreOp -> Signal a -> Signal b -> Signal b
  53
  54
  55 -- fetch (k,translate,max,memory) pc width = (instrs,pc')
  56 --   k = the number of indices between addresses.
  57 --   translate = the function that creates transaction from
  58 --               the representation in memory
  59 --   max = the largest number of instructions to fetch on
  60 --         a single cycle
  61 --   memory = the program
  62 --   pc = the pc to fetch
  63 --   width = the number of instructions to fetch starting at pc
  64 fetch  :: (Cell c, Register r, Word w, Instruction i) =>
  65           (w,f -> Trans i (c r w),Int,ArrayDesc w f) ->
  66           Signal (Trans i (c r w)) -> Signal Int ->
  67           (Signal [Trans i (c r w)],Signal (Trans i (c r w)))
  68
  69
  70 -- trans_alu is alu applied to transactions in the obvious way:
  71 -- intuitively,
  72 --  trans_alu(Trans [dst] op [s1,s2]) = Trans [dst=alu(op,s1,s2)] op [s1,s2]
  73 trans_alu :: (Register r, Cell c, Word w, Instruction i) =>
  74              (Trans i (c r w)) -> (Trans i (c r w))
  75
  76 --- exec is trans_alu lifted on signals
  77 exec :: (Register r, Cell c, Word w, Instruction i) =>
  78         Signal (Trans i (c r w)) -> Signal (Trans i (c r w))
  79
  80
  81 -- mem serves loads and stores
  82 mem :: (Instruction i, Cell c, Register r,Word w) =>
  83        w -> ArrayDesc w w ->
  84        Signal (Trans i (c r w)) -> Signal (Trans i (c r w))
  85
  86 ss_mem :: (Instruction i, Cell c, Register r, Word w) =>
  87        w -> ArrayDesc w w ->
  88        Signal [Trans i (c r w)] -> Signal [Trans i (c r w)]
  89
  90
  91
  92 -- End Signature -------------------------------------------------------
  93
  94 ss_mem k m = superscalar (mem k m)
  95
  96
  97 --- WHOA! this code is a black-hole.  Read only if you must!
  98 --- This could use some serious house-cleaning.
  99
 100 -- "fetch n mem pc size" fetches (min n size) consec. instructions
 101 -- following "pc"
 102 fetch (k,f,lim,memory@(range,_)) pc n
 103      = (id,last') >< instrsFetch k f memory pcs
 104   where
 105   size = Signaled.min n (lift0 lim)
 106   last' s = if' (Signaled.length s *< 1) then' pc
 107             else' (Signaled.last s)
 108   pcs = lift2 (buildPCs k range) pc n
 109
 110   buildPCs :: (Word w, Cell c, Register r, Instruction i) =>
 111             w -> (w,w) -> Trans i (c r w) -> Int -> [Trans i (c r w)]
 112   buildPCs k range pctrans n
 113     = do p <- fmap getReg $ T.getDstPC pctrans
 114          pc <- fmap getVal $ T.getDstPC pctrans
 115          let pcs = filter (inRange range) $ take n [pc,pc+k .. ]
 116          return $ map (mkPC range) pcs
 117       `catchEx` []
 118   mkPC range x = if inRange range x then T.pcTrans x
 119                   else T.nop
 120
 121 instrFetch n convert m input = (head' x, head' y)
 122   where
 123   fetch = instrsFetch n convert m
 124   (x,y) = fetch (toList input)
 125   toList = lift1 $ \x -> [x]
 126   head' = lift1 head
 127
 128
 129 instrsFetch n convert initContents pcs
 130   = (insertPCs curPC $ instructions `bypassList` nextPCTrans, nextPCTrans)
 131     where
 132       bypassList = lift2 $ \x y -> zipWith T.bypass x y
 133       instructions = lift1 (map convert) $ instrMemory n initContents curPC
 134       curPC = lift1 (map getpc) pcs
 135       nextPCTrans = lift1 (map (\x -> T.pcTrans $ x+n)) curPC
 136       getpc t =
 137           do reg <- T.getDstPC t
 138              let p = getReg reg
 139              let x = getVal reg
 140              guard $ ispc p
 141              return x
 142            `catchEx` (error "ugh" ) -- $ "getpc " ++ show t)
 143       insertPCs pcs l = lift2 addPCs pcs l
 144       addPCs x y = zipWith addPC x y
 145       addPC pc (Trans d o s l) = Trans d o s (loc pc:l)
 146
 147
 148 exec trans = lift1 trans_alu trans
 149
 150 trans_alu trans@(Trans (dest:_) op (src:_) _)
 151     | isAluOp op && aluOp op == Input1 =
 152          trans `T.evalTrans` (dest,(alu Input1 (getVal src) undefined))
 153 trans_alu trans@(Trans (dest:_) op (src:_) _)
 154     | isAluOp op && aluOp op == SetHi =
 155          trans `T.evalTrans` (dest,(alu SetHi (getVal src) undefined))
 156 trans_alu trans@(Trans [dest] op (src1:src2:_) _)
 157     | isAluOp op =
 158          trans `T.evalTrans` (dest,(alu (aluOp op) (getVal src1) (getVal src2)))
 159 trans_alu t@(Trans (d1:d2:_) op (s1:s2:_) _)
 160   | isAluOp op =
 161       let t' = t `T.evalTrans` (d1,(alu (aluOp op) (getVal s1) (getVal s2)))
 162           Trans (d1':_) _ _ _ = t'
 163       in t' `T.evalTrans` (d2,(alu Not (getVal d1') (getVal d1')))
 164 trans_alu trans@(Trans (dest:_) op (cond:src1:src2:_) _) | isCond op =
 165                 let eqZeroFunc = fstOp op
 166                     neqZeroFunc = sndOp op
 167                 in trans `T.evalTrans` (dest,alu
 168                         (if (getVal cond) == 0 then eqZeroFunc else neqZeroFunc)
 169                                       (getVal src1)
 170                                       (getVal src2))
 171 trans_alu trans@(Trans (dest1:dest2:_)
 172                          op
 173                          (src1:src2:_) _) | isPar op
 174         = (trans `T.evalTrans` (dest1,alu aluFunc1 src1Data src2Data))
 175                  `T.evalTrans` (dest2,alu aluFunc2 src1Data src2Data)
 176           where
 177             aluFunc1 = fstOp op
 178             aluFunc2 = sndOp op
 179             src1Data = getVal src1
 180             src2Data = getVal src2
 181 trans_alu trans@(Trans _ o _ _ )
 182             | isMemOp o = trans
 183             | isNoOp o = trans
 184 --            | otherwise = error ("Unexecutable transaction: ")
 185             | otherwise = trans
 186
 187
 188 ------------ Memory stage ------------
 189
 190
 191 mem k initContents trans
 192   = if' loadInstr
 193       then' (trans `evalTrans` (bundle2 (loadReg,lift1 Just
 194             (dataMemory k initContents loadStoreOp address contents))))
 195       else' trans
 196     where
 197       (loadInstr,loadReg,loadStoreOp,address,contents)
 198         = unbundle5 $ lift1 dataMemOps trans
 199 dataMemOps (Trans (dest:_) op (address:offset:_) _) | isLoadOp op
 200         = (True,dest,loadOp,getVal address + getVal offset,0)
 201            where loadOp = memOp op
 202 dataMemOps(Trans _ op (address:offset:val:_) _) | isStoreOp op
 203         = (False,
 204            undefined, -- pcNothing
 205            storeOp,
 206            getVal address + getVal offset,
 207            getVal val)
 208           where storeOp = memOp op
 209 dataMemOps _
 210         = (False,
 211            undefined, -- pcNothing,
 212            NOP,
 213            0,
 214            0)
 215
 216
 217
 218
 219
 220 flush n d s1 s2 = runST (
 221     do { n' <- newSTRef 0
 222        ; loop (bundle2 (s1,s2)) (\(s1,s2) ->
 223          do { if s1 then writeSTRef n' n else return ()
 224             ; n <- readSTRef n'
 225             ; if n>0 then do {writeSTRef n' (n-1)
 226                              ; return d
 227                              }
 228                else return s2
 229             })
 230        }
 231   )
 232
 233
 234
 235 --------------- Latches ----------------
 236 -- latch stores a value, until it is reset to a new value by
 237 --  the boolean signal. "init" is the value stored in latch
 238 --  at time zero.
 239 latch init reset resetVal = out
 240   where
 241   out = (if' reset then' resetVal else' last)
 242   last = delay init out
 243
 244
 245 --------------- Buses ------------------
 246
 247 --busReg      :: Int -> [a] -> [Signal a] -> [Signal a]
 248 --busReg n inits xs = zipInt n delay inits xs
 249 --  where
 250 --  zipInt 0 f xs ys           = []
 251 --  zipInt n f ~(x:xs) ~(y:ys) = f x y : zipInt (n-1) f xs ys
 252
 253
 254 ------------------ Register Files ----------------
 255
 256 -- A bank of registers. The bank
 257 --  contains multiple read- and write-ports. Note that
 258 --  the contents of a write port are reflected in the
 259 --  associated read port in the same clock cycle.
 260 regFile bounds initContents writePorts readPorts
 261   = map (lift2 (!) registers) readPorts
 262     where
 263     registers = updateArray lastRegisters writePorts
 264     lastRegisters = delay (listArray bounds initContents) registers
 265
 266
 267
 268 -- Bank of registers, where each register holds a pair of values.
 269 {-
 270 pairRegFile :: Ix i => (i,i) ->                -- Register addresses
 271                        [(a,b)] ->                         -- Initial contents
 272                        [(Signal Bool,                     -- Write enables
 273                         (Signal i,Signal a,Signal b))] -> -- Write ports
 274                        [Signal i] ->                      -- Read ports
 275                        [(Signal a,Signal b)]              -- Read port contents
 276
 277 pairRegFile bounds initVals writePorts readPorts
 278   = map unbundle2 (regFile bounds initVals zipWritePorts readPorts)
 279     where
 280     zipWritePorts = map (\(writeEnable,(writeAddress,writeA,writeB)) ->
 281                         (writeEnable,(writeAddress, bundle2 (writeA,writeB))))
 282                         writePorts
 283
 284 --type WriteBackData s reg w = (s w       -- writeback contents
 285 --                          ,s reg     -- writeback register name
 286 --                          )
 287
 288
 289 -}
 290
 291
 292 -- I THINK THAT THIS ONE SHOULD GO...
 293 registers src1 src2 p
 294   = unbundle2 $ fmap getContents arrResps
 295     where
 296       (writebackContents,writebackReg) = unbundle2 p
 297       arrResps = stateArray ((minBound,maxBound),[(minBound,maxBound,0)])
 298                              (lift4 arrReqs src1 src2 writebackContents writebackReg)
 299
 300       getContents [ReadVal src1, ReadVal src2]
 301         = (src1,src2)
 302       getContents [Written, ReadVal src1, ReadVal src2]
 303         = (src1,src2)
 304       getContents [Written,Written, ReadVal src1, ReadVal src2]
 305         = (src1,src2)
 306
 307       arrReqs src1 src2 wbContents wbReg
 308         = wb ++
 309           [ ReadArr src1,
 310            ReadArr src2]
 311         where wb = map (\(x,y) -> WriteArr x x y) (zip wbReg wbContents)
 312
 313
 314
 315 instrMemory sz arrDesc pcAddresses = lift1 (map getInstr) arrResp
 316   where
 317   getInstr (ReadVal instr) = instr
 318   arrResp = let y = lift1 ( map (\addr -> ReadArr (addr `div` sz))) pcAddresses
 319             in stateArray arrDesc y
 320
 321
 322
 323 -----------------------------------------------------------------------------
 324 dataMemory sz arrDesc loadStoreCmd addr writeVal
 325   = liftFn getLMD $ stateArray arrDesc arrReqs
 326     where
 327       {- Halfword and byte stores are implemented by loading the relevent
 328          word from memory, modifying the correct portion of the word, and
 329          then storing the revised word back to memory, all within one
 330          clock cycle
 331       -}
 332
 333       liftFn = lift2 ($)
 334
 335       (arrReqs,getLMD) = unbundle2 $ lift3 interpCmd loadStoreCmd addr writeVal
 336
 337 --      interpCmd :: Word w => LoadStoreOp -> w -> w ->
 338 --                   ([ArrReq w w],[ArrResp w w] -> w)
 339
 340       interpCmd (Load FullWord _ ) addr _
 341         = ([ReadArr (addr `div` sz)],
 342            (\[ReadVal val] -> val))
 343
 344       interpCmd (Load HalfWord signedness) addr _
 345         = ([ReadArr wordAddr],
 346            (\[ReadVal val] -> subfield signedness
 347                          (4 * sz) ((4 * sz) - (2 * sz) * wordMod) val)
 348            )
 349           where
 350             (wordAddr,wordMod) = addr `divMod` sz
 351
 352       interpCmd (Load Byte signedness) addr _
 353         = ([ReadArr wordAddr],
 354            (\[ReadVal val] -> subfield signedness
 355                    (2 * sz) ((6 * sz) - (2 * sz) * wordMod) val)
 356            )
 357           where
 358             (wordAddr,wordMod) = addr `divMod` sz
 359
 360       interpCmd (Store FullWord) addr val
 361         = ([WriteArr wordAddr wordAddr val],
 362            (\[Written] -> val))
 363           where
 364             wordAddr = addr `div` sz
 365
 366       interpCmd (Store HalfWord) addr val
 367         = ([WriteFn wordAddr modifyHalfword],
 368            (\[WrittenFn val] -> val))
 369           where
 370             (wordAddr,wordMod) = addr `divMod` sz
 371             modifyHalfword wordContents
 372               = setSubfield (4 * sz)
 373                             ((4 * sz) - (2 * sz) * wordMod)
 374                             wordContents
 375                             (wordContents `mod` num_half)
 376
 377       interpCmd (Store Byte) addr val
 378         = ([WriteFn wordAddr modifyByte],
 379            (\[WrittenFn val] -> val))
 380           where
 381             (wordAddr,wordMod) = addr `divMod` 4
 382             modifyByte wordContents
 383               = setSubfield (2 * sz)
 384                             ((6 * sz) - (2 * sz) * wordMod)
 385                             wordContents
 386                             (wordContents `mod` num_bytes)
 387
 388       interpCmd NOP _ _
 389         = ([],const 0)
 390
 391
 392
 393 --  treating 'n' as a bitfield, this function extracts a subrange
 394 --  bitfield specified by 'subfieldLen' and 'subfieldStartPos'.
 395 --  For subfieldStartPos, 0 indicates the subfield starts at the
 396 --  least significant bit position of 'n'.
 397 --  If 'signedness' == Signed, this function performs sign-extension
 398 --  to the result subfield.
 399 subfield :: (Integral a, Integral b, Integral c) => Sign -> c -> a -> b -> b
 400 subfield signed subfieldLen subfieldStartPos n
 401  = (n `div` (2^subfieldStartPos)) `modOp` (2^subfieldLen)
 402  where
 403  modOp = case signed of
 404            Signed   -> signedModulus
 405            Unsigned -> mod
 406
 407 -- This function returns 'n', modified by replacing the subfield
 408 --  denoted with (subfieldLen,subfieldStartPos), by 's'.
 409 --  Note that s must satisfy ( 0 <= s <= 2^subfieldLen)
 410 setSubfield :: (Integral a, Integral b, Integral c) => a -> b -> c -> c -> c
 411 setSubfield subfieldLen subfieldStartPos n s
 412  = n + (2^subfieldLen)*(s - (subfield Unsigned subfieldLen subfieldStartPos n))
 413
 414
 415