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

   1 -- Execution Units --
   2
   3 module EUs where
   4 import List
   5 import qualified PreludeSig as Sig
   6 import Hawk
   7 import Trans
   8 import DLX
   9
  10 type EU i c = Signal Bool -> Signal [(Trans i c)] ->
  11                 Signal ([Trans i c],[Trans i c])
  12
  13 -- Schedule Combinator ---------------------------------------------------
  14 schedule :: Register r => [EU i (c r w)] -> EU i (c r w)
  15 schedule l b = foldl combine end (map ($b) l)
  16   where
  17   end = lift1 $ \x -> ([],x)
  18   combine f g sig = let (ac,rej) = unbundle2 $ f sig
  19                         (ac',rej') = unbundle2 $ g rej
  20                     in bundle2 (ac *++ ac',rej')
  21
  22 -- EUs -----------------------------------------------------------
  23
  24 addUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
  25 addUnit = makeUnit isAdd aluDevice
  26
  27 subUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
  28 subUnit = makeUnit isSub aluDevice
  29
  30 multUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
  31 multUnit = makeDelayedUnit 2 isMul aluDevice
  32
  33 divUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
  34 divUnit = makeDelayedUnit 4 isDiv aluDevice
  35
  36 cmpUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
  37 cmpUnit = makeUnit isCmp aluDevice
  38
  39 jumpUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
  40 jumpUnit = makeUnit isJump (map jumpDevice)
  41
  42 moveUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
  43 moveUnit = makeUnit isMove aluDevice
  44
  45 -- Devices -------------------------------------------------------------
  46 jumpDevice trans@(Trans [dest] op [cond,src1,src2] _) | isJumpOp op =
  47         (trans `evalTrans`
  48             (dest,alu func val1 val2))
  49    where func = if (getVal cond) == 0 then z else nz
  50          val1 = getVal src1
  51          val2 = getVal src2
  52          z = fstOp op
  53          nz = sndOp op
  54
  55 aluDevice x
  56      = map (\t@(Trans [dest] op [src1,src2] x) ->
  57               let aluFunc = aluOp op
  58               in (t `evalTrans` (dest,
  59                     (alu aluFunc (getVal src1) (getVal src2))))
  60            ) x
  61
  62 -- Higher-order Constructors   ----------------------------------------------
  63 makeUnit :: Register r => (Trans i (c r w) -> Bool) ->
  64                           ([Trans i (c r w)] -> [Trans i (c r w)]) ->
  65                           EU i (c r w)
  66 makeUnit accept unit kill instrs
  67    = lift1 (\(k,x) -> let (acceptable,rejects) = partition accept x
  68                           (instr,others) = splitAt 1 acceptable
  69                    in (unit instr,others ++ rejects)) $ bundle2 (kill,instrs)
  70
  71
  72 makeDelayedUnit :: Register r => Int -> (Trans i (c r w) -> Bool) ->
  73                                  ([Trans i (c r w)] -> [Trans i (c r w)]) ->
  74                                  EU i (c r w)
  75 makeDelayedUnit n f g kill sig = bundle2 (flush n [] kill $ delayN n [] x,y)
  76   where
  77   (x,y) = unbundle2 $ unit kill sig
  78   unit = makeUnit f g
  79
  80 delayN n x s = xs `before` s
  81    where xs = take n (repeat x)