3a_asm/DT.hs

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