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.
34 (* A range of addresses (start and start+size). *)
35 type interval = addr * addr
41 (* Bigarray mmap(2)'d region with byte addressing: *)
42 arr : (char,int8_unsigned_elt,c_layout) Array1.t;
43 (* The order that the mappings were added, 0 for the first mapping,
44 * 1 for the second mapping, etc.
50 type ('ws,'e,'hm) t = {
51 (* List of mappings, kept in reverse order they were added (new
52 * mappings are added at the head of this list).
54 mappings : mapping list;
56 (* Segment tree for fast access to a mapping at a particular address.
57 * This is rebuilt each time a new mapping is added.
58 * NB! If mappings = [], ignore contents of this field. (This is
59 * enforced by the 'hm phantom type).
61 tree : (interval * mapping list, interval * mapping list) binary_tree;
63 (* Word size, endianness.
64 * Phantom types enforce that these are set before being used.
67 endian : Bitstring.endian;
72 tree = Leaf ((0L,0L),[]);
74 endian = Bitstring.LittleEndian;
77 let set_wordsize t ws = { t with wordsize = ws }
79 let set_endian t e = { t with endian = e }
81 let get_wordsize t = t.wordsize
83 let get_endian t = t.endian
85 (* Build the segment tree from the list of mappings. This code
86 * is taken from virt-df. For an explanation of the process see:
87 * http://en.wikipedia.org/wiki/Segment_tree
89 let tree_of_mappings mappings =
90 (* Construct the list of distinct endpoints. *)
93 (fun { start = start; size = size } -> [start; start +^ size])
95 let eps = sort_uniq (List.concat eps) in
97 (* Construct the elementary intervals. *)
99 let elints, lastpoint =
101 fun (elints, prevpoint) point ->
102 ((point, point) :: (prevpoint, point) :: elints), point
104 let elints = (lastpoint, Int64.max_int(*XXX*)) :: elints in
108 eprintf "elementary intervals (%d in total):\n" (List.length elints);
110 fun (startpoint, endpoint) ->
111 eprintf " %Lx %Lx\n" startpoint endpoint
115 (* Construct the binary tree of elementary intervals. *)
117 (* Each elementary interval becomes a leaf. *)
118 let elints = List.map (fun elint -> Leaf elint) elints in
119 (* Recursively build this into a binary tree. *)
120 let rec make_layer = function
123 (* Turn pairs of leaves at the bottom level into nodes. *)
124 | (Leaf _ as a) :: (Leaf _ as b) :: xs ->
125 let xs = make_layer xs in
126 Node (a, (), b) :: xs
127 (* Turn pairs of nodes at higher levels into nodes. *)
128 | (Node _ as left) :: ((Node _|Leaf _) as right) :: xs ->
129 let xs = make_layer xs in
130 Node (left, (), right) :: xs
131 | Leaf _ :: _ -> assert false (* never happens??? (I think) *)
133 let rec loop = function
136 | xs -> loop (make_layer xs)
141 let leaf_printer (startpoint, endpoint) =
142 sprintf "%Lx-%Lx" startpoint endpoint
144 let node_printer () = "" in
145 print_binary_tree leaf_printer node_printer tree
148 (* Insert the mappings into the tree one by one. *)
150 (* For each node/leaf in the tree, add its interval and an
151 * empty list which will be used to store the mappings.
153 let rec interval_tree = function
154 | Leaf elint -> Leaf (elint, [])
155 | Node (left, (), right) ->
156 let left = interval_tree left in
157 let right = interval_tree right in
158 let (leftstart, _) = interval_of_node left in
159 let (_, rightend) = interval_of_node right in
160 let interval = leftstart, rightend in
161 Node (left, (interval, []), right)
162 and interval_of_node = function
163 | Leaf (elint, _) -> elint
164 | Node (_, (interval, _), _) -> interval
167 let tree = interval_tree tree in
168 (* This should always be true: *)
169 assert (interval_of_node tree = (0L, Int64.max_int(*XXX*)));
171 (* "Contained in" operator.
172 * 'a <-< b' iff 'a' is a subinterval of 'b'.
174 * |<----------- b ----------->|
176 let (<-<) (a1, a2) (b1, b2) = b1 <= a1 && a2 <= b2 in
178 (* "Intersects" operator.
179 * 'a /\ b' iff intervals 'a' and 'b' overlap, eg:
181 * |<----------- b ----------->|
183 let ( /\ ) (a1, a2) (b1, b2) = a2 > b1 || b2 > a1 in
185 let rec insert_mapping tree mapping =
186 let { start = start; size = size } = mapping in
187 let seginterval = start, start +^ size in
190 (* Test if we should insert into this leaf or node: *)
191 | Leaf (interval, mappings) when interval <-< seginterval ->
192 Leaf (interval, mapping :: mappings)
193 | Node (left, (interval, mappings), right)
194 when interval <-< seginterval ->
195 Node (left, (interval, mapping :: mappings), right)
197 | (Leaf _) as leaf -> leaf
199 (* Else, should we insert into left or right subtrees? *)
200 | Node (left, i, right) ->
202 if seginterval /\ interval_of_node left then
203 insert_mapping left mapping
207 if seginterval /\ interval_of_node right then
208 insert_mapping right mapping
211 Node (left, i, right)
213 let tree = List.fold_left insert_mapping tree mappings in
217 let printer ((sp, ep), mappings) =
218 sprintf "[%Lx-%Lx] " sp ep ^
220 (List.map (fun { start = start; size = size } ->
221 sprintf "%Lx+%Lx" start size)
224 print_binary_tree printer printer tree
229 let add_mapping ({ mappings = mappings } as t) start size arr =
230 let order = List.length mappings in
231 let mapping = { start = start; size = size; arr = arr; order = order } in
232 let mappings = mapping :: mappings in
233 let tree = tree_of_mappings mappings in
234 { t with mappings = mappings; tree = tree }
236 let add_file t fd addr =
237 let size = (fstat fd).st_size in
238 (* mmap(2) the file using Bigarray module. *)
239 let arr = Array1.map_file fd char c_layout false size in
240 (* Create the mapping entry. *)
241 add_mapping t addr (Int64.of_int size) arr
243 let add_string ({ mappings = mappings } as t) str addr =
244 let size = String.length str in
245 (* Copy the string data to a Bigarray. *)
246 let arr = Array1.create char c_layout size in
247 for i = 0 to size-1 do
248 Array1.set arr i (String.unsafe_get str i)
250 (* Create the mapping entry. *)
251 add_mapping t addr (Int64.of_int size) arr
253 let of_file fd addr =
257 let of_string str addr =
259 add_string t str addr
261 (* Look up an address and get the top-most mapping which contains it.
262 * This uses the segment tree, so it's fast. The top-most mapping is
263 * the one with the highest 'order' field.
265 * Warning: This 'hot' code was carefully optimized based on
266 * feedback from 'gprof'. Avoid fiddling with it.
268 let rec get_mapping addr = function
269 | Leaf (_, []) -> None
270 | Leaf (_, [mapping]) -> Some mapping
271 | Leaf (_, mappings) -> Some (find_highest_order mappings)
273 (* Try to avoid expensive search if node mappings is empty: *)
274 | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
278 if addr < leftend then get_mapping addr left
279 else get_mapping addr right in
282 (* ... or a singleton: *)
283 | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
287 if addr < leftend then get_mapping addr left
288 else get_mapping addr right in
289 (match submapping with
290 | None -> Some mapping
292 Some (if mapping.order > submapping.order then mapping
296 (* Normal recursive case: *)
297 | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
301 if addr < leftend then get_mapping addr left
302 else get_mapping addr right in
303 (match submapping with
304 | None -> Some (find_highest_order mappings)
305 | Some submapping -> Some (find_highest_order (submapping :: mappings))
308 and find_highest_order mappings =
310 fun mapping1 mapping2 ->
311 if mapping1.order > mapping2.order then mapping1 else mapping2
312 ) (List.hd mappings) (List.tl mappings)
314 (* Get a single byte. *)
315 let get_byte { tree = tree } addr =
316 (* Get the mapping which applies to this address: *)
317 match get_mapping addr tree with
318 | Some { start = start; size = size; arr = arr } ->
319 let offset = Int64.to_int (addr -^ start) in
320 Char.code (Array1.get arr offset)
322 invalid_arg "get_byte"
324 let rec loop = function
325 | [] -> invalid_arg "get_byte"
326 | { start = start; size = size; arr = arr } :: _
327 when start <= addr && addr < start +^ size ->
328 let offset = Int64.to_int (addr -^ start) in
329 Char.code (Array1.get arr offset)
338 (* Find in mappings and return first predicate match. *)
339 let _find_map { mappings = mappings } pred =
340 let rec loop = function
349 (* The following functions are actually written in C
350 * because memmem(3) is likely to be much faster than anything
351 * we could write in OCaml.
353 * Also OCaml bigarrays are specifically designed to be accessed
355 * http://caml.inria.fr/pub/docs/manual-ocaml/manual043.html
358 (* Array+offset = string? *)
359 let string_at arr offset str strlen =
360 let j = ref offset in
362 if i >= strlen then true
364 if Array1.get arr !j <> str.[i] then false
372 (* Find in a single file mapping.
373 * [start] is relative to the mapping and we return an offset relative
376 let _find_in start align str arr =
377 let strlen = String.length str in
380 let e = Array1.dim arr - strlen in
383 if string_at arr !j str strlen then Some !j
396 int -> int -> string -> (char,int8_unsigned_elt,c_layout) Array1.t ->
397 int option = "virt_mem_mmap_find_in"
399 (* Generic find function. *)
400 let _find t start align str =
402 fun { start = mstart; size = msize; arr = arr } ->
403 if mstart >= start then (
404 (* Check this mapping from the beginning. *)
405 match _find_in 0 align str arr with
406 | Some offset -> Some (mstart +^ Int64.of_int offset)
409 else if mstart < start && start <= mstart+^msize then (
410 (* Check this mapping from somewhere in the middle. *)
411 let offset = Int64.to_int (start -^ mstart) in
412 match _find_in offset align str arr with
413 | Some offset -> Some (mstart +^ Int64.of_int offset)
419 let find t ?(start=0L) str =
422 let find_align t ?(start=0L) str =
423 let align = bytes_of_wordsize (get_wordsize t) in
424 _find t start align str
426 let rec _find_all t start align str =
427 match _find t start align str with
430 offset :: _find_all t (offset +^ Int64.of_int align) align str
432 let find_all t ?(start=0L) str =
433 _find_all t start 1 str
435 let find_all_align t ?(start=0L) str =
436 let align = bytes_of_wordsize (get_wordsize t) in
437 _find_all t start align str
439 (* NB: Phantom types in the interface ensure that these pointer functions
440 * can only be called once endianness and wordsize have both been set.
443 let rec find_pointer t ?start addr =
444 find_align t ?start (string_of_addr t addr)
446 and find_pointer_all t ?start addr =
447 find_all_align t ?start (string_of_addr t addr)
450 and string_of_addr t addr =
451 let bits = bits_of_wordsize (get_wordsize t) in
452 let e = get_endian t in
453 let bs = BITSTRING { addr : bits : endian (e) } in
454 Bitstring.string_of_bitstring bs
456 (* XXX bitstring is missing 'construct_int64_le_unsigned' so we
457 * have to force this to 32 bits for the moment.
459 and string_of_addr t addr =
460 let bits = bits_of_wordsize (get_wordsize t) in
462 let e = get_endian t in
463 let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in
464 Bitstring.string_of_bitstring bs
466 and addr_of_string t str =
467 let bits = bits_of_wordsize (get_wordsize t) in
468 let e = get_endian t in
469 let bs = Bitstring.bitstring_of_string str in
471 | { addr : bits : endian (e) } -> addr
472 | { _ } -> invalid_arg "addr_of_string"
474 (* Take bytes until a condition is not met. This is efficient in that
475 * we stay within the same mapping as long as we can.
477 let dowhile { mappings = mappings } addr cond =
478 let rec get_next_mapping addr = function
479 | [] -> invalid_arg "dowhile"
480 | { start = start; size = size; arr = arr } :: _
481 when start <= addr && addr < start +^ size ->
482 let offset = Int64.to_int (addr -^ start) in
483 let len = Int64.to_int size - offset in
485 | _ :: ms -> get_next_mapping addr ms
488 let arr, offset, len = get_next_mapping addr mappings in
491 let c = Array1.get arr (offset+i) in
492 if cond c then loop2 (i+1)
494 loop (addr +^ Int64.of_int len)
500 let get_bytes t addr len =
501 let str = String.create len in
512 Invalid_argument _ -> invalid_arg "get_bytes"
514 let get_int32 t addr =
515 let e = get_endian t in
516 let str = get_bytes t addr 4 in
517 let bs = Bitstring.bitstring_of_string str in
519 | { addr : 32 : endian (e) } -> addr
520 | { _ } -> invalid_arg "follow_pointer"
522 let get_int64 t addr =
523 let e = get_endian t in
524 let str = get_bytes t addr 8 in
525 let bs = Bitstring.bitstring_of_string str in
527 | { addr : 64 : endian (e) } -> addr
528 | { _ } -> invalid_arg "follow_pointer"
530 let get_C_int = get_int32
532 let get_C_long t addr =
533 let ws = get_wordsize t in
535 | W32 -> Int64.of_int32 (get_int32 t addr)
536 | W64 -> get_int64 t addr
538 let get_string t addr =
539 let chars = ref [] in
543 if c <> '\000' then (
544 chars := c :: !chars;
548 let chars = List.rev !chars in
549 let len = List.length chars in
550 let str = String.create len in
552 List.iter (fun c -> str.[!i] <- c; incr i) chars;
555 Invalid_argument _ -> invalid_arg "get_string"
557 let is_string t addr =
558 try dowhile t addr (fun c -> c <> '\000'); true
559 with Invalid_argument _ -> false
561 let is_C_identifier t addr =
569 c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z'
571 if c = '\000' then false
573 if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' ||
574 c >= '0' && c <= '9' then
587 Invalid_argument _ -> false
589 let is_mapped { mappings = mappings } addr =
590 let rec loop = function
592 | { start = start; size = size; arr = arr } :: _
593 when start <= addr && addr < start +^ size -> true
598 let follow_pointer t addr =
599 let ws = get_wordsize t in
600 let e = get_endian t in
601 let bits = bits_of_wordsize ws in
602 let str = get_bytes t addr (bytes_of_wordsize ws) in
603 let bs = Bitstring.bitstring_of_string str in
605 | { addr : bits : endian (e) } -> addr
606 | { _ } -> invalid_arg "follow_pointer"
608 let succ_long t addr =
609 let ws = get_wordsize t in
610 addr +^ Int64.of_int (bytes_of_wordsize ws)
612 let pred_long t addr =
613 let ws = get_wordsize t in
614 addr -^ Int64.of_int (bytes_of_wordsize ws)
617 let ws = get_wordsize t in
618 let mask = Int64.of_int (bytes_of_wordsize ws - 1) in
619 (addr +^ mask) &^ (Int64.lognot mask)
621 let map { mappings = mappings } f =
622 List.map (fun { start = start; size = size } -> f start size) mappings
625 ignore (map t (fun start size -> let () = f start size in ()))
627 let nr_mappings { mappings = mappings } = List.length mappings