From: simonpj Date: Thu, 29 Apr 1999 11:53:34 +0000 (+0000) Subject: [project @ 1999-04-29 11:53:12 by simonpj] X-Git-Tag: Approximately_9120_patches~6276 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=fa7bd36ec8751d0f29a3b4b5272be5990cb6201f;p=ghc-hetmet.git [project @ 1999-04-29 11:53:12 by simonpj] Minor fixes to tests --- diff --git a/ghc/tests/ccall/should_fail/cc001.hs b/ghc/tests/ccall/should_fail/cc001.hs index 4019f61..c6e851d 100644 --- a/ghc/tests/ccall/should_fail/cc001.hs +++ b/ghc/tests/ccall/should_fail/cc001.hs @@ -1,4 +1,4 @@ --- !!! cc002 -- ccall with ambiguous argument +-- !!! cc001 -- ccall with ambiguous argument module Test where f :: IO () diff --git a/ghc/tests/ccall/should_fail/cc001.stderr b/ghc/tests/ccall/should_fail/cc001.stderr index dfeb20a..e959631 100644 --- a/ghc/tests/ccall/should_fail/cc001.stderr +++ b/ghc/tests/ccall/should_fail/cc001.stderr @@ -1,8 +1,8 @@ - + 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 + diff --git a/ghc/tests/ccall/should_fail/cc002.stderr b/ghc/tests/ccall/should_fail/cc002.stderr index 4157c7e..d41df55 100644 --- a/ghc/tests/ccall/should_fail/cc002.stderr +++ b/ghc/tests/ccall/should_fail/cc002.stderr @@ -1,7 +1,7 @@ - + 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 + diff --git a/ghc/tests/ccall/should_fail/cc004.stderr b/ghc/tests/ccall/should_fail/cc004.stderr index 3173740..1b02c46 100644 --- a/ghc/tests/ccall/should_fail/cc004.stderr +++ b/ghc/tests/ccall/should_fail/cc004.stderr @@ -1,11 +1,11 @@ - + 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 + diff --git a/ghc/tests/codeGen/should_run/cg036.hs b/ghc/tests/codeGen/should_run/cg036.hs index e2575eb..40bfa74 100644 --- a/ghc/tests/codeGen/should_run/cg036.hs +++ b/ghc/tests/codeGen/should_run/cg036.hs @@ -4,13 +4,13 @@ -- 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] diff --git a/ghc/tests/deSugar/should_compile/ds020.hs b/ghc/tests/deSugar/should_compile/ds020.hs index 54a1101..86ffff1 100644 --- a/ghc/tests/deSugar/should_compile/ds020.hs +++ b/ghc/tests/deSugar/should_compile/ds020.hs @@ -50,3 +50,5 @@ g ~(~(~(~([])))) = [] eq2 = (2::Int) == (4::Int) eq3 = (3::Int) == (3::Int) eq4 = (4::Int) == (2::Int) + + diff --git a/ghc/tests/deriving/should_fail/drvfail007.stderr b/ghc/tests/deriving/should_fail/drvfail007.stderr index 9ca1d3b..ae4b9bf 100644 --- a/ghc/tests/deriving/should_fail/drvfail007.stderr +++ b/ghc/tests/deriving/should_fail/drvfail007.stderr @@ -1,7 +1,7 @@ - + drvfail007.hs:2: No instance for `Eq (Int -> Int)' When deriving classes for `Foo' - Compilation had errors + diff --git a/ghc/tests/programs/jeff-bug/AQ.hs b/ghc/tests/programs/jeff-bug/AQ.hs new file mode 100644 index 0000000..397f96c --- /dev/null +++ b/ghc/tests/programs/jeff-bug/AQ.hs @@ -0,0 +1,167 @@ +-- 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 + diff --git a/ghc/tests/programs/jeff-bug/Arithmetic.hs b/ghc/tests/programs/jeff-bug/Arithmetic.hs new file mode 100644 index 0000000..b5bd247 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Arithmetic.hs @@ -0,0 +1,229 @@ +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 + + diff --git a/ghc/tests/programs/jeff-bug/BoundedSet.hs b/ghc/tests/programs/jeff-bug/BoundedSet.hs new file mode 100644 index 0000000..0583ba6 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/BoundedSet.hs @@ -0,0 +1,93 @@ +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) + } + + + diff --git a/ghc/tests/programs/jeff-bug/Cell.hs b/ghc/tests/programs/jeff-bug/Cell.hs new file mode 100644 index 0000000..448e007 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Cell.hs @@ -0,0 +1,91 @@ +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 ---------------------------------------------- + + + + diff --git a/ghc/tests/programs/jeff-bug/DLX.hs b/ghc/tests/programs/jeff-bug/DLX.hs new file mode 100644 index 0000000..59cec97 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/DLX.hs @@ -0,0 +1,227 @@ +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) ++ "]" + + + + + + + + + + diff --git a/ghc/tests/programs/jeff-bug/DLX_Cell.hs b/ghc/tests/programs/jeff-bug/DLX_Cell.hs new file mode 100644 index 0000000..9d88a09 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/DLX_Cell.hs @@ -0,0 +1,86 @@ +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 + + + + + + + + diff --git a/ghc/tests/programs/jeff-bug/DLX_Op.hs b/ghc/tests/programs/jeff-bug/DLX_Op.hs new file mode 100644 index 0000000..cb74c0b --- /dev/null +++ b/ghc/tests/programs/jeff-bug/DLX_Op.hs @@ -0,0 +1,99 @@ +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 + + + diff --git a/ghc/tests/programs/jeff-bug/DLX_Reg.hs b/ghc/tests/programs/jeff-bug/DLX_Reg.hs new file mode 100644 index 0000000..07929ec --- /dev/null +++ b/ghc/tests/programs/jeff-bug/DLX_Reg.hs @@ -0,0 +1,15 @@ +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) diff --git a/ghc/tests/programs/jeff-bug/Devices.hs b/ghc/tests/programs/jeff-bug/Devices.hs new file mode 100644 index 0000000..96a2940 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Devices.hs @@ -0,0 +1,414 @@ +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 <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)) + + + diff --git a/ghc/tests/programs/jeff-bug/EUs.hs b/ghc/tests/programs/jeff-bug/EUs.hs new file mode 100644 index 0000000..39c7d0d --- /dev/null +++ b/ghc/tests/programs/jeff-bug/EUs.hs @@ -0,0 +1,81 @@ +-- 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) diff --git a/ghc/tests/programs/jeff-bug/Hawk.hs b/ghc/tests/programs/jeff-bug/Hawk.hs new file mode 100644 index 0000000..6855e2d --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Hawk.hs @@ -0,0 +1,48 @@ +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 diff --git a/ghc/tests/programs/jeff-bug/HawkIO.hs b/ghc/tests/programs/jeff-bug/HawkIO.hs new file mode 100644 index 0000000..595b86b --- /dev/null +++ b/ghc/tests/programs/jeff-bug/HawkIO.hs @@ -0,0 +1,29 @@ +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) + } diff --git a/ghc/tests/programs/jeff-bug/IFU.hs b/ghc/tests/programs/jeff-bug/IFU.hs new file mode 100644 index 0000000..5975e0e --- /dev/null +++ b/ghc/tests/programs/jeff-bug/IFU.hs @@ -0,0 +1,27 @@ +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 + } + } + ) diff --git a/ghc/tests/programs/jeff-bug/Init.hs b/ghc/tests/programs/jeff-bug/Init.hs new file mode 100644 index 0000000..1957fd8 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Init.hs @@ -0,0 +1,42 @@ +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 diff --git a/ghc/tests/programs/jeff-bug/Instruction.hs b/ghc/tests/programs/jeff-bug/Instruction.hs new file mode 100644 index 0000000..c732b03 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Instruction.hs @@ -0,0 +1,63 @@ +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 ------------------------------------------------------ + + + + + + + + diff --git a/ghc/tests/programs/jeff-bug/Main.hs b/ghc/tests/programs/jeff-bug/Main.hs new file mode 100644 index 0000000..f56c1ed --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Main.hs @@ -0,0 +1,52 @@ +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' + diff --git a/ghc/tests/programs/jeff-bug/Makefile b/ghc/tests/programs/jeff-bug/Makefile new file mode 100644 index 0000000..72b7b2e --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Makefile @@ -0,0 +1,219 @@ +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 diff --git a/ghc/tests/programs/jeff-bug/Memory.hs b/ghc/tests/programs/jeff-bug/Memory.hs new file mode 100644 index 0000000..d37d7d7 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Memory.hs @@ -0,0 +1,49 @@ +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 ------------------------------------------------------- + + diff --git a/ghc/tests/programs/jeff-bug/PipeReg.hs b/ghc/tests/programs/jeff-bug/PipeReg.hs new file mode 100644 index 0000000..7907412 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/PipeReg.hs @@ -0,0 +1,42 @@ +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 + diff --git a/ghc/tests/programs/jeff-bug/Predict.hs b/ghc/tests/programs/jeff-bug/Predict.hs new file mode 100644 index 0000000..66475b3 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Predict.hs @@ -0,0 +1,13 @@ +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 + diff --git a/ghc/tests/programs/jeff-bug/PreludeSig.hs b/ghc/tests/programs/jeff-bug/PreludeSig.hs new file mode 100644 index 0000000..f2cd610 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/PreludeSig.hs @@ -0,0 +1,55 @@ +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 ---------------------------------------------------- diff --git a/ghc/tests/programs/jeff-bug/Probe.hs b/ghc/tests/programs/jeff-bug/Probe.hs new file mode 100644 index 0000000..89225f6 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Probe.hs @@ -0,0 +1,122 @@ +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 ' ')) diff --git a/ghc/tests/programs/jeff-bug/Processor.hs b/ghc/tests/programs/jeff-bug/Processor.hs new file mode 100644 index 0000000..48ddac5 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Processor.hs @@ -0,0 +1,50 @@ +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' diff --git a/ghc/tests/programs/jeff-bug/RAT.hs b/ghc/tests/programs/jeff-bug/RAT.hs new file mode 100644 index 0000000..b4e0d07 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/RAT.hs @@ -0,0 +1,42 @@ +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 diff --git a/ghc/tests/programs/jeff-bug/RF.hs b/ghc/tests/programs/jeff-bug/RF.hs new file mode 100644 index 0000000..c2b6953 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/RF.hs @@ -0,0 +1,18 @@ +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 diff --git a/ghc/tests/programs/jeff-bug/ROB.hs b/ghc/tests/programs/jeff-bug/ROB.hs new file mode 100644 index 0000000..ace8b71 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/ROB.hs @@ -0,0 +1,57 @@ +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 + } + + diff --git a/ghc/tests/programs/jeff-bug/ROB_insert.hs b/ghc/tests/programs/jeff-bug/ROB_insert.hs new file mode 100644 index 0000000..d443fd4 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/ROB_insert.hs @@ -0,0 +1,60 @@ +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) + } + diff --git a/ghc/tests/programs/jeff-bug/ROB_retire.hs b/ghc/tests/programs/jeff-bug/ROB_retire.hs new file mode 100644 index 0000000..0080259 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/ROB_retire.hs @@ -0,0 +1,61 @@ +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 () + } + + + diff --git a/ghc/tests/programs/jeff-bug/RS.hs b/ghc/tests/programs/jeff-bug/RS.hs new file mode 100644 index 0000000..dc10d74 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/RS.hs @@ -0,0 +1,54 @@ +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) + } + diff --git a/ghc/tests/programs/jeff-bug/Register.hs b/ghc/tests/programs/jeff-bug/Register.hs new file mode 100644 index 0000000..337d1d3 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Register.hs @@ -0,0 +1,39 @@ +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.... diff --git a/ghc/tests/programs/jeff-bug/STEx.hs b/ghc/tests/programs/jeff-bug/STEx.hs new file mode 100644 index 0000000..cb77722 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/STEx.hs @@ -0,0 +1,88 @@ +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 + diff --git a/ghc/tests/programs/jeff-bug/Signal.hs b/ghc/tests/programs/jeff-bug/Signal.hs new file mode 100644 index 0000000..5498a26 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Signal.hs @@ -0,0 +1,300 @@ +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 = +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) + + + diff --git a/ghc/tests/programs/jeff-bug/StateArray.hs b/ghc/tests/programs/jeff-bug/StateArray.hs new file mode 100644 index 0000000..0224b01 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/StateArray.hs @@ -0,0 +1,168 @@ +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] + + diff --git a/ghc/tests/programs/jeff-bug/Trans.hs b/ghc/tests/programs/jeff-bug/Trans.hs new file mode 100644 index 0000000..29c96c6 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Trans.hs @@ -0,0 +1,338 @@ +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 + + + + + + + + + + diff --git a/ghc/tests/programs/jeff-bug/TransSig.hs b/ghc/tests/programs/jeff-bug/TransSig.hs new file mode 100644 index 0000000..afe0f8e --- /dev/null +++ b/ghc/tests/programs/jeff-bug/TransSig.hs @@ -0,0 +1,310 @@ +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 diff --git a/ghc/tests/programs/jeff-bug/Utilities.hs b/ghc/tests/programs/jeff-bug/Utilities.hs new file mode 100644 index 0000000..6b0ba79 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Utilities.hs @@ -0,0 +1,18 @@ +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) + + diff --git a/ghc/tests/programs/jeff-bug/Utils.hs b/ghc/tests/programs/jeff-bug/Utils.hs new file mode 100644 index 0000000..ed7b872 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Utils.hs @@ -0,0 +1,43 @@ +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 + diff --git a/ghc/tests/programs/jeff-bug/VRegister.hs b/ghc/tests/programs/jeff-bug/VRegister.hs new file mode 100644 index 0000000..3d25f34 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/VRegister.hs @@ -0,0 +1,132 @@ +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 + diff --git a/ghc/tests/programs/jeff-bug/Words.hs b/ghc/tests/programs/jeff-bug/Words.hs new file mode 100644 index 0000000..76d83c2 --- /dev/null +++ b/ghc/tests/programs/jeff-bug/Words.hs @@ -0,0 +1,98 @@ +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 + + diff --git a/ghc/tests/programs/jeff-bug/hawk-macros.h b/ghc/tests/programs/jeff-bug/hawk-macros.h new file mode 100644 index 0000000..bf61cdc --- /dev/null +++ b/ghc/tests/programs/jeff-bug/hawk-macros.h @@ -0,0 +1,6 @@ +#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