(* Memory info command for virtual domains. (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Functions for making a memory map of a virtual machine from various sources. The memory map will most certainly have holes. *) open Unix open Bigarray open Virt_mem_utils (* Simple implementation at the moment: Store a list of mappings, * sorted by start address. We assume that mappings do not overlap. * We can change the implementation later if we need to. In most cases * there will only be a small number of mappings (probably 1). *) type ('a,'b) t = { mappings : mapping list; wordsize : wordsize option; endian : Bitmatch.endian option; } and mapping = { start : addr; size : addr; (* Bigarray mmap(2)'d region with byte addressing: *) arr : (char,int8_unsigned_elt,c_layout) Array1.t; } and addr = int64 let create () = { mappings = []; wordsize = None; endian = None } let set_wordsize t ws = { t with wordsize = Some ws } let set_endian t e = { t with endian = Some e } let get_wordsize t = Option.get t.wordsize let get_endian t = Option.get t.endian let sort_mappings mappings = let cmp { start = s1 } { start = s2 } = compare s1 s2 in List.sort cmp mappings let add_file ({ mappings = mappings } as t) fd addr = if addr &^ 7L <> 0L then invalid_arg "add_file: mapping address must be aligned to 8 bytes"; let size = (fstat fd).st_size in (* mmap(2) the file using Bigarray module. *) let arr = Array1.map_file fd char c_layout false size in (* Create the mapping entry and keep the mappings sorted by start addr. *) let mappings = { start = addr; size = Int64.of_int size; arr = arr } :: mappings in let mappings = sort_mappings mappings in { t with mappings = mappings } let of_file fd addr = let t = create () in add_file t fd addr (* Find in mappings and return first predicate match. *) let _find_map { mappings = mappings } pred = let rec loop = function | [] -> None | m :: ms -> match pred m with | Some n -> Some n | None -> loop ms in loop mappings (* Array+offset = string? *) let string_at arr offset str strlen = let j = ref offset in let rec loop i = if i >= strlen then true else if Array1.get arr !j <> str.[i] then false else ( incr j; loop (i+1) ) in loop 0 (* Find in a single file mapping. * [start] is relative to the mapping and we return an offset relative * to the mapping. *) let _find_in start align str arr = let strlen = String.length str in if strlen > 0 then ( let j = ref start in let e = Array1.dim arr - strlen in let rec loop () = if !j <= e then ( if string_at arr !j str strlen then Some !j else ( j := !j + align; loop () ) ) else None in loop () ) else Some start (* Generic find function. *) let _find t start align str = _find_map t ( fun { start = mstart; size = msize; arr = arr } -> if mstart >= start then ( (* Check this mapping from the beginning. *) match _find_in 0 align str arr with | Some offset -> Some (mstart +^ Int64.of_int offset) | None -> None ) else if mstart < start && start <= mstart+^msize then ( (* Check this mapping from somewhere in the middle. *) let offset = Int64.to_int (start -^ mstart) in match _find_in offset align str arr with | Some offset -> Some (mstart +^ Int64.of_int offset) | None -> None ) else None ) let find t ?(start=0L) str = _find t start 1 str let find_align t ?(start=0L) str = let align = bytes_of_wordsize (get_wordsize t) in _find t start align str let rec _find_all t start align str = match _find t start align str with | None -> [] | Some offset -> offset :: _find_all t (offset +^ Int64.of_int align) align str let find_all t ?(start=0L) str = _find_all t start 1 str let find_all_align t ?(start=0L) str = let align = bytes_of_wordsize (get_wordsize t) in _find_all t start align str (* NB: Phantom types in the interface ensure that these pointer functions * can only be called once endianness and wordsize have both been set. *) let rec find_pointer t ?start addr = find_align t ?start (string_of_addr t addr) and find_pointer_all t ?start addr = find_all_align t ?start (string_of_addr t addr) (* and string_of_addr t addr = let bits = bits_of_wordsize (get_wordsize t) in let e = get_endian t in let bs = BITSTRING { addr : bits : endian (e) } in Bitmatch.string_of_bitstring bs *) (* XXX bitmatch is missing 'construct_int64_le_unsigned' so we * have to force this to 32 bits for the moment. *) and string_of_addr t addr = let bits = bits_of_wordsize (get_wordsize t) in assert (bits = 32); let e = get_endian t in let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in Bitmatch.string_of_bitstring bs and addr_of_string t str = let bits = bits_of_wordsize (get_wordsize t) in let e = get_endian t in let bs = Bitmatch.bitstring_of_string str in bitmatch bs with | { addr : bits : endian (e) } -> addr | { _ } -> invalid_arg "addr_of_string" let get_byte { mappings = mappings } addr = let rec loop = function | [] -> invalid_arg "get_byte" | { start = start; size = size; arr = arr } :: _ when start <= addr && addr < start +^ size -> let offset = Int64.to_int (addr -^ start) in Char.code (Array1.get arr offset) | _ :: ms -> loop ms in loop mappings (* Take bytes until a condition is not met. This is efficient in that * we stay within the same mapping as long as we can. *) let dowhile { mappings = mappings } addr cond = let rec get_next_mapping addr = function | [] -> invalid_arg "dowhile" | { start = start; size = size; arr = arr } :: _ when start <= addr && addr < start +^ size -> let offset = Int64.to_int (addr -^ start) in let len = Int64.to_int size - offset in arr, offset, len | _ :: ms -> get_next_mapping addr ms in let rec loop addr = let arr, offset, len = get_next_mapping addr mappings in let rec loop2 i = if i < len then ( let c = Array1.get arr (offset+i) in if cond c then loop2 (i+1) ) else loop (addr +^ Int64.of_int len) in loop2 0 in loop addr let get_bytes t addr len = let str = String.create len in let i = ref 0 in try dowhile t addr ( fun c -> str.[!i] <- c; incr i; !i < len ); str with Invalid_argument _ -> invalid_arg "get_bytes" let get_string t addr = let chars = ref [] in try dowhile t addr ( fun c -> if c <> '\000' then ( chars := c :: !chars; true ) else false ); let chars = List.rev !chars in let len = List.length chars in let str = String.create len in let i = ref 0 in List.iter (fun c -> str.[!i] <- c; incr i) chars; str with Invalid_argument _ -> invalid_arg "get_string" let is_string t addr = try dowhile t addr (fun c -> c <> '\000'); true with Invalid_argument _ -> false let is_C_identifier t addr = let i = ref 0 in let r = ref true in try dowhile t addr ( fun c -> let b = if !i = 0 then ( c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' ) else ( if c = '\000' then false else ( if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' || c >= '0' && c <= '9' then true else ( r := false; false ) ) ) in incr i; b ); !r with Invalid_argument _ -> false let is_mapped { mappings = mappings } addr = let rec loop = function | [] -> false | { start = start; size = size; arr = arr } :: _ when start <= addr && addr < start +^ size -> true | _ :: ms -> loop ms in loop mappings let follow_pointer t addr = let ws = get_wordsize t in let e = get_endian t in let bits = bits_of_wordsize ws in let str = get_bytes t addr (bytes_of_wordsize ws) in let bs = Bitmatch.bitstring_of_string str in bitmatch bs with | { addr : bits : endian (e) } -> addr | { _ } -> invalid_arg "follow_pointer" let succ_long t addr = let ws = get_wordsize t in addr +^ Int64.of_int (bytes_of_wordsize ws) let pred_long t addr = let ws = get_wordsize t in addr -^ Int64.of_int (bytes_of_wordsize ws) let align t addr = let ws = get_wordsize t in let mask = Int64.of_int (bytes_of_wordsize ws - 1) in (addr +^ mask) &^ (Int64.lognot mask)