--- !!! cc002 -- ccall with ambiguous argument
+-- !!! cc001 -- ccall with ambiguous argument
module Test where
f :: IO ()
-
+
cc001.hs:5:
- Ambiguous type variable(s) `$0'
- in the constraint `PrelGHC.CCallable $0'
+ Ambiguous type variable(s) `t'
+ in the constraint `PrelGHC.CCallable t'
arising from an argument in the _ccall_ to `foo', namely `(undefined ())' at cc001.hs:5
-
Compilation had errors
+
-
+
cc002.hs:10:
No instance for `PrelGHC.CReturnable ForeignObj'
arising from the result of the _ccall_ to `a' at cc002.hs:10
-
Compilation had errors
+
-
+
cc004.hs:2:
Cannot generalise these overloadings (in a _ccall_):
- `PrelGHC.CReturnable $ren' arising from the result of the _ccall_ to `f' at cc004.hs:18
-
+ `PrelGHC.CReturnable b' arising from the result of the _ccall_ to `f' at cc004.hs:15
+
cc004.hs:2:
Cannot generalise these overloadings (in a _ccall_):
- `PrelGHC.CReturnable a' arising from the result of the _ccall_ to `f' at cc004.hs:11
-
+ `PrelGHC.CReturnable b' arising from the result of the _ccall_ to `f' at cc004.hs:8
Compilation had errors
+
--
module Main ( main, g ) where
-main = putStr (shows (g 42) "\n")
+main = putStr (shows (g 42 45 45) "\n")
-g :: Int -> Int -> Int -> (Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int, Int)
+g :: Int -> Int -> Int -> [Int]
g x y z
= let
f a b = a + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b + b * a * b - a + a + b
g c = f c c
in
- (g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y)
+ [g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y, g z, g x, g y]
eq2 = (2::Int) == (4::Int)
eq3 = (3::Int) == (3::Int)
eq4 = (4::Int) == (2::Int)
+
+
-
+
drvfail007.hs:2:
No instance for `Eq (Int -> Int)'
When deriving classes for `Foo'
-
Compilation had errors
+
--- /dev/null
+-- Addressable Queues --
+module AQ where
+import LazyST
+import Utils
+
+import Hawk
+
+type AQ s a = (STArray s Int (Maybe a), Front s,Back s,QSize s,Int)
+type Front s = STRef s Int
+type Back s = STRef s Int
+type QSize s = STRef s Int
+type QAddr = Int
+
+
+new :: Int -> ST s (AQ s a)
+enQueue :: AQ s a -> a -> ST s QAddr
+deQueue :: AQ s a -> ST s (a,QAddr)
+reQueue :: AQ s a -> a -> ST s QAddr
+getSize :: AQ s a -> ST s Int
+getMax :: AQ s a -> ST s Int
+deQueueWhile :: AQ s a -> (a -> Bool) -> ST s [a]
+enList :: AQ s a -> [a] -> ST s [QAddr]
+update :: AQ s a -> QAddr -> (a -> a) -> ST s ()
+clear :: AQ s a -> ST s ()
+space :: AQ s a -> ST s Int
+
+------------------------------------------------------------------------------
+
+assertM True _ = return ()
+assertM False s = error $ s ++ "\n"
+
+insert x y z = setQVal x y (Just z)
+
+new n
+ = do { q <- newSTArray (0,n) Nothing
+ ; f <- newSTRef (-1)
+ ; b <- newSTRef 0
+ ; s <- newSTRef 0
+ ; return (q,f,b,s,n)
+ }
+
+clear (q,f,b,s,n)
+ = do { mapM (\x -> writeSTArray q x Nothing) [0 .. n]
+ ; writeSTRef f (-1)
+ ; writeSTRef b 0
+ ; writeSTRef s 0
+ }
+
+enQueue q elem
+ = do { sz <- getSize q
+ ; max <- getMax q
+ ; () <- assertM (sz < max) "enQueue over max"
+ ; f <- getFront q
+ ; let f' = (f+1) `mod` max
+ ; setQVal q f' (Just elem)
+ ; setSize q (sz+1)
+ ; setFront q f'
+ ; return f'
+ }
+
+reQueue q elem
+ = do { sz <- getSize q
+ ; max <- getMax q
+ ; assertM (sz < max) "reQueue over max"
+ ; b <- getBack q
+ ; let b' = (b-1) `mod` max
+ ; setQVal q b' (Just elem)
+ ; setSize q (sz+1)
+ ; setBack q b'
+ ; return b'
+ }
+
+deQueue q
+ = do { sz <- getSize q
+ ; max <- getMax q
+ ; assertM (sz > 0) "deQueue under min"
+ ; b <- getBack q
+ ; mj <- getQVal q b
+ ; let j = mj `catchEx` error "deQueue"
+ ; setSize q (sz-1)
+ ; setBack q $ (b+1) `mod` max
+ ; return (j,b)
+ }
+
+space q
+ = do { sz <- getSize q
+ ; m <- getMax q
+ ; return $ m - sz
+ }
+
+deQueueWhile q f
+ = do { sz <- getSize q
+ ; if (sz < 1)
+ then return []
+ else do { (elem,addr) <- deQueue q
+ ; if (f elem)
+ then do { elems <- deQueueWhile q f
+ ; return (elem:elems)
+ }
+ else do { reQueue q elem
+ ; return []
+ }
+ }
+ }
+
+
+
+enList q [] = return []
+enList q (x:xs)
+ = do { sz <- space q
+ ; if (sz > 0)
+ then do { a <- enQueue q x
+ ; l <- enList q xs
+ ; return $ a:l
+ }
+ else return []
+ }
+
+assignAddrs q l
+ = do { let len = length l
+ ; sz <- space q
+ ; max <- getMax q
+ ; assertM (sz >= len) "sz < len"
+ ; f <- getFront q
+ ; let f' = f+1
+ ; let addrs = map (`mod` max) [f' .. f'+len]
+ ; return $ zip l addrs
+ }
+
+assignAddr q x
+ = do { ans <- assignAddrs q [x]
+ ; return $ head ans
+ }
+
+iterateQueue q f
+ = do { front <- getFront q
+ ; back <- getBack q
+ ; max <- getMax q
+ ; updateWhile q front front back max f
+ }
+ where updateWhile q front n back max f
+ | n == back = return ()
+ | otherwise = do { val <- getQVal q n
+ ; val <- case val of
+ Just x -> return $ Just $ f x
+ Nothing -> return Nothing
+ ; setQVal q n val
+ ; updateWhile q front ((n+1) `mod` max) back max f
+ }
+
+update q n f
+ = do { x <- getQVal q n
+ ; setQVal q n $ map f x
+ }
+
+-------------------------------------------------------------------------
+
+getSize (q,f,b,s,m) = readSTRef s
+setSize (q,f,b,s,m) v = writeSTRef s v
+getMax (q,f,b,s,m) = return m
+getFront (q,f,b,s,m) = readSTRef f
+setFront (q,f,b,s,m) v = writeSTRef f v
+getBack (q,f,b,s,m) = readSTRef b
+setBack (q,f,b,s,m) v = writeSTRef b v
+getQVal (q,f,b,s,m) n = readSTArray q n
+setQVal (q,f,b,s,m) n e = writeSTArray q n e
+
--- /dev/null
+module Arithmetic
+ (
+ alu
+ ,Immediate
+ ,Sign(..)
+ ,Comparison(..)
+ ,AluOp(..)
+ ,ImmediateSize(..)
+ ) where
+
+import Words
+import Word
+
+-- Begin Signature: Arithmetic ----------------------------------------------
+{-
+
+The Arithmetic module defines the datatype "AluOp" to represent the
+various sorts of operations you might pass to an ALU like circuit.
+The "Instruction" class defines its methods to use AluOp as the
+least-common denomiator (no pun intended) of arithmetic-based instructions.
+
+-}
+
+type Immediate = Int
+
+data Sign = Signed
+ | Unsigned
+ deriving (Eq,Show, Read)
+
+data Comparison = LessThan
+ | LessEqual
+ | GreaterThan
+ | GreaterEqual
+ | Equal
+ | NotEqual
+ deriving (Eq,Show, Read)
+
+data AluOp = Add Sign |
+ Sub Sign |
+ Mult Sign |
+ Div Sign |
+ And |
+ Not |
+ Or | Xor |
+ Sll | Srl | Sra |
+ S Comparison |
+ SetHi | -- Set high 16 bits of value.
+ Input1 | -- pass input1 through
+ Input2 | -- pass input2 through
+ Invalidate -- Invalidate the result of the
+ -- ALU operation
+ deriving (Eq,Show, Read)
+
+
+data ImmediateSize = Imm16Bits | Imm26Bits
+
+alu :: Word w => AluOp -> w -> w -> Maybe w
+
+-- End Signature: Arithmetic ------------------------------------------------
+
+-- If the ALUfunc is "Invalidate", this function returns Nothing,
+-- otherwise it performs the assiciated ALU operation.
+alu Invalidate _ _
+ = Nothing
+alu aluFunc word1 word2
+ = Just (exec_op aluFunc word1 word2)
+
+
+-- signExtend is only used inside combinational circuits.
+signExtend :: Word w => ImmediateSize -> Immediate -> w
+signExtend Imm16Bits = fromInt
+signExtend Imm26Bits = fromInt
+
+
+------------------------ Integer ALU unit ---------------------------
+
+
+-- Performs integer addition and also returns whether overflow ocurred
+addOverflowCheck :: Word w => w -> w -> (w,Bool)
+addOverflowCheck a b
+ = (out,overflow)
+ where
+ out = a + b
+ overflow = out > maxBound || out < minBound
+
+overflowErr :: Word w => AluOp -> w -> w -> a
+overflowErr op a b
+ = error ("alu (" ++ show op ++ ") " ++ show a ++ " "
+ ++ show b ++ " <-- overflow")
+
+{-
+ NOTE: I'm not worrying about whether overflow
+ calculations are computed correctly, except
+ for signed addition and subtraction. In the
+ other cases, I'm letting the bits fall where
+ they may. Hopefully none of the benchmarks
+ cause overflows at all.
+-}
+
+
+-- This function performs the unsigned version of the normal signed
+-- integer operation
+unsignedWordOp :: Word w => (w->w->w) -> (w->w->w)
+unsignedWordOp f a b = sign $ unsign a `f` unsign b
+
+
+-- These functions convert between a Word and a vector of Bools.
+
+bitValues :: Word w => [w]
+bitValues = map (2 ^) [31,30..0]
+
+buildVec :: Word w => w -> [Bool]
+buildVec n
+ = makeVec (unsign n) bitValues
+ where
+ makeVec :: Word w => w -> [w] -> [Bool]
+ makeVec 0 [] = []
+ makeVec _ [] = [] ---- should we catch this?
+ makeVec n (b:bs)
+ = if n >= b
+ then True : makeVec (n-b) bs
+ else False : makeVec n bs
+
+buildWord :: Word w => [Bool] -> w
+buildWord bools
+ = sign $ makeInteger bools bitValues
+ where
+ makeInteger [] []
+ = 0
+ makeInteger n []
+ = error ("buildWord -- argument too large: " ++ show bools)
+ makeInteger (b:bs) (n:ns)
+ = if b
+ then n + makeInteger bs ns
+ else makeInteger bs ns
+
+-- Performs an element-wise boolean operation on corresponding
+-- pairs of bits of the argument integers
+bitOp :: Word w => (Bool->Bool->Bool) -> (w->w->w)
+bitOp f a b
+ = buildWord $ zipWith f (buildVec a) (buildVec b)
+
+
+
+-- This function assumes the ALUfunc argument is not "Invalidate"
+exec_op :: Word w => AluOp -> w -> w -> w
+
+exec_op op@(Add Signed) a b
+ = if overflow
+ then overflowErr op a b
+ else out
+ where
+ (out,overflow) = addOverflowCheck a b
+
+exec_op (Add Unsigned) a b
+ = unsignedWordOp (+) a b
+
+exec_op op@(Sub Signed) a b
+ = if overflow
+ then overflowErr op a b
+ else out
+ where
+ (out,overflow) = addOverflowCheck a (-b)
+
+exec_op (Sub Unsigned) a b
+ = unsignedWordOp (-) a b
+
+exec_op (Mult Signed) a b
+ = sign $ a * b
+
+exec_op (Mult Unsigned) a b
+ = unsignedWordOp (*) a b
+
+exec_op (Div Signed) a b
+ = sign $ a `div` b
+
+exec_op (Div Unsigned) a b
+ = unsignedWordOp div a b
+
+exec_op And a b = bitOp (&&) a b
+
+exec_op Or a b = bitOp (||) a b
+
+-- eh, this is kinda temporary.
+--exec_op Not a b = bitOp (\x y -> not x) a b
+exec_op Not a b = if a == 0 then 1 else 0
+
+exec_op Xor a b = bitOp xor a b
+ where
+ xor False x = x
+ xor True x = not x
+
+exec_op Sll a b
+ = buildWord $ drop shiftAmt (buildVec a) ++ replicate shiftAmt False
+ where
+ shiftAmt = toInt $ unsign b `mod` 32
+
+exec_op Srl a b
+ = buildWord $ replicate shiftAmt False ++ take (32 - shiftAmt) (buildVec a)
+ where
+ shiftAmt = toInt $ unsign b `mod` 32
+
+exec_op Sra a b
+ = buildWord $ replicate shiftAmt signBit ++ take (32 - shiftAmt) (buildVec a)
+ where
+ shiftAmt = toInt $ unsign b `mod` 32
+ signBit = (a < 0)
+
+exec_op (S relop) a b
+ = if (a `relation` b) then 1 else 0
+ where
+ relation = case relop of
+ LessThan -> (<)
+ LessEqual -> (<=)
+ GreaterThan -> (>)
+ GreaterEqual -> (>=)
+ Equal -> (==)
+ NotEqual -> (/=)
+
+exec_op SetHi a _
+ = a * num_half -- a * 2^n
+
+exec_op Input1 a b
+ = a
+
+exec_op Input2 a b
+ = b
+
+
--- /dev/null
+module BoundedSet
+ ( new
+ , readBound
+ , readSize
+ , read
+ , clear
+ , insert
+ , spaceAvail
+ , rmSuch
+ , rmSuchN
+ , BoundedSet
+ , iterateSet
+ ) where
+
+import LazyST
+import Prelude hiding (read)
+import List
+
+
+new :: Int -> ST s (BoundedSet s a)
+readBound :: BoundedSet s a -> ST s Int
+readSize :: BoundedSet s a -> ST s Int
+read :: BoundedSet s a -> ST s [a]
+clear :: BoundedSet s a -> ST s [a]
+insert :: BoundedSet s a -> [a] -> ST s ()
+spaceAvail :: BoundedSet s a -> ST s Int
+rmSuch :: BoundedSet s a -> (a -> Bool) -> ST s [a]
+rmSuchN :: BoundedSet s a -> Int -> (a -> Bool) -> ST s [a]
+iterateSet :: BoundedSet s a -> (a -> a) -> ST s ()
+
+
+-- Implementation ----------------------------------------------------
+type BoundedSet s a = (STRef s [a],Int)
+
+
+iterateSet s f =
+ do { set <- read s
+ ; write s (map f set)
+ }
+
+read (s,n) = readSTRef s
+
+rmSuch s f
+ = do { set <- read s
+ ; let (yes,no) = partition f set
+ ; write s no
+ ; return yes
+ }
+
+rmSuchN s n f
+ = do { such <- rmSuch s f
+ ; let (big,small) = splitAt n such
+ ; insert s small
+ ; return big
+ }
+
+write :: BoundedSet s a -> [a] -> ST s ()
+write (s,n) x = writeSTRef s x
+
+
+readBound (s,n) = return n
+
+new n
+ = do { set <- newSTRef []
+ ; return (set,n)
+ }
+
+clear s =
+ do { set <- read s
+ ; write s []
+ ; return set
+ }
+
+readSize s =
+ do { set <- read s
+ ; return ( length set)
+ }
+
+spaceAvail s
+ = do { bnd <- readBound s
+ ; sz <- readSize s
+ ; return (bnd - sz)
+ }
+
+
+insert s l
+ = do { set <- read s
+ ; n <- readBound s
+ ; write s $ take n (set ++ l)
+ }
+
+
+
--- /dev/null
+module Cell where
+
+import Register
+import Words
+
+-- Begin Signature: Cell ----------------------------------------------
+{-
+
+Cells are intended to be used to represent the source and destination
+operands in machine instructions. Consider, for example:
+
+ r1=? <- r20=15 + 8
+
+Here the first cell (r1=?) is a register reference, and its value is
+not known yet. The source cell r20=15 is a register reference with
+its value calculated. 8 is the other source operand --- in this
+case a constant. The Cell class hopes to capture this notion, while
+allowing you freedom to define richer Cell-like structures.
+
+The Cell's interface supports register references, constants,
+PCs, speculative PCs and predicates.
+
+See the DLX_Cell module for a concrete instance
+
+Currently several of the Cell methods overlap with each other ----
+Eventually we will slim the methods to the minimum set.
+-}
+
+
+class Cell c where
+
+ -- return a PC register reference with no value
+ pcNothing :: (Register r,Word w) => c r w
+
+ -- return the value within the cell (undefined if no value exists)
+ getVal :: (Register r,Word w) => c r w -> w
+
+ -- update the value within the cell
+ putVal :: (Register r,Word w) => c r w -> Maybe w -> c r w
+
+ -- place the cell in an invalid state
+ invalidate :: (Register r,Word w) => c r w -> c r w
+
+ -- is the cell a register reference?
+ isReg :: (Register r,Word w) => c r w -> Bool
+
+ -- is the cell a PC register reference?
+ isPC :: (Register r,Word w) => c r w -> Bool
+
+ -- is the cell a speculative PC register reference?
+ isSpecPC :: (Register r,Word w) => c r w -> Bool
+
+ -- is the cell indicates a location in memory?
+ isLoc :: (Register r,Word w) => c r w -> Bool
+
+ -- is the cell a constant value?
+ isVal :: (Register r,Word w) => c r w -> Bool
+
+ -- is the cell in an invalide state?
+ isInv :: (Register r,Word w) => c r w -> Bool
+
+ -- is the value of the cell is known?
+ -- isVal (r2=6) = True
+ -- isVal (r2=?) = False
+ isAss :: (Register r,Word w) => c r w -> Bool
+
+ -- is the cell a predicate register reference?
+ isPred :: (Register r,Word w) => c r w -> Bool
+
+ -- has the value been calculated? (ie. isAss || isInv)
+ isComputed :: (Register r,Word w) => c r w -> Bool
+
+ -- are the two cells both refering to the same register?
+ sameLoc :: (Register r,Word w) => c r w -> c r w -> Bool
+
+ -- true if sameLoc is true and neither cell is invalid
+ cellHazard :: (Register r,Word w) => c r w -> c r w -> Bool
+
+ -- get the register reference
+ getReg :: (Register r,Word w) => c r w -> r
+
+ -- construct a cell with a memory reference
+ loc :: Word w => w -> c r w
+
+ isPred x = False
+
+-- End Signature: Cell ----------------------------------------------
+
+
+
+
--- /dev/null
+module DLX
+ (
+ Instr(..)
+ ,BranchFunc(..)
+ ,ImmOpcode(..)
+ ,RegOpcode(..)
+ ,JmpOpcode(..)
+ ,DLXReg(..)
+ ,SrcReg
+ ,DstReg
+ ,DLX_Trans
+ ,DLXCell
+ ,DLX_Word
+ ,DLX_Instr
+ ,DLX_InstrMem
+ ,dlx2trans
+ ,VDLXTrans
+ ,VReg
+ ,VTrans
+ ,module DLX_Cell
+ ,module DLX_Reg
+ ,module DLX_Op
+ ) where
+
+
+import Ix
+import Hawk
+import Word
+import Trans
+import DLX_Cell
+import DLX_Reg
+import DLX_Op
+
+type DLX_Word = Word32
+type VDLXTrans = VTrans DLXReg DLX_Word
+type VReg a = Virtual a Int
+type VTrans r w = Trans DLX_Op (VReg r)
+
+fillIn x= fillInCells x
+
+
+data Instr reg i
+ = ImmIns ImmOpcode reg reg i |
+ RegReg RegOpcode AluOp reg reg reg |
+ Jmp JmpOpcode Int |
+ Nop
+ deriving (Eq,Show, Read)
+
+
+data BranchFunc = Never | Always | IfEqZero | IfNeqZero
+ deriving (Eq,Show, Read)
+
+data ImmOpcode = LoadStoreImm LoadStoreOp |
+ ALUImm AluOp |
+ BEQZ | BNEZ |
+ JR |
+ JALR
+ deriving (Eq,Show, Read)
+
+data RegOpcode = MOVI2S | MOVS2I |
+ ALU
+ deriving (Eq,Show, Read)
+
+data JmpOpcode = J |
+ JAL |
+ TRAP |
+ RFE
+ deriving (Eq,Show, Read)
+
+
+
+instance Register DLXReg where
+ readOnly R0 = True
+ readOnly Dummy = True
+ readOnly _ = False
+ pc = PC
+ specpc = SpecPC
+-- specpc = PC
+-- bug fix? Thu Nov 19 18:12:24 PST 1998
+ ispc x = PC == x
+ isspecpc x = SpecPC == x
+
+type DLXCell a = DLX_Cell DLXReg a
+type DLX_Trans a = Trans DLX_Op (DLXCell a)
+type DLX_Instr a = Instr DLXReg a
+
+type DLX_InstrMem a = InstrMemoryState DLX_Word (DLX_Instr a)
+
+
+type SrcReg = DLXReg -- Source register
+type DstReg = DLXReg -- Destination register
+
+
+
+regNothing R0 = Reg R0 (Val 0)
+regNothing reg = Reg reg NotKnown
+
+dlx2trans :: Word2 i a => Instr DLXReg i -> DLX_Trans a
+
+dlx2trans (ImmIns (LoadStoreImm loadOp@(Load _ _ )) dest src offset)
+ = Trans [regNothing dest] (MemOp loadOp)
+ [regNothing src,Imm (toWord offset)] []
+ -- [regNothing src,Imm (toWord offset),regNothing Dummy] []
+
+{-
+dlx2trans (ImmIns (LoadStoreImm storeOp@(Store _ )) writeAddr writeReg offset)
+ = Trans [regNothing Dummy] (MemOp storeOp) [regNothing writeAddr,
+ Imm (toWord offset),
+ regNothing writeReg] []
+
+dlx2trans (ImmIns (ALUImm SetHi) dest _ imm)
+ = Trans [destCell] (ExecOp SetHi) [Imm (toWord imm)] []
+ where
+ destCell = regNothing dest
+
+dlx2trans (ImmIns (ALUImm aluFunc) dest src imm)
+ = Trans [destCell] (ExecOp aluFunc) [srcCell,Imm (toWord imm)] []
+ where
+ destCell = regNothing dest
+ srcCell = regNothing src
+
+dlx2trans (ImmIns BEQZ _ src pcOffset)
+ = Trans [pcNothing'] (CondExecOp (Add Signed) Input1) [regNothing src,
+ pcNothing',
+ Imm (toWord pcOffset)]
+ []
+
+dlx2trans (ImmIns BNEZ _ src pcOffset)
+ = Trans [pcNothing'] (CondExecOp Input1 (Add Signed)) [regNothing src,
+ pcNothing',
+ Imm (toWord pcOffset)]
+ []
+
+dlx2trans (ImmIns JR _ src _ )
+ = Trans [pcNothing'] (ExecOp Input1) [regNothing src] []
+
+
+dlx2trans (RegReg ALU aluFunc dest src1 src2)
+ = Trans [regNothing dest] (ExecOp aluFunc) [regNothing src1, regNothing src2] []
+
+dlx2trans (RegReg unknownOp _ _ _ _ )
+ = error ("Can't translate " ++ show unknownOp)
+
+dlx2trans (Jmp J offset)
+ = Trans [pcNothing'] (ExecOp (Add Signed)) [pcNothing', Imm (toWord offset)] []
+
+dlx2trans (ImmIns JALR _ src _ )
+ = Trans [pcNothing',regNothing R31]
+ (ParExecOp Input1 Input2)
+ [regNothing src, pcNothing'] []
+
+dlx2trans (Jmp JAL offset)
+ = Trans [pcNothing',regNothing R31]
+ (ParExecOp (Add Signed) Input2)
+ [Imm (toWord offset),pcNothing']
+ []
+
+
+dlx2trans (Jmp TRAP offset )
+ = Trans [pcNothing',regNothing IAR]
+ (ParExecOp Input1 Input2)
+ [Imm (toWord offset),pcNothing']
+ []
+
+
+dlx2trans (Jmp RFE _ )
+ = Trans [pcNothing'] (ExecOp Input1) [regNothing IAR] []
+
+dlx2trans Nop
+-- = Trans [Reg Dummy (Val 0)] (NoOp "dlx2trans") [] []
+ = Trans [] (NoOp "dlx2trans") [] []
+
+-}
+
+pcNothing' = Reg PC NotKnown
+
+
+instance Show a => Probe (DLXCell a)
+instance Probe DLXReg
+
+instance Probe DLX_Op where
+ outp (ExecOp (Add _ )) = "+"
+ outp (ExecOp (Sub _ )) = "-"
+ outp (ExecOp (Div _ )) = "/"
+ outp (ExecOp (Mult _ )) = "*"
+ outp (ExecOp op) = show op
+ outp (MemOp (Load _ _)) = "Load"
+ outp (MemOp (Store _)) = "Store"
+ outp (ParExecOp op1 op2) = "PAR("++outp op1++","++outp op2 ++ ")"
+ outp x = show x
+
+
+instance Show a => Probe (DLX_Trans a) where
+ outp (Trans [] op [] i) = outp op ++ outInfo i
+ outp (Trans [x] (CondExecOp op1 op2) [c,y,z] i)
+ = outp x ++ " <- " ++ "(if0 " ++ outp c ++ " ("
+ ++ outp op1 ++ "," ++ outp op2 ++ ")) "
+ ++ outp y ++ " " ++ outp z
+ ++ outInfo i
+ outp (Trans dummy (MemOp (Store x)) [c,y,z] i)
+ = outp (MemOp (Store x)) ++" "++ outp c ++"("++ outp y ++") <- "
+ ++ outp z ++ outInfo i
+ outp (Trans [o] op [x,y] i)
+ = outp o ++ " <- " ++ outp x ++ " " ++ outp op ++ " " ++ outp y
+ ++ outInfo i
+ outp (Trans [] op l i) = outp op ++" "++ outList l ++ outInfo i
+ outp (Trans [o] op l i)
+ = outp o ++ " <- " ++ outp op ++" "++ outList l ++ outInfo i
+ outp (Trans l1 op l2 i)
+ = outList l1 ++" <- "++ outp op ++" "++ outList l2 ++ outInfo i
+
+outInfo [] = ""
+outInfo l = " {" ++ foldr1 (\x y -> x ++ "," ++ y) (map outp l) ++ "}"
+
+outList [] = ""
+outList [x] = outp x
+outList l = "[" ++ foldr1 (\x y -> x ++ "," ++ y) (map outp l) ++ "]"
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+module DLX_Cell where
+
+import Cell
+import Register
+import Words
+
+data Value a = NotKnown
+ | Inv
+ | Val a
+ deriving (Eq,Show)
+
+data DLX_Cell r w = Reg r (Value w)
+ | Loc w
+ | Imm w
+ deriving (Eq,Show)
+
+instance Cell DLX_Cell where
+ pcNothing = Reg pc NotKnown
+ loc = Loc
+
+ getReg (Reg r _) = r
+
+ getVal (Reg _ (Val val)) = val
+ getVal (Imm val) = val
+ getVal cell = error ("No data for getData: " ++
+ show cell)
+
+ putVal cell Nothing = invalidate cell
+ putVal reg@(Reg r x) (Just v)
+ | readOnly r = reg
+ | otherwise = Reg r (Val v)
+
+ putVal valCell@(Imm _ ) _
+ = error ("Can't put data into a value cell: " ++ show valCell)
+
+
+ invalidate reg@(Reg r _ )
+ | readOnly r = reg
+ | otherwise = Reg r Inv
+ invalidate imm@(Imm _ ) = imm
+
+
+ isReg (Reg _ _ ) = True
+ isReg _ = False
+
+ isPC (Reg x _) = ispc x
+ isPC _ = False
+
+ isSpecPC (Reg x _)= isspecpc x
+ isSpecPC _ = False
+
+ isLoc (Loc _) = True
+ isLoc _ = False
+
+ isVal (Imm _ ) = True
+ isVal _ = False
+
+ isInv (Reg _ Inv) = True
+ isInv _ = False
+
+ isAss (Reg _ (Val _ )) = True
+ isAss (Imm _ ) = True
+ isAss _ = False
+
+ isComputed (Reg _ NotKnown) = False
+ isComputed _ = True
+
+
+-- Do the two cells name the same Loc (Reg or PC?)
+ sameLoc (Reg reg1 _ ) (Reg reg2 _ ) = reg1 == reg2
+ sameLoc _ _ = False
+
+
+ cellHazard (Reg precReg pRegVal ) (Reg followReg fRegVal )
+ | readOnly precReg = False
+ | precReg == followReg = pRegVal /= Inv && fRegVal /= Inv
+ | True = False
+ cellHazard _ _ = False
+
+
+
+
+
+
+
+
--- /dev/null
+module DLX_Op (DLX_Op(..)) where
+
+import Arithmetic
+import Memory
+import Instruction
+import Probe
+
+data DLX_Op = ExecOp AluOp |
+ CondExecOp AluOp AluOp | -- If first source == zero, then the
+ -- first AluOp is performed on rest
+ -- of source arguments, otherwise the
+ -- second AluOp is performed on them.
+ ParExecOp AluOp AluOp | -- The first destination cell is the
+ -- result of the first AluOp; the
+ -- second destination cell is the
+ -- result of the second AluOp.
+ MemOp LoadStoreOp |
+ NoOp String -- Null operation. The string argument
+ -- can be used as a comment indicating
+ -- which phase generated a stall.
+ deriving (Eq,Show)
+
+-- Begin Signature ---------------------------------------------------------
+-- End Signature ---------------------------------------------------------
+
+instance Instruction DLX_Op where
+ isNoOp t = case t of
+ NoOp _ -> True
+ _ -> False
+
+ isAddOp t = case t of
+ ExecOp (Add _) -> True
+ _ -> False
+
+ isSubOp t = case t of
+ ExecOp (Sub _) -> True
+ _ -> False
+
+ isMultOp t = case t of
+ ExecOp (Mult _) -> True
+ _ -> False
+
+ isDivOp t = case t of
+ ExecOp (Div _) -> True
+ _ -> False
+
+ isJumpOp t = case t of
+ CondExecOp _ _ -> True
+ _ -> False
+
+ isMemOp t = case t of
+ MemOp _ -> True
+ _ -> False
+
+ isLoadOp t = case t of
+ MemOp (Load _ _) -> True
+ _ -> False
+
+ isStoreOp t = case t of
+ MemOp (Store _) -> True
+ _ -> False
+
+ noOp = NoOp ""
+ isAluOp t = case t of
+ ExecOp _ -> True
+ _ -> False
+
+ isCmpOp t = case t of
+ ExecOp (S _) -> True
+ _ -> False
+
+ isBoolOp t = case t of
+ ExecOp Xor -> True
+ ExecOp Or -> True
+ ExecOp And -> True
+ ExecOp Not -> True
+ _ -> False
+
+ isMoveOp t = case t of
+ ExecOp Input1 -> True
+ _ -> False
+
+ aluOp (ExecOp f) = f
+
+ isCond = isJumpOp
+
+ isPar (ParExecOp _ _) = True
+ isPar _ = False
+
+ fstOp (ParExecOp f _) = f
+ fstOp (CondExecOp f _) = f
+
+ sndOp (ParExecOp f g) = g
+ sndOp (CondExecOp f g) = g
+
+ memOp (MemOp f) = f
+
+
+
--- /dev/null
+module DLX_Reg where
+
+import Ix
+
+
+data DLXReg = R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7 |
+ R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15 |
+ R16 | R17 | R18 | R19 | R20 | R21 | R22 | R23 |
+ R24 | R25 | R26 | R27 | R28 | R29 | R30 | R31 |
+ F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 |
+ F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 |
+ F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23 |
+ F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 |
+ IAR | PC | SpecPC | Dummy
+ deriving (Ix,Eq,Ord,Bounded,Show,Read,Enum)
--- /dev/null
+module Devices where
+
+import List
+import TransSig
+import qualified Trans as T
+import qualified PreludeSig as Signaled
+import Signal
+import Words
+import Register
+import Arithmetic
+import Cell
+import Memory
+import Utilities
+
+import LazyST
+import Instruction
+
+import Array
+import StateArray
+import Ix
+
+
+
+-- Begin Signature -------------------------------------------------------
+{-
+ Devices defines common circuits (for example ,instruction
+ and data memory or alus)
+-}
+
+
+-- flush k x b s , when b then return x for k cycles, otherwise s
+-- flush 2 10 <False,False,True,False,False,False,False .. > <1 .. 7 .. >
+-- = <1,2,10,10,5,6,7 .. >
+flush :: Int -> a -> Signal Bool -> Signal a -> Signal a
+
+-- latch x b xs. return the value of xs when last b occurred. initialize
+-- with x
+latch :: a -> Signal Bool -> Signal a -> Signal a
+
+
+
+regFile :: Ix i => (i,i) -> -- Register addresses
+ [a] -> -- Initial contents
+ [(Signal Bool, -- Write enables
+ (Signal i,Signal a))] -> -- Write ports
+ [Signal i] -> -- Read ports
+ [Signal a] -- Read port contents
+
+
+dataMemory :: (Word a, Word b) => a -> ArrayDesc a b ->
+ Signal LoadStoreOp -> Signal a -> Signal b -> Signal b
+
+
+-- fetch (k,translate,max,memory) pc width = (instrs,pc')
+-- k = the number of indices between addresses.
+-- translate = the function that creates transaction from
+-- the representation in memory
+-- max = the largest number of instructions to fetch on
+-- a single cycle
+-- memory = the program
+-- pc = the pc to fetch
+-- width = the number of instructions to fetch starting at pc
+fetch :: (Cell c, Register r, Word w, Instruction i) =>
+ (w,f -> Trans i (c r w),Int,ArrayDesc w f) ->
+ Signal (Trans i (c r w)) -> Signal Int ->
+ (Signal [Trans i (c r w)],Signal (Trans i (c r w)))
+
+
+-- trans_alu is alu applied to transactions in the obvious way:
+-- intuitively,
+-- trans_alu(Trans [dst] op [s1,s2]) = Trans [dst=alu(op,s1,s2)] op [s1,s2]
+trans_alu :: (Register r, Cell c, Word w, Instruction i) =>
+ (Trans i (c r w)) -> (Trans i (c r w))
+
+--- exec is trans_alu lifted on signals
+exec :: (Register r, Cell c, Word w, Instruction i) =>
+ Signal (Trans i (c r w)) -> Signal (Trans i (c r w))
+
+
+-- mem serves loads and stores
+mem :: (Instruction i, Cell c, Register r,Word w) =>
+ w -> ArrayDesc w w ->
+ Signal (Trans i (c r w)) -> Signal (Trans i (c r w))
+
+ss_mem :: (Instruction i, Cell c, Register r, Word w) =>
+ w -> ArrayDesc w w ->
+ Signal [Trans i (c r w)] -> Signal [Trans i (c r w)]
+
+
+
+-- End Signature -------------------------------------------------------
+
+ss_mem k m = superscalar (mem k m)
+
+
+--- WHOA! this code is a black-hole. Read only if you must!
+--- This could use some serious house-cleaning.
+
+-- "fetch n mem pc size" fetches (min n size) consec. instructions
+-- following "pc"
+fetch (k,f,lim,memory@(range,_)) pc n
+ = (id,last') >< instrsFetch k f memory pcs
+ where
+ size = Signaled.min n (lift0 lim)
+ last' s = if' (Signaled.length s *< 1) then' pc
+ else' (Signaled.last s)
+ pcs = lift2 (buildPCs k range) pc n
+
+ buildPCs :: (Word w, Cell c, Register r, Instruction i) =>
+ w -> (w,w) -> Trans i (c r w) -> Int -> [Trans i (c r w)]
+ buildPCs k range pctrans n
+ = do p <- map getReg $ T.getDstPC pctrans
+ pc <- map getVal $ T.getDstPC pctrans
+ let pcs = filter (inRange range) $ take n [pc,pc+k .. ]
+ return $ map (mkPC range) pcs
+ `catchEx` []
+ mkPC range x = if inRange range x then T.pcTrans x
+ else T.nop
+
+instrFetch n convert m input = (head' x, head' y)
+ where
+ fetch = instrsFetch n convert m
+ (x,y) = fetch (toList input)
+ toList = lift1 $ \x -> [x]
+ head' = lift1 head
+
+
+instrsFetch n convert initContents pcs
+ = (insertPCs curPC $ instructions `bypassList` nextPCTrans, nextPCTrans)
+ where
+ bypassList = lift2 $ \x y -> zipWith T.bypass x y
+ instructions = lift1 (map convert) $ instrMemory n initContents curPC
+ curPC = lift1 (map getpc) pcs
+ nextPCTrans = lift1 (map (\x -> T.pcTrans $ x+n)) curPC
+ getpc t =
+ do reg <- T.getDstPC t
+ let p = getReg reg
+ let x = getVal reg
+ guard $ ispc p
+ return x
+ `catchEx` (error "ugh" ) --$ "getpc " ++ show t)
+ insertPCs pcs l = lift2 addPCs pcs l
+ addPCs x y = zipWith addPC x y
+ addPC pc (Trans d o s l) = Trans d o s (loc pc:l)
+
+
+exec trans = lift1 trans_alu trans
+
+trans_alu trans@(Trans (dest:_) op (src:_) _)
+ | isAluOp op && aluOp op == Input1 =
+ trans `T.evalTrans` (dest,(alu Input1 (getVal src) undefined))
+trans_alu trans@(Trans (dest:_) op (src:_) _)
+ | isAluOp op && aluOp op == SetHi =
+ trans `T.evalTrans` (dest,(alu SetHi (getVal src) undefined))
+trans_alu trans@(Trans [dest] op (src1:src2:_) _)
+ | isAluOp op =
+ trans `T.evalTrans` (dest,(alu (aluOp op) (getVal src1) (getVal src2)))
+trans_alu t@(Trans (d1:d2:_) op (s1:s2:_) _)
+ | isAluOp op =
+ let t' = t `T.evalTrans` (d1,(alu (aluOp op) (getVal s1) (getVal s2)))
+ Trans (d1':_) _ _ _ = t'
+ in t' `T.evalTrans` (d2,(alu Not (getVal d1') (getVal d1')))
+trans_alu trans@(Trans (dest:_) op (cond:src1:src2:_) _) | isCond op =
+ let eqZeroFunc = fstOp op
+ neqZeroFunc = sndOp op
+ in trans `T.evalTrans` (dest,alu
+ (if (getVal cond) == 0 then eqZeroFunc else neqZeroFunc)
+ (getVal src1)
+ (getVal src2))
+trans_alu trans@(Trans (dest1:dest2:_)
+ op
+ (src1:src2:_) _) | isPar op
+ = (trans `T.evalTrans` (dest1,alu aluFunc1 src1Data src2Data))
+ `T.evalTrans` (dest2,alu aluFunc2 src1Data src2Data)
+ where
+ aluFunc1 = fstOp op
+ aluFunc2 = sndOp op
+ src1Data = getVal src1
+ src2Data = getVal src2
+trans_alu trans@(Trans _ o _ _ )
+ | isMemOp o = trans
+ | isNoOp o = trans
+-- | otherwise = error ("Unexecutable transaction: ")
+ | otherwise = trans
+
+
+------------ Memory stage ------------
+
+
+mem k initContents trans
+ = if' loadInstr
+ then' (trans `evalTrans` (bundle2 (loadReg,lift1 Just
+ (dataMemory k initContents loadStoreOp address contents))))
+ else' trans
+ where
+ (loadInstr,loadReg,loadStoreOp,address,contents)
+ = unbundle5 $ lift1 dataMemOps trans
+dataMemOps (Trans (dest:_) op (address:offset:_) _) | isLoadOp op
+ = (True,dest,loadOp,getVal address + getVal offset,0)
+ where loadOp = memOp op
+dataMemOps(Trans _ op (address:offset:val:_) _) | isStoreOp op
+ = (False,
+ undefined, -- pcNothing
+ storeOp,
+ getVal address + getVal offset,
+ getVal val)
+ where storeOp = memOp op
+dataMemOps _
+ = (False,
+ undefined, -- pcNothing,
+ NOP,
+ 0,
+ 0)
+
+
+
+
+
+flush n d s1 s2 = runST (
+ do { n' <- newSTRef 0
+ ; loop (bundle2 (s1,s2)) (\(s1,s2) ->
+ do { if s1 then writeSTRef n' n else return ()
+ ; n <- readSTRef n'
+ ; if n>0 then do {writeSTRef n' (n-1)
+ ; return d
+ }
+ else return s2
+ })
+ }
+ )
+
+
+
+--------------- Latches ----------------
+-- latch stores a value, until it is reset to a new value by
+-- the boolean signal. "init" is the value stored in latch
+-- at time zero.
+latch init reset resetVal = out
+ where
+ out = (if' reset then' resetVal else' last)
+ last = delay init out
+
+
+--------------- Buses ------------------
+
+--busReg :: Int -> [a] -> [Signal a] -> [Signal a]
+--busReg n inits xs = zipInt n delay inits xs
+-- where
+-- zipInt 0 f xs ys = []
+-- zipInt n f ~(x:xs) ~(y:ys) = f x y : zipInt (n-1) f xs ys
+
+
+------------------ Register Files ----------------
+
+-- A bank of registers. The bank
+-- contains multiple read- and write-ports. Note that
+-- the contents of a write port are reflected in the
+-- associated read port in the same clock cycle.
+regFile bounds initContents writePorts readPorts
+ = map (lift2 (!) registers) readPorts
+ where
+ registers = updateArray lastRegisters writePorts
+ lastRegisters = delay (listArray bounds initContents) registers
+
+
+
+-- Bank of registers, where each register holds a pair of values.
+{-
+pairRegFile :: Ix i => (i,i) -> -- Register addresses
+ [(a,b)] -> -- Initial contents
+ [(Signal Bool, -- Write enables
+ (Signal i,Signal a,Signal b))] -> -- Write ports
+ [Signal i] -> -- Read ports
+ [(Signal a,Signal b)] -- Read port contents
+
+pairRegFile bounds initVals writePorts readPorts
+ = map unbundle2 (regFile bounds initVals zipWritePorts readPorts)
+ where
+ zipWritePorts = map (\(writeEnable,(writeAddress,writeA,writeB)) ->
+ (writeEnable,(writeAddress, bundle2 (writeA,writeB))))
+ writePorts
+
+--type WriteBackData s reg w = (s w -- writeback contents
+-- ,s reg -- writeback register name
+-- )
+
+
+-}
+
+
+-- I THINK THAT THIS ONE SHOULD GO...
+registers src1 src2 p
+ = unbundle2 $ map getContents arrResps
+ where
+ (writebackContents,writebackReg) = unbundle2 p
+ arrResps = stateArray ((minBound,maxBound),[(minBound,maxBound,0)])
+ (lift4 arrReqs src1 src2 writebackContents writebackReg)
+
+ getContents [ReadVal src1, ReadVal src2]
+ = (src1,src2)
+ getContents [Written, ReadVal src1, ReadVal src2]
+ = (src1,src2)
+ getContents [Written,Written, ReadVal src1, ReadVal src2]
+ = (src1,src2)
+
+ arrReqs src1 src2 wbContents wbReg
+ = wb ++
+ [ ReadArr src1,
+ ReadArr src2]
+ where wb = map (\(x,y) -> WriteArr x x y) (zip wbReg wbContents)
+
+
+
+instrMemory sz arrDesc pcAddresses = lift1 (map getInstr) arrResp
+ where
+ getInstr (ReadVal instr) = instr
+ arrResp = let y = lift1 ( map (\addr -> ReadArr (addr `div` sz))) pcAddresses
+ in stateArray arrDesc y
+
+
+
+-----------------------------------------------------------------------------
+dataMemory sz arrDesc loadStoreCmd addr writeVal
+ = liftFn getLMD $ stateArray arrDesc arrReqs
+ where
+ {- Halfword and byte stores are implemented by loading the relevent
+ word from memory, modifying the correct portion of the word, and
+ then storing the revised word back to memory, all within one
+ clock cycle
+ -}
+
+ liftFn = lift2 ($)
+
+ (arrReqs,getLMD) = unbundle2 $ lift3 interpCmd loadStoreCmd addr writeVal
+
+-- interpCmd :: Word w => LoadStoreOp -> w -> w ->
+-- ([ArrReq w w],[ArrResp w w] -> w)
+
+ interpCmd (Load FullWord _ ) addr _
+ = ([ReadArr (addr `div` sz)],
+ (\[ReadVal val] -> val))
+
+ interpCmd (Load HalfWord signedness) addr _
+ = ([ReadArr wordAddr],
+ (\[ReadVal val] -> subfield signedness
+ (4 * sz) ((4 * sz) - (2 * sz) * wordMod) val)
+ )
+ where
+ (wordAddr,wordMod) = addr `divMod` sz
+
+ interpCmd (Load Byte signedness) addr _
+ = ([ReadArr wordAddr],
+ (\[ReadVal val] -> subfield signedness
+ (2 * sz) ((6 * sz) - (2 * sz) * wordMod) val)
+ )
+ where
+ (wordAddr,wordMod) = addr `divMod` sz
+
+ interpCmd (Store FullWord) addr val
+ = ([WriteArr wordAddr wordAddr val],
+ (\[Written] -> val))
+ where
+ wordAddr = addr `div` sz
+
+ interpCmd (Store HalfWord) addr val
+ = ([WriteFn wordAddr modifyHalfword],
+ (\[WrittenFn val] -> val))
+ where
+ (wordAddr,wordMod) = addr `divMod` sz
+ modifyHalfword wordContents
+ = setSubfield (4 * sz)
+ ((4 * sz) - (2 * sz) * wordMod)
+ wordContents
+ (wordContents `mod` num_half)
+
+ interpCmd (Store Byte) addr val
+ = ([WriteFn wordAddr modifyByte],
+ (\[WrittenFn val] -> val))
+ where
+ (wordAddr,wordMod) = addr `divMod` 4
+ modifyByte wordContents
+ = setSubfield (2 * sz)
+ ((6 * sz) - (2 * sz) * wordMod)
+ wordContents
+ (wordContents `mod` num_bytes)
+
+ interpCmd NOP _ _
+ = ([],const 0)
+
+
+
+-- treating 'n' as a bitfield, this function extracts a subrange
+-- bitfield specified by 'subfieldLen' and 'subfieldStartPos'.
+-- For subfieldStartPos, 0 indicates the subfield starts at the
+-- least significant bit position of 'n'.
+-- If 'signedness' == Signed, this function performs sign-extension
+-- to the result subfield.
+subfield :: (Integral a, Integral b, Integral c) => Sign -> c -> a -> b -> b
+subfield signed subfieldLen subfieldStartPos n
+ = (n `div` (2^subfieldStartPos)) `modOp` (2^subfieldLen)
+ where
+ modOp = case signed of
+ Signed -> signedModulus
+ Unsigned -> mod
+
+-- This function returns 'n', modified by replacing the subfield
+-- denoted with (subfieldLen,subfieldStartPos), by 's'.
+-- Note that s must satisfy ( 0 <= s <= 2^subfieldLen)
+setSubfield :: (Integral a, Integral b, Integral c) => a -> b -> c -> c -> c
+setSubfield subfieldLen subfieldStartPos n s
+ = n + (2^subfieldLen)*(s - (subfield Unsigned subfieldLen subfieldStartPos n))
+
+
+
--- /dev/null
+-- Execution Units --
+
+module EUs where
+import List
+import qualified PreludeSig as Sig
+import Hawk
+import Trans
+import DLX
+
+type EU i c = Signal Bool -> Signal [(Trans i c)] ->
+ Signal ([Trans i c],[Trans i c])
+
+-- Schedule Combinator ---------------------------------------------------
+schedule :: Register r => [EU i (c r w)] -> EU i (c r w)
+schedule l b = foldl combine end (map ($b) l)
+ where
+ end = lift1 $ \x -> ([],x)
+ combine f g sig = let (ac,rej) = unbundle2 $ f sig
+ (ac',rej') = unbundle2 $ g rej
+ in bundle2 (ac *++ ac',rej')
+
+-- EUs -----------------------------------------------------------
+
+addUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
+addUnit = makeUnit isAdd aluDevice
+
+subUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
+subUnit = makeUnit isSub aluDevice
+
+multUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
+multUnit = makeDelayedUnit 2 isMul aluDevice
+
+divUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
+divUnit = makeDelayedUnit 4 isDiv aluDevice
+
+cmpUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
+cmpUnit = makeUnit isCmp aluDevice
+
+jumpUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
+jumpUnit = makeUnit isJump (map jumpDevice)
+
+moveUnit :: (Cell c,Register r,Word w,Instruction i) => EU i (c r w)
+moveUnit = makeUnit isMove aluDevice
+
+-- Devices -------------------------------------------------------------
+jumpDevice trans@(Trans [dest] op [cond,src1,src2] _) | isJumpOp op =
+ (trans `evalTrans`
+ (dest,alu func val1 val2))
+ where func = if (getVal cond) == 0 then z else nz
+ val1 = getVal src1
+ val2 = getVal src2
+ z = fstOp op
+ nz = sndOp op
+
+aluDevice x
+ = map (\t@(Trans [dest] op [src1,src2] x) ->
+ let aluFunc = aluOp op
+ in (t `evalTrans` (dest,
+ (alu aluFunc (getVal src1) (getVal src2))))
+ ) x
+
+-- Higher-order Constructors ----------------------------------------------
+makeUnit :: Register r => (Trans i (c r w) -> Bool) ->
+ ([Trans i (c r w)] -> [Trans i (c r w)]) ->
+ EU i (c r w)
+makeUnit accept unit kill instrs
+ = lift1 (\(k,x) -> let (acceptable,rejects) = partition accept x
+ (instr,others) = splitAt 1 acceptable
+ in (unit instr,others ++ rejects)) $ bundle2 (kill,instrs)
+
+
+makeDelayedUnit :: Register r => Int -> (Trans i (c r w) -> Bool) ->
+ ([Trans i (c r w)] -> [Trans i (c r w)]) ->
+ EU i (c r w)
+makeDelayedUnit n f g kill sig = bundle2 (flush n [] kill $ delayN n [] x,y)
+ where
+ (x,y) = unbundle2 $ unit kill sig
+ unit = makeUnit f g
+
+delayN n x s = xs `before` s
+ where xs = take n (repeat x)
--- /dev/null
+module Hawk
+ (
+ module Arithmetic
+ ,module Cell
+ ,module Devices
+ ,module HawkIO
+ ,module Memory
+ ,module Register
+ ,module STEx
+ ,module Signal
+ ,module Utilities
+ ,module VRegister
+ ,module Words
+ ,module Instruction
+ ,module Probe
+ ,module PipeReg
+ ,module Init
+ ) where
+
+import Arithmetic
+import Cell
+import Devices
+import HawkIO
+import Memory
+import Register
+import STEx
+import Signal
+import Utilities
+import VRegister
+import Words
+import Instruction
+import Probe
+import PipeReg
+import Init
+
+
+-- This serves as the top-level module, with perhaps some instance
+-- declarations:
+
+instance (Show a, Show b, Show c, Show d, Show e,Show f) =>
+ Show (a,b,c,d,e,f) where
+ showsPrec n (a,b,c,d,e,f) s = ('(' : ) $
+ showsPrec n a $ (',' :) $
+ showsPrec n b $ (',' :) $
+ showsPrec n c $ (',' :) $
+ showsPrec n d $ (',' :) $
+ showsPrec n e $ (',' :) $
+ showsPrec n f $ ')' : s
--- /dev/null
+module HawkIO
+ (
+ hawkMain
+ ) where
+
+import IO
+import Memory
+
+-- Begin Signature ------------------------------------------------------
+{-
+Given a filename, and function from a memory state and a starting point to a
+an output, "hawkMain" will open the file and parse it and apply the
+function to it.
+-}
+
+
+hawkMain :: (Read a,Read w) => String -> ((MemoryState w a,w) -> IO b) -> IO b
+-- End Signature ------------------------------------------------------
+
+
+hawkMain filename f = do {ps <- readInitFile filename; f ps}
+
+
+readInitFile :: (Read a,Read w) => String -> IO (MemoryState w a,w)
+readInitFile infile =
+ do{ h <- openFile infile ReadMode
+ ; s <- hGetContents h
+ ; return (read s)
+ }
--- /dev/null
+module IFU where
+
+
+import LazyST
+import Ix
+
+import Trans
+import Hawk
+import DLX
+
+import qualified PreludeSig as Signaled
+
+import Word
+
+
+
+ifu (a,b) c d = (unique',id) >< fetch (4,dlx2trans,a,b) c d
+
+unique' ts = runST (
+ do { v <- newSTRef 1
+ ; step1(ts) { mapM (\(Trans x y z i) -> do { v' <- readSTRef v
+ ; writeSTRef v (v'+1)
+ ; return $ Trans x y z (loc v':i)
+ }) ts
+ }
+ }
+ )
--- /dev/null
+module Init where
+
+import Signal
+
+-- Begin Signature ------------------------------------------------------
+{-
+
+Very often, particularily when operating over pointed domains, each
+type has a particular value that serves well as an inital state.
+The Init class picks that value out. For example, the "def" value
+for lists is "[]"
+
+-}
+
+class Init a where
+ def :: a
+
+{-instance Init [a]-}
+{-instance Init (Maybe a)-}
+{-instance Init Int-}
+{-instance Init Bool-}
+
+
+-- delay a signal using the type's default value as the initializer
+del :: Init a => Signal a -> Signal a
+
+
+-- End Signature ------------------------------------------------------
+
+instance Init [a] where
+ def = []
+
+instance Init (Maybe a) where
+ def = Nothing
+
+instance Init Int where
+ def = 0
+
+instance Init Bool where
+ def = False
+
+del x = delay def x
--- /dev/null
+module Instruction where
+
+import Arithmetic
+import Memory
+
+-- Begin Signature ------------------------------------------------------
+
+{-
+
+While not knowing the details of a particular instruction set, the
+Instruction class allows code defined in arithmetic and other
+modules to do the right thing for the often-defined instructions.
+
+-}
+
+
+class (Show i, Eq i) => Instruction i where
+
+ -- is a nop instruction?
+ isNoOp :: i -> Bool
+
+ -- is an add instruction?
+ isAddOp :: i -> Bool
+ isSubOp :: i -> Bool
+ isMultOp :: i -> Bool
+ isDivOp :: i -> Bool
+ isJumpOp :: i -> Bool
+ isMemOp :: i -> Bool
+ isLoadOp :: i -> Bool
+ isStoreOp :: i -> Bool
+ isAluOp :: i -> Bool
+ isCmpOp :: i -> Bool
+ isBoolOp :: i -> Bool
+ isMoveOp :: i -> Bool
+
+ -- map the instruction to an AluOp (undefined if not isAluOp)
+ aluOp :: i -> AluOp
+
+ -- is a conditional instruction?
+ isCond :: i -> Bool
+
+ -- is a parallel instruction?
+ -- example: [r1,r2] <- SWAP [r1,r2] can be mapped two instruction
+ isPar :: i -> Bool
+ -- get the first instruction (if isPar)
+ fstOp :: i -> AluOp
+ -- get the second instruction (if isPar)
+ sndOp :: i -> AluOp
+
+ memOp :: i -> LoadStoreOp
+
+ noOp :: i
+
+
+-- End Signature ------------------------------------------------------
+
+
+
+
+
+
+
+
--- /dev/null
+module Main where
+
+import System
+import Hawk--(hawkMain)
+import DLX
+import DLX_Cell
+import DLX_Reg
+import DLX_Op
+import Processor
+import Signal
+import Trans
+import LazyST
+
+import Probe
+
+main =
+ do { clearProbes_UNIX
+ ; args <- getArgs
+ ; case args of
+ [file] -> run file
+ ["-count", file] -> count file
+ ["-sample",n,file] -> sample (read n) file
+ otherwise -> error "Usage: pgm [-count] file\n"
+ ; return ()
+ }
+
+p :: ((ArrayDesc Int (Instr DLXReg Int), a), Int) -> Signal [Trans DLX_Op (DLX_Cell DLXReg Int)]
+--p :: ((ArrayDesc Int (Instr DLXReg Int), a), Int) -> Signal [Trans DLX_Op (DLX_Cell (Virtual DLXReg Int) Int)]
+p = processor
+
+run file =
+ hawkMain file (mapM_ (putStrLn . show) . (view . p))
+count file =
+ hawkMain file (mapM_ (putStrLn . show) . (cnt. view . p))
+
+sample n file =
+ hawkMain file (mapM_ (putStrLn . pretty) . (take n . view . p))
+
+pretty tss =
+ foldr (\x y -> show x ++ "\n" ++ y) "\n" tss
+
+cnt l = runST (
+ do n <- newSTRef 0
+ mapM (\l -> n+=(length l)) l
+ )
+
+n += v =
+ do n' <- readSTRef n
+ let v' = v+n'
+ writeSTRef n v'
+ return v'
+
--- /dev/null
+TOP = ..
+include $(TOP)/mk/boilerplate.mk
+
+SRC_HC_OPTS += -fglasgow-exts -cpp -optP-imacros -optPhawk-macros.h
+SRC_RUNTEST_OPTS += -d tex mygames.pgn
+
+all :: runtest
+
+include $(TOP)/mk/target.mk
+
+
+# DO NOT DELETE: Beginning of Haskell dependencies
+AQ.o : AQ.hs
+AQ.o : ./Utils.hi
+AQ.o : ./Hawk.hi
+Arithmetic.o : Arithmetic.hs
+Arithmetic.o : ./Words.hi
+BoundedSet.o : BoundedSet.hs
+Cell.o : Cell.hs
+Cell.o : ./Register.hi
+Cell.o : ./Words.hi
+DLX.o : DLX.hs
+DLX.o : ./Hawk.hi
+DLX.o : ./Trans.hi
+DLX.o : ./DLX_Cell.hi
+DLX.o : ./DLX_Reg.hi
+DLX.o : ./DLX_Op.hi
+DLX_Cell.o : DLX_Cell.hs
+DLX_Cell.o : ./Cell.hi
+DLX_Cell.o : ./Register.hi
+DLX_Cell.o : ./Words.hi
+DLX_Op.o : DLX_Op.hs
+DLX_Op.o : ./Arithmetic.hi
+DLX_Op.o : ./Memory.hi
+DLX_Op.o : ./Instruction.hi
+DLX_Op.o : ./Probe.hi
+DLX_Reg.o : DLX_Reg.hs
+Devices.o : Devices.hs
+Devices.o : ./TransSig.hi
+Devices.o : ./Trans.hi
+Devices.o : ./PreludeSig.hi
+Devices.o : ./Signal.hi
+Devices.o : ./Words.hi
+Devices.o : ./Register.hi
+Devices.o : ./Arithmetic.hi
+Devices.o : ./Cell.hi
+Devices.o : ./Memory.hi
+Devices.o : ./Utilities.hi
+Devices.o : ./Instruction.hi
+Devices.o : ./StateArray.hi
+EUs.o : EUs.hs
+EUs.o : ./PreludeSig.hi
+EUs.o : ./Hawk.hi
+EUs.o : ./Trans.hi
+EUs.o : ./DLX.hi
+Hawk.o : Hawk.hs
+Hawk.o : ./Arithmetic.hi
+Hawk.o : ./Cell.hi
+Hawk.o : ./Devices.hi
+Hawk.o : ./HawkIO.hi
+Hawk.o : ./Memory.hi
+Hawk.o : ./Register.hi
+Hawk.o : ./STEx.hi
+Hawk.o : ./Signal.hi
+Hawk.o : ./Utilities.hi
+Hawk.o : ./VRegister.hi
+Hawk.o : ./Words.hi
+Hawk.o : ./Instruction.hi
+Hawk.o : ./Probe.hi
+Hawk.o : ./PipeReg.hi
+Hawk.o : ./Init.hi
+HawkIO.o : HawkIO.hs
+HawkIO.o : ./Memory.hi
+IFU.o : IFU.hs
+IFU.o : ./Trans.hi
+IFU.o : ./Hawk.hi
+IFU.o : ./DLX.hi
+IFU.o : ./PreludeSig.hi
+IQ.o : IQ.hs
+Init.o : Init.hs
+Init.o : ./Signal.hi
+Instruction.o : Instruction.hs
+Instruction.o : ./Arithmetic.hi
+Instruction.o : ./Memory.hi
+Main.o : Main.hs
+Main.o : ./Hawk.hi
+Main.o : ./DLX.hi
+Main.o : ./DLX_Cell.hi
+Main.o : ./DLX_Reg.hi
+Main.o : ./DLX_Op.hi
+Main.o : ./Processor.hi
+Main.o : ./Signal.hi
+Main.o : ./Trans.hi
+Main.o : ./Probe.hi
+Memory.o : Memory.hs
+Memory.o : ./Arithmetic.hi
+Memory.o : ./Words.hi
+PipeReg.o : PipeReg.hs
+PipeReg.o : ./Trans.hi
+PipeReg.o : ./Signal.hi
+PipeReg.o : ./Register.hi
+PipeReg.o : ./Instruction.hi
+Predict.o : Predict.hs
+Predict.o : ./Hawk.hi
+Predict.o : ./Trans.hi
+Predict.o : ./TransSig.hi
+Predict.o : ./DLX.hi
+PreludeSig.o : PreludeSig.hs
+PreludeSig.o : ./Signal.hi
+Probe.o : Probe.hs
+Probe.o : ./Arithmetic.hi
+Probe.o : ./Cell.hi
+Probe.o : ./Devices.hi
+Probe.o : ./Memory.hi
+Probe.o : ./Trans.hi
+Probe.o : ./VRegister.hi
+Probe.o : ./Signal.hi
+Probe.o : ./PipeReg.hi
+Probe.o : ./Trans.hi
+Processor.o : Processor.hs
+Processor.o : ./Hawk.hi
+Processor.o : ./Trans.hi
+Processor.o : ./TransSig.hi
+Processor.o : ./PreludeSig.hi
+Processor.o : ./Utils.hi
+Processor.o : ./DLX.hi
+Processor.o : ./Predict.hi
+Processor.o : ./IFU.hi
+Processor.o : ./RS.hi
+Processor.o : ./ROB.hi
+Processor.o : ./EUs.hi
+RAT.o : RAT.hs
+RAT.o : ./Hawk.hi
+RAT.o : ./DLX.hi
+RAT.o : ./Trans.hi
+RAT.o : ./Utils.hi
+RF.o : RF.hs
+RF.o : ./Utils.hi
+RF.o : ./Hawk.hi
+ROB.o : ROB.hs
+ROB.o : ./Hawk.hi
+ROB.o : ./Trans.hi
+ROB.o : ./RF.hi
+ROB.o : ./AQ.hi
+ROB.o : ./RAT.hi
+ROB.o : ./RF.hi
+ROB.o : ./AQ.hi
+ROB.o : ./RAT.hi
+ROB.o : ./ROB_insert.hi
+ROB.o : ./ROB_retire.hi
+ROB.o : ./DLX.hi
+ROB_insert.o : ROB_insert.hs
+ROB_insert.o : ./Hawk.hi
+ROB_insert.o : ./Trans.hi
+ROB_insert.o : ./RF.hi
+ROB_insert.o : ./AQ.hi
+ROB_insert.o : ./RAT.hi
+ROB_insert.o : ./AQ.hi
+ROB_insert.o : ./RAT.hi
+ROB_insert.o : ./RF.hi
+ROB_insert.o : ./Utils.hi
+ROB_insert.o : ./DLX.hi
+ROB_retire.o : ROB_retire.hs
+ROB_retire.o : ./Hawk.hi
+ROB_retire.o : ./Trans.hi
+ROB_retire.o : ./RF.hi
+ROB_retire.o : ./AQ.hi
+ROB_retire.o : ./RAT.hi
+ROB_retire.o : ./RF.hi
+ROB_retire.o : ./AQ.hi
+ROB_retire.o : ./RAT.hi
+ROB_retire.o : ./DLX.hi
+ROB_retire.o : ./Utils.hi
+RS.o : RS.hs
+RS.o : ./Hawk.hi
+RS.o : ./PreludeSig.hi
+RS.o : ./Trans.hi
+RS.o : ./TransSig.hi
+RS.o : ./BoundedSet.hi
+RS.o : ./EUs.hi
+RS.o : ./DLX.hi
+Register.o : Register.hs
+STEx.o : STEx.hs
+Signal.o : Signal.hs
+StateArray.o : StateArray.hs
+StateArray.o : ./Signal.hi
+StateArray.o : ./Memory.hi
+StateArray.o : ./Words.hi
+StateArray.o : ./Memory.hi
+StateArray.o : ./Signal.hi
+StateArray.o : ./Words.hi
+StateArray.o : ./Memory.hi
+Trans.o : Trans.hs
+Trans.o : ./Words.hi
+Trans.o : ./Arithmetic.hi
+Trans.o : ./Cell.hi
+Trans.o : ./Memory.hi
+Trans.o : ./Register.hi
+Trans.o : ./Instruction.hi
+TransSig.o : TransSig.hs
+TransSig.o : ./Instruction.hi
+TransSig.o : ./Signal.hi
+TransSig.o : ./Register.hi
+TransSig.o : ./Words.hi
+TransSig.o : ./Arithmetic.hi
+TransSig.o : ./Trans.hi
+TransSig.o : ./Trans.hi
+TransSig.o : ./Cell.hi
+Utilities.o : Utilities.hs
+Utils.o : Utils.hs
+Utils.o : ./Hawk.hi
+Utils.o : ./Trans.hi
+Utils.o : ./DLX.hi
+VRegister.o : VRegister.hs
+VRegister.o : ./Register.hi
+VRegister.o : ./Cell.hi
+VRegister.o : ./Trans.hi
+Words.o : Words.hs
+# DO NOT DELETE: End of Haskell dependencies
--- /dev/null
+module Memory where
+
+import Word
+import Ix
+import Maybe
+import Arithmetic
+import Array
+import Words
+
+-- Begin Signature -------------------------------------------------
+
+{-
+ Some types to describe encodings of memory state and the
+ communication to memory
+-}
+
+type ArrayDesc i v = ((i,i),[(i,i,v)])
+
+type InstrMemoryState w i = ArrayDesc w i
+type MemoryState w i = (InstrMemoryState w i,DataMemoryState w)
+type DataMemoryState w = ArrayDesc w w
+
+data WordSize = Byte | HalfWord | FullWord
+ deriving (Eq,Show, Read)
+
+data LoadStoreOp = Load WordSize Sign
+ | Store WordSize
+ | NOP -- No operation
+ deriving (Eq,Show, Read)
+
+
+
+-- Array request
+data ArrReq i a = ReadArr i |
+ WriteArr i i a |
+ WriteFn i (a -> a) | -- modify contents at location i
+ FreezeArr
+ deriving Show
+
+-- Array response
+data ArrResp i a = ReadVal a |
+ Written |
+ WrittenFn a |
+ ArrayVal (Array i a)
+ deriving Show
+
+-- End Signature -------------------------------------------------------
+
+
--- /dev/null
+module PipeReg where
+
+
+import Trans
+import Signal
+import Register
+import Instruction
+
+-- Begin Signature ----------------------------------------------------------
+
+{-
+ pipeReg is helpful for constructing in pipelines
+-}
+
+data PipeRegCmd = Input | Stall | Kill
+ deriving (Eq,Ord,Enum,Bounded,Show)
+
+
+-- pipeReg t cmd ts , on the first cycle return "t", in later cycles,
+-- if cmd=Input then return ts, if cmd=Stall then return the previous
+-- value and store the input, if cmd=Kill then return a nop
+
+pipeReg :: (Instruction a, Register b) =>
+ Trans a (c b d) -> Signal PipeRegCmd ->
+ Signal (Trans a (c b d)) -> Signal (Trans a (c b d))
+
+input :: Signal PipeRegCmd
+stall :: Signal PipeRegCmd
+kill :: Signal PipeRegCmd
+
+-- End Signature ----------------------------------------------------------
+
+pipeReg init cmd incoming = out
+ where out = delay init (if' (cmd*==input) then' incoming
+ else' (if' (cmd*==stall) then' out
+ else' (lift0 nop))
+ )
+
+input = lift0 Input
+stall = lift0 Stall
+kill = lift0 Kill
+
--- /dev/null
+module Predict where
+
+import Hawk
+import Trans
+import qualified TransSig as T
+
+import DLX
+
+annotate x = lift1 (map anno) x
+ where anno t = let Just (Reg PC (Val pc)) = getSrcPC t
+ in if isBranch t then addInfo (Reg SpecPC (Val pc)) t
+ else t
+
--- /dev/null
+module PreludeSig where
+
+import Prelude(Ord,Bool,MonadZero,Int,($),(.))
+import qualified Prelude as P
+import qualified List
+import Signal
+
+-- Begin Signature ----------------------------------------------------
+{-
+ Functions in this module are functions from the Haskell
+ prelude lifted on Signals
+-}
+
+last :: Signal [a] -> Signal a
+head :: Signal [a] -> Signal a
+tail :: Signal [a] -> Signal [a]
+splitAt :: Signal Int -> Signal [a] -> (Signal [a], Signal [a])
+length :: Signal [a] -> Signal Int
+max :: Ord a => Signal a -> Signal a -> Signal a
+min :: Ord a => Signal a -> Signal a -> Signal a
+maximum :: Ord a => Signal [a] -> Signal a
+minimum :: Ord a => Signal [a] -> Signal a
+filter :: MonadZero c => (a -> Bool) -> Signal (c a) -> Signal (c a)
+partition :: (a -> Bool) -> Signal [a] -> (Signal [a],Signal [a])
+fst :: Signal (a,b) -> Signal a
+snd :: Signal (a,b) -> Signal b
+
+-- End Signature -----------------------------------------------------
+last = lift1 P.last
+
+head = lift1 P.head
+
+tail = lift1 P.tail
+
+splitAt x y = unbundle2 $ lift2 P.splitAt x y
+
+length = lift1 P.length
+
+max = lift2 P.max
+
+min = lift2 P.min
+
+maximum = lift1 P.maximum
+
+minimum = lift1 P.minimum
+
+filter x y = lift1 (P.filter x) y
+
+partition x y = unbundle2 (lift1 (List.partition x) y )
+
+fst = lift1 P.fst
+
+snd = lift1 P.snd
+
+-- Begin Signature ----------------------------------------------------
--- /dev/null
+module Probe where
+import IO
+import Arithmetic
+import Cell
+import Devices
+import Memory
+import Trans
+import VRegister
+import Word
+import Signal
+import PipeReg
+
+import Trans
+
+import IOExts
+
+import System
+
+-- Begin Signature -------------------------------------------------------
+
+{-
+ In practice it is nice to be able to place a probe on a signal.
+ Suppose that "s" is a signal. 'probe "s.output" s' has the
+ same meaning as 's' --- but s's contents have been written to
+ the file "s.output". This function has turned out to be
+ critical in the development of the Visio Hawk interface.
+
+ Some issues to consider:
+ * probe is a hack --- and it messes with referential
+ trancparency. Some Haskell compilers may wreak havoc with
+ probes.
+ * probe is pretty careful not to change the strictness
+ behavior.
+ * Avoid using probes within unit definitions. If you duplicate
+ the use of the unit, the output file will be written to
+ simultaniously by both units instantiations. Try using probe
+ only at the top-level of your microarchitecture.
+ * Probes are typically stored in a subdirectory "Probes/"
+-}
+
+
+class Show a => Probe a where
+ probe :: String -> Signal a -> Signal a
+ outp :: a -> String
+ probe n (List vals) = List (zipWith (dataOut n) [1..] vals)
+ outp = show
+
+-- clear the probes subdirectory in UNIX
+clearProbes_UNIX :: IO ()
+
+-- clear the probes subdirectory in Microsoft
+clearProbes_MS :: IO ()
+
+instance (Show a,Show b) => Probe (a,b)
+instance (Show a,Show b,Show c) => Probe (a,b,c)
+instance Probe Bool
+instance Probe Int
+instance Probe Word32
+instance Probe Word64
+instance Probe Char
+instance Probe a => Probe (Maybe a)
+{-instance (Probe a, Probe b) => Probe (Virtual a b )-}
+{-instance Probe PipeRegCmd-}
+{-instance Probe AluOp-}
+{-instance Probe a => Probe [a]-}
+
+-- End Signature --------------------------------------------------------
+
+clearProbes_UNIX
+ = do { system "rm -f Probes/*"
+ ; return ()
+ }
+
+clearProbes_MS
+ = do { system "del \\Q Probes\\*.*"
+ ; return ()
+ }
+
+dataOut :: Probe a => String -> Int -> a -> a
+dataOut fileName clock val = unsafePerformIO $
+ do
+ {h <- openFile ("Probes/" ++ fileName) AppendMode;
+ hPutStrLn h (rjustify 3 (show clock) ++ ": " ++ outp val);
+ hClose h;
+ return val}
+
+
+
+instance (Probe a, Probe b) => Probe (Virtual a b ) where
+ outp (Virtual n (Just r)) = "V"++show n ++ "{" ++ outp r ++"}"
+ outp (Virtual n Nothing) = "V"++show n
+ outp (Real r) = outp r
+
+
+instance Probe PipeRegCmd where
+ outp Input = "Ok"
+ outp Kill = "Kill"
+ outp Stall = "Stall"
+
+instance Probe AluOp where
+ outp (Add _) = "+"
+ outp (Sub _) = "-"
+ outp (Div _) = "/"
+ outp (Mult _) = "*"
+ outp And = "AND"
+ outp Or = "OR"
+ outp Xor = "XOR"
+ outp Not = "NOT"
+ outp Input1 = "fst"
+ outp Input2 = "snd"
+ outp x = show x
+
+
+
+instance Probe a => Probe [a] where
+ outp [] = "[]"
+ outp l = "[\t" ++ foldr1 (\x y -> x ++ "\n\t" ++ y) (map outp l) ++ "]"
+
+
+
+rjustify n s = reverse (take (max n (length s))
+ (reverse s ++ repeat ' '))
--- /dev/null
+module Processor where
+
+
+import Hawk
+import Trans
+import qualified TransSig as T
+import qualified PreludeSig as Signaled
+import Word
+
+
+import Utils
+import DLX
+
+import Predict
+
+import IFU(ifu)
+import RS(rs)
+import ROB(rob)
+import EUs
+
+processor ((pgm,pgmdata),startingPC) = retired -- retired
+ where
+
+ (instrs,pc') = ifu (5,pgm) pc ([5,5] `before` space)
+ instrs' = probe "UFO" instrs
+
+ --testTrans = lift1 (\n -> [pcTrans n]) space
+
+ pc = delay (pcTrans startingPC) npc
+ npc = if' miss then' (Signaled.last retired )
+ else' pc'
+
+ annotated = delay [] (
+ if' miss then' (lift0 [])
+ else' (annotate $ filterOut isNop $ instrs)
+ )
+
+ (retired,ready,space,miss) = rob 100 (annotated, computed)
+ --miss' = if' miss then' (lift0 $ pcTrans 1) else' (lift0 $ pcTrans 0)
+
+ computed = rs (150,execUnits) (delay False miss, delay [] ready)
+
+
+execUnits :: Word a => [EU DLX_Op (DLX_Cell (Virtual DLXReg Int) a)]
+execUnits = [addUnit,addUnit,subUnit,jumpUnit,jumpUnit,multUnit,divUnit,cmpUnit,moveUnit]
+
+multUnit' b s = probe "mu_out" out
+ where b' = probe "mu_cnt" b
+ s' = probe "mu_in" s
+ out = multUnit b' s'
--- /dev/null
+module RAT where
+
+import LazyST
+
+import Prelude hiding (read)
+import Hawk
+import DLX
+import qualified Trans
+import Utils
+
+new :: Register a => ST s (RAT s a b)
+write :: Register a => RAT s a b -> a -> b -> ST s ()
+remove :: Register a => RAT s a b -> a -> ST s ()
+read :: Register a => RAT s a b -> a -> ST s (Maybe b)
+clear :: Register a => RAT s a b -> ST s ()
+
+type RAT s a b = (STArray s a (Maybe b),a,a)
+
+clear (xs,x1,x2)
+ = do { mapM (\x -> writeSTArray xs x Nothing) [x1 .. x2]
+ ; return ()
+ }
+
+replace rat (Reg r x)
+ = do { a <- read rat r
+ ; let res = do { v <- a
+ ; return (Reg (Virtual v (Just r)) x)
+ }
+ `catchEx` Reg (Real r) x
+ ; return res
+ }
+replace rat x = return $ convert x
+
+
+new
+ = do { x <- newSTArray (minBound,maxBound) Nothing
+ ; return (x,minBound,maxBound)
+ }
+
+write (xy,_,_) x y = writeSTArray xy x (return y)
+remove (xy,_,_) x = writeSTArray xy x Nothing
+read (xy,_,_) x = readSTArray xy x
--- /dev/null
+module RF where
+
+import Prelude hiding (read)
+import LazyST
+import Utils
+
+import Hawk
+
+type RF s a b = STArray s a b
+
+new :: (Register a,Num b) => ST c (RF c a b)
+read :: Register a => RF s a b -> a -> ST s b
+write :: Register a => RF s a b -> a -> b -> ST s ()
+
+new = newSTArray (minBound,maxBound) 0
+read = readSTArray
+write f x z = if readOnly x then return ()
+ else writeSTArray f x z
--- /dev/null
+module ROB(rob) where
+import LazyST
+
+import Hawk
+import Trans
+
+import qualified RF
+import qualified AQ as Q
+import qualified RAT
+import RF(RF)
+import AQ(AQ)
+import RAT(RAT)
+import ROB_insert(insert)
+import ROB_retire(retire)
+
+import DLX
+
+
+{-
+type ROB s i r w = Int ->
+ (s [Trans i r w], s [VTrans r w]) ->
+ (s [Trans i r w], s [VTrans r w], s Int,s Bool)
+-}
+
+
+--rob :: (Signal s,Register r,Word w) => ROB s StandardOp r w
+rob n (fetched,computed)
+ = unbundle4 $ runST (
+ do { q <- Q.new n
+ ; rat <- RAT.new
+ ; regfile <- RF.new
+ ; step2(fetched,computed)
+ { update q computed
+ ; instrs <- insert rat q regfile fetched
+ ; (retired,missed) <- retire rat q regfile
+ ; inCase missed $ do { Q.clear q
+ ; RAT.clear rat
+ }
+ ; capacity <- Q.space q
+ ; let ready = if missed then [] else instrs
+ ; return (retired,ready,capacity,missed)
+ }
+ }
+ )
+ where
+ inCase x y = if x then y else return ()
+
+
+-- assumes single register dest ops (not a good assumption)
+--update :: (Register r,Word w) => AQ s (VTrans r w) -> [VTrans r w] -> ST s ()
+update q
+ = mapM_ $ \t ->
+ do { let [Reg (Virtual v (Just r)) val] = getDst t
+ ; Q.insert q v t
+ }
+
+
--- /dev/null
+module ROB_insert(insert) where
+
+import Hawk
+import Trans
+import LazyST
+
+import qualified RF
+import qualified AQ as Q
+import qualified RAT
+import AQ(AQ)
+import RAT(RAT)
+import RF(RF)
+import Utils
+
+
+import DLX
+
+
+{-
+insert :: (Register r,Word w) =>
+ RAT st r Int -> AQ st (VTrans r w) ->
+ RF st r w -> [Trans StandardOp r w] -> ST st [VTrans r w]
+-}
+insert rat q regfile instrs
+ = mapM setAndSubst instrs
+ where
+ setAndSubst t =
+ do { (reg,alias) <- bind q t
+ ; src <- mapM (RAT.replace rat) $ getSrc t
+ ; let info = map convert $ getInfo t
+ ; let op = getOp t
+ ; RAT.write rat reg alias
+ ; dest <- mapM (RAT.replace rat) $ getDst t
+ ; new <- regRead q regfile $ Trans dest op src info
+ ; Q.enQueue q new
+ ; return $ new
+ }
+ bind q trans = Q.assignAddr q (head . getDstRegs $ trans)
+
+{-
+regRead :: (Register r,Word w) => AQ s (VTrans r w) -> RF s r w ->
+ VTrans r w -> ST s (VTrans r w)
+-}
+regRead q file t
+ = do { cells <- mapM subst (getSrcRegs t)
+ ; return $ fillInSrcCells t cells
+ }
+ where
+ subst (Virtual n x)
+ = do { v <- liftST $ Q.getQVal q n
+ ; t <- liftEx v
+ ; [Reg _ val] <- return $ getDst t
+ ; return $ Reg (Virtual n x) val
+ }
+ `handle` (Reg (Virtual n x) NotKnown)
+ subst (Real r)
+ = do { val <- RF.read file r
+ ; return $ Reg (Real r) (Val val)
+ }
+
--- /dev/null
+module ROB_retire(retire) where
+
+import LazyST
+import Hawk
+import Trans
+
+import qualified RF
+import qualified AQ as Q
+import qualified RAT
+import RF(RF)
+import AQ(AQ)
+import RAT(RAT)
+
+import DLX
+import Utils
+
+
+
+retire rat q regfile
+ = do { perhaps <- retireable q
+ ; let (retired,missed) = jumpHazard perhaps
+ ; mapM (writeOut regfile rat) retired
+ ; return (cleanUp retired,missed)
+ }
+ where cleanUp = map removeVirtuals
+
+--retireable :: Register r => AQ s (Trans i r w) -> ST s [Trans i r w]
+retireable q = Q.deQueueWhile q complete
+
+--jumpHazard :: (Register r,Word w) => [VTrans r w] -> ([VTrans r w],Bool)
+jumpHazard [] = ([],False)
+jumpHazard (instr:is)
+ = if branchMissed instr then ([instr],True)
+ else (instr:is',False || die)
+ where (is',die) = jumpHazard is
+
+--branchMissed :: (Register r,Word w) => VTrans r w -> Bool
+branchMissed t =
+ do { Reg (Virtual _ (Just pc)) (Val x) <- getDstPC t
+ ; Reg (Real spc) (Val y) <- getSpecPC t
+ ; guard $ ispc pc
+ ; guard $ isspecpc spc
+ ; return $ x /= y
+ }
+ `catchEx` False
+
+--writeOut :: Register r => RF s r w -> RAT s r Int ->
+-- VTrans r w -> ST s ()
+writeOut file rat t
+ = do { let [Reg (Virtual vr (Just real)) (Val x)] = getDst t
+ ; RF.write file real x
+ ; a <- RAT.read rat real
+ ; do {v <- a
+ ; guard $ v == vr
+ ; return $ RAT.remove rat real
+ }
+ `catchEx` return ()
+ }
+
+
+
--- /dev/null
+module RS
+ (
+ rs
+ ) where
+
+import LazyST
+
+import Hawk
+import qualified PreludeSig as Sig
+import Trans
+import qualified TransSig as T
+import qualified BoundedSet as Set
+
+import EUs
+import DLX
+
+
+type RS i c r w = (Int,[EU i (c (VReg r) w)]) ->
+ (Signal Bool,Signal [VTrans r w]) ->
+ Signal [VTrans r w]
+
+
+--rs :: (Register r,Word w) => RS StandardOp c r w
+rs (n,execUnits) (mispredicted,input)
+ = computed
+ where
+ ready = runST (
+ do { set <- Set.new n
+ ; loop wires $
+ \(instrs,mispredicted,computed,rejected) ->
+ if mispredicted
+ then do { Set.clear set
+ ; return []
+ }
+ else do { Set.insert set instrs
+ ; Set.insert set rejected
+ ; broadcast' set computed
+ ; ready <- Set.rmSuch set isComputable
+ ; return ready
+ }
+ }
+ )
+ wires = bundle4 (input,mispredicted,computed,rejected)
+ (computed,rejected) = unbundle2 $ delay ([],[]) $
+ execUnit mispredicted ready
+
+ execUnit = schedule execUnits
+
+broadcast' set computed
+ = do { s <- Set.read set
+ ; let dests = concat $ map getDst computed
+ ; Set.iterateSet set (flip fillInSrcCells dests)
+ }
+
--- /dev/null
+module Register where
+
+import Ix
+
+
+-- Begin Signature -------------------------------------------------
+{-
+
+ Register captures the common instances and methods that is
+ usually required of a register-set like type. Register
+ supports PCs, speculative PCs, and predicate registers.
+
+-}
+
+
+class (Ix a,Eq a,Ord a,Bounded a,Show a,Read a,Enum a) => Register a where
+
+ -- is the register read only? for example, in DLX
+ -- r0 <- r0 + r0 is equivilant to a nop because r0 is read only
+ readOnly :: a -> Bool
+
+ -- pick out the PC register
+ pc :: a
+
+ -- pick out the speculative PC register
+ specpc :: a
+
+ ispc :: a -> Bool
+ isspecpc :: a -> Bool
+
+ -- is the register a predicate register?
+ ispred :: a -> Bool
+
+ readOnly x = False
+ ispred x = False
+
+-- End Signature -------------------------------------------------
+ -- ispc and isspec should probably be defined as :
+ -- ispc r = pc == r. havent tested this though....
--- /dev/null
+module STEx where
+import LazyST
+
+infixl 1 `handle`
+
+-- Begin Signature ----------------------------------------------------------
+
+{-
+ STEx synthesizes the state and exception monads.
+-}
+
+
+{-data STEx s a-}
+
+{-instance Monad (STEx s)-}
+{-instance MonadZero (STEx s)-}
+{-instance MonadPlus (STEx s)-}
+
+-- c `handle` x, return x if c raises an exception
+handle :: STEx a b -> b -> ST a b
+
+-- lift an exception or st monad thing or into STEx
+liftEx :: Maybe a -> STEx s a
+liftST :: ST s a -> STEx s a
+
+-- raise an exception if Bool is False
+assert :: Bool -> STEx s ()
+
+-- the following functions have the same meaning as their corresponding
+-- state monad functions
+{-readVarSTEx :: MutVar a b -> STEx a b-}
+{-writeVarSTEx :: MutVar a b -> b -> STEx a ()-}
+{-newVarSTEx :: a -> STEx b (MutVar b a)-}
+
+{-readArraySTEx :: Ix b => MutArr a b c -> b -> STEx a c-}
+{-writeArraySTEx :: Ix b => MutArr a b c -> b -> c -> STEx a ()-}
+{-newArraySTEx :: Ix a => (a,a) -> b -> STEx c (MutArr c a b)-}
+
+-- End Signature -----------------------------------------------------------
+
+newtype STEx s a = STEx (ST s (Maybe a))
+
+instance Monad (STEx s) where
+ return = STEx . return . return
+ (STEx x) >>= f
+ = STEx $ do y <- x
+ case y of
+ Just z -> let STEx z' = f z
+ in z'
+ Nothing -> return Nothing
+
+instance MonadZero (STEx s) where
+ zero = liftEx zero
+
+instance MonadPlus (STEx s) where
+ (STEx x) ++ (STEx y) = STEx $ do x' <- x
+ y' <- y
+ return $ x' ++ y'
+liftST x = STEx $ do {z <- x ; return $ return z}
+
+liftEx x = STEx $ return x
+
+
+handle (STEx m) x
+ = do y <- m
+ case y of
+ Just z -> return z
+ Nothing -> return x
+
+readVarSTEx v = liftST $ readSTRef v
+writeVarSTEx v x = liftST $ writeSTRef v x
+newVarSTEx x = liftST $ newSTRef x
+
+readArraySTEx v n = liftST $ readSTArray v n
+writeArraySTEx v x n = liftST $ writeSTArray v x n
+newArraySTEx x n = liftST $ newSTArray x n
+
+{- example
+f x = do y <- liftEx x
+ v <- newVarSTEx y
+ readVarSTEx v
+
+g x = runST (handle (f x) 2)
+-}
+
+assert True = liftEx $ Just ()
+assert False = liftEx $ Nothing
+
--- /dev/null
+module Signal where
+import LazyST
+import List
+import Random
+import IOExts
+
+-- infixl 9 *!
+
+-- Begin Signature -------------------------------------------------------
+{-
+ In essence Hawk is Haskell with built-in Lustre-like signals. The
+ rest are libraries built upon this structure. In the event of
+ circuit synthesis, the Signal type and its operators represent
+ the residule of elaboration (partial-evaluation).
+-}
+
+{-data Signal a-}
+
+infix 4 *==, */=, *<, *<=, *>=, *>
+infixr 3 *&&
+infixr 2 *||
+infixr 5 *:, *++
+infixl 9 `at`
+infixr 0 `delay`
+infixr 0 `before`
+
+at :: Signal a -> Int -> a
+
+-- [1,3,2] `before` <10 .. > = <1,3,2,10 .. >
+before :: [a] -> Signal a -> Signal a
+
+-- loop s f, apply f to s at each cycle, saving the state....
+loop :: Signal a -> (a -> ST st c)-> ST st (Signal c)
+
+view :: Signal a -> [a]
+
+-- delay x <x1,x2 .. > = <x,x1,x2 .. >
+delay :: a -> Signal a -> Signal a
+
+-- if,then,else lifted on signals...
+cond :: Signal Bool -> Signal a -> Signal a -> Signal a
+
+-- apply a function pointwise to a signal
+lift0 :: a -> Signal a
+lift1 :: (a -> b) -> Signal a -> Signal b
+lift2 :: (a->b->c) -> Signal a -> Signal b -> Signal c
+lift3 :: (a->b->c->d) -> Signal a -> Signal b -> Signal c -> Signal d
+lift4 :: (a->b->c->d->e) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e
+lift5 :: (a->b->c->d->e->f) -> Signal a -> Signal b -> Signal c -> Signal d -> Signal e -> Signal f
+
+-- make a single signal of tuples out of tuple of signals
+bundle2 :: (Signal a,Signal b) -> Signal (a,b)
+bundle3 :: (Signal a,Signal b,Signal c) -> Signal (a,b,c)
+bundle4 :: (Signal a,Signal b,Signal c,Signal d) -> Signal (a,b,c,d)
+bundle5 :: (Signal a,Signal b,Signal c,Signal d,Signal e) -> Signal (a,b,c,d,e)
+bundle6 :: (Signal a,Signal b,Signal c,Signal d,Signal e,Signal f) ->
+ Signal (a,b,c,d,e,f)
+bundleList :: [Signal a] -> Signal [a]
+
+-- make a tuple of signals from a signal of tuples
+unbundle2 :: Signal (a,b) -> (Signal a,Signal b)
+unbundle3 :: Signal (a,b,c) -> (Signal a,Signal b,Signal c)
+unbundle4 :: Signal (a,b,c,e) -> (Signal a,Signal b,Signal c,Signal e)
+unbundle5 :: Signal (a,b,c,e,d) ->
+ (Signal a,Signal b,Signal c,Signal e,Signal d)
+
+-- careful using this function. the size of the list of the input
+-- must be the same at each cycle.
+unbundleList :: Signal [a] -> [Signal a]
+
+
+-- corresponding functions lifted on signals.
+(*==) :: Eq a => Signal a -> Signal a -> Signal Bool
+(*/=) :: Eq a => Signal a -> Signal a -> Signal Bool
+(*<) :: Ord a => Signal a -> Signal a -> Signal Bool
+(*<=) :: Ord a => Signal a -> Signal a -> Signal Bool
+(*>) :: Ord a => Signal a -> Signal a -> Signal Bool
+(*>=) :: Ord a => Signal a -> Signal a -> Signal Bool
+(*&&) :: Signal Bool -> Signal Bool -> Signal Bool
+(*||) :: Signal Bool -> Signal Bool -> Signal Bool
+(*++) :: MonadPlus m => Signal (m a) -> Signal (m a) -> Signal (m a)
+(*:) :: Signal a -> Signal [a] -> Signal [a]
+
+
+{-instance Eq a => Eq (Signal a)-}
+{-instance Ord a => Ord (Signal a)-}
+{-instance Enum a => Enum (Signal a)-}
+{-instance Bounded a => Bounded (Signal a)-}
+{-instance Num a => Num (Signal a)-}
+{-instance Real a => Real (Signal a)-}
+{-instance Integral a => Integral (Signal a)-}
+{-instance Functor Signal where-}
+
+-- make the trivial superscalar circuit from a scalar circuit by
+-- applying it sequentially (left to right)
+superscalar :: (Signal a -> Signal b) -> Signal [a] -> Signal [b]
+
+{-
+ The following functions will give different streams for every use ----
+ giving a form of non-determinism.
+
+ NOTE that these functions should be used carefully. They
+ break referential transparency
+
+-}
+
+ints :: (Int,Int) -> Signal Int
+integers :: (Integer,Integer) -> Signal Integer
+-- End Signature ------------------------------------------------------
+
+
+
+-- End Signature -------------------------------------------------------
+
+
+delay i s = [i] `before` s
+cond x y z = lift3 (\x y z -> if x then y else z) x y z
+
+
+
+
+bundle2 (a,b) = lift2 (,) a b
+bundle3 (a,b,c) = lift3 (,,) a b c
+bundle4 (a,b,c,d) = lift4 (,,,) a b c d
+bundle5 (a,b,c,d,e) = lift5 (,,,,) a b c d e
+bundle6 (a,b,c,d,e,f) = lift6 (,,,,,) a b c d e f
+
+bundleList [] = lift0 []
+bundleList (s:ss) = lift2 (:) s (bundleList ss)
+
+unbundle2 s = (a,b)
+ where a = lift1 (\(x,_) -> x) s
+ b = lift1 (\(_,x) -> x) s
+unbundle3 s = (a,b,c)
+ where a = lift1 (\(x,_,_) -> x) s
+ b = lift1 (\(_,x,_) -> x) s
+ c = lift1 (\(_,_,x) -> x) s
+unbundle4 s = (a,b,c,d)
+ where a = lift1 (\(x,_,_,_) -> x) s
+ b = lift1 (\(_,x,_,_) -> x) s
+ c = lift1 (\(_,_,x,_) -> x) s
+ d = lift1 (\(_,_,_,x) -> x) s
+unbundle5 s = (a,b,c,d,e)
+ where a = lift1 (\(x,_,_,_,_) -> x) s
+ b = lift1 (\(_,x,_,_,_) -> x) s
+ c = lift1 (\(_,_,x,_,_) -> x) s
+ d = lift1 (\(_,_,_,x,_) -> x) s
+ e = lift1 (\(_,_,_,_,x) -> x) s
+
+ -- not particularily safe....
+unbundleList s = map (nth s) szs
+ where sz = length $ head $ view s
+ szs = [0 .. sz-1]
+ nth s n = lift1 (!!n) s
+
+
+
+instance Eq a => Eq (Signal a) where
+ (==) = error "Cannot compare two signals for equality in general"
+
+instance Ord a => Ord (Signal a) where
+ compare = error "Cannot compare two signals in general"
+ min = lift2 min
+ max = lift2 max
+
+instance Enum a => Enum (Signal a) where
+ toEnum = lift0 . toEnum
+ fromEnum = error "Trying to convert a Signal to an Enum"
+ enumFrom = unbundleList . lift1 enumFrom
+ enumFromThen n m = unbundleList $ lift2 enumFromThen n m
+ enumFromTo n m = unbundleList $ lift2 enumFromTo n m
+ enumFromThenTo n n' m = unbundleList $ lift3 enumFromThenTo n n' m
+
+instance Bounded a => Bounded (Signal a) where
+ minBound = lift0 minBound
+ maxBound = lift0 maxBound
+
+instance Num a => Num (Signal a) where
+ (+) = lift2 (+)
+ (-) = lift2 (-)
+ (*) = lift2 (*)
+ negate = lift1 negate
+ fromInteger = lift0 . fromInteger
+ fromInt = lift0 . fromInt
+ abs = lift1 abs
+ signum = lift1 signum
+
+instance Real a => Real (Signal a) where
+ toRational = error "Trying to convert a signal to a Rational"
+
+instance Integral a => Integral (Signal a) where
+ quot = lift2 quot
+ rem = lift2 rem
+ div = lift2 div
+ mod = lift2 mod
+ x `quotRem` y = unbundle2 (lift2 quotRem x y)
+ x `divMod` y = unbundle2 (lift2 divMod x y)
+ toInteger = error "Trying to convert a Signal to an Integer"
+ toInt = error "Trying to convert a Signal to an Int"
+
+
+------------------------------------------------------------------
+-- definitons
+
+
+
+(*==) = lift2 (==)
+(*/=) = lift2 (/=)
+(*<) = lift2 (<)
+(*<=) = lift2 (<=)
+(*>) = lift2 (>)
+(*>=) = lift2 (>=)
+(*&&) = lift2 (&&)
+(*||) = lift2 (||)
+(*++) = lift2 (++)
+(*:) = lift2 (:)
+
+data Then = Then
+data Else = Else
+
+if' x Then y Else z = cond x y z
+
+{-
+if' ~(Sig x) Then ~(Sig y) Else ~(Sig z) = Sig (cond x y z)
+ where
+ cond ~(x:xs) ~(y:ys) ~(z:zs) =
+ let v = if x then y else z
+ vs = cond xs ys zs
+ in (v:vs)
+-}
+
+
+then' = Then
+else' = Else
+
+------------------------------------------------------------------------
+-- Specific to List implementation:
+
+
+newtype Signal a = List [a]
+ deriving Show
+
+instance Functor Signal where
+ map f ~(List as) = List (map f as)
+
+
+at ~(List l) n = l!!n
+before l ~(List l') = List (l ++ l')
+loop ~(List l) f = do {l' <- mapM f l; return $ List l'}
+
+lift0 x = List (repeat x)
+
+
+----------------------------
+-- UGH!! the lazy pattern matching found in lazyMap is pretty important when
+-- using signals to communicate with closely timed mutually dependant
+-- signal transducers. Probably, lazy versions of zipWith should be
+-- used too.
+--- Byron , Sun Dec 6 16:46:09 PST 1998
+
+lift1 f (List xs) = List $ lazyMap f xs
+ where
+ lazyMap f ~(x:xs) = f x : lazyMap f xs
+
+lift2 f ~(List as) ~(List bs)
+ = List (zipWith f as bs)
+
+lift3 f ~(List as) ~(List bs) ~(List cs)
+ = List (zipWith3 f as bs cs)
+
+lift4 f ~(List as) ~(List bs) ~(List cs) ~(List ds)
+ = List (zipWith4 f as bs cs ds)
+
+lift5 f ~(List as) ~(List bs) ~(List cs) ~(List ds) ~(List es)
+ = List (zipWith5 f as bs cs ds es)
+
+lift6 f ~(List as) ~(List bs) ~(List cs) ~(List ds) ~(List es) ~(List fs)
+ = List (zipWith6 f as bs cs ds es fs)
+
+view ~(List s) = s
+
+superscalar f (List input) = List (chop lens output)
+ where
+ lens = map length input
+ List output = f (List $ concat input)
+ chop (n:ns) l = let (l',l'') = splitAt n l
+ in l' : chop ns l''
+
+
+------------------------------------------------------------------------
+-- Non-determinism
+
+integers = List . unsafePerformIO . randomIO
+
+ints = map toInt . integers . toIntegers
+ where
+ toIntegers (x,y) = (toInteger x,toInteger y)
+
+
+
--- /dev/null
+module StateArray ( stateArray,updateArray) where
+
+import List
+import Signal
+import LazyST
+
+import Array
+import Memory
+import Words
+import Array
+import Memory
+import Signal
+import LazyST
+import Words
+import Memory
+
+{-
+ these functions accept vectors of Array requests (reads or writes)
+ and services them.
+-}
+
+stateArray :: (Ix a, Enum a) => ((a,a),[(a,a,b)]) ->
+ Signal [ArrReq a b] -> Signal [ArrResp a b]
+
+updateArray :: Ix a => Signal (Array a b) ->
+ [(Signal Bool,(Signal a,Signal b))] ->
+ Signal (Array a b)
+
+
+-- BEWARE --- unless you're really digging deep into the
+-- library you've probably made a wrong turn.
+-- Unless you know what you're doing dont be here.
+
+
+stateArray (bounds@(loBound,hiBound),initWrites) input =
+ runST (
+ do arr <- newSTArray bounds initVal
+ initArray arr
+ loop (input) $ \input -> performRequests arr input
+ )
+ where
+ -- Determine what the array should be initialized to; remove
+ -- some of the writes that would initialize the array to the
+ -- same value to speed up the initialization process.
+ contigWrites = contigWriteRanges
+ (loBound,hiBound,
+ error "uninitialized value read from stateArray")
+ initWrites
+ maxRange@(_,_,initVal) = maxWriteRange contigWrites
+ reducedInitWrites = removeWriteRange maxRange contigWrites
+
+
+ -- Initialize the array according to 'initWrites'
+ initArray arr
+ = strictSequence [ writeSTArray arr index val |
+ (lowIdx,hiIdx,val) <- reducedInitWrites,
+ index <- range (lowIdx,hiIdx) ]
+
+ -- Perform the requested writes, reads, and freezes for each clock cycle
+performRequests arr reqs = performReqs reqs
+ where
+ performReqs reqs
+ = mapM performReq reqs
+
+ performReq (ReadArr i)
+ = do val <- readSTArray arr i
+ return (ReadVal val)
+
+ performReq (WriteArr loAddr hiAddr val)
+ = do sequence [ writeSTArray arr loc val |
+ loc <- range (loAddr,hiAddr) ]
+ return Written
+
+ performReq (WriteFn loc f)
+ = do readVal <- readSTArray arr loc
+ let writeVal = f readVal
+ writeSTArray arr loc writeVal
+ return (WrittenFn writeVal)
+
+ performReq FreezeArr
+ = do arr <- freezeSTArray arr
+ return (ArrayVal arr)
+
+-- Forces each action in its argument list by pattern-matching
+-- on the action's output unit. This function is useful in preventing
+-- large sequences of actions from being built.
+strictSequence :: Monad m => [m ()] -> m ()
+strictSequence = foldr (\m n -> do { () <- m; n }) (return ())
+
+{-
+ The following functions dealing with write-ranges are
+ needed because the hugs interpreter is very slow in evaluating
+ lazy monadic expressions involving lots of writes to a MutArr.
+ Even simple programs output by dlxgcc ask to have about 16K-words
+ of data to be initialized to zero, while other areas of memory
+ should be initialized to an error value. These routines
+ allow me to isolate what the majority of array locations should
+ be initialized to; I can pass this initialization value to
+ newArr (which is implemented as a primitive) to avoid most
+ of the initial writes.
+-}
+
+-- Given a write-range and a list of contiguous sorted write ranges,
+-- this function outputs a contiguous sorted write range that would
+-- result when the first write range is written to an array after the other
+-- write ranges are written to an array. Note that the write-range to
+-- be inserted must overlap or be contiguous to the write-range list.
+insertWrite :: (Ix i,Enum i) => (i,i,a) -> [(i,i,a)] -> [(i,i,a)]
+insertWrite writeRange []
+ = [writeRange]
+insertWrite writeRange@(lo,hi,v) (first@(firstLo,firstHi,firstVal):rest)
+ -- empty writeRange
+ | hi < lo = first : rest
+ -- writeRange is completely less than first element
+ | hi < firstLo = writeRange : first : rest
+ -- writeRange is completely greater than first element
+ | firstHi < lo = first : insertWrite writeRange rest
+ -- writeRange completely overlaps the first element
+ | lo <= firstLo && hi >= firstHi = insertWrite writeRange rest
+ -- writeRange partially overlaps the first element; the leading
+ -- edge of writeRange is less than or equal to the leading edge
+ -- of the first element.
+ | lo <= firstLo = writeRange : (succ hi,firstHi,firstVal) : rest
+ -- writeRange partially overlaps the first element; the leading
+ -- edge of writeRange is greater than the leading edge of the
+ -- first element.
+ | firstLo < lo = (firstLo,pred lo,firstVal) : insertWrite writeRange ((lo,firstHi,firstVal):rest)
+ | True = error "bug in insertWrite"
+
+
+-- Given a write range 'writeRange' and a list of write-ranges 'ranges' whose
+-- elements are subranges of 'writeRange', this function outputs a contiguous,
+-- non-overlapping list of write-ranges that is equivalent to writing
+-- 'writeRange' to an array, followed by writing the elements of 'ranges'
+-- in order to the same array.
+contigWriteRanges :: (Ix i,Enum i) => (i,i,a) -> [(i,i,a)] -> [(i,i,a)]
+contigWriteRanges writeRange ranges
+ = foldr insertWrite [writeRange] (reverse ranges)
+
+
+-- Finds the largest write-range in a list of write-ranges.
+maxWriteRange :: (Ix i,Enum i) => [(i,i,a)] -> (i,i,a)
+maxWriteRange
+ = foldr1 (\a@(loA,hiA,_) b@(loB,hiB,_) ->
+ if rangeSize (loA,hiA) >= rangeSize (loB,hiB)
+ then a
+ else b)
+
+-- removes a given write-range from a list of write-ranges
+removeWriteRange :: (Ix i,Enum i) => (i,i,a) -> [(i,i,a)] -> [(i,i,a)]
+removeWriteRange (lo,hi,_) = filter (\(loA,hiA,_) -> lo /= loA || hi /= hiA)
+
+
+
+-- Updates an array Signal, given a static list of updaters. Each
+-- updater consists of a Boolean enable signal, and a signal pair
+-- of the update address and update value.
+updateArray arr updaters
+ = foldr (\(updateEnable,updater) prevArray ->
+ if' updateEnable
+ then' (lift2 (//) prevArray (singleton (bundle2 updater)))
+ else' prevArray
+ )
+ arr
+ updaters
+ where singleton = lift1 $ \x -> [x]
+
+
--- /dev/null
+module Trans where
+
+import List
+import Words
+import Word
+import Arithmetic
+import Cell
+import Memory
+import Register
+import Instruction
+
+-- Begin Signature ----------------------------------------------------------
+{-
+
+ We have used Transactions to represent instructions w/ their data.
+ These have been particularly useful in pipelined and out-of-order
+ superscalar machines.
+
+-}
+
+data Trans i c = Trans [c] i [c] [c]
+ deriving (Eq,Show,Read)
+
+-- Convention: if Trans d op s i
+-- we say that d is the destination, op is the instruction
+-- s is the source, and i is the information
+
+-- return a nop-like transaction
+nop :: (Instruction i,Register r) => Trans i (c r w)
+
+-- return a PC transaction
+pcTrans :: (Cell c,Instruction i,Register r, Word w) =>
+ w -> Trans i (c r w)
+
+isNop :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isAdd :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isAlu :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isCmp :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isBool :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isSub :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isMul :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isDiv :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isJump :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isMove :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isMem :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isLoad :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isStore :: (Instruction i,Register r) => Trans i (c r w) -> Bool
+isBranch :: (Cell c,Register r,Word w) => Trans i (c r w) -> Bool
+isComputable :: (Cell c,Register r,Word w) => Trans i (c r w) -> Bool
+
+-- update destination fields
+updDst :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> [c r w] -> Trans i (c r w)
+
+-- apply a function to the destination fields
+repDst :: Register r => (c r w -> c r w -> Bool) ->
+ Trans i (c r w) -> [c r w] -> Trans i (c r w)
+
+-- add to the destination
+addDst :: Register r => c r w -> Trans i (c r w) -> Trans i (c r w)
+
+-- get the destination
+getDst :: Register r => Trans i (c r w) -> [c r w]
+
+-- replace the dest fields
+putDst :: Register r => Trans i (c r w) -> [c r w] -> Trans i (c r w)
+
+
+updSrc :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> [c r w] -> Trans i (c r w)
+addSrc :: Register r => c r w -> Trans i (c r w) -> Trans i (c r w)
+getSrc :: Register r => Trans i (c r w) -> [c r w]
+putSrc :: Register r => Trans i (c r w) -> [c r w] -> Trans i (c r w)
+
+addInfo :: Register r => c r w -> Trans i (c r w) -> Trans i (c r w)
+getInfo :: Register r => Trans i (c r w) -> [c r w]
+putInfo :: Register r => Trans i (c r w) -> [c r w] -> Trans i (c r w)
+
+getOp :: Trans i (c r w) -> i
+putOp :: Trans i (c r w) -> i -> Trans i (c r w)
+
+
+-- return the speculative PC from the info area
+getSpecPC :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> Maybe (c r w)
+
+-- return the PC from the destination area
+getDstPC :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> Maybe (c r w)
+getSrcPC :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> Maybe (c r w)
+
+-- return the instructions location from memory from the destination
+-- area
+getLoc :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> Maybe (c r w)
+
+-- get register references
+getSrcRegs :: (Cell c,Register r,Word w) => Trans i (c r w) -> [r]
+getDstRegs :: (Cell c,Register r,Word w) => Trans i (c r w) -> [r]
+
+-- get register reference values
+getSrcRegVals :: (Cell c,Register r,Word w) => Trans i (c r w) -> [w]
+putDstRegVal :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> w -> Trans i (c r w)
+
+-- evalTrans t (c,w) update the destination fields in t with w if they match
+-- c
+evalTrans :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> (c r w,Maybe w) -> Trans i (c r w)
+
+-- is there a Read-After-Write hazard between two transactions?
+rawHazard :: (Cell c,Register r,Word w) =>
+ (Trans i (c r w),Trans i (c r w)) -> Bool
+
+-- bypass t t2 source operands of t with the dest operands of t2
+-- if the references match.
+
+bypass :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> Trans i (c r w) -> Trans i (c r w)
+
+-- bypass the dest. operands instead of the source operands.
+bypassDst :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> Trans i (c r w) -> Trans i (c r w)
+
+-- bypass with multiple transactions
+bypassMany :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> [Trans i (c r w)] -> Trans i (c r w)
+bypassDstMany :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> [Trans i (c r w)] -> Trans i (c r w)
+
+-- bypass to multiple transaction with multiple transactions
+broadcast :: (Cell a, Register b, Word c) =>
+ [Trans e (a b c)] -> [Trans e (a b c)] -> [Trans e (a b c)]
+
+--source operands and dest operands all filled in?
+complete :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> Bool
+
+-- if (x,y) = readyToRetire z, then
+-- x is the lift of transactions that are "complete"
+readyToRetire :: (Cell c,Register r,Word w) =>
+ [Trans i (c r w)] -> ([Trans i (c r w)],[Trans i (c r w)])
+
+
+-- if (x,y) = readyToCompute z, then
+-- x is the lift of transactions with all of their source operands filled in
+readyToCompute :: (Cell c,Register r,Word w) =>
+ [Trans i (c r w)] -> ([Trans i (c r w)],[Trans i (c r w)])
+
+
+updatePC :: Register r => c r w -> Trans i (c r w) -> Trans i (c r w)
+
+
+getPredicate :: (Cell c,Register r,Word w) => Trans i (c r w) -> c r w
+isPredicated :: (Cell c,Register r,Word w) => Trans i (c r w) -> Bool
+
+evalPredicate :: (Cell c,Register r,Word w) => Trans i (c r w) -> w
+
+-- End Signature ----------------------------------------------------------
+
+
+updCells :: (Cell c,Register r,Word w) => [c r w] -> [c r w] -> [c r w]
+repCells :: Register r => (c r w -> c r w -> Bool) ->
+ [c r w] -> [c r w] -> [c r w]
+
+-- perhaps these functions can go?
+filterDst :: Register r => (c r w -> Bool) -> Trans i (c r w) -> [c r w]
+
+fillInCells :: (Cell c,Register r,Word w) => [c r w] -> [c r w] -> [c r w]
+
+fillInSrcCells :: (Cell c,Register r,Word w) =>
+ Trans i (c r w) -> [c r w] -> Trans i (c r w)
+
+filterOut :: (Register r,Functor m) =>
+ (Trans i (c r w) -> Bool) -> m [Trans i (c r w)] ->
+ m [Trans i (c r w)]
+
+
+
+nop = Trans [] noOp [] []
+
+pcTrans addr = Trans [putVal pcNothing (Just addr)] noOp [] []
+isNop t = isNoOp (getOp t)
+isAdd t = isAddOp (getOp t)
+isAlu t = isAluOp (getOp t)
+isCmp t = isCmpOp (getOp t)
+isBool t = isBoolOp (getOp t)
+isSub t = isSubOp (getOp t)
+isMul t = isMultOp (getOp t)
+isDiv t = isDivOp (getOp t)
+isJump t = isJumpOp (getOp t)
+isMem t = isMemOp (getOp t)
+isMove t = isMoveOp (getOp t)
+isLoad t = isLoadOp (getOp t)
+isStore t = isStoreOp (getOp t)
+
+isBranch (Trans d _ _ _) = any search d where
+ search r = if isReg r then ispc (getReg r)
+ else False
+
+isComputable = and . map isComputed . getSrc
+
+
+
+
+repCells replFunc cells replacements
+ = map (\cell -> foldr bypassCell cell replacements) cells
+ where
+ bypassCell bypassed argCell
+ = if replFunc bypassed argCell
+ then bypassed
+ else argCell
+
+
+updCells cells bypassCells = repCells cellHazard cells bypassCells
+
+
+repDst repFunc (Trans d o s i) cells = Trans (repCells repFunc d cells) o s i
+updDst = repDst cellHazard
+addDst c t = putDst t (c:getDst t)
+getDst (Trans d o s i) = d
+putDst (Trans _ o s i) d = Trans d o s i
+
+updSrc (Trans d o s i) cells = Trans d o (updCells s cells) i
+addSrc c t = putSrc t (c:getSrc t)
+getSrc (Trans d o s i) = s
+putSrc (Trans d o _ i) s = Trans d o s i
+
+addInfo c t = putInfo t (c:getInfo t)
+getInfo (Trans d o s i) = i
+putInfo (Trans d o s _) i = Trans d o s i
+
+getOp (Trans d o s i) = o
+putOp (Trans d _ s i) o = Trans d o s i
+
+getSpecPC = find isSpecPC . getInfo
+getDstPC = find isPC . getDst
+getSrcPC = find isPC . getSrc
+getLoc = find isLoc . getInfo
+
+getSrcRegs t = map getReg $ filter isReg $ getSrc t
+getDstRegs t = map getReg $ filter isReg $ getDst t
+
+getSrcRegVals t = map getVal $
+ filter isReg $ getSrc t
+
+{-
+putDstRegVal (Trans [Reg r _] o s i) n
+ = Trans [Reg r (Val n)] o s i
+-}
+putDstRegVal (Trans [r] o s i) n
+ = Trans [putVal r (Just n)] o s i
+
+getPredicate (Trans _ _ l _) = last (filter isPred l)
+
+getPredicate' t = if isPredicated t then Just (getPredicate t)
+ else Nothing
+
+isPredicated (Trans _ _ x _)
+ = case filter isPred x of
+ [] -> False
+ _ -> True
+
+
+evalPredicate t =
+ case getPredicate' t of
+ Just c -> if isAss c then getVal c
+ -- else error $ "evalPredicate" ++ show t
+ else error "evalPredicate"
+ Nothing -> 1
+
+bypass tran bypassT = --updSrc tran $ getDst bypassT
+ if evalPredicate bypassT /= 0
+ then updSrc tran $ getDst bypassT
+ else tran
+
+bypassDst tran bypassT = if evalPredicate bypassT /= 0
+ then updDst tran $ getDst bypassT
+ else tran
+
+bypassMany tran bypassT = foldr (\a b -> b `bypass` a) tran bypassT
+
+bypassDstMany tran bypassT = foldr (\a b -> b `bypassDst` a) tran bypassT
+
+broadcast xs ys = map (`bypassMany` ys) xs
+
+{- PRE-predication
+bypass tran bypassT = updSrc tran $ getDst bypassT
+
+bypassDst tran bypassT = updDst tran $ getDst bypassT
+
+bypassTrans tran bypassT = foldr (\a b -> b `bypass` a) tran bypassT
+
+broadcast xs ys = map (`bypassTrans` ys) xs
+-}
+
+
+readyToRetire = partition $ and . map isComputed . getDst
+
+complete = and . map isComputed . getDst
+
+readyToCompute = partition $ and . map isComputed . getSrc
+
+tran `evalTrans` (dest,val) = repDst sameLoc tran [putVal dest val]
+
+rawHazard (preceeding,following)
+ = or [ cellHazard precCell followCell |
+ precCell <- getDst preceeding,
+ followCell <- getSrc following]
+
+filterDst f (Trans d _ _ _) = filter f d
+
+--added 19 Nov
+filterOut f = map (filter $ not . f)
+
+fillInCells cells bypassCells
+ = repCells (\x y -> (not $ isAss y) && cellHazard x y) cells bypassCells
+
+fillInSrcCells (Trans d o s i) cells = Trans d o (fillInCells s cells) i
+
+fillInCells' cells bypassCells
+ = repCells cellHazard cells bypassCells
+
+fillInSrcCells' (Trans d o s i) cells = Trans d o (fillInCells' s cells) i
+
+-- TEMPORARY --- NOT ROBUST!
+updatePC c (Trans _ o s i) = Trans [c] o s i
+
+
+
+
+
+
+
+
+
+
--- /dev/null
+module TransSig
+ ( Trans(..)
+
+ ,nop
+
+ ,isNop
+ ,isAdd
+ ,isAlu
+ ,isCmp
+ ,isBool
+ ,isSub
+ ,isMul
+ ,isDiv
+ ,isJump
+ ,isMem
+ ,isMove
+ ,isLoad
+ ,isStore
+ ,isBranch
+
+ ,updCells
+ ,repCells
+
+ ,updDst
+ ,repDst
+ ,addDst
+ ,getDst
+ ,putDst
+
+ ,updSrc
+ ,addSrc
+ ,getSrc
+ ,putSrc
+
+ ,addInfo
+ ,getInfo
+ ,putInfo
+
+ ,getOp
+ ,putOp
+
+ ,getSpecPC
+ ,getDstPC
+ ,getSrcPC
+ ,getLoc
+
+ ,getSrcRegs
+ ,getDstRegs
+ ,getSrcRegVals
+ ,putDstRegVal
+
+ ,bypass
+ ,bypassDst
+ ,bypassMany
+ ,bypassDstMany
+ ,broadcast
+
+ ,readyToRetire
+ ,complete
+ ,readyToCompute
+
+ ,evalTrans
+ ,rawHazard
+ ,filterDst
+
+ ,pcTrans
+ , getPredicate
+ , isPredicated
+ , evalPredicate
+
+
+
+ ) where
+
+import List
+import Instruction
+import Signal
+import Register
+import Words
+import Arithmetic
+import qualified Trans as T
+import Trans(Trans(..))
+import Cell
+
+
+-- Begin Signature ---------------------------------------------------
+{-
+ The functions in TransSig are identical to Trans, except
+ that they have been lifted on Signals
+-}
+
+
+nop :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w))
+isNop :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isAdd :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isAlu :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isCmp :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isBool :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isSub :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isMul :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isDiv :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isJump :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isMem :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isMove :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isLoad :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isStore :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+isBranch :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+updCells :: (Cell c, Word w, Register r) =>
+ Signal [c r w] -> Signal [c r w] -> Signal [c r w]
+repCells :: (Cell c, Word w, Register r) =>
+ (c r w -> c r w -> Bool) ->
+ Signal [c r w] -> Signal [c r w] -> Signal [c r w]
+
+updDst :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [c r w] ->
+ Signal (Trans i (c r w))
+repDst :: (Instruction i,Cell c,Register r,Word w) =>
+ (c r w -> c r w -> Bool) ->
+ Signal (Trans i (c r w)) -> Signal [c r w] ->
+ Signal (Trans i (c r w))
+addDst :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (c r w) -> Signal (Trans i (c r w)) ->
+ Signal (Trans i (c r w))
+getDst :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [c r w]
+putDst :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [c r w] ->
+ Signal (Trans i (c r w))
+updSrc :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [c r w] ->
+ Signal (Trans i (c r w))
+addSrc :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (c r w) -> Signal (Trans i (c r w)) ->
+ Signal (Trans i (c r w))
+getSrc :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [c r w]
+putSrc :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [c r w] ->
+ Signal (Trans i (c r w))
+
+addInfo :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (c r w) -> Signal (Trans i (c r w)) ->
+ Signal (Trans i (c r w))
+getInfo :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [c r w]
+putInfo :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [c r w] ->
+ Signal (Trans i (c r w))
+
+getOp :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal i
+putOp :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal i ->
+ Signal (Trans i (c r w))
+
+getSpecPC :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal (Maybe (c r w))
+getDstPC :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal (Maybe (c r w))
+getSrcPC :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal (Maybe (c r w))
+getLoc :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal (Maybe (c r w))
+
+getSrcRegs :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [r]
+getDstRegs :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [r]
+getSrcRegVals :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [w]
+putDstRegVal :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal w ->
+ Signal (Trans i (c r w))
+bypass :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal (Trans i (c r w)) ->
+ Signal (Trans i (c r w))
+bypassDst :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal (Trans i (c r w)) ->
+ Signal (Trans i (c r w))
+bypassMany :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [Trans i (c r w)] ->
+ Signal (Trans i (c r w))
+bypassDstMany :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal [Trans i (c r w)] ->
+ Signal (Trans i (c r w))
+broadcast :: (Cell a, Register b, Word c) =>
+ Signal [Trans e (a b c)] -> Signal [Trans e (a b c)] ->
+ Signal [Trans e (a b c)]
+
+
+readyToRetire :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal [Trans i (c r w)] ->
+ Signal ([Trans i (c r w)],[Trans i (c r w)])
+complete :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+readyToCompute :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal [Trans i (c r w)] ->
+ Signal ([Trans i (c r w)],[Trans i (c r w)])
+
+evalTrans :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal (c r w, Maybe w) ->
+ Signal (Trans i (c r w))
+rawHazard :: (Instruction i,Cell c,Register r,Word w) =>
+ (Signal (Trans i (c r w)),Signal (Trans i (c r w)))
+ -> Signal Bool
+filterDst :: (Instruction i,Cell c,Register r,Word w) =>
+ (c r w -> Bool) -> Signal (Trans i (c r w)) ->
+ Signal [c r w]
+
+pcTrans :: (Instruction i,Cell c,Register r,Word w) =>
+ Signal w -> Signal (Trans i (c r w))
+
+
+
+getPredicate :: (Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal (c r w)
+isPredicated :: (Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal Bool
+
+evalPredicate :: (Cell c,Register r,Word w) =>
+ Signal (Trans i (c r w)) -> Signal w
+
+
+-- End Signature -------------------------------------------------------------
+nop = lift0 $ T.nop
+
+isNop = lift1 T.isNop
+isAdd = lift1 T.isAdd
+isAlu = lift1 T.isAlu
+isCmp = lift1 T.isCmp
+isBool = lift1 T.isBool
+isSub = lift1 T.isSub
+isMul = lift1 T.isMul
+isDiv = lift1 T.isDiv
+isJump = lift1 T.isJump
+isMem = lift1 T.isMem
+isMove = lift1 T.isMove
+isLoad = lift1 T.isLoad
+isStore = lift1 T.isStore
+isBranch = lift1 T.isBranch
+
+updCells = lift2 T.updCells
+repCells f = lift2 $ T.repCells f
+
+updDst = lift2 T.updDst
+repDst f = lift2 $ T.repDst f
+addDst = lift2 T.addDst
+getDst = lift1 T.getDst
+putDst = lift2 T.putDst
+
+updSrc = lift2 T.updSrc
+--repSrc =
+addSrc = lift2 T.addSrc
+getSrc = lift1 T.getSrc
+putSrc = lift2 T.putSrc
+
+addInfo = lift2 T.addInfo
+getInfo = lift1 T.getInfo
+putInfo = lift2 T.putInfo
+
+getOp = lift1 T.getOp
+putOp = lift2 T.putOp
+
+getSpecPC = lift1 T.getSpecPC
+getDstPC = lift1 T.getDstPC
+getSrcPC = lift1 T.getSrcPC
+getLoc = lift1 T.getLoc
+
+getSrcRegs = lift1 T.getSrcRegs
+getDstRegs = lift1 T.getDstRegs
+getSrcRegVals = lift1 T.getSrcRegVals
+putDstRegVal = lift2 T.putDstRegVal
+
+evalTrans = lift2 T.evalTrans
+rawHazard ts = lift1 T.rawHazard (bundle2 ts)
+
+bypass = lift2 T.bypass
+bypassDst = lift2 T.bypassDst
+bypassMany = lift2 T.bypassMany
+bypassDstMany = lift2 T.bypassDstMany
+broadcast = lift2 T.broadcast
+
+readyToRetire = lift1 T.readyToRetire
+complete = lift1 T.complete
+readyToCompute = lift1 T.readyToCompute
+
+filterDst f = lift1 $ T.filterDst f
+
+
+pcTrans = lift1 T.pcTrans
+
+-- Predicated instructions
+getPredicate = lift1 T.getPredicate
+isPredicated = lift1 T.isPredicated
+evalPredicate = lift1 T.evalPredicate
--- /dev/null
+module Utilities where
+
+import Maybe
+
+
+-- Begin Signature -------------------------------------------------
+
+infixr 1 `catchEx`
+
+catchEx :: Maybe a -> a -> a
+(><) :: (a -> b,c -> d) -> (a,c) -> (b,d)
+
+-- End Signature -------------------------------------------------
+
+catchEx = flip fromMaybe
+(f,g) >< (x,y) = (f x, g y)
+
+
--- /dev/null
+module Utils where
+
+import Hawk
+import Trans
+import DLX
+import Maybe
+import LazyST
+
+--(f,g) >< (x,y) = (f x, g y)
+
+
+
+unique x = x
+{-
+unique (Sig xs) = runST (
+ do { x <- newSTRef 0
+ ; l <- mapM (anno x) xs
+ ; return $ Sig l
+ }
+ )
+ where anno x xs = mapM (anno' x) xs
+ anno' x y = do { v <- readSTRef x
+ ; writeSTRef x (v+1)
+ ; return $ addInfo (Loc (Word v)) y
+ }
+-}
+
+convert (Loc y) = Loc y
+convert (Imm y) = Imm y
+convert (Reg r x) = Reg (Real r) x
+
+convertBack (Loc y) = Loc y
+convertBack (Imm y) = Imm y
+convertBack (Reg (Real r) x) = Reg r x
+convertBack (Reg (Virtual _ (Just r)) x) = Reg r x
+convertBack t@(Reg (Virtual r Nothing) x) = error "ConvertBack"
+
+removeVirtuals t = Trans dest op src info
+ where src = map convertBack $ getSrc t
+ dest = map convertBack $ getDst t
+ info = map convertBack $ getInfo t
+ op = getOp t
+
--- /dev/null
+module VRegister where
+
+import Ix
+import Register
+import Cell
+import Trans
+
+
+-- Begin Signature -------------------------------------------------
+
+{-
+ Given two register sets, VRegister facilitates the mapping
+ between them. See the P6 model for an example of register renaming
+ with VRegister
+-}
+
+data Virtual r v
+ = Real r
+ | Virtual v (Maybe r)
+ deriving (Read,Show,Ord)
+
+isReal :: Virtual a b -> Bool
+isVirtual :: Virtual a b -> Bool
+
+{-instance (Ix a, Ix b,Bounded a,Bounded b) => Ix (Virtual a b)-}
+{-instance (Enum a,Bounded a,Enum b,Bounded b) => Enum (Virtual a b)-}
+{-instance (Bounded a,Bounded b) => Bounded (Virtual a b)-}
+{-instance (Register a,Register b) => Register (Virtual a b)-}
+{-instance Eq Virtual r v-}
+{-instance Register Int-}
+
+
+
+
+-- End Signature -------------------------------------------------
+
+instance Register Int where
+ pc = error "Int does not have a PC"
+ specpc = error "Int does not have a SPECPC"
+ isspecpc _ = False
+ ispc _ = False
+
+
+
+virtual x = Virtual x Nothing
+
+isReal (Real _) = True
+isReal _ = False
+
+isVirtual (Virtual _ _) = True
+isVirtual _ = False
+
+-----------------------Instances--------------------------------
+
+instance (Eq a,Eq b) => Eq (Virtual a b) where
+ (Virtual x _) == (Virtual y _) = x == y
+ (Real x) == (Real y) = x == y
+ _ == _ = False
+ (Virtual x _) /= (Virtual y _) = x /= y
+ (Real x) /= (Real y) = x /= y
+ _ /= _ = True
+
+instance (Register a,Register b) => Register (Virtual a b) where
+ readOnly (Virtual v x) = readOnly v
+ readOnly (Real v) = readOnly v
+ ispc (Virtual n (Just x)) = ispc x
+ ispc (Real x) = ispc x
+ isspecpc (Virtual n (Just x)) = isspecpc x
+ isspecpc (Real x) = isspecpc x
+ pc = Real pc
+ specpc = Real specpc
+
+
+instance (Ix a, Ix b,Bounded a,Bounded b) => Ix (Virtual a b) where
+-- range :: (a,a) -> [a]
+ range (Real r, Real r') = map Real $ range (r,r')
+ range (Virtual r _, Virtual r' _) = map (\x -> Virtual x Nothing) $ range (r,r')
+ range (Real r, Virtual r' _) = range1 ++ range2
+ where range1 = map Real $ range (r,maxBound)
+ range2 = map (\x -> Virtual x Nothing) $ range (minBound,r')
+ range (Virtual r _, Real r') = []
+-- index :: (a,a) -> a -> Int
+ index (Virtual r _,Virtual r' _) (Virtual r'' _) = index (r,r') r''
+ index (Real r,Real r') (Real r'') = index (r,r') r''
+ index (Virtual r _,Virtual r' _) _ = error "index: Real Reg out of range"
+ index (Real r,Real r') _ = error "index: Virtual Reg out of range"
+ index (Virtual r _,Real r') _ = error "index: Virtual Reg out of range"
+ index (Real r,Virtual r' _) (Real x) = index(r,maxBound) x
+ index (Real r,Virtual r' _) (Virtual x _) = index(minBound,r') x
+-- inRange :: (a,a) -> a -> Bool
+ inRange (Virtual x _,Virtual y _) (Virtual z _) = inRange (x,y) z
+ inRange (Real x,Real y) (Real z) = inRange (x,y) z
+ inRange (Virtual x _,Virtual y _) _ = False
+ inRange (Real x,Real y) _ = False
+ inRange (Virtual x _,Real y) _ = False
+ inRange (Real y,_) (Real r) = inRange (y,maxBound) r
+ inRange (_,Virtual y _) (Virtual r _) = inRange (minBound,y) r
+
+
+instance (Enum a,Bounded a,Enum b,Bounded b) => Enum (Virtual a b) where
+-- toEnum :: Int -> a
+-- toEnum = Virtual . toEnum
+ toEnum x = error "Virtual.toEnum"
+
+-- fromEnum :: a -> Int
+-- fromEnum (Virtual x) = fromEnum x
+ fromEnum x = error "Virtual.fromEnum"
+
+-- enumFrom :: a -> [a]
+ enumFrom (Virtual x _) = map virtual (enumFrom x)
+ enumFrom (Real x) = map Real (enumFrom x) ++ enumFrom (virtual minBound)
+
+-- enumFromThen :: a -> a -> [a]
+ enumFromThen _ _ = error "Virtual.enumFromThen"
+
+-- enumFromTo :: a -> a -> [a]
+ enumFromTo (Virtual x _) (Virtual y _)
+ = map virtual (enumFromTo x y)
+ enumFromTo (Real x) (Real y)
+ = map Real (enumFromTo x y)
+ enumFromTo (Real x) (Virtual y z)
+ = enumFrom (Real x) ++
+ enumFromTo (Virtual minBound Nothing) (Virtual y z)
+-- enumFromThenTo :: a -> a -> a -> [a]
+ enumFromThenTo _ _ _ = error "Virtual.enumFromThenTo"
+
+instance (Bounded a,Bounded b) => Bounded (Virtual a b) where
+-- minBound :: a
+ minBound = Real minBound
+-- maxBound :: a
+ maxBound = Virtual maxBound Nothing
+
--- /dev/null
+module Words where
+
+import Word
+import Ix
+
+-- Begin Signature ---------------------------------------------------------
+
+{-
+The Word class captures both the common operations and class instances
+that you would want from words of different sizes.
+-}
+
+class (Ix w,Num w,Integral w,Bounded w, Eq w) => Word w where
+ --intToWord :: Int -> w
+ num_half :: w
+ num_bytes :: w
+ max_signed :: w
+ min_signed :: w
+ max_signed_half :: w
+ sign :: w -> w
+ unsign :: w -> w
+ --toWord :: Integral a => a -> w
+ sign_half :: w -> w
+
+ --toWord = intToWord . toInt
+ sign_half n = n `signedModulus` num_half
+
+class Word w => Word2 i w where
+ toWord :: i -> w
+
+{-instance Word Int-}
+{-instance Word Word8-}
+{-instance Word Word32-}
+
+-- This isn't set yet because Word64 is not set to Num in Hugs
+-- instance Word Word64
+
+-- End Signature ---------------------------------------------------------
+
+
+
+
+instance Word Int where
+ num_half = mk_num_half 31
+ num_bytes = mk_num_bytes 31
+ max_signed = mk_max_signed 31
+ min_signed = mk_min_signed 31
+ max_signed_half = mk_max_signed_half 31
+ sign = mk_sign 31
+ unsign = mk_unsign 31
+
+instance Integral i => Word2 i Int where
+ toWord = toInt
+
+instance Word Word8 where
+ num_half = mk_num_half 8
+ num_bytes = mk_num_bytes 8
+ max_signed = mk_max_signed 8
+ min_signed = mk_min_signed 8
+ max_signed_half = mk_max_signed_half 8
+ sign = mk_sign 8
+ unsign = mk_unsign 8
+
+instance Integral i => Word2 i Word8 where
+ toWord = intToWord8 . toInt
+
+
+instance Word Word32 where
+ num_half = mk_num_half 32
+ num_bytes = mk_num_bytes 32
+ max_signed = mk_max_signed 32
+ min_signed = mk_min_signed 32
+ max_signed_half = mk_max_signed_half 32
+ sign = mk_sign 32
+ unsign = mk_unsign 32
+
+instance Integral i => Word2 i Word32 where
+ toWord = intToWord32 . toInt
+
+mk_num_half x = 2^(x `div` 2)
+mk_num_bytes x = 2^(x `div` 4)
+mk_max_signed x = 2^(x-1) - 1
+mk_min_signed x = -2^(x-1)
+mk_max_signed_half x = 2^((x `div` 2) - 1) - 1
+mk_sign x n = fromInteger $ n' `signedModulus` ((2^x)::Integer)
+ where n' = toInteger n
+mk_unsign x n = fromInteger $ if n' >=0 then n' else n' + 2^x'
+ where n' = toInteger n
+ x' = toInteger x
+
+signedModulus x m
+ = if modNum <= (m `div` 2) - 1
+ then modNum
+ else m - modNum
+ where
+ modNum = x `mod` m
+
+
--- /dev/null
+#define step4(w,x,y,z) loop(bundle4(w,x,y,z)) $ \ ~(w,x,y,z) -> do
+#define step3(x,y,z) loop(bundle3(x,y,z)) $ \ ~(x,y,z) -> do
+#define step2(x,y) loop(bundle2 (x,y)) $ \ ~(x,y) -> do {- stp2(x,y) -}
+#define step1(x) loop(x) $ \ ~x -> do
+#define step loop(lift0 ()) $ \ ~() -> do
+#define _probeST () <- stpProbe
projects / ghc-hetmet.git / commitdiff