3a_asm/DT.hs

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