6 import Prelude hiding (not,and,or)
8 import Data.Bits hiding (xor)
9 import qualified Data.Map as Map
13 import Text.Parsec.String
14 import Text.Parsec.Combinator
16 import Control.Applicative hiding ((<|>))
20 instruction :: Dict -> Parser Word32
21 instruction dict = foldl1 (<|>) (fmap (\x -> try (x dict)) instructions) <* char '\n'
23 testins :: String -> IO ()
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 }
29 dict = (0x8000,[("lolz", 0x1337), ("rofl", 0xaaaa)])
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}
39 iLit :: Dict -> Parser Word32
43 string "@hi"; parseMySpaces;
44 return $ shiftR val 16
46 string "@lo"; parseMySpaces;
47 return $ val .&. 0xffff
48 } <|> do {parseMySpaces; return val}
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
58 try (do a <- digit; b <- digit; return $ [a,b]) <|> (do a <- digit; return $ [a])
60 read4imm :: String -> Word32
61 read4imm s = if erg > 15 then error "invalid register" else erg
65 reg = do {parseMySpaces; string "r"; ret <- liftM read4imm (imm4); parseMySpaces; return ret}
67 condition :: Parser Word32
69 str <- foldl1 (<|>) (fmap (try . string . fst) conds)
70 let (Just ret) = lookup str conds
73 hlcondition :: Parser (Word32,Word32)
74 hlcondition = try(do {
78 hl <- highlow; c <- condition;
80 } <?> "DO NOT USE ldil (you can skip 'l' [low], since it is default)"
82 carry :: Parser Word32
83 carry = do { char 'c'; return 1} <|> do {string ""; return 0}
85 updateDisable :: Parser Word32
86 updateDisable = do { char 'd'; return 1} <|> do {string ""; return 0}
88 highlow :: Parser Word32
89 highlow = do { char 'h'; return 1} <|> do {char 'l'; return 0} <|> do {string ""; return 0}
92 fill = do { char 'f'; return 1} <|> do {string ""; return 0}
95 sign = do { char 's'; return 1} <|> do {string ""; return 0}
97 branchpred :: Parser Word32
99 x <- do { char '+'; return 1} <|> do {char '-'; return 0} <|> do {string ""; return 0}
103 shiftArith :: Parser Word32
104 shiftArith = do { char 'a'; return 1} <|> do {string ""; return 0}
106 parseBracketClose :: Parser Char
107 parseBracketClose = do { c <- char ')'; parseMySpaces; return c}
109 (<.>) p n = p<*comma<*>n
110 (<%>) p n = p<*space<*>n
111 (<@>) p n = p<*char '('<*>n<*parseBracketClose
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
133 instructions = [add, addi, mov, sub, subi,
134 and, andx, or, orx, xor, xorx, not,
136 pop, push, disc, fetch,
137 movpf, movsf, movpt, movst,
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
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
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
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
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)]
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
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
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
206 bform opcd typ s cond bp imm = pack [(cond,28),(opcd,23),(imm,7),(free,4),(typ,2),(bp,1),(s,0)]
208 bform' opcd typ cond bp = bform opcd typ 0 cond bp 0
210 sform opcd typ cond rd = pack [(cond,28),(opcd,23),(rd,19),(typ,17)]
212 brrform opcd typ cond ra = pack [(cond,28),(opcd,23),(ra,19),(typ,2)]
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)]
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)]
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)]
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)]
241 pack bf = foldr1 (.|.) $ map (uncurry rotateL) bf
244 conds :: [(String,Word32)]
246 ("nq", 0x0), ("nz", 0x0),
247 ("eq", 0x1), ("zs", 0x1),
250 ("nc", 0x4), ("ae", 0x4),
251 ("cs", 0x5), ("bl", 0x5),
252 ("ns", 0x6), ("nn", 0x6),
253 ("ss", 0x7), ("ns", 0x7),