3a_asm/DT.hs

   1 module DT where
   2
   3 import DTFormat
   4 import Expr_eval
   5
   6 import Prelude hiding (not,and,or)
   7
   8 import Data.Bits hiding (xor)
   9 import qualified Data.Map as Map
  10 import Data.Word
  11 import Text.Printf
  12 import Text.Parsec
  13 import Text.Parsec.String
  14 import Text.Parsec.Combinator
  15 import Control.Monad
  16 import Control.Applicative hiding ((<|>))
  17
  18
  19 -- parsing --
  20 instruction :: Dict -> Parser Word32
  21 instruction dict = foldl1 (<|>) (fmap (\x -> try (x dict)) instructions) <* char '\n'
  22
  23 testins :: String -> IO ()
  24 testins input =
  25         case (parse (instruction dict) "" (input++"\n")) of
  26                 Left err -> do { putStr "fail :/\n"; print err}
  27                 Right x -> do { printf "0x%08X\n" x }
  28         where
  29         dict = (0x8000,[("lolz", 0x1337), ("rofl", 0xaaaa)])
  30
  31
  32 comma = char ','
  33 mnem m = string m
  34
  35 iLabel :: Dict -> Parser Word32
  36 -- TODO: save msb (=sign) correctly...
  37 iLabel d@(aktadr,_) = do {i <- (iLit d); return $ ((i - aktadr)`div`4) .&. 0xffff}
  38
  39 iLit :: Dict -> Parser Word32
  40 iLit (_,d) = do
  41         val <- expr d;
  42         try (do {
  43                 string "@hi"; parseMySpaces;
  44                 return $ shiftR val 16
  45         }) <|> do {
  46                 string "@lo"; parseMySpaces;
  47                 return $ val .&. 0xffff
  48         } <|> do {parseMySpaces; return val}
  49
  50
  51 iLit5  d = do i <- iLit d; return $ i .&. 0x001f
  52 iLit12 d = do i <- iLit d; return $ i .&. 0x0fff
  53 iLit15 d = do i <- iLit d; return $ i .&. 0x7fff
  54 iLit16 d = do i <- iLit d; return $ i .&. 0xffff
  55
  56 imm4 :: Parser String
  57 imm4 = do
  58         try (do a <- digit; b <- digit; return $ [a,b]) <|> (do a <- digit; return $ [a])
  59
  60 read4imm :: String -> Word32
  61 read4imm s = if erg > 15 then error "invalid register" else erg
  62         where erg = read s
  63
  64 reg :: Parser Word32
  65 reg = do {parseMySpaces; string "r"; ret <- liftM read4imm (imm4); parseMySpaces; return ret}
  66
  67 condition :: Parser Word32
  68 condition = do
  69         str <- foldl1 (<|>) (fmap (try . string . fst) conds)
  70         let (Just ret) = lookup str conds
  71         return $ ret
  72
  73 carry :: Parser Word32
  74 carry = do { char 'c'; return 1} <|> do {string ""; return 0}
  75
  76 updateDisable :: Parser Word32
  77 updateDisable = do { char 'd'; return 1} <|> do {string ""; return 0}
  78
  79 highlow :: Parser Word32
  80 highlow = do { char 'h'; return 1} <|> do {char 'l'; return 0} <|> do {string ""; return 0}
  81
  82 fill :: Parser Word32
  83 fill = do { char 'f'; return 1} <|> do {string ""; return 0}
  84
  85 sign :: Parser Word32
  86 sign = do { char 's'; return 1} <|> do {string ""; return 0}
  87
  88 branchpred :: Parser Word32
  89 branchpred = do
  90         x <- do { char '+'; return 1} <|> do {char '-'; return 0} <|> do {string ""; return 0}
  91         parseMySpaces
  92         return x
  93
  94 shiftArith :: Parser Word32
  95 shiftArith = do { char 'a'; return 1} <|> do {string ""; return 0}
  96
  97 parseBracketClose :: Parser Char
  98 parseBracketClose = do { c <- char ')'; parseMySpaces; return c}
  99
 100 (<.>) p n = p<*comma<*>n
 101 (<%>) p n = p<*space<*>n
 102 (<@>) p n = p<*char '('<*>n<*parseBracketClose
 103 infixl 1 <.>
 104 infixl 1 <%>
 105 infixl 1 <@>
 106
 107 ins m form e  = do {mnem m; form e}
 108 csv0i_p dict f = f<$>condition<*>branchpred<*>(iLabel dict)
 109 csv0i_p' f = f<$>condition<*>branchpred
 110 csv1 f = f<$>condition<%>reg
 111 csv1_p f = f<$>condition<%>reg
 112 csv2 f = f<$>condition<%>reg<.>reg
 113 csv2i dict f = f<$>condition<%>reg<.>(iLit16 dict)
 114 csv2_scd f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg
 115 csv2m dict f = f<$>condition<%>reg<.>(iLit15 dict)<@>reg
 116 csv2i_cd dict f = f<$>carry<*>updateDisable<*>condition<%>reg<.>reg<.>(iLit5 dict)
 117 csv2i_d dict f = f<$>updateDisable<*>condition<%>reg<.>reg<.>(iLit5 dict)
 118 csv2i_scd dict f = f<$>sign<*>carry<*>updateDisable<*>condition<%>reg<.>reg<.>(iLit12 dict)
 119 csv2i_sl dict f = f<$>sign<*>highlow<*>condition<%>reg<.>(iLit16 dict)
 120 csv2i_lfd dict f = f<$>highlow<*>fill<*>updateDisable<*>condition<%>reg<.>(iLit16 dict)
 121 csv3_cd f = f<$>carry<*>updateDisable<*>condition<%>reg<.>reg<.>reg
 122 csv3_d f = f<$>updateDisable<*>condition<%>reg<.>reg<.>reg
 123
 124 instructions = [add, addi, mov, sub, subi,
 125         and, andx, or, orx, xor, xorx, not,
 126         lls, lrs, ars,
 127         pop, push, disc, fetch,
 128         movpf, movsf, movpt, movst,
 129         ldh, ldb, ldw, ldi,
 130         stw, sth, stb,
 131         ldx, stx,
 132         br, ret, call, reti,
 133         brr, callr,
 134         cmp, cmpi
 135         ]
 136
 137 -- arithmetic
 138 add _ = ins "add" csv3_cd $ aform 0x00
 139 addi dict = ins "addi" (csv2i_scd dict) $ aformi 0x02
 140 mov _ = ins "mov" csv2_scd $ aformi' 0x02
 141 sub _ = ins "sub" csv3_cd $ aform 0x01
 142 subi dict = ins "subi" (csv2i_scd dict) $ aformi 0x03
 143 -- logic
 144 and _ = ins "and" csv3_d $ aform 0x04 0
 145 andx dict = ins "andx" (csv2i_lfd dict) $ lformi 0x05
 146 or _ = ins "or" csv3_d $ aform 0x06 0
 147 orx dict = ins "orx" (csv2i_lfd dict) $ lformi 0x07
 148 xor _ = ins "xor" csv3_d $ aform 0x08 0
 149 xorx dict = ins "xorx" (csv2i_lfd dict) $ lformi 0x09
 150 not _ = ins "not" csv1 $ lformi'not 0x09
 151 lls dict = ins "lls" (csv2i_cd dict) $ shiform 0x0a 0 0
 152 lrs dict = ins "lrs" (csv2i_cd dict) $ shiform 0x0a 1 0
 153 ars dict = ins "ars" (csv2i_d dict) $ shiform 0x0a 1 1 0
 154 -- memory
 155 pop _ = ins "pop" csv1 $ sform 0x0b 0x0
 156 disc _ = ins "disc" csv1 $ sform 0x0b 0x1
 157 fetch _ = ins "fetch" csv1 $ sform 0x0b 0x2
 158 push _ = ins "push" csv1 $ sform 0x0b 0x3
 159 movpf _ = ins "movpf" csv1 $ sform 0x0c 0x2
 160 movsf _ = ins "movsf" csv1 $ sform 0x0c 0x0
 161 movpt _ = ins "movpt" csv1 $ sform 0x0d 0x2
 162 movst _ = ins "movst" csv1 $ sform 0x0d 0x0
 163 ldw dict = ins "ldw" (csv2m dict) $ mformi 0x0e
 164 ldh dict = ins "ldh" (csv2m dict) $ mformi 0x10
 165 ldb dict = ins "ldb" (csv2m dict) $ mformi 0x12
 166 ldi dict = ins "ldi" (csv2i_sl dict) $ lformi' 0x1a
 167 stw dict = ins "stw" (csv2m dict) $ mformi 0x0f
 168 sth dict = ins "sth" (csv2m dict) $ mformi 0x11
 169 stb dict = ins "stb" (csv2m dict) $ mformi 0x13
 170 ldx dict = ins "ldx" (csv2m dict) $ mformi 0x14
 171 stx dict = ins "stx" (csv2m dict) $ mformi 0x15
 172 -- misc
 173 -- set signed by default! in very rare cases this can be an issue.
 174 br dict = ins "br" (csv0i_p dict) $ bform 0x16 0x0 1
 175 call dict = ins "call" (csv0i_p dict) $ bform 0x16 0x1 1
 176 ret _ = ins "ret" csv0i_p' $ bform' 0x16 0x2
 177 reti _ = ins "reti" csv0i_p' $ bform' 0x16 0x3
 178 brr _ = ins "brr" csv1_p $ brrform 0x17 0
 179 callr _ = ins "callr" csv1_p $ brrform 0x17 1
 180 cmp _ = ins "cmp" csv2 $ mformi' 0x18
 181 cmpi dict = ins "cmpi" (csv2i dict) $ lformi 0x19 0 0 0
 182
 183 -- instruction formats
 184 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)]
 185         where free = 0
 186
 187 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)]
 188 aformi' opcd s c d cond rd ra = aformi opcd s c d cond rd ra 0
 189
 190 lformi opcd hl f d cond rd imm = pack [(cond,28),(opcd,23),(rd,19),(imm,3),(hl,2),(f,1),(d,0)]
 191 lformi' opcd s hl cond rd imm = lformi opcd s hl 0 cond rd imm
 192 lformi'not opcd cond rd = lformi opcd 0 1 0 cond rd 0xefffffff
 193
 194 mformi opcd cond rd disp ra = pack [(cond,28),(opcd,23),(rd,19),(ra,15),(disp,0)]
 195 mformi' opcd cond rd = mformi opcd cond rd 0
 196
 197 bform opcd typ s cond bp imm = pack [(cond,28),(opcd,23),(imm,7),(free,4),(typ,2),(bp,1),(s,0)]
 198         where free = 0
 199 bform' opcd typ cond bp = bform opcd typ 0 cond bp 0
 200
 201 sform opcd typ cond rd = pack [(cond,28),(opcd,23),(rd,19),(typ,17)]
 202
 203 brrform opcd typ cond ra = pack [(cond,28),(opcd,23),(ra,19),(typ,2)]
 204
 205 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)]
 206
 207 -- ppc64 stuff (TODO: remove)
 208 iform opcd aa lk li = pack [(opcd,6),(li,30),(aa,31),(lk,0)]
 209 scform opcd lev = pack [(opcd,6),(lev,27),(1,31)]
 210 dform'b opcd bf l ra si = pack [(opcd,6),(bf,9),(0,10),(l,11),(ra,16),(si,0)]
 211 dsform opcd rt ra ds xo = pack [(opcd,6),(rt,11),(ra,16),(ds,30),(xo,0)]
 212 xform'a opcd rt ra rb xo = pack [(opcd,6),(rt,11),(ra,16),(rb,21),(xo,31)]
 213 xform'b opcd xo bf l ra rb = pack [(opcd,6),(bf,9),(0,10),(l,11),(ra,16),(rb,21),(xo,31),(0,0)]
 214 xform'c opcd xo rs ra rb rc = pack [(opcd,6),(rs,11),(ra,16),(rb,21),(xo,31),(rc,0)]
 215 xform'd opcd xo rc rs ra = pack [(opcd,6),(rs,11),(ra,16),(0,21),(xo,31),(rc,0)]
 216 xlform'a opcd xo bt ba bb = pack [(opcd,6),(bt,11),(ba,16),(bb,21),(xo,31)]
 217 xlform'b opcd xo lk bo bi bh = pack [(opcd,6),(bo,11),(bi,16),(bh,21),(xo,31),(lk,0)]
 218 xlform'c opcd xo bf bfa = pack [(opcd,6),(bf,9),(bfa,14),(xo,31)]
 219 xfxform opcd xo rs spr = pack [(opcd,6),(rs,11),(spr,21),(xo,31)]
 220 xfxform'b opcd h xo fxm rs = pack [(opcd,6),(rs,11),(h,12),(fxm,20),(xo,31)]
 221 --xflform
 222 -- fix xsform
 223 xsform opcd xo rc ra rs sh = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(xo,30),(sh,31),(rc,0)]
 224 xoform' opcd xo oe rc rt ra = pack [(opcd,6),(rt,11),(ra,16),(0,21),(oe,22),(xo,31),(rc,0)]
 225 --aform
 226 mform opcd rc ra rs sh mb me = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(mb,26),(me,31),(rc,0)]
 227 -- mdform needs to be fixed to handle sh correctly
 228 mdform opcd h rc ra rs sh mb = pack [(opcd,6),(rs,11),(ra,16),(sh,21),(mb,27),(h,30),(sh,31),(rc,0)]
 229 mdsform opcd h rc ra rs rb mb = pack [(opcd,6),(rs,11),(ra,16),(rb,21),(mb,27),(h,31),(rc,0)]
 230
 231 -- bit-packing --
 232 pack bf = foldr1 (.|.) $ map (uncurry rotateL) bf
 233
 234 -- condition table
 235 conds :: [(String,Word32)]
 236 conds = [
 237         ("nq", 0x0), ("nz", 0x0),
 238         ("eq", 0x1), ("zs", 0x1),
 239         ("no", 0x2),
 240         ("ov", 0x3),
 241         ("nc", 0x4), ("ae", 0x4),
 242         ("cs", 0x5), ("bl", 0x5),
 243         ("ns", 0x6), ("nn", 0x6),
 244         ("ss", 0x7), ("ns", 0x7),
 245         ("ab", 0x8),
 246         ("be", 0x9),
 247         ("ge", 0xa),
 248         ("lt", 0xb),
 249         ("gt", 0xc),
 250         ("le", 0xd),
 251         ("nv", 0xf),
 252         ("", 0xe) -- always
 253         ]