Stupid bug - extract the content fields correctly.
[virt-mem.git] / lib / virt_mem_mmap.ml
1 (* Memory info command for virtual domains.
2    (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
3    http://libvirt.org/
4
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.
9
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.
14
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.
18
19    Functions for making a memory map of a virtual machine from
20    various sources.  The memory map will most certainly have holes.
21  *)
22
23 open Unix
24 open Printf
25 open Bigarray
26
27 open Virt_mem_utils
28
29 let debug = false
30
31 (* An address. *)
32 type addr = int64
33
34 (* A range of addresses (start and start+size). *)
35 type interval = addr * addr
36
37 (* A mapping. *)
38 type mapping = {
39   start : addr;
40   size : 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.
45    *)
46   order : int;
47 }
48
49 (* A memory map. *)
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).
53    *)
54   mappings : mapping list;
55
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).
60    *)
61   tree : (interval * mapping option, interval * mapping option) binary_tree;
62
63   (* Word size, endianness.
64    * Phantom types enforce that these are set before being used.
65    *)
66   wordsize : wordsize;
67   endian : Bitstring.endian;
68 }
69
70 let create () = {
71   mappings = [];
72   tree = Leaf ((0L,0L),None);
73   wordsize = W32;
74   endian = Bitstring.LittleEndian;
75 }
76
77 let set_wordsize t ws = { t with wordsize = ws }
78
79 let set_endian t e = { t with endian = e }
80
81 let get_wordsize t = t.wordsize
82
83 let get_endian t = t.endian
84
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
88  *
89  * See also the 'get_mapping' function below which uses this tree
90  * to do fast lookups.
91  *)
92 let tree_of_mappings mappings =
93   (* Construct the list of distinct endpoints. *)
94   let eps =
95     List.map
96       (fun { start = start; size = size } -> [start; start +^ size])
97       mappings in
98   let eps = sort_uniq (List.concat eps) in
99
100   (* Construct the elementary intervals. *)
101   let elints =
102     let elints, lastpoint =
103       List.fold_left (
104         fun (elints, prevpoint) point ->
105           ((point, point) :: (prevpoint, point) :: elints), point
106       ) ([], 0L) eps in
107     let elints = (lastpoint, Int64.max_int(*XXX*)) :: elints in
108     List.rev elints in
109
110   if debug then (
111     eprintf "elementary intervals (%d in total):\n" (List.length elints);
112     List.iter (
113       fun (startpoint, endpoint) ->
114         eprintf "  %Lx %Lx\n" startpoint endpoint
115     ) elints
116   );
117
118   (* Construct the binary tree of elementary intervals. *)
119   let tree =
120     (* Each elementary interval becomes a leaf. *)
121     let elints = List.map (fun elint -> Leaf elint) elints in
122     (* Recursively build this into a binary tree. *)
123     let rec make_layer = function
124       | [] -> []
125       | ([_] as x) -> x
126       (* Turn pairs of leaves at the bottom level into nodes. *)
127       | (Leaf _ as a) :: (Leaf _ as b) :: xs ->
128           let xs = make_layer xs in
129           Node (a, (), b) :: xs
130       (* Turn pairs of nodes at higher levels into nodes. *)
131       | (Node _ as left) :: ((Node _|Leaf _) as right) :: xs ->
132           let xs = make_layer xs in
133           Node (left, (), right) :: xs
134       | Leaf _ :: _ -> assert false (* never happens??? (I think) *)
135     in
136     let rec loop = function
137       | [] -> assert false
138       | [x] -> x
139       | xs -> loop (make_layer xs)
140     in
141     loop elints in
142
143   if debug then (
144     let leaf_printer (startpoint, endpoint) =
145       sprintf "%Lx-%Lx" startpoint endpoint
146     in
147     let node_printer () = "" in
148     print_binary_tree leaf_printer node_printer tree
149   );
150
151   (* Insert the mappings into the tree one by one. *)
152   let tree =
153     (* For each node/leaf in the tree, add its interval and an
154      * empty list which will be used to store the mappings.
155      *)
156     let rec interval_tree = function
157       | Leaf elint -> Leaf (elint, None)
158       | Node (left, (), right) ->
159           let left = interval_tree left in
160           let right = interval_tree right in
161           let (leftstart, _) = interval_of_node left in
162           let (_, rightend) = interval_of_node right in
163           let interval = leftstart, rightend in
164           Node (left, (interval, None), right)
165     and interval_of_node = function
166       | Leaf (elint, _) -> elint
167       | Node (_, (interval, _), _) -> interval
168     in
169
170     let tree = interval_tree tree in
171     (* This should always be true: *)
172     assert (interval_of_node tree = (0L, Int64.max_int(*XXX*)));
173
174     (* "Contained in" operator.
175      * 'a <-< b' iff 'a' is a subinterval of 'b'.
176      *      |<---- a ---->|
177      * |<----------- b ----------->|
178      *)
179     let (<-<) (a1, a2) (b1, b2) = b1 <= a1 && a2 <= b2 in
180
181     (* "Intersects" operator.
182      * 'a /\ b' iff intervals 'a' and 'b' overlap, eg:
183      *      |<---- a ---->|
184      *                |<----------- b ----------->|
185      *)
186     let ( /\ ) (a1, a2) (b1, b2) = a2 > b1 || b2 > a1 in
187
188     let rec insert_mapping tree mapping =
189       let { start = start; size = size } = mapping in
190       let seginterval = start, start +^ size in
191
192       match tree with
193       (* Test if we should insert into this leaf or node: *)
194       | Leaf (interval, None) when interval <-< seginterval ->
195           Leaf (interval, Some mapping)
196       | Leaf (interval, Some oldmapping) when interval <-< seginterval ->
197           let mapping =
198             if oldmapping.order > mapping.order then oldmapping else mapping in
199           Leaf (interval, Some mapping)
200
201       | Node (left, (interval, None), right) when interval <-< seginterval ->
202           Node (left, (interval, Some mapping), right)
203
204       | Node (left, (interval, Some oldmapping), right)
205           when interval <-< seginterval ->
206           let mapping =
207             if oldmapping.order > mapping.order then oldmapping else mapping in
208           Node (left, (interval, Some mapping), right)
209
210       | (Leaf _) as leaf -> leaf
211
212       (* Else, should we insert into left or right subtrees? *)
213       | Node (left, i, right) ->
214           let left =
215             if seginterval /\ interval_of_node left then
216               insert_mapping left mapping
217             else
218               left in
219           let right =
220             if seginterval /\ interval_of_node right then
221               insert_mapping right mapping
222             else
223               right in
224           Node (left, i, right)
225     in
226     let tree = List.fold_left insert_mapping tree mappings in
227     tree in
228
229   if debug then (
230     let printer ((sp, ep), mapping) =
231       sprintf "[%Lx-%Lx] " sp ep ^
232         match mapping with
233         | None -> "(none)"
234         | Some { start = start; size = size; order = order } ->
235             sprintf "%Lx..%Lx(%d)" start (start+^size-^1L) order
236     in
237     print_binary_tree printer printer tree
238   );
239
240   tree
241
242 let add_mapping ({ mappings = mappings } as t) start size arr =
243   let order = List.length mappings in
244   let mapping = { start = start; size = size; arr = arr; order = order } in
245   let mappings = mapping :: mappings in
246   let tree = tree_of_mappings mappings in
247   { t with mappings = mappings; tree = tree }
248
249 let add_file t fd addr =
250   let size = (fstat fd).st_size in
251   (* mmap(2) the file using Bigarray module. *)
252   let arr = Array1.map_file fd char c_layout false size in
253   (* Create the mapping entry. *)
254   add_mapping t addr (Int64.of_int size) arr
255
256 let add_string ({ mappings = mappings } as t) str addr =
257   let size = String.length str in
258   (* Copy the string data to a Bigarray. *)
259   let arr = Array1.create char c_layout size in
260   for i = 0 to size-1 do
261     Array1.set arr i (String.unsafe_get str i)
262   done;
263   (* Create the mapping entry. *)
264   add_mapping t addr (Int64.of_int size) arr
265
266 let of_file fd addr =
267   let t = create () in
268   add_file t fd addr
269
270 let of_string str addr =
271   let t = create () in
272   add_string t str addr
273
274 (* 'get_mapping' is the crucial, fast lookup function for address -> mapping.
275  * It searches the tree (hence fast) to work out the topmost mapping which
276  * applies to an address.
277  *
278  * Returns (rightend * mapping option)
279  * where 'mapping option' is the mapping (or None if it's a hole)
280  *   and 'rightend' is the next address at which there is a different
281  *       mapping/hole.  In other words, this mapping result is good for
282  *       addresses [addr .. rightend-1].
283  *)
284 let rec get_mapping addr = function
285   | Leaf ((_, rightend), mapping) -> rightend, mapping
286
287   | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
288           (_, None),
289           right) ->
290       let subrightend, submapping =
291         if addr < leftend then get_mapping addr left
292         else get_mapping addr right in
293       subrightend, submapping
294
295   | Node ((Leaf ((_, leftend), _) | Node (_, ((_, leftend), _), _) as left),
296           (_, Some mapping),
297           right) ->
298       let subrightend, submapping =
299         if addr < leftend then get_mapping addr left
300         else get_mapping addr right in
301       (match submapping with
302        | None -> subrightend, Some mapping
303        | Some submapping ->
304            subrightend,
305            Some (if mapping.order > submapping.order then mapping
306                  else submapping)
307       )
308
309 (* Use the tree to quickly check if an address is mapped (returns false
310  * if it's a hole).
311  *)
312 let is_mapped { mappings = mappings; tree = tree } addr =
313   (* NB: No [`HasMapping] in the type so we have to check mappings <> []. *)
314   match mappings with
315   | [] -> false
316   | _ ->
317       let _, mapping = get_mapping addr tree in
318       mapping <> None
319
320 (* Get a single byte. *)
321 let get_byte { tree = tree } addr =
322   (* Get the mapping which applies to this address: *)
323   let _, mapping = get_mapping addr tree in
324   match mapping with
325   | Some { start = start; size = size; arr = arr } ->
326       let offset = Int64.to_int (addr -^ start) in
327       Char.code (Array1.get arr offset)
328   | None ->
329       invalid_arg "get_byte"
330
331 (* Get a range of bytes, possibly across several intervals. *)
332 let get_bytes { tree = tree } addr len =
333   let str = String.create len in
334
335   let rec loop addr pos len =
336     if len > 0 then (
337       let rightend, mapping = get_mapping addr tree in
338       match mapping with
339       | Some { start = start; size = size; arr = arr } ->
340           (* Offset within this mapping. *)
341           let offset = Int64.to_int (addr -^ start) in
342           (* Number of bytes to read before we either get to the end
343            * of our 'len' or we fall off the end of this interval.
344            *)
345           let n = min len (Int64.to_int (rightend -^ addr)) in
346           for i = 0 to n-1 do
347             String.unsafe_set str (pos + i) (Array1.get arr (offset + i))
348           done;
349           let len = len - n in
350           loop (addr +^ Int64.of_int n) (pos + n) len
351
352       | None ->
353           invalid_arg "get_bytes"
354     )
355   in
356   loop addr 0 len;
357
358   str
359
360 let get_int32 t addr =
361   let e = get_endian t in
362   let str = get_bytes t addr 4 in
363   let bs = Bitstring.bitstring_of_string str in
364   bitmatch bs with
365   | { addr : 32 : endian (e) } -> addr
366   | { _ } -> invalid_arg "get_int32"
367
368 let get_int64 t addr =
369   let e = get_endian t in
370   let str = get_bytes t addr 8 in
371   let bs = Bitstring.bitstring_of_string str in
372   bitmatch bs with
373   | { addr : 64 : endian (e) } -> addr
374   | { _ } -> invalid_arg "get_int64"
375
376 let get_C_int = get_int32
377
378 let get_C_long t addr =
379   let ws = get_wordsize t in
380   match ws with
381   | W32 -> Int64.of_int32 (get_int32 t addr)
382   | W64 -> get_int64 t addr
383
384 (* Take bytes until a condition is not met.  This is efficient
385  * in that we stay within the same mapping as long as we can.
386  *
387  * If we hit a hole, raises Invalid_argument "dowhile".
388  *)
389 let dowhile { tree = tree } addr cond =
390   let rec loop addr =
391     let rightend, mapping = get_mapping addr tree in
392     match mapping with
393     | Some { start = start; size = size; arr = arr } ->
394         (* Offset within this mapping. *)
395         let offset = Int64.to_int (addr -^ start) in
396         (* Number of bytes before we fall off the end of this interval. *)
397         let n = Int64.to_int (rightend -^ addr) in
398
399         let rec loop2 addr offset n =
400           if n > 0 then (
401             let c = Array1.get arr offset in
402             if cond addr c then
403               loop2 (addr +^ 1L) (offset + 1) (n - 1)
404             else
405               false (* stop now, finish outer loop too *)
406           )
407           else true (* fell off the end, so continue outer loop *)
408         in
409         if loop2 addr offset n then
410           loop (addr +^ Int64.of_int n)
411
412     | None ->
413         invalid_arg "dowhile"
414   in
415   loop addr
416
417 let is_mapped_range ({ mappings = mappings } as t) addr size =
418   match mappings with
419   (* NB: No [`HasMapping] in the type so we have to check mappings <> []. *)
420   | [] -> false
421   | _ ->
422       (* Quick and dirty.  It's possible to make a much faster
423        * implementation of this which doesn't call the closure for every
424        * byte.
425        *)
426       let size = ref size in
427       try dowhile t addr (fun _ _ -> decr size; !size > 0); true
428       with Invalid_argument "dowhile" -> false
429
430 (* Get a string, ending at ASCII NUL character. *)
431 let get_string t addr =
432   let chars = ref [] in
433   try
434     dowhile t addr (
435       fun _ c ->
436         if c <> '\000' then (
437           chars := c :: !chars;
438           true
439         ) else false
440     );
441     let chars = List.rev !chars in
442     let len = List.length chars in
443     let str = String.create len in
444     let i = ref 0 in
445     List.iter (fun c -> String.unsafe_set str !i c; incr i) chars;
446     str
447   with
448     Invalid_argument _ -> invalid_arg "get_string"
449
450 let is_string t addr =
451   try dowhile t addr (fun _ c -> c <> '\000'); true
452   with Invalid_argument _ -> false
453
454 let is_C_identifier t addr =
455   let i = ref 0 in
456   let r = ref true in
457   try
458     dowhile t addr (
459       fun _ c ->
460         let b =
461           if !i = 0 then (
462             c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z'
463           ) else (
464             if c = '\000' then false
465             else (
466               if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' ||
467                 c >= '0' && c <= '9' then
468                   true
469               else (
470                 r := false;
471                 false
472               )
473             )
474           ) in
475         incr i;
476         b
477     );
478     !r
479   with
480     Invalid_argument _ -> false
481
482 (* The following functions are actually written in C
483  * because memmem(3) is likely to be much faster than anything
484  * we could write in OCaml.
485  *
486  * Also OCaml bigarrays are specifically designed to be accessed
487  * easily from C:
488  *   http://caml.inria.fr/pub/docs/manual-ocaml/manual043.html
489  *)
490 (*
491 (* Array+offset = string? *)
492 let string_at arr offset str strlen =
493   let j = ref offset in
494   let rec loop i =
495     if i >= strlen then true
496     else
497       if Array1.get arr !j <> str.[i] then false
498       else (
499         incr j;
500         loop (i+1)
501       )
502   in
503   loop 0
504
505 (* Find in a single file mapping.
506  * [start] is relative to the mapping and we return an offset relative
507  * to the mapping.
508  *)
509 let _find_in start align str arr =
510   let strlen = String.length str in
511   if strlen > 0 then (
512     let j = ref start in
513     let e = Array1.dim arr - strlen in
514     let rec loop () =
515       if !j <= e then (
516         if string_at arr !j str strlen then Some !j
517         else (
518           j := !j + align;
519           loop ()
520         )
521       )
522       else None
523     in
524     loop ()
525   )
526   else Some start
527 *)
528 external _find_in :
529   int -> int -> string -> (char,int8_unsigned_elt,c_layout) Array1.t ->
530   int option = "virt_mem_mmap_find_in"
531
532 (* Generic find function. *)
533 let _find { tree = tree } start align str =
534   let rec loop addr =
535     let rightend, mapping = get_mapping addr tree in
536     match mapping with
537     | Some { start = start; size = size; arr = arr } ->
538         (* Offset within this mapping. *)
539         let offset = Int64.to_int (addr -^ start) in
540
541         (match _find_in offset align str arr with
542         | None -> None
543         | Some offset -> Some (start +^ Int64.of_int offset)
544         )
545
546     | None ->
547         (* Find functions all silently skip holes, so: *)
548         loop rightend
549   in
550   loop start
551
552 let find t ?(start=0L) str =
553   _find t start 1 str
554
555 let find_align t ?(start=0L) str =
556   let align = bytes_of_wordsize (get_wordsize t) in
557   _find t start align str
558
559 let rec _find_all t start align str =
560   match _find t start align str with
561   | None -> []
562   | Some offset ->
563       offset :: _find_all t (offset +^ Int64.of_int align) align str
564
565 let find_all t ?(start=0L) str =
566   _find_all t start 1 str
567
568 let find_all_align t ?(start=0L) str =
569   let align = bytes_of_wordsize (get_wordsize t) in
570   _find_all t start align str
571
572 (* NB: Phantom types in the interface ensure that these pointer functions
573  * can only be called once endianness and wordsize have both been set.
574  *)
575
576 let rec find_pointer t ?start addr =
577   find_align t ?start (string_of_addr t addr)
578
579 and find_pointer_all t ?start addr =
580   find_all_align t ?start (string_of_addr t addr)
581
582 (*
583 and string_of_addr t addr =
584   let bits = bits_of_wordsize (get_wordsize t) in
585   let e = get_endian t in
586   let bs = BITSTRING { addr : bits : endian (e) } in
587   Bitstring.string_of_bitstring bs
588 *)
589 (* XXX bitstring is missing 'construct_int64_le_unsigned' so we
590  * have to force this to 32 bits for the moment.
591  *)
592 and string_of_addr t addr =
593   let bits = bits_of_wordsize (get_wordsize t) in
594   assert (bits = 32);
595   let e = get_endian t in
596   let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in
597   Bitstring.string_of_bitstring bs
598
599 let follow_pointer t addr =
600   let ws = get_wordsize t in
601   let e = get_endian t in
602   let bits = bits_of_wordsize ws in
603   let str = get_bytes t addr (bytes_of_wordsize ws) in
604   let bs = Bitstring.bitstring_of_string str in
605   bitmatch bs with
606   | { addr : bits : endian (e) } -> addr
607   | { _ } -> invalid_arg "follow_pointer"
608
609 let succ_long t addr =
610   let ws = get_wordsize t in
611   addr +^ Int64.of_int (bytes_of_wordsize ws)
612
613 let pred_long t addr =
614   let ws = get_wordsize t in
615   addr -^ Int64.of_int (bytes_of_wordsize ws)
616
617 let align t addr =
618   let ws = get_wordsize t in
619   let mask = Int64.of_int (bytes_of_wordsize ws - 1) in
620   (addr +^ mask) &^ (Int64.lognot mask)