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)