(* ************************************************** *) (* Convenience functions for working with binary data *) (* ************************************************** *) (* Low-level types *) type dword = int32 type word = int32 type byte = int32 type rva = int32 type register = Eax | Ebx | Ecx | Edx | Esp | Ebp | Esi | Edi | NoRegister (* Read a binary file into an array of integers *) let make_bin_array f = let ic = open_in_bin f in let rec makelist lst = (* Catch expected end-of-file error; exit gracefully *) try let b = (input_byte ic) in b::(makelist lst) with End_of_file -> close_in ic; lst in Array.of_list (makelist []) (* Write an array of integers into a binary file *) let write_bin_array a f = let oc = open_out_bin f in Array.iter (fun a -> output_byte oc a) a; close_out oc (* Make a byte/word/dword (int32) from data; will throw on array EOB *) let make_byte arr idx = Int32.of_int arr.(idx) let make_word arr idx = Int32.logor (make_byte arr idx) (Int32.shift_left (make_byte arr (idx+1)) 8) let make_dword arr idx = Int32.logor (make_word arr idx) (Int32.shift_left (make_word arr (idx+2)) 16) (* Make an array of integers out of a word *) let make_word_into_array d = let b1 = Int32.to_int (Int32.logand d (Int32.of_int 255)) in let b2 = Int32.to_int (Int32.logand (Int32.shift_left d 8) (Int32.of_int 255)) in Array.of_list (b1::b2::[]) (* Make an array of integers out of a dword *) let make_dword_into_array d = let b1 = Int32.to_int (Int32.logand d (Int32.of_int 255) ) in let b2 = Int32.to_int (Int32.logand (Int32.shift_right d 8) (Int32.of_int 255)) in let b3 = Int32.to_int (Int32.logand (Int32.shift_right d 16) (Int32.of_int 255)) in let b4 = Int32.to_int (Int32.logand (Int32.shift_right d 24) (Int32.of_int 255)) in Array.of_list (b1::b2::b3::b4::[]) (* Set a dword into a given position in the array. Will throw on EOB *) let set_dword_into_array arr pos d = let b1 = Int32.to_int (Int32.logand d (Int32.of_int 255) ) in let b2 = Int32.to_int (Int32.logand (Int32.shift_right d 8) (Int32.of_int 255)) in let b3 = Int32.to_int (Int32.logand (Int32.shift_right d 16) (Int32.of_int 255)) in let b4 = Int32.to_int (Int32.logand (Int32.shift_right d 24) (Int32.of_int 255)) in (arr.(pos) <- b1); (arr.(pos+1) <- b2); (arr.(pos+2) <- b3); (arr.(pos+3) <- b4) (* Add a dword to a dword in the array *) let fixup_array arr pos amt = let d1 = make_dword arr pos in let d2 = Int32.add d1 amt in set_dword_into_array arr pos d2 (* *********************************************************************************** *) (* Inputs to the analysis algorithm: VM bytecode, imagebase, marker, permutation table *) (* *********************************************************************************** *) (* Should be the same for each executable, but could change *) let imagebase = Int32.of_int 0x400000 let marker = Int32.of_int 0xFFFF (* We need this from every sample *) let perm_table = make_bin_array "c:\\perm_table.bin" (* This should be genericisized into a list of arrays with their corresponding file positions *) let arr = make_bin_array "c:\\1.bin" let arr2 = make_bin_array "c:\\2.bin" let arr3 = make_bin_array "c:\\3.bin" (* ********************************************************************** *) (* Type declarations for the instruction set used by ReWolf's Virtualizer *) (* ********************************************************************** *) type conditioncode = Z | NZ | O | NO | C | NC | S | NS | P | NP | A | BE | G | GE | L | LE (* These are the instructions virtualized by the ReWolf VM *) type syntheticOperand = Rol of byte | Ror of byte | Rcl of byte | Rcr of byte | Shl of byte | Shr of byte | Sar of byte | Add of dword | Or of dword | Adc of dword | Sbb of dword | And of dword | Sub of dword | Xor of dword | Cmp of dword | Mov of dword | Push | Call | Jmp | Arbitrary of int * register (* Expression-tree depiction of modRM[/SIB] encoding *) type exprPart = Plus of exprPart * exprPart | ShlReg of exprPart * exprPart | Constant of int32 | Register of register (* Instruction set supported by ReWolf VM *) type vis = ConditionalJump of int32 * conditioncode | CurrentlyUnknown2 | X86Call of rva | CurrentlyUnknown4 | VMExit of word | CurrentlyUnknown6 of byte * dword | SetTemp of dword | SetRegisterToTemp of register | AddImmediateToTemp of dword | AddRegisterToTemp of register | ShiftTemporaryLeft of byte | ArbitraryModRM of int * register | UnconditionalJump of dword | RolDereferencedTemp of byte | RorDereferencedTemp of byte | RclDereferencedTemp of byte | RcrDereferencedTemp of byte | ShlDereferencedTemp of byte | ShrDereferencedTemp of byte | SarDereferencedTemp of byte | AddDereferencedTemp of dword | OrDereferencedTemp of dword | AdcDereferencedTemp of dword | SbbDereferencedTemp of dword | AndDereferencedTemp of dword | SubDereferencedTemp of dword | XorDereferencedTemp of dword | CmpDereferencedTemp of dword | MovDereferencedTemp of dword | CallDereferencedTemp | JumpDereferencedTemp | PushDereferencedTemp | CurrentlyUnknown23 | ImagebaseFixupInstruction of (int array) * byte | PushWithImagebaseFixup of dword | Null | LiteralInstruction of int array (* These last ones need consideration. They were added in the code generator and linker stages. Should be revisited. *) | RelativeFixupInstruction of (int array) * rva * byte | SyntheticInstruction of syntheticOperand * exprPart | FlattenedByteRegion of (int array) * (int list) * ((int * rva) list) | RegionNeedsRelocations of (int array) * ((int * rva) list) (* ********************************************************************** *) (* Pretty printer for the data types given above *) (* ********************************************************************** *) let print_dword d = print_string (Int32.to_string d) let print_word w = print_string (Int32.to_string w) let print_byte b = print_string (Int32.to_string b) let rva_to_va rva = Int32.add rva imagebase let reg_pretty = function Eax -> print_string "eax" | Ebx -> print_string "ebx" | Ecx -> print_string "ecx" | Edx -> print_string "edx" | Esp -> print_string "esp" | Ebp -> print_string "ebp" | Esi -> print_string "esi" | Edi -> print_string "edi" | NoRegister -> print_string "This is a bug, if it ever manifests itself" let vis_pretty = function ConditionalJump(d,c) -> print_string "jcc @@" ; print_dword d ; print_endline "" | X86Call(r) -> print_string "x86call " ; print_dword (rva_to_va r) ; print_endline "" | SetTemp(d) -> print_string "mov Temp, 0" ; print_dword d ; print_endline "" | SetRegisterToTemp(r) -> print_string "mov Temp, " ; reg_pretty r ; print_endline "" | AddImmediateToTemp(d) -> print_string "add Temp, " ; print_dword d ; print_endline "" | AddRegisterToTemp(r) -> print_string "add Temp, " ; reg_pretty r ; print_endline "" | ShiftTemporaryLeft(b) -> print_string "shl Temp, " ; print_byte b ; print_endline "" | UnconditionalJump(d) -> print_string "jmp @@" ; print_dword d ; print_endline "" | RolDereferencedTemp(b) -> print_string "rol [Temp], " ; print_byte b ; print_endline "" | RorDereferencedTemp(b) -> print_string "ror [Temp], " ; print_byte b ; print_endline "" | RclDereferencedTemp(b) -> print_string "rcl [Temp], " ; print_byte b ; print_endline "" | RcrDereferencedTemp(b) -> print_string "rcr [Temp], " ; print_byte b ; print_endline "" | ShlDereferencedTemp(b) -> print_string "shl [Temp], " ; print_byte b ; print_endline "" | ShrDereferencedTemp(b) -> print_string "shr [Temp], " ; print_byte b ; print_endline "" | SarDereferencedTemp(b) -> print_string "sar [Temp], " ; print_byte b ; print_endline "" | AddDereferencedTemp(d) -> print_string "add [Temp], " ; print_dword d ; print_endline "" | OrDereferencedTemp(d) -> print_string "or [Temp], " ; print_dword d ; print_endline "" | AdcDereferencedTemp(d) -> print_string "adc [Temp], " ; print_dword d ; print_endline "" | SbbDereferencedTemp(d) -> print_string "sbb [Temp], " ; print_dword d ; print_endline "" | AndDereferencedTemp(d) -> print_string "and [Temp], " ; print_dword d ; print_endline "" | SubDereferencedTemp(d) -> print_string "sub [Temp], " ; print_dword d ; print_endline "" | XorDereferencedTemp(d) -> print_string "xor [Temp], " ; print_dword d ; print_endline "" | CmpDereferencedTemp(d) -> print_string "cmp [Temp], " ; print_dword d ; print_endline "" | MovDereferencedTemp(d) -> print_string "mov [Temp], " ; print_dword d ; print_endline "" | PushDereferencedTemp -> print_endline "push [Temp]" | CallDereferencedTemp -> print_endline "call [Temp]" | JumpDereferencedTemp -> print_endline "jmp [Temp]" | Null -> print_endline "nop" | VMExit(w) -> print_string "retn " ; print_word w ; print_endline "" | LiteralInstruction(_) -> print_endline "[literal]" | ImagebaseFixupInstruction(_,_) -> print_endline "[literal w/fixup]" | CurrentlyUnknown23 -> print_endline "unk23" | CurrentlyUnknown2 -> print_endline "unk2" | CurrentlyUnknown4 -> print_endline "unk4" | CurrentlyUnknown6(b,d) -> print_string "unk6 " ; print_byte b ; print_string "," ; print_dword d ; print_endline "" | PushWithImagebaseFixup(d) -> print_string "push " ; print_dword (rva_to_va d) ; print_endline "" (* ********************************************************************** *) (* The decryptor (polymorphic, so this will only work for this one sample *) (* ********************************************************************** *) let ror_byte b i = let i = i mod 8 in ((b lsr i) lor (b lsl (8-i))) land 255 let rol_byte b i = let i = i mod 8 in ((b lsl i) lor (b lsr (8-i))) land 255 let xor_byte b1 b2 = (b1 lxor b2) land 255 let add_byte b1 b2 = (b1 + b2) land 255 let sub_byte b1 b2 = (b1 - b2) land 255 let decrypt arr len key = let index = ref 0 in while !index < len do let byte = xor_byte arr.(!index) key in let byte = ror_byte ((((!index lxor ((!index lxor byte) - !index - 69 + 1 - !index - 117)) lxor 0xF8) - !index) land 255) !index in let byte = ror_byte (byte land 255) !index in let byte = ror_byte ((!index + !index + (!index lxor (!index + byte)) - 14) land 255) !index in let byte = (((((!index lxor byte) lxor 0xCA) - !index - !index - 87) lxor 0xE1) + 48 - !index) lxor 0x77 in arr.(!index) <- byte land 255; index := !index + 1; done let decrypt_instruction arr index = let len = (arr.(index) lxor arr.(index+1)) in let subarr = Array.sub arr (index+1) len in decrypt subarr len index; subarr (* *********************** *) (* Very stupid graph class *) (* *********************** *) exception GraphCoherencyProblem type 'a rvvertex = { label: int; instruction: 'a } type 'a rvedge = ('a rvvertex ref) * ('a rvvertex ref) type 'a rvgraph = { vertexlist: 'a rvvertex list; edgelist: 'a rvedge list } let find_vertex graph lab = let rec rec_vertex_exists lab = function [] -> None | hd::tl -> if hd.label = lab then Some(hd) else rec_vertex_exists lab tl in rec_vertex_exists lab graph.vertexlist let add_vertex graph lab inst = let k = find_vertex graph lab in match k with Some(a) -> print_endline ("Tried to add a vertex with label " ^ string_of_int lab ^ "; already existed"); graph | None -> let v = graph.vertexlist in let e = graph.edgelist in { vertexlist = ({label = lab; instruction = inst }::v); edgelist = e } let add_edge graph vertex1 vertex2 = let v = graph.vertexlist in let e = graph.edgelist in { vertexlist = v; edgelist = ((ref vertex1, ref vertex2)::e) } let get_predecessors graph vertex = let rec iterate vt = function [] -> [] | (a,b)::tl when !b.label = vt.label -> [!a]@(iterate vt tl) | x::tl -> iterate vt tl in iterate vertex graph.edgelist let get_successors graph vertex = let rec iterate vt = function [] -> [] | (a,b)::tl when !a.label = vt.label -> [!b]@(iterate vt tl) | x::tl -> iterate vt tl in iterate vertex graph.edgelist let map_graph f graph = let trans = List.map f graph.vertexlist in let newgraph = ref { vertexlist = trans; edgelist = [] } in let helperfun ov1 ov2 = let v1 = find_vertex !newgraph (!ov1).label in let v2 = find_vertex !newgraph (!ov2).label in (match (v1,v2) with (Some(a),Some(b)) -> newgraph := add_edge !newgraph a b | _ -> raise GraphCoherencyProblem) in List.iter (fun (ov1,ov2) -> helperfun ov1 ov2) graph.edgelist; !newgraph (* *************************************************** *) (* VM bytecode to instruction-level control flow graph *) (* *************************************************** *) exception BadInstruction exception BadRegister exception BadConditionCode exception GraphScrewedUp exception NoNodeIndexZero let analyze_register = function 0 -> Eax | 1 -> Ecx | 2 -> Edx | 3 -> Ebx | 4 -> Esp | 5 -> Ebp | 6 -> Esi | 7 -> Edi | _ -> raise BadRegister let analyze_conditioncode = function 0 -> GE | 1 -> L | 2 -> LE | 3 -> Z | 4 -> O | 5 -> BE | 6 -> NZ | 7 -> NO | 8 -> S | 9 -> P | 10 -> C | 11 -> G | 12 -> A | 13 -> NP | 14 -> NS | 15 -> NC | _ -> raise BadConditionCode (* This function analyzes one VM instruction, returns an ML datatype for that instruction and a list of instructions that may be executed subsequently (e.g. a conditional jump has two successors) *) let analyze_instruction decryptedarr currentindex = let nextinstrlst = [currentindex + Array.length decryptedarr + 1] in if (Array.length decryptedarr = 1) || (make_word decryptedarr 0 <> marker) then (LiteralInstruction(decryptedarr),nextinstrlst) else match perm_table.(decryptedarr.(2)) with 0x00 | 0x01 -> let dest_displacement = make_dword decryptedarr 4 in let dest = Int32.add (Int32.of_int currentindex) dest_displacement in (ConditionalJump(dest, analyze_conditioncode (decryptedarr.(3))), ((Int32.to_int dest)::nextinstrlst)) | 0x02 -> let dest_displacement = make_dword decryptedarr 4 in let dest = Int32.add (Int32.of_int currentindex) dest_displacement in (CurrentlyUnknown2, ((Int32.to_int dest)::nextinstrlst)) | 0x03 -> (X86Call(make_dword decryptedarr 3), nextinstrlst) | 0x04 -> (CurrentlyUnknown4, []) | 0x05 -> (VMExit(make_word decryptedarr 3), []) | 0x06 -> let dest_displacement = make_dword decryptedarr 4 in let dest = Int32.add (Int32.of_int currentindex) dest_displacement in (CurrentlyUnknown6(make_byte decryptedarr 4, dest), ((Int32.to_int dest)::nextinstrlst)) | 0x07 -> (SetTemp(make_dword decryptedarr 3), nextinstrlst) | 0x08 -> (SetRegisterToTemp(analyze_register decryptedarr.(3)), nextinstrlst) | 0x09 -> (AddImmediateToTemp(make_dword decryptedarr 3), nextinstrlst) | 0x0A -> (AddRegisterToTemp(analyze_register decryptedarr.(3)), nextinstrlst) | 0x0B -> (ShiftTemporaryLeft(make_byte decryptedarr 3), nextinstrlst) | 0x0C -> (ArbitraryModRM(decryptedarr.(3),analyze_register (decryptedarr.(4) land 7)), nextinstrlst) | 0x0D | 0x0E -> let dest_displacement = make_dword decryptedarr 3 in let dest = Int32.add (Int32.of_int currentindex) dest_displacement in (UnconditionalJump(dest), [Int32.to_int dest]) | 0x0F -> (RolDereferencedTemp(make_byte decryptedarr 3), nextinstrlst) | 0x10 -> (RorDereferencedTemp(make_byte decryptedarr 3), nextinstrlst) | 0x11 -> (RclDereferencedTemp(make_byte decryptedarr 3), nextinstrlst) | 0x12 -> (RcrDereferencedTemp(make_byte decryptedarr 3), nextinstrlst) | 0x13 -> (ShlDereferencedTemp(make_byte decryptedarr 3), nextinstrlst) | 0x14 -> (ShrDereferencedTemp(make_byte decryptedarr 3), nextinstrlst) | 0x15 -> (SarDereferencedTemp(make_byte decryptedarr 3), nextinstrlst) | 0x16 -> (ShlDereferencedTemp(make_byte decryptedarr 3), nextinstrlst) | 0x17 -> (AddDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x18 -> ( OrDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x19 -> (AdcDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x1A -> (SbbDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x1B -> (AndDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x1C -> (SubDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x1D -> (XorDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x1E -> (CmpDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x1F -> (MovDereferencedTemp(make_dword decryptedarr 3), nextinstrlst) | 0x20 -> (CallDereferencedTemp, nextinstrlst) | 0x21 -> (JumpDereferencedTemp, nextinstrlst) | 0x22 -> (PushDereferencedTemp, nextinstrlst) | 0x23 -> (CurrentlyUnknown23, nextinstrlst) | 0x24 -> (ImagebaseFixupInstruction(Array.sub decryptedarr 5 (decryptedarr.(4)), make_byte decryptedarr 3), nextinstrlst) | 0x25 -> (PushWithImagebaseFixup(make_dword decryptedarr 3), nextinstrlst) | 0x26 -> (Null, nextinstrlst) | _ -> raise BadInstruction (* This function adds a node to the graph, and then adds edges to each one of its children. If those children are not already in the graph, then we call ourselves recursively to add the new node, and then add its children to the graph, etc. etc. The big problem with this idea is that the graph structure changes after each call to add_vertex and add_edge, so I need to maintain coherency throughout the loop. E.g. the final graph that I return must be the one with all of the edges in it. *) let add_instruction graph encryptedarray index = let oldvertexo = find_vertex graph index in match oldvertexo with Some(a) -> (graph,a,[]) | None -> let decarr = decrypt_instruction encryptedarray index in let (i,lst) = analyze_instruction decarr index in (* Debugging code: print each instruction as it's processed *) (* print_int index; print_string " "; vis_pretty i; *) let newgraph = add_vertex graph index i in let newvertexo = find_vertex newgraph index in let newvertex = (match newvertexo with Some(a) -> a | None -> raise GraphScrewedUp) in (newgraph,newvertex,lst) (* OK, this actually works. *) let make_instruction_cfg encryptedarray = let build_graph graph encryptedarray index = let (g,v,l) = add_instruction graph encryptedarray index in let rec loop gr v ls = match ls with [] -> gr | hd::tl -> let (g',v',l') = add_instruction gr encryptedarray hd in let g'' = loop g' v' l' in loop (add_edge g'' v v') v tl in loop g v l in build_graph {vertexlist = []; edgelist = []} encryptedarray 0 (* ********************************************* *) (* Instruction-to-block-level control flow graph *) (* ********************************************* *) (* Get the successors of the current instruction. If there are more than one, this is the end of the block. If there are more than one predecessor to the sole successor of this instruction, then it too ends a basic block. Same if there are no sucessors. *) let ends_block instruction_cfg vertex = let l = get_successors instruction_cfg vertex in let k = List.length l in if k = 0 || k > 1 then true else match l with sv::[] -> let l = get_predecessors instruction_cfg sv in if List.length l > 1 then true else false let build_block instruction_cfg vertex = let rec rec_build_block v1 = if ends_block instruction_cfg v1 then ([v1.instruction], [v1]) else let sv = List.nth (get_successors instruction_cfg v1) 0 in let (l,v) = rec_build_block sv in ([v1.instruction]@l, [v1]@v) in rec_build_block vertex let rec successors_to_int_list = function [] -> [] | hd::tl -> [hd.label]@(successors_to_int_list tl) let add_block instruction_cfg index block_cfg = let oldvertexo = find_vertex block_cfg index in match oldvertexo with None -> let ivertexo = find_vertex instruction_cfg index in let ivertex = (match ivertexo with Some(a) -> a | None -> print_endline ("Could not find node with index " ^ (string_of_int index)); raise NoNodeIndexZero) in let (inslist, ivlist) = build_block instruction_cfg ivertex in let lastivertex = (List.nth ivlist ((List.length ivlist)-1)) in let isuccessors = get_successors instruction_cfg lastivertex in let newbgraph = add_vertex block_cfg index (Array.of_list inslist) in let bvertexo = find_vertex newbgraph index in let bvertex = (match bvertexo with Some(a) -> a | None -> raise GraphScrewedUp) in let nsuccessors = successors_to_int_list isuccessors in (newbgraph,bvertex,nsuccessors) | Some(a) -> (block_cfg,a,[]) let make_block_cfg instruction_cfg = let build_graph igraph bgraph index = let (g,v,l) = add_block igraph index bgraph in let rec loop bgr v ls = match ls with [] -> bgr | hd::tl -> let (g',v',l') = add_block igraph hd bgr in let g'' = loop g' v' l' in loop (add_edge g'' v v') v tl in loop g v l in build_graph instruction_cfg {vertexlist = []; edgelist = []} 0 (* let make_block_cfg arr = make_instruction_cfg arr *) (* ********* *) (* Optimizer *) (* ********* *) type varusage = Def | Use | Both | None;; exception OptimizerError of string let defuse = function ConditionalJump(d,c) -> None | X86Call(r) -> None | SetTemp(d) -> Def | SetRegisterToTemp(r) -> Def | AddImmediateToTemp(d) -> Both | AddRegisterToTemp(r) -> Both | ShiftTemporaryLeft(b) -> Both | ArbitraryModRM(b,r) -> Use | UnconditionalJump(d) -> None | RolDereferencedTemp(b) -> Use | RorDereferencedTemp(b) -> Use | RclDereferencedTemp(b) -> Use | RcrDereferencedTemp(b) -> Use | ShlDereferencedTemp(b) -> Use | ShrDereferencedTemp(b) -> Use | SarDereferencedTemp(b) -> Use | AddDereferencedTemp(d) -> Use | OrDereferencedTemp(d) -> Use | AdcDereferencedTemp(d) -> Use | SbbDereferencedTemp(d) -> Use | AndDereferencedTemp(d) -> Use | SubDereferencedTemp(d) -> Use | XorDereferencedTemp(d) -> Use | CmpDereferencedTemp(d) -> Use | MovDereferencedTemp(d) -> Use | PushDereferencedTemp -> Use | CallDereferencedTemp -> Use | JumpDereferencedTemp -> Use | Null -> None | VMExit(w) -> None | LiteralInstruction(_) -> None | ImagebaseFixupInstruction(_,_) -> None | CurrentlyUnknown23 -> None | CurrentlyUnknown2 -> None | CurrentlyUnknown4 -> None | CurrentlyUnknown6(b,d) -> None | PushWithImagebaseFixup(d) -> None | SyntheticInstruction(_,_) -> raise (OptimizerError "Synthetic instruction appeared in pre-optimized code") let build_def_use_chains insarray = let duarray = Array.map (fun a -> (a, defuse a)) insarray in let arrlen = Array.length duarray in let last_def = ref (-1) in let du_list = ref [] in let index = ref 0 in let helper = while (!index < arrlen) do let (_,du) = duarray.(!index) in (match du with Def -> last_def := !index; () | Use -> if !last_def = -1 then raise (OptimizerError "Use occurs before definition, should not happen in ReWolf Virtualizer") else du_list := (!du_list)@[(!last_def, !index)] ; () | Both -> if !last_def = -1 then raise (OptimizerError "Use occurs before definition, should not happen in ReWolf Virtualizer") else let k = !last_def in last_def := !index; du_list := (!du_list)@[(k, !index)] ; () | None -> ()) ; index := !index + 1; done; in helper; !du_list;; (* If the previous use is the same as the current define, group them *) let group_def_use_chains duchains = let previous_pair = ref (-1,-1) in let current_list = ref [] in let list_of_lists = ref [] in let helper = function (d,u) when d = -1 && u = -1 -> if ((List.length !current_list) != 0) then list_of_lists := (!list_of_lists)@[(!current_list)] else () | (d,u) when !previous_pair = (-1,-1) -> previous_pair := (d,u) | (d,u) when snd(!previous_pair) = d -> if ((List.length !current_list)=0) then (current_list := [!previous_pair;(d,u)];previous_pair := (d,u)) else (current_list := (!current_list)@[(d,u)];previous_pair := (d,u)) | (d,u) -> if ((List.length !current_list)=0) then (list_of_lists := (!list_of_lists)@[[!previous_pair]];previous_pair := (d,u);) else (list_of_lists := (!list_of_lists)@[(!current_list)]; current_list := [];previous_pair := (d,u);) in let go = List.iter (fun a -> helper a) (duchains@[(-1,-1)]) in go; !list_of_lists;; let build_grouped_def_use_chains x = group_def_use_chains (build_def_use_chains x) exception SyntheticOperandError of string exception BuildingSyntaxTree of string let get_synthetic_operand = function RolDereferencedTemp(b) -> Rol(b) | RorDereferencedTemp(b) -> Ror(b) | RclDereferencedTemp(b) -> Rcl(b) | RcrDereferencedTemp(b) -> Rcr(b) | ShlDereferencedTemp(b) -> Shl(b) | ShrDereferencedTemp(b) -> Shr(b) | SarDereferencedTemp(b) -> Sar(b) | AddDereferencedTemp(d) -> Add(d) | OrDereferencedTemp(d) -> Or(d) | AdcDereferencedTemp(d) -> Adc(d) | SbbDereferencedTemp(d) -> Sbb(d) | AndDereferencedTemp(d) -> And(d) | SubDereferencedTemp(d) -> Sub(d) | XorDereferencedTemp(d) -> Xor(d) | CmpDereferencedTemp(d) -> Cmp(d) | MovDereferencedTemp(d) -> Mov(d) | PushDereferencedTemp -> Push | CallDereferencedTemp -> Call | JumpDereferencedTemp -> Jmp | ArbitraryModRM(b1,r) -> Arbitrary(b1,r) | _ -> raise (SyntheticOperandError "End of du chain does not contain a use") let build_synthetic_instruction grouped_def_use_chain insarray = let rec build_expression_tree = function [] -> raise (BuildingSyntaxTree "Ran out of input") | (d,u)::tl -> let dinst = insarray.(d) in match dinst with SetTemp(d) -> Constant(d) | SetRegisterToTemp(r) -> Register(r) | AddImmediateToTemp(d) -> Plus(Constant(d), build_expression_tree(tl)) | AddRegisterToTemp(r) -> Plus(Register(r), build_expression_tree(tl)) | ShiftTemporaryLeft(b) -> ShlReg(Constant(b), build_expression_tree(tl)) | _ -> raise (BuildingSyntaxTree "Instruction does not modify temporary") in let rec prettify = function Constant(d) -> Constant(d) | Register(r) -> Register(r) | Plus(Constant(d),e) -> if (Int32.compare d (Int32.of_int 0)) == 0 then prettify e else Plus(Constant(d), prettify e) | Plus(e,Constant(d)) -> if (Int32.compare d (Int32.of_int 0)) == 0 then prettify e else Plus(prettify e, Constant(d)) | Plus(e1,e2) -> Plus(prettify e1, prettify e2) | ShlReg(e1,e2) -> ShlReg(prettify e1, prettify e2) in let helper = let revlist = List.rev grouped_def_use_chain in let (d,u) = List.hd revlist in let instr = insarray.(u) in let opnd = get_synthetic_operand instr in let t = build_expression_tree revlist in SyntheticInstruction(opnd,prettify t) in helper let build_synthetic_instructions insarray = let g_du_chain = build_grouped_def_use_chains insarray in List.map (fun x -> build_synthetic_instruction x insarray) g_du_chain let get_begin_end_du_chain duc = if (List.length duc == 0) then raise (SyntheticOperandError "Trying to optimize an empty DU chain") else let (d,_) = List.hd duc in let (_,u) = List.hd (List.rev duc) in (d, u) (* Iterate through the instructions, copying those which are not part of a DU chain, and replacing those that are with their corresponding synthetic instruction *) let optimize_instructions_array insarray = let g_du_chain = ref ((build_grouped_def_use_chains insarray)@[[(-1,-1)]]) in let update_du_chain x = g_du_chain := x in let index = ref 0 in let update_index x = index := x in let current_insn_list = ref [] in let update_insn_list x = current_insn_list := (!current_insn_list)@x in let next_du_group = ref [(-1,-1)] in let update_du_group x = next_du_group := x in let arrsize = Array.length insarray in let rec helper = update_du_group (List.hd !g_du_chain); update_du_chain (List.tl !g_du_chain); while( !index < arrsize ) do (* print_endline ("Top of loop: !index = " ^ (string_of_int (!index)) ^ " (fst(List.hd !next_du_group)) = " ^ (string_of_int ((fst(List.hd !next_du_group)))) ^ " (snd(List.hd !next_du_group)) = " ^ (string_of_int (snd(List.hd !next_du_group))) ^ " arrsize = " ^ (string_of_int arrsize)); *) let nextd = (fst(List.hd !next_du_group)) in if( nextd = -1 || !index < nextd ) then ((*print_string ("About to add regular instruction " ^ (string_of_int !index));*) update_insn_list [insarray.(!index)]; update_index (!index + 1); (*print_endline ("... adding succeeded.")*)) else let ins = (build_synthetic_instruction !next_du_group insarray) in let (_,nextu) = get_begin_end_du_chain !next_du_group in (*print_endline ("Added synthetic instruction at (" ^ (string_of_int !index) ^ "," ^ (string_of_int nextu) ^ ")");*) update_du_group (List.hd !g_du_chain); update_du_chain (List.tl !g_du_chain); update_insn_list ([ins]); update_index (nextu + 1); done in helper; Array.of_list !current_insn_list;; let optimize_block_graph = map_graph ( fun v -> { label = v.label; instruction = optimize_instructions_array v.instruction } );; (* ************** *) (* Code Generator *) (* ************** *) type expressionYield = { mutable immediate: dword; mutable indexreg: register; mutable scalereg: register; mutable scalefac: dword } exception CodeGeneratorNotYetImplemented of string let analyze_expression_tree e = let exprYield = ref { indexreg = NoRegister; scalereg = NoRegister; scalefac = Int32.of_int 0; immediate = Int32.of_int 0 } in let rec rec_analyze_expression_tree = function Plus(Constant(d),e) | Plus(e,Constant(d)) -> (rec_analyze_expression_tree e); (!exprYield).immediate <- d | Plus(Register(r),e) | Plus(e,Register(r)) -> (rec_analyze_expression_tree e); (!exprYield).indexreg <- r | ShlReg(Register(r),Constant(d)) | ShlReg(Constant(d),Register(r)) -> (!exprYield).scalereg <- r; (!exprYield).scalefac <- d | Constant(d) -> (!exprYield).immediate <- d | Register(r) -> (!exprYield).indexreg <- r in rec_analyze_expression_tree e; (!exprYield) let register_to_binary = function Eax -> 0 | Ecx -> 1 | Edx -> 2 | Ebx -> 3 | Esp -> 4 | Ebp -> 5 | Esi -> 6 | Edi -> 7 | NoRegister -> raise BadRegister (* Mod Opc R/M FF30 PUSH DWORD PTR DS:[EAX] 00 110 000 FF70 04 PUSH DWORD PTR DS:[EAX+4] 01 110 000 FFB0 80000000 PUSH DWORD PTR DS:[EAX+80] 10 110 000 SS Idx Reg FF3418 PUSH DWORD PTR DS:[EAX+EBX] 00 110 100 00 011 000 FF3498 PUSH DWORD PTR DS:[EAX+EBX*4] 00 110 100 10 011 000 FF3418 PUSH DWORD PTR DS:[EAX+EBX] 00 110 100 00 011 000 FFB498 80000000 PUSH DWORD PTR DS:[EAX+EBX*4+80] 10 110 100 10 011 000 FF3424 PUSH DWORD PTR SS:[ESP] 00 110 100 00 100 100 FF349C PUSH DWORD PTR SS:[ESP+EBX*4] 00 110 100 10 011 100 FF742414 push dword ptr ds:[esp+14h] 01 110 100 00 100 100 Dw Eax SIB *1 Eax Edi 8D8407 78A46AD7 lea eax, [edi+eax-28955B88h] 10 000 100 00 000 111 *) let generate_instruction exprd byt1 opcode immsize = let imm = exprd.immediate in let hasimmediate = (immsize <> 0) in let hasscale = match exprd.scalereg with NoRegister -> false | _ -> true in let scalefac = exprd.scalefac in let ss = (Int32.to_int scalefac) in let indexreg = (register_to_binary exprd.indexreg) in let mod_ = if (hasimmediate = false) then 0 else if immsize = 1 then 1 else if immsize = 4 then 2 else 0 in let modopc = (mod_ lsl 6) lor (opcode lsl 3) in (* is there a scale factor? *) if (hasscale = false) then (* No scale byte, so no need for SIB unless we have ESP *) if (indexreg == 4) then (* We have ESP *) let modrm = modopc lor 4 in let sib = (ss lsl 6) lor (4 lsl 3) lor 4 in if immsize = 1 then LiteralInstruction([|byt1;modrm;sib;Int32.to_int imm|]) else if immsize = 4 then LiteralInstruction(Array.append [|byt1;modrm;sib|] (make_dword_into_array imm)) else LiteralInstruction([|byt1;modrm;sib|]) (* Register other than ESP, no scale factor *) else let modrm = modopc lor indexreg in if immsize = 1 then LiteralInstruction([|byt1;modrm;Int32.to_int imm|]) else if immsize = 4 then LiteralInstruction(Array.append [|byt1;modrm|] (make_dword_into_array imm)) else LiteralInstruction([|byt1;modrm|]) (* we do have a scale factor *) else let modrm = modopc lor 4 in let sib = (ss lsl 6) lor ((register_to_binary exprd.scalereg) lsl 3) lor indexreg in if immsize = 1 then LiteralInstruction([|byt1;modrm;sib;Int32.to_int imm|]) else if immsize = 4 then LiteralInstruction(Array.append [|byt1;modrm;sib|] (make_dword_into_array imm)) else LiteralInstruction([|byt1;modrm;sib|]) let generate_literal_instruction_from_synthetic o e = let exprDetails = analyze_expression_tree e in let k = exprDetails.immediate in let isize = (if (Int32.to_int k) = 0 then 0 else if( ((Int32.compare (Int32.abs k) (Int32.of_int 0x80)) <= 0) && Int32.to_int k <> 0x80 ) then 1 else 4) in match o with Rol(b) -> generate_instruction exprDetails 0xC1 0 1 | Ror(b) -> generate_instruction exprDetails 0xC1 1 1 | Rcl(b) -> generate_instruction exprDetails 0xC1 2 1 | Rcr(b) -> generate_instruction exprDetails 0xC1 3 1 | Shl(b) -> generate_instruction exprDetails 0xC1 4 1 | Sar(b) -> generate_instruction exprDetails 0xC1 5 1 | Shr(b) -> generate_instruction exprDetails 0xC1 7 1 | Add(d) -> generate_instruction exprDetails 0x81 0 4 | Or(d) -> generate_instruction exprDetails 0x81 1 4 | Adc(d) -> generate_instruction exprDetails 0x81 2 4 | Sbb(d) -> generate_instruction exprDetails 0x81 3 4 | And(d) -> generate_instruction exprDetails 0x81 4 4 | Sub(d) -> generate_instruction exprDetails 0x81 5 4 | Xor(d) -> generate_instruction exprDetails 0x81 6 4 | Cmp(d) -> generate_instruction exprDetails 0x81 7 4 | Mov(d) -> generate_instruction exprDetails 0xC7 0 4 | Call -> generate_instruction exprDetails 0xFF 2 isize | Jmp -> generate_instruction exprDetails 0xFF 4 isize | Push -> generate_instruction exprDetails 0xFF 6 isize | Arbitrary(b1,r) -> generate_instruction exprDetails b1 (register_to_binary r) isize let generate_literal_instruction = function VMExit(w) when w = Int32.of_int 0 -> LiteralInstruction([|0xC3|]) | VMExit(w) -> LiteralInstruction(Array.append [|0xC2|] (make_word_into_array w)) | X86Call(r) -> RelativeFixupInstruction((Array.append [|0xE8|] (make_dword_into_array (Int32.of_int 0))),r,Int32.of_int 1) | PushWithImagebaseFixup(d) -> ImagebaseFixupInstruction((Array.append [|0x6A|] (make_dword_into_array d)), Int32.of_int 1) | SyntheticInstruction(o,e) -> generate_literal_instruction_from_synthetic o e | a -> a let code_generate_block_graph = map_graph ( fun v -> { label = v.label; instruction = Array.map generate_literal_instruction v.instruction } ) (* ****** *) (* Linker *) (* ****** *) exception LinkerBadInstruction of string let flatten_block insarray = let arrlen = (Array.length insarray)-1 in let y = insarray.(arrlen) in let islastjmp = match y with ConditionalJump(_,_) | UnconditionalJump(_) -> true | _ -> false in let newarray = if (islastjmp = true) then Array.sub insarray 0 (arrlen) else insarray in let flatarr = ref [||] in let ibfixuplocs = ref [] in let rlfixuplocs = ref [] in let helper = function LiteralInstruction(x) -> flatarr := Array.append !flatarr x | ImagebaseFixupInstruction (x,l) -> ibfixuplocs := ((Array.length !flatarr)+(Int32.to_int l))::(!ibfixuplocs); flatarr := Array.append !flatarr x | RelativeFixupInstruction(x,r,l) -> rlfixuplocs := (((Array.length !flatarr)+(Int32.to_int l)),r)::(!rlfixuplocs); flatarr := Array.append !flatarr x | _ -> raise (LinkerBadInstruction "Encountered non-compiled instruction in linker phase") in Array.iter helper newarray; let i = FlattenedByteRegion(!flatarr,!ibfixuplocs,!rlfixuplocs) in Array.of_list(if(islastjmp = true) then [i]@[y] else [i]) let flatten_block_graph = map_graph ( fun v -> { label = v.label; instruction = flatten_block v.instruction } ) (* Need to fixup the aforementioned *) let apply_ib_fixups arr ib iblist = let rec helper = function [] -> () | hd::tl -> fixup_array arr hd ib; helper tl in helper iblist let fixup_imagebase i1 ib = match i1 with FlattenedByteRegion(arr,ibl,rl) -> apply_ib_fixups arr ib ibl; RegionNeedsRelocations(arr,rl) | a -> a let apply_reloc_fixups arr destaddr rl = let rec helper = function [] -> () | (p,r)::tl -> fixup_array arr p (Int32.sub r (Int32.add destaddr (Int32.of_int(p+4)))); helper tl in helper rl let recompile i1 destaddr = match i1 with RegionNeedsRelocations(arr,rl) -> apply_reloc_fixups arr destaddr rl; write_bin_array arr "c:\\o.bin"; LiteralInstruction(arr) | a -> a (* *** *) (* TOP *) (* *** *) let so_far = let icfg = make_instruction_cfg arr2 in let bcfg = make_block_cfg icfg in let ocfg = optimize_block_graph bcfg in let ccfg = code_generate_block_graph ocfg in let v1 = List.find (fun a -> a.label = 429) ccfg.vertexlist in v1;; let fucfg = fixup_block_graph fcfg (*let v1 = List.hd ccfg.vertexlist in let f1 = flatten_block v1.instruction in let fu = fixup_imagebase f1.(0) imagebase in let ru = recompile fu (Int32.of_int (0x131D0)) in ru;;*)