{- `Deep Thought', a softcore CPU implemented on a FPGA Copyright (C) 2010 Markus Hofstaetter Copyright (C) 2010 Martin Perner Copyright (C) 2010 Stefan Rebernig Copyright (C) 2010 Manfred Schwarz Copyright (C) 2010 Bernhard Urban This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . -} module DT where import DTFormat import Expr_eval import Prelude hiding (not,and,or) import Data.Bits hiding (xor) import qualified Data.Map as Map import Data.Word import Text.Printf import Text.Parsec import Text.Parsec.String import Text.Parsec.Combinator import Control.Monad import Control.Applicative hiding ((<|>)) -- parsing -- instruction :: LineNo -> Dict -> Parser Word32 instruction lno dict = foldl1 (<|>) (fmap (\x -> try (x dict)) instructions) <* char '\n' (". something at line " ++ show lno ++ " is wrong (ignore line 1 hint above, but pay attention for possible line offset due to #include).") testins :: String -> IO () testins input = case (parse (instruction 0 dict) "" (input++"\n")) of Left err -> do { putStr "fail :/\n"; print err} Right x -> do { printf "0x%08X\n" x } where dict = (0x8000,[("lolz", 0x1337), ("rofl", 0xaaaa)]) comma = char ',' mnem m = string m iLabel :: Dict -> Parser Word32 -- TODO: save msb (=sign) correctly... iLabel d@(aktadr,_) = do {i <- (iLit d); return $ ((i - aktadr)`div`4) .&. 0xffff} iLit :: Dict -> Parser Word32 iLit (_,d) = do parseMySpaces val <- expr d; try (do { string "@hi"; parseMySpaces; return $ shiftR val 16 }) <|> do { string "@lo"; parseMySpaces; return $ val .&. 0xffff } <|> do {parseMySpaces; return val} iLit5 d = do i <- iLit d; return $ i .&. 0x001f iLit12 d = do i <- iLit d; return $ i .&. 0x0fff iLit15 d = do i <- iLit d; return $ i .&. 0x7fff iLit16 d = do i <- iLit d; return $ i .&. 0xffff imm4 :: Parser String imm4 = do try (do a <- digit; b <- digit; return $ [a,b]) <|> (do a <- digit; return $ [a]) read4imm :: String -> Word32 read4imm s = if erg > 15 then error "invalid register" else erg where erg = read s reg :: Parser Word32 reg = do {parseMySpaces; string "r"; ret <- liftM read4imm (imm4); parseMySpaces; return ret} condition :: Parser Word32 condition = do str <- foldl1 (<|>) (fmap (try . string . fst) conds) let (Just ret) = lookup str conds return $ ret carry :: Parser Word32 carry = do { char 'c'; return 1} <|> do {string ""; return 0} updateDisable :: Parser Word32 updateDisable = do { char 'd'; return 1} <|> do {string ""; return 0} highonly :: Parser Word32 highonly = do { char 'h'; return 1} <|> do {string ""; return 0} highlow :: Parser Word32 highlow = do { char 'h'; return 1} <|> do {char 'l'; return 0} <|> do {string ""; return 0} fill :: Parser Word32 fill = do { char 'f'; return 1} <|> do {string ""; return 0} sign :: Parser Word32 sign = do { char 's'; return 1} <|> do {string ""; return 0} branchpred :: Parser Word32 branchpred = do x <- do { char '+'; return 1} <|> do {char '-'; return 0} <|> do {string ""; return 0} parseMySpaces return x shiftArith :: Parser Word32 shiftArith = do { char 'a'; return 1} <|> do {string ""; return 0} parseBracketClose :: Parser Char parseBracketClose = do { c <- char ')'; parseMySpaces; return c} (<.>) p n = p<*comma<*>n (<%>) p n = p<*space<*>n (<@>) p n = p<*char '('<*>n<*parseBracketClose infixl 1 <.> infixl 1 <%> infixl 1 <@> ins m form e = do {mnem m; form e} csv0i_p dict f = f<$>condition<*>branchpred<*>(iLabel dict) csv0i_p' f = f<$>condition<*>branchpred csv1 f = f<$>condition<%>reg csv1' f = f<$>condition csv1_p f = f<$>condition<%>reg csv2 f = f<$>condition<%>reg<.>reg csv2i dict f = f<$>condition<%>reg<.>(iLit16 dict) csv2_scd f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg csv2m dict f = f<$>condition<%>reg<.>(iLit15 dict)<@>reg csv2i_cd dict f = f<$>carry<*>updateDisable<*>condition<%>reg<.>reg<.>(iLit5 dict) csv2i_d dict f = f<$>updateDisable<*>condition<%>reg<.>reg<.>(iLit5 dict) csv2i_scd dict f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg<.>(iLit12 dict) csv2i_sl dict f = f<$>highonly<*>sign<*>condition<%>reg<.>(iLit16 dict) csv2i_sl' dict f = f<$>sign<*>condition<%>reg<.>(iLit16 dict) csv2i_lfd dict f = f<$>highlow<*>fill<*>updateDisable<*>condition<%>reg<.>(iLit16 dict) csv3_cd f = f<$>carry<*>updateDisable<*>condition<%>reg<.>reg<.>reg csv3_d f = f<$>updateDisable<*>condition<%>reg<.>reg<.>reg instructions = [add, addi, mov, sub, subi, and, andx, or, orx, xor, xorx, not, lls, lrs, ars, pop, push, disc, fetch, movpf, movsf, movpt, movst, ldh, ldb, ldw, ldi, ldil, stw, sth, stb, ldx, stx, br, ret, call, reti, brr, callr, cmp, cmpi ] -- arithmetic add _ = ins "add" csv3_cd $ aform 0x00 addi dict = ins "addi" (csv2i_scd dict) $ aformi 0x02 mov _ = ins "mov" csv2_scd $ aformi' 0x02 sub _ = ins "sub" csv3_cd $ aform 0x01 subi dict = ins "subi" (csv2i_scd dict) $ aformi 0x03 -- logic and _ = ins "and" csv3_d $ aform 0x04 0 andx dict = ins "andx" (csv2i_lfd dict) $ lformi 0x05 or _ = ins "or" csv3_d $ aform 0x06 0 orx dict = ins "orx" (csv2i_lfd dict) $ lformi 0x07 xor _ = ins "xor" csv3_d $ aform 0x08 0 xorx dict = ins "xorx" (csv2i_lfd dict) $ lformi 0x09 not _ = ins "not" csv1 $ lformi'not 0x09 lls dict = ins "lls" (csv2i_cd dict) $ shiform 0x0a 0 0 lrs dict = ins "lrs" (csv2i_cd dict) $ shiform 0x0a 1 0 ars dict = ins "ars" (csv2i_d dict) $ shiform 0x0a 1 1 0 -- memory pop _ = ins "pop" csv1 $ sform 0x0b 0x0 disc _ = ins "disc" csv1' $ sform' 0x0b 0x1 0 fetch _ = ins "fetch" csv1 $ sform 0x0b 0x2 push _ = ins "push" csv1 $ sform 0x0b 0x3 movpf _ = ins "movpf" csv1 $ sform 0x0c 0x2 movsf _ = ins "movsf" csv1 $ sform 0x0c 0x0 movpt _ = ins "movpt" csv1 $ sform 0x0d 0x2 movst _ = ins "movst" csv1 $ sform 0x0d 0x0 ldw dict = ins "ldw" (csv2m dict) $ mformi 0x0e ldh dict = ins "ldh" (csv2m dict) $ mformi 0x10 ldb dict = ins "ldb" (csv2m dict) $ mformi 0x12 ldi dict = ins "ldi" (csv2i_sl dict) $ lformi' 0x1a ldil dict = ins "ldil" (csv2i_sl' dict) $ lformi' 0x1a 0 stw dict = ins "stw" (csv2m dict) $ mformi 0x0f sth dict = ins "sth" (csv2m dict) $ mformi 0x11 stb dict = ins "stb" (csv2m dict) $ mformi 0x13 ldx dict = ins "ldx" (csv2m dict) $ mformi 0x14 stx dict = ins "stx" (csv2m dict) $ mformi 0x15 -- misc -- set signed by default! in very rare cases this can be an issue. br dict = ins "br" (csv0i_p dict) $ bform 0x16 0x0 1 call dict = ins "call" (csv0i_p dict) $ bform 0x16 0x1 1 ret _ = ins "ret" csv0i_p' $ bform' 0x16 0x2 reti _ = ins "reti" csv0i_p' $ bform' 0x16 0x3 brr _ = ins "brr" csv1_p $ brrform 0x17 0 callr _ = ins "callr" csv1_p $ brrform 0x17 1 cmp _ = ins "cmp" csv2 $ mformi' 0x18 cmpi dict = ins "cmpi" (csv2i dict) $ lformi 0x19 0 0 0 -- instruction formats aform opcd c d cond rd ra rb = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(rb,11),(free,2),(c,1),(d,0)] where free = 0 aformi opcd s c d cond rd ra imm = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(imm,3),(s,2),(c,1),(d,0)] aformi' opcd s c d cond rd ra = aformi opcd s c d cond rd ra 0 lformi opcd hl f d cond rd imm = pack [(cond,28),(opcd,23),(rd,19),(imm,3),(hl,2),(f,1),(d,0)] lformi' opcd hl s cond rd imm = lformi opcd s hl 0 cond rd imm lformi'not opcd cond rd = lformi opcd 0 1 0 cond rd 0xffff mformi opcd cond rd disp ra = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(disp,0)] mformi' opcd cond rd = mformi opcd cond rd 0 bform opcd typ s cond bp imm = pack [(cond,28),(opcd,23),(imm,7),(free,4),(typ,2),(bp,1),(s,0)] where free = 0 bform' opcd typ cond bp = bform opcd typ 0 cond bp 0 sform opcd typ cond rd = pack [(cond,28),(opcd,23),(rd,19),(typ,17)] sform' opcd typ rd cond = sform opcd typ cond rd brrform opcd typ cond ra = pack [(cond,28),(opcd,23),(ra,19),(typ,2)] shiform opcd lr a c d cond rd ra imm = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(imm,10),(lr,3),(a,2),(c,1),(d,0)] -- bit-packing -- pack bf = foldr1 (.|.) $ map (uncurry rotateL) bf -- condition table conds :: [(String,Word32)] conds = [ ("nq", 0x0), ("nz", 0x0), ("eq", 0x1), ("zs", 0x1), ("no", 0x2), ("ov", 0x3), ("nc", 0x4), ("ae", 0x4), ("cs", 0x5), ("bl", 0x5), ("ns", 0x6), ("nn", 0x6), ("ss", 0x7), ("ns", 0x7), ("ab", 0x8), ("be", 0x9), ("ge", 0xa), ("lt", 0xb), ("gt", 0xc), ("le", 0xd), ("nv", 0xf), ("", 0xe) -- always ]