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