(** Common types. *) (* Memory info command for virtual domains. (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc. http://libvirt.org/ This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. Common types. *) module D = Libvirt.Domain open Virt_mem_utils open Virt_mem_mmap type ksym = string module Ksymmap = Map.Make (String) type ksymmap = addr Ksymmap.t type image = { dom : Libvirt.ro D.t option; domname : string; arch : architecture; mem : ([`Wordsize], [`Endian], [`HasMapping]) Virt_mem_mmap.t; kernel_min : addr; kernel_max : addr; } type utsname = { uts_kernel_name : string; uts_nodename : string; uts_kernel_release : string; uts_kernel_version : string; uts_machine : string; uts_domainname : string; } type task = { task_state : int64; task_prio : int64; task_normal_prio : int64; task_static_prio : int64; task_comm : string; task_pid : int64; } type net_device = { netdev_name : string; netdev_dev_addr : string; } type kdata = { ksyms : ksymmap option; utsname : utsname option; tasks : task list option; net_devices : net_device list option; } exception ParseError of string * string * string type fieldsig = { field_available : bool; field_offset : int; } (* This is the maximum we can download in one go over the libvirt * remote connection. * * XXX Should have a 'D.max_peek' function. *) let max_memory_peek = 65536 type load_memory_error = | AddressOutOfRange | DomIsNull exception LoadMemoryError of load_memory_error * string let _load_memory mem dom start size = let str = String.create size in let rec loop i = let remaining = size - i in if remaining > 0 then ( let size = min remaining max_memory_peek in D.memory_peek dom [D.Virtual] (start +^ Int64.of_int i) size str i; loop (i + size) ) in loop 0; Virt_mem_mmap.add_string mem str start let load_static_memory ~dom ~domname ~arch ~wordsize ~endian ~kernel_min ~kernel_max start size = if start < kernel_min then raise (LoadMemoryError (AddressOutOfRange, "load_memory: start < kernel_min")) else if start +^ Int64.of_int size > kernel_max then raise (LoadMemoryError (AddressOutOfRange, "load_memory: start+size > kernel_max")) else ( let mem = Virt_mem_mmap.create () in let mem = Virt_mem_mmap.set_wordsize mem wordsize in let mem = Virt_mem_mmap.set_endian mem endian in let mem = _load_memory mem dom start size in { dom = Some dom; domname = domname; mem = mem; arch = arch; kernel_min = kernel_min; kernel_max = kernel_max } ) let load_memory ({ dom = dom; mem = mem; kernel_min = kernel_min; kernel_max = kernel_max } as image) start size = if start < kernel_min then raise (LoadMemoryError (AddressOutOfRange, "load_memory: start < kernel_min")) else if start +^ Int64.of_int size > kernel_max then raise (LoadMemoryError (AddressOutOfRange, "load_memory: start+size > kernel_max")) else if Virt_mem_mmap.is_mapped_range mem start size then image else ( match dom with | None -> raise (LoadMemoryError (DomIsNull, "load_memory: dom = None")) | Some dom -> let mem = _load_memory mem dom start size in { image with mem = mem } )