1 (* Memory info command for virtual domains.
2 (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
19 Functions for making a memory map of a virtual machine from
20 various sources. The memory map will most certainly have holes.
28 (* Simple implementation at the moment: Store a list of mappings,
29 * sorted by start address. We assume that mappings do not overlap.
30 * We can change the implementation later if we need to. In most cases
31 * there will only be a small number of mappings (probably 1).
34 mappings : mapping list;
35 wordsize : wordsize option;
36 endian : Bitmatch.endian option;
41 (* Bigarray mmap(2)'d region with byte addressing: *)
42 arr : (char,int8_unsigned_elt,c_layout) Array1.t;
53 let set_wordsize t ws = { t with wordsize = Some ws }
55 let set_endian t e = { t with endian = Some e }
57 let get_wordsize t = Option.get t.wordsize
59 let get_endian t = Option.get t.endian
61 let sort_mappings mappings =
62 let cmp { start = s1 } { start = s2 } = compare s1 s2 in
63 List.sort cmp mappings
65 let add_file ({ mappings = mappings } as t) fd addr =
66 if addr &^ 7L <> 0L then
67 invalid_arg "add_file: mapping address must be aligned to 8 bytes";
68 let size = (fstat fd).st_size in
69 (* mmap(2) the file using Bigarray module. *)
70 let arr = Array1.map_file fd char c_layout false size in
71 (* Create the mapping entry and keep the mappings sorted by start addr. *)
73 { start = addr; size = Int64.of_int size; arr = arr } :: mappings in
74 let mappings = sort_mappings mappings in
75 { t with mappings = mappings }
81 let add_string ({ mappings = mappings } as t) str addr =
82 if addr &^ 7L <> 0L then
83 invalid_arg "add_file: mapping address must be aligned to 8 bytes";
84 let size = String.length str in
85 (* Copy the string data to a Bigarray. *)
86 let arr = Array1.create char c_layout size in
87 for i = 0 to size-1 do
88 Array1.set arr i (String.unsafe_get str i)
90 (* Create the mapping entry and keep the mappings sorted by start addr. *)
92 { start = addr; size = Int64.of_int size; arr = arr } :: mappings in
93 let mappings = sort_mappings mappings in
94 { t with mappings = mappings }
96 let of_string str addr =
100 (* Find in mappings and return first predicate match. *)
101 let _find_map { mappings = mappings } pred =
102 let rec loop = function
111 (* The following functions are actually written in C
112 * because memmem(3) is likely to be much faster than anything
113 * we could write in OCaml.
115 * Also OCaml bigarrays are specifically designed to be accessed
117 * http://caml.inria.fr/pub/docs/manual-ocaml/manual043.html
120 (* Array+offset = string? *)
121 let string_at arr offset str strlen =
122 let j = ref offset in
124 if i >= strlen then true
126 if Array1.get arr !j <> str.[i] then false
134 (* Find in a single file mapping.
135 * [start] is relative to the mapping and we return an offset relative
138 let _find_in start align str arr =
139 let strlen = String.length str in
142 let e = Array1.dim arr - strlen in
145 if string_at arr !j str strlen then Some !j
158 int -> int -> string -> (char,int8_unsigned_elt,c_layout) Array1.t ->
159 int option = "virt_mem_mmap_find_in"
161 (* Generic find function. *)
162 let _find t start align str =
164 fun { start = mstart; size = msize; arr = arr } ->
165 if mstart >= start then (
166 (* Check this mapping from the beginning. *)
167 match _find_in 0 align str arr with
168 | Some offset -> Some (mstart +^ Int64.of_int offset)
171 else if mstart < start && start <= mstart+^msize then (
172 (* Check this mapping from somewhere in the middle. *)
173 let offset = Int64.to_int (start -^ mstart) in
174 match _find_in offset align str arr with
175 | Some offset -> Some (mstart +^ Int64.of_int offset)
181 let find t ?(start=0L) str =
184 let find_align t ?(start=0L) str =
185 let align = bytes_of_wordsize (get_wordsize t) in
186 _find t start align str
188 let rec _find_all t start align str =
189 match _find t start align str with
192 offset :: _find_all t (offset +^ Int64.of_int align) align str
194 let find_all t ?(start=0L) str =
195 _find_all t start 1 str
197 let find_all_align t ?(start=0L) str =
198 let align = bytes_of_wordsize (get_wordsize t) in
199 _find_all t start align str
201 (* NB: Phantom types in the interface ensure that these pointer functions
202 * can only be called once endianness and wordsize have both been set.
205 let rec find_pointer t ?start addr =
206 find_align t ?start (string_of_addr t addr)
208 and find_pointer_all t ?start addr =
209 find_all_align t ?start (string_of_addr t addr)
212 and string_of_addr t addr =
213 let bits = bits_of_wordsize (get_wordsize t) in
214 let e = get_endian t in
215 let bs = BITSTRING { addr : bits : endian (e) } in
216 Bitmatch.string_of_bitstring bs
218 (* XXX bitmatch is missing 'construct_int64_le_unsigned' so we
219 * have to force this to 32 bits for the moment.
221 and string_of_addr t addr =
222 let bits = bits_of_wordsize (get_wordsize t) in
224 let e = get_endian t in
225 let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in
226 Bitmatch.string_of_bitstring bs
228 and addr_of_string t str =
229 let bits = bits_of_wordsize (get_wordsize t) in
230 let e = get_endian t in
231 let bs = Bitmatch.bitstring_of_string str in
233 | { addr : bits : endian (e) } -> addr
234 | { _ } -> invalid_arg "addr_of_string"
236 let get_byte { mappings = mappings } addr =
237 let rec loop = function
238 | [] -> invalid_arg "get_byte"
239 | { start = start; size = size; arr = arr } :: _
240 when start <= addr && addr < start +^ size ->
241 let offset = Int64.to_int (addr -^ start) in
242 Char.code (Array1.get arr offset)
247 (* Take bytes until a condition is not met. This is efficient in that
248 * we stay within the same mapping as long as we can.
250 let dowhile { mappings = mappings } addr cond =
251 let rec get_next_mapping addr = function
252 | [] -> invalid_arg "dowhile"
253 | { start = start; size = size; arr = arr } :: _
254 when start <= addr && addr < start +^ size ->
255 let offset = Int64.to_int (addr -^ start) in
256 let len = Int64.to_int size - offset in
258 | _ :: ms -> get_next_mapping addr ms
261 let arr, offset, len = get_next_mapping addr mappings in
264 let c = Array1.get arr (offset+i) in
265 if cond c then loop2 (i+1)
267 loop (addr +^ Int64.of_int len)
273 let get_bytes t addr len =
274 let str = String.create len in
285 Invalid_argument _ -> invalid_arg "get_bytes"
287 let get_int32 t addr =
288 let e = get_endian t in
289 let str = get_bytes t addr 4 in
290 let bs = Bitmatch.bitstring_of_string str in
292 | { addr : 32 : endian (e) } -> addr
293 | { _ } -> invalid_arg "follow_pointer"
295 let get_int64 t addr =
296 let e = get_endian t in
297 let str = get_bytes t addr 8 in
298 let bs = Bitmatch.bitstring_of_string str in
300 | { addr : 64 : endian (e) } -> addr
301 | { _ } -> invalid_arg "follow_pointer"
303 let get_C_int = get_int32
305 let get_C_long t addr =
306 let ws = get_wordsize t in
308 | W32 -> Int64.of_int32 (get_int32 t addr)
309 | W64 -> get_int64 t addr
311 let get_string t addr =
312 let chars = ref [] in
316 if c <> '\000' then (
317 chars := c :: !chars;
321 let chars = List.rev !chars in
322 let len = List.length chars in
323 let str = String.create len in
325 List.iter (fun c -> str.[!i] <- c; incr i) chars;
328 Invalid_argument _ -> invalid_arg "get_string"
330 let is_string t addr =
331 try dowhile t addr (fun c -> c <> '\000'); true
332 with Invalid_argument _ -> false
334 let is_C_identifier t addr =
342 c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z'
344 if c = '\000' then false
346 if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' ||
347 c >= '0' && c <= '9' then
360 Invalid_argument _ -> false
362 let is_mapped { mappings = mappings } addr =
363 let rec loop = function
365 | { start = start; size = size; arr = arr } :: _
366 when start <= addr && addr < start +^ size -> true
371 let follow_pointer t addr =
372 let ws = get_wordsize t in
373 let e = get_endian t in
374 let bits = bits_of_wordsize ws in
375 let str = get_bytes t addr (bytes_of_wordsize ws) in
376 let bs = Bitmatch.bitstring_of_string str in
378 | { addr : bits : endian (e) } -> addr
379 | { _ } -> invalid_arg "follow_pointer"
381 let succ_long t addr =
382 let ws = get_wordsize t in
383 addr +^ Int64.of_int (bytes_of_wordsize ws)
385 let pred_long t addr =
386 let ws = get_wordsize t in
387 addr -^ Int64.of_int (bytes_of_wordsize ws)
390 let ws = get_wordsize t in
391 let mask = Int64.of_int (bytes_of_wordsize ws - 1) in
392 (addr +^ mask) &^ (Int64.lognot mask)