1(* interactive use: 2 val _ = loadPath := !loadPath @ 3 ["/local/scratch/acjf3/hol98/tools/mlyacc/mlyacclib", 4 "/local/scratch/acjf3/hol98/tools/mlton/pre", 5 "/local/scratch/acjf3/hol98/src/portableML"]; 6 val _ = load "armParser.grm"; 7 val _ = load "armParser.lex"; 8 val _ = app load ["Arbnum", "Nonstdio", "Data"]; 9*) 10 11structure assemblerML :> assemblerML = 12struct 13 14structure armLrVals = 15 armLrValsFun(structure Token = LrParser.Token) 16 17structure armLex = 18 armLexFun(structure Tokens = armLrVals.Tokens) 19 20structure armParser = 21 Join(structure ParserData = armLrVals.ParserData 22 structure Lex = armLex 23 structure LrParser = LrParser) 24 25open Data; 26 27(* ------------------------------------------------------------------------- *) 28 29fun mem i = 30 let fun itr [] = false 31 | itr (a::rst) = i=a orelse itr rst 32 in itr end; 33 34fun I x = x; 35 36fun funpow n f x = 37 let fun iter (0,res) = res 38 | iter (n,res) = iter (n-1, f res) 39 in if n<0 then x else iter(n,x) 40 end; 41 42fun fst (x,_) = x and snd (_,y) = y; 43 44(* ------------------------------------------------------------------------- *) 45 46local 47 fun rnum2list l n = 48 if l = 0 then 49 [] 50 else if n = Arbnum.zero then 51 List.tabulate(l,fn x => false) 52 else 53 (rnum2list (l - 1) (Arbnum.div2 n)) @ [Arbnum.mod2 n = Arbnum.one] 54in 55 fun num2list l n = rev (rnum2list l n) 56end; 57 58local 59 fun llist2num [] n = n 60 | llist2num (x::xs) n = 61 llist2num xs ((if x then Arbnum.plus1 else I) (Arbnum.times2 n)) 62in 63 fun list2num l = llist2num (rev l) Arbnum.zero 64end; 65 66val list2int = Arbnum.toInt o list2num; 67 68fun bits h l (n:bool list) = List.take(List.drop(n,l),h + 1 - l); 69fun bit b n = (bits b b n = [true]); 70 71fun sign_extend l h n = 72 let open Arbnum 73 val ln = fromInt l 74 val exp_l_sub1 = pow(two, ln - one) 75 val exp_l = exp_l_sub1 * two 76 val m = n mod exp_l 77 in 78 if mod2 (n div exp_l_sub1) = one then 79 pow(two, fromInt h) - exp_l + m 80 else 81 m 82 end; 83 84(* ------------------------------------------------------------------------- *) 85 86val int2register = armLex.UserDeclarations.int2register; 87 88fun register2int r = 89 case r of 90 R0 => 0 | R1 => 1 | R2 => 2 | R3 => 3 91 | R4 => 4 | R5 => 5 | R6 => 6 | R7 => 7 92 | R8 => 8 | R9 => 9 | R10 => 10 | R11 => 11 93 | R12 => 12 | R13 => 13 | R14 => 14 | R15 => 15; 94 95fun reg2string (NReg r) = 96 let val n = register2int r in 97 case n of 98 13 => "sp" 99 | 14 => "lr" 100 | 15 => "pc" 101 | _ => "r" ^ Int.toString n 102 end 103 | reg2string (VReg x) = x; 104 105fun cp_reg2string (NReg r) = "c" ^ Int.toString (register2int r) 106 | cp_reg2string (VReg x) = x; 107 108fun cp_num2string n = "p" ^ Int.toString n; 109 110fun opcode2string opc = 111 case opc of 112 AND => "and" | EOR => "eor" | SUB => "sub" | RSB => "rsb" 113 | ADD => "add" | ADC => "adc" | SBC => "sbc" | RSC => "rsc" 114 | TST => "tst" | TEQ => "teq" | CMP => "cmp" | CMN => "cmn" 115 | ORR => "orr" | MOV => "mov" | BIC => "bic" | MVN => "mvn"; 116 117fun condition2string cond = 118 case cond of 119 EQ => "eq" | NE => "ne" | CS => "cs" | CC => "cc" 120 | MI => "mi" | PL => "pl" | VS => "vs" | VC => "vc" 121 | HI => "hi" | LS => "ls" | GE => "ge" | LT => "lt" 122 | GT => "gt" | LE => "le" | AL => "" | NV => "nv"; 123 124val list2register = NReg o int2register o list2int; 125 126fun list2opcode l = 127 case list2int l of 128 0 => AND | 1 => EOR | 2 => SUB | 3 => RSB 129 | 4 => ADD | 5 => ADC | 6 => SBC | 7 => RSC 130 | 8 => TST | 9 => TEQ | 10 => CMP | 11 => CMN 131 | 12 => ORR | 13 => MOV | 14 => BIC | 15 => MVN 132 | _ => raise Parse "list2opcode: not an opcode list"; 133 134fun list2condition l = 135 case list2int l of 136 0 => EQ | 1 => NE | 2 => CS | 3 => CC 137 | 4 => MI | 5 => PL | 6 => VS | 7 => VC 138 | 8 => HI | 9 => LS | 10 => GE | 11 => LT 139 | 12 => GT | 13 => LE | 14 => AL | 15 => NV 140 | _ => raise Parse "list2condition: not a condition code list"; 141 142fun list2shift l = 143 case list2int l of 144 0 => LSL | 1 => LSR | 2 => ASR | 3 => ROR 145 | _ => raise Parse "list2shift: not a shift list"; 146 147(* ------------------------------------------------------------------------- *) 148 149val Rn = list2register o bits 19 16; 150val Rd = list2register o bits 15 12; 151val Rs = list2register o bits 11 8; 152val Rm = list2register o bits 3 0; 153 154local 155 open Arbnum 156 fun smsb b = if b then pow(two,fromInt 31) else zero 157 fun mror32 x n = 158 if n = 0 then x 159 else mror32 ((div2 x) + smsb (mod2 x = one)) (Int.-(n, 1)) 160 fun ror32 x n = mror32 x (Int.mod(n, 32)) 161in 162 fun rol32 x n = ror32 x (Int.-(32,Int.mod(n, 32))) 163 fun mk_immediate rot imm = ror32 imm (Int.*(2, rot)) 164 fun dec_immediate l = 165 mk_immediate (list2int (bits 11 8 l)) (list2num (bits 7 0 l)) 166end; 167 168fun dec_shift_immediate l = 169let val imm = list2int (bits 11 7 l) in 170 {Rm = Rm l, Imm = imm, Sh = list2shift (bits 6 5 l)} 171end; 172 173(* ------------------------------------------------------------------------- *) 174 175fun dec_br l = 176 Br {L = bit 24 l, offset = Arbnum.toInt (list2num (bits 23 0 l))}; 177 178local 179 fun dec_shift_register l = 180 {Rm = Rm l, Rs = Rs l, Sh = list2shift (bits 6 5 l)} 181 182 fun dec_addr_mode1 l = 183 if bit 25 l then 184 DpImmediate (dec_immediate l) 185 else if bit 4 l then 186 DpShiftRegister (dec_shift_register l) 187 else 188 DpShiftImmediate (dec_shift_immediate l) 189in 190 fun dec_data_proc l = Data_proc 191 {opc = list2opcode (bits 24 21 l), S = bit 20 l, 192 Rn = Rn l, Rd = Rd l, op2 = dec_addr_mode1 l} 193end; 194 195fun dec_mla_mul l = Mla_mul 196 {L = bit 23 l, Signed = bit 22 l, A = bit 21 l, S = bit 20 l, 197 Rd = Rn l, Rn = Rd l, Rs = Rs l, Rm = Rm l}; 198 199local 200 fun dec_addr_mode3 l = 201 if bit 22 l then 202 DthImmediate (list2int ((bits 11 8 l) @ (bits 3 0 l))) 203 else 204 DthRegister (Rm l) 205in 206 fun dec_ldrh_strh l = Ldrh_strh 207 {P = bit 24 l, U = bit 23 l, W = bit 21 l, L = bit 20 l, 208 S = bit 6 l, H = bit 5 l, Rn = Rn l, Rd = Rd l, offset = dec_addr_mode3 l} 209end; 210 211local 212 fun dec_addr_mode2 l = 213 if bit 25 l then 214 DtShiftImmediate (dec_shift_immediate l) 215 else 216 DtImmediate (list2int (bits 11 0 l)) 217in 218 fun dec_ldr_str l = Ldr_str 219 {P = bit 24 l, U = bit 23 l, B = bit 22 l, W = bit 21 l, L = bit 20 l, 220 Rn = Rn l, Rd = Rd l, offset = dec_addr_mode2 l} 221end; 222 223fun dec_ldm_stm l = Ldm_stm 224 {P = bit 24 l, U = bit 23 l, S = bit 22 l, W = bit 21 l, L = bit 20 l, 225 Rn = Rn l, list = list2int (bits 15 0 l)}; 226 227fun dec_swp l = Swp {B = bit 22 l, Rn = Rn l, Rd = Rd l, Rm = Rm l}; 228 229fun dec_mrs l = Mrs {R = bit 22 l, Rd = Rd l}; 230 231local 232 fun dec_msr_mode l = 233 if bit 25 l then 234 MsrImmediate (dec_immediate l) 235 else 236 MsrRegister (Rm l) 237in 238 fun dec_msr l = Msr 239 {R = bit 22 l, bit19 = bit 19 l, bit16 = bit 16 l, Op = dec_msr_mode l} 240end; 241 242fun dec_cdp l = Cdp 243 {Cop1 = list2int (bits 23 20 l), CRn = Rn l, CRd = Rd l, 244 CP = list2int (bits 11 8 l), Cop2 = list2int (bits 7 5 l), CRm = Rm l}; 245 246fun dec_mcr_mrc l = Mcr_mrc 247 {Cop1 = list2int (bits 23 21 l), L = bit 20 l, Rd = Rd l, CRn = Rn l, 248 CP = list2int (bits 11 8 l), CRm = Rm l, Cop2 = list2int (bits 7 5 l)}; 249 250fun dec_ldc_stc l = Ldc_stc 251 {P = bit 24 l, U = bit 23 l, N = bit 22 l, W = bit 21 l, L = bit 20 l, 252 CRd = Rd l, Rn = Rn l, CP = list2int (bits 11 8 l), 253 offset = list2int (bits 7 0 l)}; 254 255(* ------------------------------------------------------------------------- *) 256 257fun decode_inst l = 258 case rev (map (fn x => if x then 1 else 0) l) of 259 [0,0,1,1,0,_,1,0,_,_,_,_,1,1,1,1,_,_,_,_,_,_,_,_,_,_,_,_] => dec_msr l 260 | [0,0,0,1,0,_,1,0,_,_,_,_,1,1,1,1,0,0,0,0,0,0,0,0,_,_,_,_] => dec_msr l 261 | [0,0,0,1,0,_,0,0,1,1,1,1,_,_,_,_,_,0,0,0,0,0,0,0,0,0,0,0] => dec_mrs l 262 | [0,0,0,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,1,0,0,1,_,_,_,_] => dec_mla_mul l 263 | [0,0,0,1,0,_,0,0,_,_,_,_,_,_,_,_,0,0,0,0,1,0,0,1,_,_,_,_] => dec_swp l 264 | [0,0,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,1,0,1,1,_,_,_,_] => dec_ldrh_strh l 265 | [0,0,0,_,_,_,_,1,_,_,_,_,_,_,_,_,_,_,_,_,1,1,_,1,_,_,_,_] => dec_ldrh_strh l 266 | [0,1,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_] => dec_ldr_str l 267 | [0,1,1,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,0,_,_,_,_] => dec_ldr_str l 268 | [1,0,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_] => dec_ldm_stm l 269 | [1,0,1,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_] => dec_br l 270 | [1,1,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_] => dec_ldc_stc l 271 | [1,1,1,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,0,_,_,_,_] => dec_cdp l 272 | [1,1,1,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,1,_,_,_,_] => dec_mcr_mrc l 273 | [1,1,1,1,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_] => Swi_ex 274 | [0,0,1,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_] => dec_data_proc l 275 | [0,0,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,0,_,_,_,_] => dec_data_proc l 276 | [0,0,0,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,0,_,_,1,_,_,_,_] => dec_data_proc l 277 | _ => Undef; 278 279fun num_to_arm n = 280let val l = num2list 32 n 281 val li = List.take(l,28) 282 val lc = List.drop(l,28) 283 val i = decode_inst li 284in 285 case i of 286 Undef => 287 if list2num li = Arbnum.fromHexString "6000010" then 288 Instruction (i, list2condition lc) 289 else 290 Data n 291 | _ => Instruction (i, list2condition lc) 292end; 293 294(* ------------------------------------------------------------------------- *) 295 296local open Arbnum 297 val max = pow(two, fromInt 32) 298in 299 fun num1comp n = (max - one) - n mod max 300 fun num2comp n = (max - n mod max) mod max 301 fun add32 a b = (a + b) mod max 302end; 303 304local 305 fun num2imm(x,n) = 306 let val x8 = Arbnum.mod(x,Arbnum.fromInt 256) in 307 if x8 = x then 308 (Arbnum.fromInt n, x8) 309 else 310 if n < 15 then 311 num2imm(rol32 x 2, n + 1) 312 else 313 raise Parse 314 "num2immediate: number cannot be represented as an immediate" 315 end 316in 317 fun num2immediate n = num2imm(n, 0) 318end; 319 320fun ipow2 x = Word.toInt (Word.<<(Word.fromInt 1,Word.fromInt x)) 321 322local 323 val n24 = ipow2 24 324in 325 fun validate_instruction (Data n) = Data n 326 | validate_instruction (ic as Instruction(i,c)) = 327 case i of 328 Br x => if #offset x <= n24 then ic else 329 raise BadInstruction "Branch offset too large" 330 | Data_proc x => 331 (case #op2 x of 332 DpImmediate n => 333 (let val _ = num2immediate n in ic end handle _ => 334 let val cn = num1comp n 335 fun copc a b = Instruction(Data_proc {opc = a, S = #S x, 336 Rd = #Rd x, Rn = #Rn x, op2 = DpImmediate b},c) 337 in 338 (case #opc x of 339 CMP => let val _ = num2immediate cn in copc CMN cn end 340 | CMN => let val _ = num2immediate cn in copc CMN cn end 341 | MOV => let val _ = num2immediate cn in copc MVN cn end 342 | MVN => let val _ = num2immediate cn in copc MOV cn end 343 | AND => let val _ = num2immediate cn in copc BIC cn end 344 | BIC => let val _ = num2immediate cn in copc AND cn end 345 | ADC => let val _ = num2immediate cn in copc SBC cn end 346 | SBC => let val _ = num2immediate cn in copc ADC cn end 347 | ADD => let val nn = num2comp n 348 val _ = num2immediate nn in copc SUB nn end 349 | SUB => let val nn = num2comp n 350 val _ = num2immediate nn in copc SUB nn end 351 | _ => raise BadInstruction 352 "Cannot represent the immediate value") 353 end handle _ => raise BadInstruction 354 "Cannot represent the immediate value") 355 | DpShiftImmediate y => if #Imm y < 32 then ic else 356 raise BadInstruction "Immediate shift value too large" 357 | DpShiftRegister y => ic) 358 | Ldrh_strh x => 359 (case #offset x of 360 DthImmediate n => if n < ipow2 8 then ic else 361 raise BadInstruction "Offset too large" 362 | _ => ic) 363 | Ldr_str x => 364 (case #offset x of 365 DtImmediate n => if n < ipow2 12 then ic else 366 raise BadInstruction "Offset too large" 367 | DtShiftImmediate y => if #Imm y < 32 then ic else 368 raise BadInstruction "Immediate shift value too large") 369 | Ldm_stm x => if #list x < ipow2 16 then ic else 370 raise BadInstruction "Block transfer list too long" 371 | Msr x => 372 (case #Op x of 373 MsrImmediate n => 374 (let val _ = num2immediate n in ic end handle _ => 375 raise BadInstruction "Cannot represent the immediate value") 376 | _ => ic) 377 | Cdp x => 378 if 15 < #CP x then raise BadInstruction "CP# too large" else 379 if 15 < #Cop1 x then raise BadInstruction "CP Opc too large" else 380 if 7 < #Cop2 x then raise BadInstruction "CP too large" else ic 381 | Mcr_mrc x => 382 if 15 < #CP x then raise BadInstruction "CP# too large" else 383 if 7 < #Cop1 x then raise BadInstruction "CP Opc too large" else 384 if 7 < #Cop2 x then raise BadInstruction "CP too large" else ic 385 | Ldc_stc x => 386 if 15 < #CP x then raise BadInstruction "CP# too large" else 387 if 255 < #offset x then raise BadInstruction "offset too large" else ic 388 | _ => ic; 389 390 fun branch_to_arm (c,link,address) line = 391 let open Arbnum 392 val n4 = fromInt 4 393 val n8 = fromInt 8 394 val jmp = add32 address (num2comp (line + n8)) 395 val offset = (jmp div n4) mod (fromInt n24) 396 val ok = (address = 397 add32 (line + n8) (sign_extend 24 32 offset * n4)) 398 in 399 if ok then 400 Instruction(Br {L = link, offset = toInt offset},c) 401 else 402 raise Data.Parse "Invalid branch instruction" 403 end; 404 405 fun assembler_to_instruction a = 406 case a of 407 [Code c] => c 408 | [Mark line,BranchN (c,link,address)] => 409 branch_to_arm (c,link,address) line 410 | [BranchN (c,link,address)] => 411 branch_to_arm (c,link,address) Arbnum.zero 412 | [Label s, BranchS (c,link,l)] => 413 if s = l then 414 Instruction(Br {L = link, 415 offset = Arbnum.toInt (Arbnum.fromHexString "FFFFFE")},c) 416 else 417 raise Data.Parse "Not an instruction" 418 | _ => raise Data.Parse "Not an instruction"; 419end; 420 421val armErr = ref TextIO.stdErr; 422 423fun invoke lexstream = let 424 fun print_error (s,i:int,_) = 425 TextIO.output(!armErr, Int.toString i ^ ": " ^ s ^ "\n") 426in 427 #1 (armParser.parse(0,lexstream,print_error,())) 428end; 429 430fun string_to_code s = let 431 val done = ref false 432 val lexer = armParser.makeLexer 433 (fn _ => if !done then "" else (s before done := true)) 434 val _ = armLex.UserDeclarations.pos := 1 435in 436 invoke lexer 437end; 438 439fun string_to_arm s = 440 (validate_instruction o assembler_to_instruction o string_to_code) s; 441 442fun read_stream strm = let 443 val lexer = armParser.makeLexer (fn _ => Portable.input_line strm) 444 val _ = armLex.UserDeclarations.pos := 1 445in 446 invoke lexer before TextIO.closeIn strm 447end; 448 449fun parse_arm fname = read_stream (TextIO.openIn fname); 450 451(* ------------------------------------------------------------------------- *) 452 453infix 0 <<; 454 455fun op << (x,y) = let open Arbnum in 456 x * pow(two, fromInt y) 457end; 458 459fun ibits h l n = 460 let val x = ipow2 l 461 val y = ipow2 (h + 1 - l) 462 in 463 Arbnum.fromInt ((n div x) mod y) 464 end; 465 466fun register_to_num (NReg n) = Arbnum.fromInt (register2int n) 467 | register_to_num (VReg x) = raise Parse 468 "register_to_num: register is a variable"; 469 470fun condition_to_num cond = Arbnum.fromInt 471 (case cond of 472 EQ => 0 | NE => 1 | CS => 2 | CC => 3 473 | MI => 4 | PL => 5 | VS => 6 | VC => 7 474 | HI => 8 | LS => 9 | GE => 10 | LT => 11 475 | GT => 12 | LE => 13 | AL => 14 | NV => 15) << 28; 476 477fun shift_to_num (s,r) = 478 Arbnum.+(register_to_num r,Arbnum.fromHexString 479 (case s of 480 LSL => "0" | LSR => "20" 481 | ASR => "40" | ROR => "60")); 482 483fun sbit b i = if b then Arbnum.one << i else Arbnum.zero; 484 485fun addr_mode1_to_num x = let open Arbnum 486in 487 case x of 488 DpImmediate n => 489 let val (rot,imm) = num2immediate n in 490 fromHexString "2000000" + (rot << 8) + imm 491 end 492 | DpShiftImmediate i => 493 (fromInt (#Imm i) << 7) + shift_to_num (#Sh i, #Rm i) 494 | DpShiftRegister r => 495 fromHexString "10" + (register_to_num (#Rs r) << 8) + 496 shift_to_num (#Sh r, #Rm r) 497end; 498 499fun addr_mode2_to_num x = let open Arbnum 500in 501 case x of 502 DtImmediate n => fromInt n 503 | DtShiftImmediate i => fromHexString "2000000" + (fromInt (#Imm i) << 7) + 504 shift_to_num (#Sh i, #Rm i) 505end; 506 507fun addr_mode3_to_num x = let open Arbnum 508in 509 case x of 510 DthImmediate n => fromHexString "400000" + 511 ((ibits 7 4 n) << 8) + (ibits 3 0 n) 512 | DthRegister r => register_to_num r 513end; 514 515fun msr_mode_to_num x = let open Arbnum 516in 517 case x of 518 MsrImmediate n => 519 let val (rot,imm) = num2immediate n in 520 fromHexString "2000000" + (rot << 8) + imm 521 end 522 | MsrRegister r => register_to_num r 523end; 524 525fun msr_psr_to_num x = Arbnum.fromHexString 526 (case x of 527 (false,false,true) => "10000" 528 | (false,true,false) => "80000" 529 | (false,true,true) => "90000" 530 | (true,false,true) => "410000" 531 | (true,true,false) => "480000" 532 | (true,true,true) => "490000" 533 | _ => "0"); 534 535fun options_to_num (p,u,b,w) = 536let open Arbnum 537in 538 sbit p 24 + sbit u 23 + sbit b 22 + sbit w 21 539end; 540 541fun options2_to_num (l,p,u,w,s,h) = 542let open Arbnum 543in 544 sbit p 24 + sbit u 23 + sbit w 21 + 545 (if l then 546 sbit true 20 + sbit s 6 + sbit h 5 547 else 548 sbit true 5) 549end; 550 551fun opcode2int opc = 552 case opc of 553 AND => 0 | EOR => 1 | SUB => 2 | RSB => 3 554 | ADD => 4 | ADC => 5 | SBC => 6 | RSC => 7 555 | TST => 8 | TEQ => 9 | CMP => 10 | CMN => 11 556 | ORR => 12 | MOV => 13 | BIC => 14 | MVN => 15; 557 558fun opcode_to_num opc = Arbnum.fromInt (opcode2int opc) << 21; 559 560fun srn_srd opc = 561 if mem opc [TST,TEQ,CMP,CMN] then (true,false) else 562 if opc = MOV orelse opc = MVN then (false,true) else 563 (true,true); 564 565fun arm_to_num (Data n) = n 566 | arm_to_num (Instruction(x,c)) = 567let open Arbnum 568in 569 condition_to_num c + 570 (case x of 571 Br y => 572 fromHexString (if #L y then "B000000" else "A000000") + 573 fromInt (#offset y) 574 | Swi_ex => 575 fromHexString "F000000" 576 | Data_proc y => 577 let val (srn,srd) = srn_srd (#opc y) in 578 (sbit (#S y) 20) + opcode_to_num (#opc y) + 579 (if srn then register_to_num (#Rn y) << 16 else zero) + 580 (if srd then register_to_num (#Rd y) << 12 else zero) + 581 addr_mode1_to_num (#op2 y) 582 end 583 | Mla_mul y => 584 (sbit (#L y) 23) + (sbit (#Signed y) 22) + 585 (sbit (#A y) 21) + (sbit (#S y) 20) + fromHexString "90" + 586 (register_to_num (#Rd y) << 16) + (register_to_num (#Rn y) << 12) + 587 (register_to_num (#Rs y) << 8) + register_to_num (#Rm y) 588 | Ldrh_strh y => 589 fromHexString "90" + 590 options2_to_num (#L y, #P y, #U y, #W y, #S y, #H y) + 591 (register_to_num (#Rn y) << 16) + (register_to_num (#Rd y) << 12) + 592 addr_mode3_to_num (#offset y) 593 | Ldr_str y => 594 fromHexString "4000000" + (sbit (#L y) 20) + 595 options_to_num (#P y, #U y, #B y, #W y) + 596 (register_to_num (#Rn y) << 16) + (register_to_num (#Rd y) << 12) + 597 addr_mode2_to_num (#offset y) 598 | Ldm_stm y => 599 fromHexString "8000000" + (sbit (#L y) 20) + 600 options_to_num (#P y, #U y, #S y, #W y) + 601 (register_to_num (#Rn y) << 16) + fromInt (#list y) 602 | Swp y => 603 fromHexString "1000090" + (sbit (#B y) 22) + 604 (register_to_num (#Rn y) << 16) + (register_to_num (#Rd y) << 12) + 605 register_to_num (#Rm y) 606 | Mrs y => 607 fromHexString "10F0000" + (sbit (#R y) 22) + 608 (register_to_num (#Rd y) << 12) 609 | Msr y => 610 fromHexString "120F000" + msr_psr_to_num (#R y, #bit19 y, #bit16 y) + 611 msr_mode_to_num (#Op y) 612 | Cdp y => 613 fromHexString "E000000" + (fromInt (#Cop1 y) << 20) + 614 (register_to_num (#CRn y) << 16) + (register_to_num (#CRd y) << 12) + 615 (fromInt (#CP y) << 8) + (fromInt (#Cop2 y) << 5) + 616 register_to_num (#CRm y) 617 | Ldc_stc y => 618 fromHexString "C000000" + (sbit (#L y) 20) + 619 options_to_num (#P y, #U y, #N y, #W y) + 620 (register_to_num (#Rn y) << 16) + (register_to_num (#CRd y) << 12) + 621 (fromInt (#CP y) << 8) + fromInt (#offset y) 622 | Mcr_mrc y => 623 fromHexString "E000010" + (sbit (#L y) 20) + (fromInt (#Cop1 y) << 21) + 624 (register_to_num (#CRn y) << 16) + (register_to_num (#Rd y) << 12) + 625 (fromInt (#CP y) << 8) + (fromInt (#Cop2 y) << 5) + 626 register_to_num (#CRm y) 627 | Undef => fromHexString "6000010") 628end; 629 630(* ------------------------------------------------------------------------- *) 631 632(* val toUpperString = I; *) 633val toUpperString = String.map Char.toUpper; 634fun nspaces_string n = funpow n (fn x => " " ^ x) ""; 635 636fun mnemonic a s = let val max_width = 8 in 637 (toUpperString s) ^ (if a then nspaces_string (max_width - size s) else " ") 638end; 639 640fun shift2string x = toUpperString( 641 case x of 642 LSL => "lsl" 643 | LSR => "lsr" 644 | ASR => "asr" 645 | ROR => "ror"); 646 647fun shift_immediate2string (y:{Imm : int, Rm : vregister, Sh : shift}) = 648 reg2string (#Rm y) ^ 649 (if #Imm y = 0 then toUpperString( 650 case #Sh y of 651 LSL => "" 652 | LSR => ", lsr #32" 653 | ASR => ", asr #32" 654 | ROR => ", rrx") 655 else 656 ", " ^ shift2string (#Sh y) ^ " #" ^ Int.toString (#Imm y)); 657 658(* ------------------------------------------------------------------------- *) 659 660local 661 val n25 = Word.toInt (Word.<<(Word.fromInt 1,Word.fromInt 25)) 662 val n26 = Word.toInt (Word.<<(Word.fromInt 1,Word.fromInt 26)) 663 fun offset2comp i = Int.mod(n26 - i,n26) 664 fun abs_offset_string i j = let open Arbnum 665 val x = sign_extend 24 32 (fromInt j) 666 in 667 "0x" ^ toHexString(add32 (i + fromInt 8) (x * fromInt 4)) 668 end; 669 fun rel_offset_string i = 670 let val j = Int.mod(Int.mod((i + 2) * 4,n26),n26) in 671 if j < n25 then 672 Int.toString j 673 else 674 "-" ^ Int.toString (offset2comp j) 675 end 676 val err = Parse "br_to_string: not a branch instruction" 677in 678 fun br_to_string l a (Instruction(x,c)) = 679 (case x of 680 Br y => 681 let val h = mnemonic a ("b" ^ (if #L y then "l" else "") ^ 682 condition2string c) 683 in 684 h ^ (if isSome l then abs_offset_string (valOf l) (#offset y) 685 else rel_offset_string (#offset y) ^ "; relative") 686 end 687 | _ => raise err) 688 | br_to_string _ _ _ = raise err 689 fun branch_to_string (BranchS(c,l,d)) = 690 mnemonic false ("b" ^ (if l then "l" else "") ^ condition2string c) ^ d 691 | branch_to_string (BranchN(c,l,n)) = 692 mnemonic false ("b" ^ (if l then "l" else "") ^ condition2string c) ^ 693 "0x" ^ Arbnum.toHexString n 694 | branch_to_string _ = raise err 695end; 696 697fun swi_ex_to_string c = toUpperString ("swi" ^ condition2string c); 698 699local 700 fun addr_mode2string x = 701 case x of 702 DpImmediate n => "#" ^ Arbnum.toString n 703 | DpShiftImmediate i => shift_immediate2string i 704 | DpShiftRegister r => 705 reg2string (#Rm r) ^ ", " ^ shift2string (#Sh r) ^ " " ^ 706 reg2string (#Rs r) 707 val err = Parse "data_proc_to_string: not a data processing instruction" 708in 709 fun data_proc_to_string a (Instruction(x,c)) = 710 (case x of 711 Data_proc y => 712 let val opc = #opc y 713 val bop = mem opc [TST,TEQ,CMP,CMN] 714 val h = mnemonic a (opcode2string opc ^ condition2string c ^ 715 (if #S y andalso not bop then "s" else "")) 716 in 717 h ^ (if bop then "" else reg2string (#Rd y) ^ ", ") ^ 718 (if opc = MOV orelse opc = MVN then "" 719 else reg2string (#Rn y) ^ ", ") ^ addr_mode2string (#op2 y) 720 end 721 | _ => raise err) 722 | data_proc_to_string _ _ = raise err 723end; 724 725local 726 val err = Parse "mla_mul_to_string: not a multiply instruction" 727in 728 fun mla_mul_to_string a (Instruction(x,c)) = 729 (case x of 730 Mla_mul y => 731 let val opc = case (#L y,#Signed y,#A y) of 732 (false,_,false) => "mul" 733 | (false,_,true) => "mla" 734 | (true,false,false) => "umull" 735 | (true,false,true) => "umlal" 736 | (true,true,false) => "smull" 737 | (true,true,true) => "smlal" 738 val h = mnemonic a (opc ^ condition2string c ^ 739 (if #S y then "s" else "")) 740 in 741 h ^ (if #L y then reg2string (#Rn y) ^ ", " else "") ^ 742 reg2string (#Rd y) ^ ", " ^ reg2string (#Rm y) ^ ", " ^ 743 reg2string (#Rs y) ^ 744 (if not (#L y) andalso #A y then ", " ^ reg2string (#Rn y) else "") 745 end 746 | _ => raise err) 747 | mla_mul_to_string _ _ = raise err 748end; 749 750local 751 fun addr_mode2string U x = 752 case x of 753 DtImmediate n => 754 if n = 0 then "" else 755 ", #" ^ (if U then "" else "-") ^ Int.toString n 756 | DtShiftImmediate i => 757 ", " ^ (if U then "" else "-") ^ shift_immediate2string i 758 val err = Parse "ldr_str_to_string: not a load/store instruction" 759in 760 fun ldr_str_to_string a (Instruction(x,c)) = 761 (case x of 762 Ldr_str y => 763 let val h = mnemonic a ((if #L y then "ldr" else "str") ^ 764 condition2string c ^ (if #B y then "b" else "")) 765 val offset = addr_mode2string (#U y) (#offset y) 766 in 767 h ^ reg2string (#Rd y) ^ ", [" ^ reg2string (#Rn y) ^ 768 (if #P y then 769 offset ^ "]" ^ (if #W y then "!" else "") 770 else 771 "]" ^ offset) 772 end 773 | _ => raise err) 774 | ldr_str_to_string _ _ = raise err 775end; 776 777local 778 fun addr_mode3string U x = 779 case x of 780 DthImmediate n => 781 if n = 0 then "" else 782 ", #" ^ (if U then "" else "-") ^ Int.toString n 783 | DthRegister r => ", " ^ (if U then "" else "-") ^ reg2string r 784 fun format_suffix (l,s,h) = 785 case (l,s,h) of 786 (true,false,_) => "h" 787 | (true,true,false) => "sb" 788 | (true,true,true) => "sh" 789 | (false,_,_) => "h" 790 val err = Parse "ldrh_strh_to_string: not a load/store (half) instruction" 791in 792 fun ldrh_strh_to_string a (Instruction(x,c)) = 793 (case x of 794 Ldrh_strh y => 795 let val h = mnemonic a ((if #L y then "ldr" else "str") ^ 796 condition2string c ^ (format_suffix (#L y, #S y, #H y))) 797 val offset = addr_mode3string (#U y) (#offset y) 798 in 799 h ^ reg2string (#Rd y) ^ ", [" ^ reg2string (#Rn y) ^ 800 (if #P y then 801 offset ^ "]" ^ (if #W y then "!" else "") 802 else 803 "]" ^ offset) 804 end 805 | _ => raise err) 806 | ldrh_strh_to_string _ _ = raise err 807end; 808 809local 810 fun finish i ys = if ys = [] then [(i,i)] else ((fst (hd ys), i)::(tl ys)) 811 812 fun blocks [] i ys = ys 813 | blocks [x] i ys = if x then finish i ys else ys 814 | blocks (x::y::xs) i ys = 815 case (x,y) of 816 (true,true) => blocks (y::xs) (i + 1) ys 817 | (false,true) => blocks (y::xs) (i + 1) ((i + 1,~1)::ys) 818 | (true,false) => blocks (y::xs) (i + 1) (finish i ys) 819 | (false,false) => blocks (y::xs) (i + 1) ys 820 821 fun make_blocks l = rev (blocks l 0 (if hd l then [(0,~1)] else [])) 822 823 fun regn2string n = "r" ^ Int.toString n; 824 825 fun blocks2string [] s = s ^ "}" 826 | blocks2string ((i,j)::xs) s = 827 blocks2string xs (s ^ regn2string i ^ 828 (if i = j then 829 "" 830 else if i + 1 = j then 831 ", " ^ regn2string j 832 else 833 "-" ^ regn2string j) ^ 834 (if xs = [] then "" else ", ")) 835 836 fun reg_list2string l = blocks2string (make_blocks ( 837 List.take(num2list 16 (Arbnum.fromInt l),16))) "{" 838 839 fun mode2string p u = 840 case (p,u) of 841 (false,false) => "da" 842 | (false,true) => "ia" 843 | (true,false) => "db" 844 | (true,true) => "ib"; 845 val err = Parse "ldm_stm_to_string: not a block transfer instruction" 846in 847 fun ldm_stm_to_string a (Instruction(x,c)) = 848 (case x of 849 Ldm_stm y => 850 let val h = mnemonic a ((if #L y then "ldm" else "stm") ^ 851 condition2string c ^ mode2string (#P y) (#U y)) 852 in 853 h ^ reg2string (#Rn y) ^ (if #W y then "!, " else ", ") ^ 854 reg_list2string (#list y) ^ (if #S y then "^" else "") 855 end 856 | _ => raise err) 857 | ldm_stm_to_string _ _ = raise err 858end; 859 860fun swp_to_string a (Instruction(x,c)) = 861 (case x of 862 Swp y => 863 let val h = mnemonic a ("swp" ^ condition2string c ^ 864 (if #B y then "b" else "")) 865 in 866 h ^ reg2string (#Rd y) ^ ", " ^ reg2string (#Rm y) ^ ", [" ^ 867 reg2string (#Rn y) ^ "]" 868 end 869 | _ => raise Parse "swp_to_string: not a swap instruction") 870 | swp_to_string _ _ = raise Parse "swp_to_string: not a swap instruction"; 871 872fun mrs_to_string a (Instruction(x,c)) = 873 (case x of 874 Mrs y => 875 let val h = mnemonic a ("mrs" ^ condition2string c) 876 in 877 h ^ reg2string (#Rd y) ^ ", " ^ (if #R y then "SPSR" else "CPSR") 878 end 879 | _ => raise Parse "mrs_to_string: not an mrs instruction") 880 | mrs_to_string _ _ = raise Parse "mrs_to_string: not an mrs instruction"; 881 882fun msr_to_string a (Instruction(x,c)) = 883 (case x of 884 Msr y => 885 let val h = mnemonic a ("msr" ^ condition2string c) 886 in 887 h ^ (if #R y then "SPSR" else "CPSR") ^ 888 (if #bit19 y andalso not (#bit16 y) then 889 "_f, " 890 else if not (#bit19 y) andalso #bit16 y then 891 "_c, " 892 else 893 ", ") ^ 894 (case #Op y of 895 MsrImmediate n => "#" ^ Arbnum.toString n 896 | MsrRegister r => reg2string r) 897 end 898 | _ => raise Parse "msr_to_string: not an msr instruction") 899 | msr_to_string _ _ = raise Parse "msr_to_string: not an msr instruction"; 900 901fun cdp_to_string a (Instruction(x,c)) = 902 (case x of 903 Cdp y => 904 let val h = mnemonic a ("cdp" ^ condition2string c) 905 in 906 h ^ cp_num2string (#CP y) ^ ", " ^ Int.toString (#Cop1 y) ^ ", " ^ 907 cp_reg2string (#CRd y) ^ ", " ^ cp_reg2string (#CRn y) ^ ", " ^ 908 cp_reg2string (#CRm y) ^ 909 (if #Cop2 y = 0 then "" else ", " ^ Int.toString (#Cop2 y)) 910 end 911 | _ => raise Parse "cdp_to_string: not a cdp instruction") 912 | cdp_to_string _ _ = raise Parse "cdp_to_string: not a cdp instruction"; 913 914local 915 val err = Parse "mcr_mrc_to_string: not an mcr or mrc instruction" 916in 917 fun mcr_mrc_to_string a (Instruction(x,c)) = 918 (case x of 919 Mcr_mrc y => 920 let val h = mnemonic a ((if #L y then "mrc" else "mcr") ^ 921 condition2string c) 922 in 923 h ^ cp_num2string (#CP y) ^ ", " ^ Int.toString (#Cop1 y) ^ ", " ^ 924 reg2string (#Rd y) ^ ", " ^ cp_reg2string (#CRn y) ^ ", " ^ 925 cp_reg2string (#CRm y) ^ 926 (if # Cop2 y = 0 then "" else ", " ^ Int.toString (#Cop2 y)) 927 end 928 | _ => raise err) 929 | mcr_mrc_to_string _ _ = raise err 930end; 931 932local 933 val err = Parse "ldc_stc_to_string: not an ldc or stc instruction" 934in 935 fun ldc_stc_to_string a (Instruction(x,c)) = 936 (case x of 937 Ldc_stc y => 938 let val h = mnemonic a ((if #L y then "ldc" else "stc") ^ 939 condition2string c) 940 val offset = if #offset y = 0 then "" else 941 (if #U y then ", #" else ", #-") ^ 942 Int.toString (4 * #offset y) 943 in 944 h ^ cp_num2string (#CP y) ^ ", " ^ cp_reg2string (#CRd y) ^ ", [" ^ 945 reg2string (#Rn y) ^ 946 (if #P y then 947 offset ^ "]" ^ (if #W y then "!" else "") 948 else 949 "]" ^ offset) 950 end 951 | _ => raise err) 952 | ldc_stc_to_string _ _ = raise err 953end; 954 955(* ------------------------------------------------------------------------- *) 956 957fun arm_to_string l a (i as Instruction (x,c)) = 958 (case x of 959 Br y => br_to_string l a i 960 | Swi_ex => swi_ex_to_string c 961 | Data_proc y => data_proc_to_string a i 962 | Mla_mul y => mla_mul_to_string a i 963 | Ldrh_strh y => ldrh_strh_to_string a i 964 | Ldr_str y => ldr_str_to_string a i 965 | Ldm_stm y => ldm_stm_to_string a i 966 | Swp y => swp_to_string a i 967 | Mrs y => mrs_to_string a i 968 | Msr y => msr_to_string a i 969 | Cdp y => cdp_to_string a i 970 | Mcr_mrc y => mcr_mrc_to_string a i 971 | Ldc_stc y => ldc_stc_to_string a i 972 | Undef => "0x" ^ Arbnum.toHexString (arm_to_num i)) 973 | arm_to_string _ _ (Data n) = "0x" ^ Arbnum.toHexString n; 974 975fun assembler_to_string i a l = 976 let val s = if isSome l then (valOf l) ^ ": " else "" in 977 case a of 978 Data.Code c => s ^ arm_to_string i false c 979 | Data.BranchS b => s ^ branch_to_string a 980 | Data.BranchN b => s ^ branch_to_string a 981 | _ => "" 982 end; 983 984(* ------------------------------------------------------------------------- *) 985 986val encode_arm = arm_to_num o string_to_arm; 987fun decode_arm i n = arm_to_string i false (num_to_arm n); 988fun decode_arm_dec i n = decode_arm i (Arbnum.fromString n); 989fun decode_arm_hex i n = decode_arm i (Arbnum.fromHexString n); 990 991end; 992