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