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