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