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 Bigarray
  25
  26 open Virt_mem_utils
  27
  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).
  32  *)
  33 type ('a,'b) t = {
  34   mappings : mapping list;
  35   wordsize : wordsize option;
  36   endian : Bitmatch.endian option;
  37 }
  38 and 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 }
  44
  45 and addr = int64
  46
  47 let create () = {
  48   mappings = [];
  49   wordsize = None;
  50   endian = None
  51 }
  52
  53 let set_wordsize t ws = { t with wordsize = Some ws }
  54
  55 let set_endian t e = { t with endian = Some e }
  56
  57 let get_wordsize t = Option.get t.wordsize
  58
  59 let get_endian t = Option.get t.endian
  60
  61 let sort_mappings mappings =
  62   let cmp { start = s1 } { start = s2 } = compare s1 s2 in
  63   List.sort cmp mappings
  64
  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. *)
  72   let mappings =
  73     { start = addr; size = Int64.of_int size; arr = arr } :: mappings in
  74   let mappings = sort_mappings mappings in
  75   { t with mappings = mappings }
  76
  77 let of_file fd addr =
  78   let t = create () in
  79   add_file t fd addr
  80
  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   (* Use Bigarray.Array1. XXX We should just use the string. *)
  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)
  89   done;
  90   (* Create the mapping entry and keep the mappings sorted by start addr. *)
  91   let mappings =
  92     { start = addr; size = Int64.of_int size; arr = arr } :: mappings in
  93   let mappings = sort_mappings mappings in
  94   { t with mappings = mappings }
  95
  96 let of_string str addr =
  97   let t = create () in
  98   add_string t str addr
  99
 100 (* Find in mappings and return first predicate match. *)
 101 let _find_map { mappings = mappings } pred =
 102   let rec loop = function
 103     | [] -> None
 104     | m :: ms ->
 105         match pred m with
 106         | Some n -> Some n
 107         | None -> loop ms
 108   in
 109   loop mappings
 110
 111 (* Array+offset = string? *)
 112 let string_at arr offset str strlen =
 113   let j = ref offset in
 114   let rec loop i =
 115     if i >= strlen then true
 116     else
 117       if Array1.get arr !j <> str.[i] then false
 118       else (
 119         incr j;
 120         loop (i+1)
 121       )
 122   in
 123   loop 0
 124
 125 (* Find in a single file mapping.
 126  * [start] is relative to the mapping and we return an offset relative
 127  * to the mapping.
 128  *)
 129 let _find_in start align str arr =
 130   let strlen = String.length str in
 131   if strlen > 0 then (
 132     let j = ref start in
 133     let e = Array1.dim arr - strlen in
 134     let rec loop () =
 135       if !j <= e then (
 136         if string_at arr !j str strlen then Some !j
 137         else (
 138           j := !j + align;
 139           loop ()
 140         )
 141       )
 142       else None
 143     in
 144     loop ()
 145   )
 146   else Some start
 147
 148 (* Generic find function. *)
 149 let _find t start align str =
 150   _find_map t (
 151     fun { start = mstart; size = msize; arr = arr } ->
 152       if mstart >= start then (
 153         (* Check this mapping from the beginning. *)
 154         match _find_in 0 align str arr with
 155         | Some offset -> Some (mstart +^ Int64.of_int offset)
 156         | None -> None
 157       )
 158       else if mstart < start && start <= mstart+^msize then (
 159         (* Check this mapping from somewhere in the middle. *)
 160         let offset = Int64.to_int (start -^ mstart) in
 161         match _find_in offset align str arr with
 162         | Some offset -> Some (mstart +^ Int64.of_int offset)
 163         | None -> None
 164       )
 165       else None
 166   )
 167
 168 let find t ?(start=0L) str =
 169   _find t start 1 str
 170
 171 let find_align t ?(start=0L) str =
 172   let align = bytes_of_wordsize (get_wordsize t) in
 173   _find t start align str
 174
 175 let rec _find_all t start align str =
 176   match _find t start align str with
 177   | None -> []
 178   | Some offset ->
 179       offset :: _find_all t (offset +^ Int64.of_int align) align str
 180
 181 let find_all t ?(start=0L) str =
 182   _find_all t start 1 str
 183
 184 let find_all_align t ?(start=0L) str =
 185   let align = bytes_of_wordsize (get_wordsize t) in
 186   _find_all t start align str
 187
 188 (* NB: Phantom types in the interface ensure that these pointer functions
 189  * can only be called once endianness and wordsize have both been set.
 190  *)
 191
 192 let rec find_pointer t ?start addr =
 193   find_align t ?start (string_of_addr t addr)
 194
 195 and find_pointer_all t ?start addr =
 196   find_all_align t ?start (string_of_addr t addr)
 197
 198 (*
 199 and string_of_addr t addr =
 200   let bits = bits_of_wordsize (get_wordsize t) in
 201   let e = get_endian t in
 202   let bs = BITSTRING { addr : bits : endian (e) } in
 203   Bitmatch.string_of_bitstring bs
 204 *)
 205 (* XXX bitmatch is missing 'construct_int64_le_unsigned' so we
 206  * have to force this to 32 bits for the moment.
 207  *)
 208 and string_of_addr t addr =
 209   let bits = bits_of_wordsize (get_wordsize t) in
 210   assert (bits = 32);
 211   let e = get_endian t in
 212   let bs = BITSTRING { Int64.to_int32 addr : 32 : endian (e) } in
 213   Bitmatch.string_of_bitstring bs
 214
 215 and addr_of_string t str =
 216   let bits = bits_of_wordsize (get_wordsize t) in
 217   let e = get_endian t in
 218   let bs = Bitmatch.bitstring_of_string str in
 219   bitmatch bs with
 220   | { addr : bits : endian (e) } -> addr
 221   | { _ } -> invalid_arg "addr_of_string"
 222
 223 let get_byte { mappings = mappings } addr =
 224   let rec loop = function
 225     | [] -> invalid_arg "get_byte"
 226     | { start = start; size = size; arr = arr } :: _
 227         when start <= addr && addr < start +^ size ->
 228         let offset = Int64.to_int (addr -^ start) in
 229         Char.code (Array1.get arr offset)
 230     | _ :: ms -> loop ms
 231   in
 232   loop mappings
 233
 234 (* Take bytes until a condition is not met.  This is efficient in that
 235  * we stay within the same mapping as long as we can.
 236  *)
 237 let dowhile { mappings = mappings } addr cond =
 238   let rec get_next_mapping addr = function
 239     | [] -> invalid_arg "dowhile"
 240     | { start = start; size = size; arr = arr } :: _
 241         when start <= addr && addr < start +^ size ->
 242         let offset = Int64.to_int (addr -^ start) in
 243         let len = Int64.to_int size - offset in
 244         arr, offset, len
 245     | _ :: ms -> get_next_mapping addr ms
 246   in
 247   let rec loop addr =
 248     let arr, offset, len = get_next_mapping addr mappings in
 249     let rec loop2 i =
 250       if i < len then (
 251         let c = Array1.get arr (offset+i) in
 252         if cond c then loop2 (i+1)
 253       ) else
 254         loop (addr +^ Int64.of_int len)
 255     in
 256     loop2 0
 257   in
 258   loop addr
 259
 260 let get_bytes t addr len =
 261   let str = String.create len in
 262   let i = ref 0 in
 263   try
 264     dowhile t addr (
 265       fun c ->
 266         str.[!i] <- c;
 267         incr i;
 268         !i < len
 269     );
 270     str
 271   with
 272     Invalid_argument _ -> invalid_arg "get_bytes"
 273
 274 let get_int32 t addr =
 275   let e = get_endian t in
 276   let str = get_bytes t addr 4 in
 277   let bs = Bitmatch.bitstring_of_string str in
 278   bitmatch bs with
 279   | { addr : 32 : endian (e) } -> addr
 280   | { _ } -> invalid_arg "follow_pointer"
 281
 282 let get_int64 t addr =
 283   let e = get_endian t in
 284   let str = get_bytes t addr 8 in
 285   let bs = Bitmatch.bitstring_of_string str in
 286   bitmatch bs with
 287   | { addr : 64 : endian (e) } -> addr
 288   | { _ } -> invalid_arg "follow_pointer"
 289
 290 let get_C_int = get_int32
 291
 292 let get_C_long t addr =
 293   let ws = get_wordsize t in
 294   match ws with
 295   | W32 -> Int64.of_int32 (get_int32 t addr)
 296   | W64 -> get_int64 t addr
 297
 298 let get_string t addr =
 299   let chars = ref [] in
 300   try
 301     dowhile t addr (
 302       fun c ->
 303         if c <> '\000' then (
 304           chars := c :: !chars;
 305           true
 306         ) else false
 307     );
 308     let chars = List.rev !chars in
 309     let len = List.length chars in
 310     let str = String.create len in
 311     let i = ref 0 in
 312     List.iter (fun c -> str.[!i] <- c; incr i) chars;
 313     str
 314   with
 315     Invalid_argument _ -> invalid_arg "get_string"
 316
 317 let is_string t addr =
 318   try dowhile t addr (fun c -> c <> '\000'); true
 319   with Invalid_argument _ -> false
 320
 321 let is_C_identifier t addr =
 322   let i = ref 0 in
 323   let r = ref true in
 324   try
 325     dowhile t addr (
 326       fun c ->
 327         let b =
 328           if !i = 0 then (
 329             c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z'
 330           ) else (
 331             if c = '\000' then false
 332             else (
 333               if c = '_' || c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z' ||
 334                 c >= '0' && c <= '9' then
 335                   true
 336               else (
 337                 r := false;
 338                 false
 339               )
 340             )
 341           ) in
 342         incr i;
 343         b
 344     );
 345     !r
 346   with
 347     Invalid_argument _ -> false
 348
 349 let is_mapped { mappings = mappings } addr =
 350   let rec loop = function
 351     | [] -> false
 352     | { start = start; size = size; arr = arr } :: _
 353         when start <= addr && addr < start +^ size -> true
 354     | _ :: ms -> loop ms
 355   in
 356   loop mappings
 357
 358 let follow_pointer t addr =
 359   let ws = get_wordsize t in
 360   let e = get_endian t in
 361   let bits = bits_of_wordsize ws in
 362   let str = get_bytes t addr (bytes_of_wordsize ws) in
 363   let bs = Bitmatch.bitstring_of_string str in
 364   bitmatch bs with
 365   | { addr : bits : endian (e) } -> addr
 366   | { _ } -> invalid_arg "follow_pointer"
 367
 368 let succ_long t addr =
 369   let ws = get_wordsize t in
 370   addr +^ Int64.of_int (bytes_of_wordsize ws)
 371
 372 let pred_long t addr =
 373   let ws = get_wordsize t in
 374   addr -^ Int64.of_int (bytes_of_wordsize ws)
 375
 376 let align t addr =
 377   let ws = get_wordsize t in
 378   let mask = Int64.of_int (bytes_of_wordsize ws - 1) in
 379   (addr +^ mask) &^ (Int64.lognot mask)