3a_asm/DT.hs

   1 {-   `Deep Thought', a softcore CPU implemented on a FPGA
   2
   3     Copyright (C) 2010 Markus Hofstaetter <markus.manrow@gmx.at>
   4     Copyright (C) 2010 Martin Perner <e0725782@student.tuwien.ac.at>
   5     Copyright (C) 2010 Stefan Rebernig <stefan.rebernig@gmail.com>
   6     Copyright (C) 2010 Manfred Schwarz <e0725898@student.tuwien.ac.at>
   7     Copyright (C) 2010 Bernhard Urban <lewurm@gmail.com>
   8
   9     This program is free software: you can redistribute it and/or modify
  10     it under the terms of the GNU General Public License as published by
  11     the Free Software Foundation, either version 3 of the License, or
  12     (at your option) any later version.
  13
  14     This program is distributed in the hope that it will be useful,
  15     but WITHOUT ANY WARRANTY; without even the implied warranty of
  16     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17     GNU General Public License for more details.
  18
  19     You should have received a copy of the GNU General Public License
  20     along with this program.  If not, see <http://www.gnu.org/licenses/>. -}
  21
  22 module DT where
  23
  24 import DTFormat
  25 import Expr_eval
  26
  27 import Prelude hiding (not,and,or)
  28
  29 import Data.Bits hiding (xor)
  30 import qualified Data.Map as Map
  31 import Data.Word
  32 import Text.Printf
  33 import Text.Parsec
  34 import Text.Parsec.String
  35 import Text.Parsec.Combinator
  36 import Control.Monad
  37 import Control.Applicative hiding ((<|>))
  38
  39
  40 -- parsing --
  41 instruction :: LineNo -> Dict -> Parser Word32
  42 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).")
  43
  44 testins :: String -> IO ()
  45 testins input =
  46         case (parse (instruction 0 dict) "" (input++"\n")) of
  47                 Left err -> do { putStr "fail :/\n"; print err}
  48                 Right x -> do { printf "0x%08X\n" x }
  49         where
  50         dict = (0x8000,[("lolz", 0x1337), ("rofl", 0xaaaa)])
  51
  52
  53 comma = char ','
  54 mnem m = string m
  55
  56 iLabel :: Dict -> Parser Word32
  57 -- TODO: save msb (=sign) correctly...
  58 iLabel d@(aktadr,_) = do {i <- (iLit d); return $ ((i - aktadr)`div`4) .&. 0xffff}
  59
  60 iLit :: Dict -> Parser Word32
  61 iLit (_,d) = do
  62         parseMySpaces
  63         val <- expr d;
  64         try (do {
  65                 string "@hi"; parseMySpaces;
  66                 return $ shiftR val 16
  67         }) <|> do {
  68                 string "@lo"; parseMySpaces;
  69                 return $ val .&. 0xffff
  70         } <|> do {parseMySpaces; return val}
  71
  72
  73 iLit5  d = do i <- iLit d; return $ i .&. 0x001f
  74 iLit12 d = do i <- iLit d; return $ i .&. 0x0fff
  75 iLit15 d = do i <- iLit d; return $ i .&. 0x7fff
  76 iLit16 d = do i <- iLit d; return $ i .&. 0xffff
  77
  78 imm4 :: Parser String
  79 imm4 = do
  80         try (do a <- digit; b <- digit; return $ [a,b]) <|> (do a <- digit; return $ [a])
  81
  82 read4imm :: String -> Word32
  83 read4imm s = if erg > 15 then error "invalid register" else erg
  84         where erg = read s
  85
  86 reg :: Parser Word32
  87 reg = do {parseMySpaces; string "r"; ret <- liftM read4imm (imm4); parseMySpaces; return ret}
  88
  89 condition :: Parser Word32
  90 condition = do
  91         str <- foldl1 (<|>) (fmap (try . string . fst) conds)
  92         let (Just ret) = lookup str conds
  93         return $ ret
  94
  95 carry :: Parser Word32
  96 carry = do { char 'c'; return 1} <|> do {string ""; return 0}
  97
  98 updateDisable :: Parser Word32
  99 updateDisable = do { char 'd'; return 1} <|> do {string ""; return 0}
 100
 101 highonly :: Parser Word32
 102 highonly = do { char 'h'; return 1} <|> do {string ""; return 0}
 103
 104 highlow :: Parser Word32
 105 highlow = do { char 'h'; return 1} <|> do {char 'l'; return 0} <|> do {string ""; return 0}
 106
 107 fill :: Parser Word32
 108 fill = do { char 'f'; return 1} <|> do {string ""; return 0}
 109
 110 sign :: Parser Word32
 111 sign = do { char 's'; return 1} <|> do {string ""; return 0}
 112
 113 branchpred :: Parser Word32
 114 branchpred = do
 115         x <- do { char '+'; return 1} <|> do {char '-'; return 0} <|> do {string ""; return 0}
 116         parseMySpaces
 117         return x
 118
 119 shiftArith :: Parser Word32
 120 shiftArith = do { char 'a'; return 1} <|> do {string ""; return 0}
 121
 122 parseBracketClose :: Parser Char
 123 parseBracketClose = do { c <- char ')'; parseMySpaces; return c}
 124
 125 (<.>) p n = p<*comma<*>n
 126 (<%>) p n = p<*space<*>n
 127 (<@>) p n = p<*char '('<*>n<*parseBracketClose
 128 infixl 1 <.>
 129 infixl 1 <%>
 130 infixl 1 <@>
 131
 132 ins m form e  = do {mnem m; form e}
 133 csv0i_p dict f = f<$>condition<*>branchpred<*>(iLabel dict)
 134 csv0i_p' f = f<$>condition<*>branchpred
 135 csv1 f = f<$>condition<%>reg
 136 csv1' f = f<$>condition
 137 csv1_p f = f<$>condition<%>reg
 138 csv2 f = f<$>condition<%>reg<.>reg
 139 csv2i dict f = f<$>condition<%>reg<.>(iLit16 dict)
 140 csv2_scd f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg
 141 csv2m dict f = f<$>condition<%>reg<.>(iLit15 dict)<@>reg
 142 csv2i_cd dict f = f<$>carry<*>updateDisable<*>condition<%>reg<.>reg<.>(iLit5 dict)
 143 csv2i_d dict f = f<$>updateDisable<*>condition<%>reg<.>reg<.>(iLit5 dict)
 144 csv2i_scd dict f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg<.>(iLit12 dict)
 145 csv2i_sl dict f = f<$>highonly<*>sign<*>condition<%>reg<.>(iLit16 dict)
 146 csv2i_sl' dict f = f<$>sign<*>condition<%>reg<.>(iLit16 dict)
 147 csv2i_lfd dict f = f<$>highlow<*>fill<*>updateDisable<*>condition<%>reg<.>(iLit16 dict)
 148 csv3_cd f = f<$>carry<*>updateDisable<*>condition<%>reg<.>reg<.>reg
 149 csv3_d f = f<$>updateDisable<*>condition<%>reg<.>reg<.>reg
 150
 151 instructions = [add, addi, mov, sub, subi,
 152         and, andx, or, orx, xor, xorx, not,
 153         lls, lrs, ars,
 154         pop, push, disc, fetch,
 155         movpf, movsf, movpt, movst,
 156         ldh, ldb, ldw, ldi, ldil,
 157         stw, sth, stb,
 158         ldx, stx,
 159         br, ret, call, reti,
 160         brr, callr,
 161         cmp, cmpi
 162         ]
 163
 164 -- arithmetic
 165 add _ = ins "add" csv3_cd $ aform 0x00
 166 addi dict = ins "addi" (csv2i_scd dict) $ aformi 0x02
 167 mov _ = ins "mov" csv2_scd $ aformi' 0x02
 168 sub _ = ins "sub" csv3_cd $ aform 0x01
 169 subi dict = ins "subi" (csv2i_scd dict) $ aformi 0x03
 170 -- logic
 171 and _ = ins "and" csv3_d $ aform 0x04 0
 172 andx dict = ins "andx" (csv2i_lfd dict) $ lformi 0x05
 173 or _ = ins "or" csv3_d $ aform 0x06 0
 174 orx dict = ins "orx" (csv2i_lfd dict) $ lformi 0x07
 175 xor _ = ins "xor" csv3_d $ aform 0x08 0
 176 xorx dict = ins "xorx" (csv2i_lfd dict) $ lformi 0x09
 177 not _ = ins "not" csv1 $ lformi'not 0x09
 178 lls dict = ins "lls" (csv2i_cd dict) $ shiform 0x0a 0 0
 179 lrs dict = ins "lrs" (csv2i_cd dict) $ shiform 0x0a 1 0
 180 ars dict = ins "ars" (csv2i_d dict) $ shiform 0x0a 1 1 0
 181 -- memory
 182 pop _ = ins "pop" csv1 $ sform 0x0b 0x0
 183 disc _ = ins "disc" csv1' $ sform' 0x0b 0x1 0
 184 fetch _ = ins "fetch" csv1 $ sform 0x0b 0x2
 185 push _ = ins "push" csv1 $ sform 0x0b 0x3
 186 movpf _ = ins "movpf" csv1 $ sform 0x0c 0x2
 187 movsf _ = ins "movsf" csv1 $ sform 0x0c 0x0
 188 movpt _ = ins "movpt" csv1 $ sform 0x0d 0x2
 189 movst _ = ins "movst" csv1 $ sform 0x0d 0x0
 190 ldw dict = ins "ldw" (csv2m dict) $ mformi 0x0e
 191 ldh dict = ins "ldh" (csv2m dict) $ mformi 0x10
 192 ldb dict = ins "ldb" (csv2m dict) $ mformi 0x12
 193 ldi dict = ins "ldi" (csv2i_sl dict) $ lformi' 0x1a
 194 ldil dict = ins "ldil" (csv2i_sl' dict) $ lformi' 0x1a 0
 195 stw dict = ins "stw" (csv2m dict) $ mformi 0x0f
 196 sth dict = ins "sth" (csv2m dict) $ mformi 0x11
 197 stb dict = ins "stb" (csv2m dict) $ mformi 0x13
 198 ldx dict = ins "ldx" (csv2m dict) $ mformi 0x14
 199 stx dict = ins "stx" (csv2m dict) $ mformi 0x15
 200 -- misc
 201 -- set signed by default! in very rare cases this can be an issue.
 202 br dict = ins "br" (csv0i_p dict) $ bform 0x16 0x0 1
 203 call dict = ins "call" (csv0i_p dict) $ bform 0x16 0x1 1
 204 ret _ = ins "ret" csv0i_p' $ bform' 0x16 0x2
 205 reti _ = ins "reti" csv0i_p' $ bform' 0x16 0x3
 206 brr _ = ins "brr" csv1_p $ brrform 0x17 0
 207 callr _ = ins "callr" csv1_p $ brrform 0x17 1
 208 cmp _ = ins "cmp" csv2 $ mformi' 0x18
 209 cmpi dict = ins "cmpi" (csv2i dict) $ lformi 0x19 0 0 0
 210
 211 -- instruction formats
 212 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)]
 213         where free = 0
 214
 215 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)]
 216 aformi' opcd s c d cond rd ra = aformi opcd s c d cond rd ra 0
 217
 218 lformi opcd hl f d cond rd imm = pack [(cond,28),(opcd,23),(rd,19),(imm,3),(hl,2),(f,1),(d,0)]
 219 lformi' opcd hl s cond rd imm = lformi opcd s hl 0 cond rd imm
 220 lformi'not opcd cond rd = lformi opcd 0 1 0 cond rd 0xffff
 221
 222 mformi opcd cond rd disp ra = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(disp,0)]
 223 mformi' opcd cond rd = mformi opcd cond rd 0
 224
 225 bform opcd typ s cond bp imm = pack [(cond,28),(opcd,23),(imm,7),(free,4),(typ,2),(bp,1),(s,0)]
 226         where free = 0
 227 bform' opcd typ cond bp = bform opcd typ 0 cond bp 0
 228
 229 sform opcd typ cond rd = pack [(cond,28),(opcd,23),(rd,19),(typ,17)]
 230 sform' opcd typ rd cond = sform opcd typ cond rd
 231
 232 brrform opcd typ cond ra = pack [(cond,28),(opcd,23),(ra,19),(typ,2)]
 233
 234 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)]
 235
 236 -- bit-packing --
 237 pack bf = foldr1 (.|.) $ map (uncurry rotateL) bf
 238
 239 -- condition table
 240 conds :: [(String,Word32)]
 241 conds = [
 242         ("nq", 0x0), ("nz", 0x0),
 243         ("eq", 0x1), ("zs", 0x1),
 244         ("no", 0x2),
 245         ("ov", 0x3),
 246         ("nc", 0x4), ("ae", 0x4),
 247         ("cs", 0x5), ("bl", 0x5),
 248         ("ns", 0x6), ("nn", 0x6),
 249         ("ss", 0x7), ("ns", 0x7),
 250         ("ab", 0x8),
 251         ("be", 0x9),
 252         ("ge", 0xa),
 253         ("lt", 0xb),
 254         ("gt", 0xc),
 255         ("le", 0xd),
 256         ("nv", 0xf),
 257         ("", 0xe) -- always
 258         ]