2
* Copyright (C) 2006-2009 Citrix Systems Inc.
4
* This program is free software; you can redistribute it and/or modify
5
* it under the terms of the GNU Lesser General Public License as published
6
* by the Free Software Foundation; version 2.1 only. with the special
7
* exception on linking described in file LICENSE.
9
* This program is distributed in the hope that it will be useful,
10
* but WITHOUT ANY WARRANTY; without even the implied warranty of
11
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12
* GNU Lesser General Public License for more details.
21
let print_xen_dmesg ~xc =
22
let s = Xenctrl.readconsolering xc in
25
let print_xen_physinfo ~xc =
26
let physinfo = Xenctrl.physinfo xc in
27
let totalmib = Xenctrl.pages_to_mib (Int64.of_nativeint physinfo.Xenctrl.total_pages)
28
and freemib = Xenctrl.pages_to_mib (Int64.of_nativeint physinfo.Xenctrl.free_pages)
29
and scrubmib = Xenctrl.pages_to_mib (Int64.of_nativeint physinfo.Xenctrl.scrub_pages) in
30
printf "nr_cpus = %d\n" physinfo.Xenctrl.nr_cpus;
31
printf "threads_per_core = %d\n" physinfo.Xenctrl.threads_per_core;
32
printf "cores_per_socket = %d\n" physinfo.Xenctrl.cores_per_socket;
33
(*printf "sockets_per_node = %d\n" physinfo.Xenctrl.sockets_per_node;*)
34
(*printf "nr_nodes = %d\n" physinfo.Xenctrl.nr_nodes;*)
35
printf "cpu_khz = %d\n" physinfo.Xenctrl.cpu_khz;
36
printf "total_pages = %s (%Ld Mb)\n" (Nativeint.to_string physinfo.Xenctrl.total_pages) totalmib;
37
printf "free_pages = %s (%Ld Mb)\n" (Nativeint.to_string physinfo.Xenctrl.free_pages) freemib;
38
printf "scrub_pages = %s (%Ld Mb)\n" (Nativeint.to_string physinfo.Xenctrl.scrub_pages) scrubmib
40
let print_pcpus_info ~xc =
41
let physinfo = Xenctrl.physinfo xc in
42
let infos = Xenctrl.pcpu_info xc (physinfo.Xenctrl.nr_cpus) in
43
Array.iteri (fun i info -> printf "cpu: %d usage: %Ld\n" i info) infos
45
let debugkeys ~xc args =
47
try Xenctrl.send_debug_keys xc arg
49
printf "sending key \"%s\" failed: %s" arg (Printexc.to_string exn);
52
let is_hvm ~xc domid =
53
(Xenctrl.domain_getinfo xc domid).Xenctrl.hvm_guest
55
let create_domain ~xc ~xs ~hvm =
56
let uuid = Uuid.make_uuid () in
63
Domain.platformdata = [];
64
Domain.bios_strings = [];
66
let domid = Domain.make ~xc ~xs info uuid in
69
let build_domain ~xc ~xs ~kernel ?(ramdisk=None) ~cmdline ~domid ~vcpus ~static_max_kib ~target_kib =
70
let (_: Domain.domarch) = Domain.build_linux xc xs static_max_kib target_kib
71
kernel cmdline ramdisk vcpus domid in
72
printf "built domain: %u\n" domid
74
let build_hvm ~xc ~xs ~kernel ~domid ~vcpus ~static_max_kib ~target_kib =
75
let (_: Domain.domarch) = Domain.build_hvm xc xs static_max_kib target_kib 1.
76
vcpus kernel "0" 4 domid in
77
printf "built hvm domain: %u\n" domid
79
let clean_shutdown_domain ~xal ~domid ~reason ~sync =
80
let xc = Xal.xc_of_ctx xal in
81
let xs = Xal.xs_of_ctx xal in
82
Domain.shutdown ~xs domid reason;
83
(* Wait for any necessary acknowledgement. If we get a Watch.Timeout _ then
84
we abort early; otherwise we continue in Xal.wait_release below. *)
85
let acked = try Domain.shutdown_wait_for_ack ~xc ~xs domid reason; true with Watch.Timeout _ -> false in
87
eprintf "domain %u didn't acknowledged shutdown\n" domid;
89
printf "shutdown domain: %u\n" domid;
92
ignore (Xal.wait_release xal ~timeout:30. domid);
93
printf "domain shutdowned correctly\n"
95
eprintf "domain %u didn't shutdown\n" domid;
99
let hard_shutdown_domain ~xc ~domid ~reason = Domain.hard_shutdown ~xc domid reason
101
let sysrq_domain ~xs ~domid ~sysrq =
102
Domain.sysrq ~xs domid sysrq
104
let pause_domain ~xc ~domid =
105
Domain.pause ~xc domid;
106
printf "paused domain: %u\n" domid
108
let unpause_domain ~xc ~domid =
109
Domain.unpause ~xc domid;
110
printf "unpaused domain: %u\n" domid
112
let destroy_domain ~xc ~xs ~domid =
113
Domain.destroy xc xs domid
115
let suspend_domain ~xc ~xs ~domid ~file =
117
let path = xs.Xs.getdomainpath domid in
118
xs.Xs.write (Printf.sprintf "%s/control/shutdown" path) "suspend";
121
let hvm = is_hvm ~xc domid in
122
let fd = Unix.openfile file [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_EXCL ] 0o600 in
123
Domain.suspend xc xs hvm domid fd [] suspendfct;
126
let suspend_domain_and_resume ~xc ~xs ~domid ~file ~cooperative =
127
suspend_domain ~xc ~xs ~domid ~file;
128
Domain.resume ~xc ~xs ~cooperative ~hvm:(is_hvm ~xc domid) domid
130
let suspend_domain_and_destroy ~xc ~xs ~domid ~file =
131
suspend_domain ~xc ~xs ~domid ~file;
132
Domain.destroy xc xs domid
134
let restore_domain ~xc ~xs ~domid ~vcpus ~static_max_kib ~target_kib ~file =
135
let fd = Unix.openfile file [ Unix.O_RDONLY ] 0o400 in
136
Domain.pv_restore ~xc ~xs domid ~static_max_kib ~target_kib ~vcpus fd;
139
let balloon_domain ~xs ~domid ~mem_mib =
140
if mem_mib <= 16L then
141
failwith (sprintf "cannot balloon domain below 16Mb: %Ld requested" mem_mib);
142
Balloon.set_memory_target ~xs domid (Int64.mul mem_mib 1024L)
144
let domain_get_uuid ~xc ~domid =
146
let h = Xenctrl.domain_getinfo xc domid in
147
let uuid = Uuid.to_string (Uuid.uuid_of_int_array h.Xenctrl.handle) in
152
let print_table (rows: string list list) =
153
let widths = Table.compute_col_widths rows in
154
let sll = List.map (List.map2 Table.right widths) rows in
155
List.iter (fun line -> print_endline (String.concat " | " line)) sll
157
let list_domains ~xc ~verbose =
160
[ "id"; "state"; "shutdown code"; "total MiB"; "max MiB";
161
"sif"; "cpu time"; "vcpus online"; "max vcpu id"; "ssidref";
164
[ "id"; "state"; "cpu_time"; "uuid" ]
166
let sl_of_domaininfo (x: Xenctrl.domaininfo) : string list =
167
let page_to_mib pages =
168
Nativeint.to_string (Nativeint.div pages (Nativeint.of_int 256)) in
169
let int = string_of_int and int64 = Int64.to_string and int32 = Int32.to_string in
170
let domid = int x.Xenctrl.domid in
171
(* Can more than one flag be true at a time? *)
173
let bool ch = function true -> ch | _ -> " " in
174
(bool "D" x.Xenctrl.dying) ^ (bool "S" x.Xenctrl.shutdown) ^
175
(bool "P" x.Xenctrl.paused) ^ (bool "B" x.Xenctrl.blocked) ^
176
(bool "R" x.Xenctrl.running) ^ (bool "H" x.Xenctrl.hvm_guest) in
177
let shutdown_code = int x.Xenctrl.shutdown_code in
178
let tot_memory_mib = page_to_mib x.Xenctrl.total_memory_pages in
179
let max_memory_mib = page_to_mib x.Xenctrl.max_memory_pages in
180
let shared_info_frame = int64 x.Xenctrl.shared_info_frame in
181
let cpu_time = int64 x.Xenctrl.cpu_time in
182
let nr_online_vcpus = int x.Xenctrl.nr_online_vcpus in
183
let max_vcpu_id = int x.Xenctrl.max_vcpu_id in
184
let ssidref = int32 x.Xenctrl.ssidref in
185
let handle = Uuid.to_string (Uuid.uuid_of_int_array x.Xenctrl.handle) in
188
[ domid; state; shutdown_code; tot_memory_mib; max_memory_mib;
189
shared_info_frame; cpu_time; nr_online_vcpus; max_vcpu_id;
192
[ domid; state; cpu_time; handle ]
195
let l = Xenctrl.domain_getinfolist xc 0 in
196
let header = header () in
197
let infos = List.map sl_of_domaininfo l in
198
print_table (header :: infos)
202
---------------------------------------------------------------
203
domain domstate ty devid state -> domain domstate ty devid state
205
where domstate = R | S | D | ?
206
state = 1 | 2 | 3 | 4 | 5 | 6 | ?
211
backend_proto: string; (* blk or net *)
212
backend_device: string; (* physical device eg. fd:2 *)
213
backend_state: string; (* 1...6 *)
214
frontend_type: string; (* cdrom or hd *)
215
frontend_device: string; (* linux device name *)
216
frontend_state: string; (* 1..6 *)
218
let device_state_to_sl ds =
219
let int = string_of_int in
220
[ int ds.device.backend.domid; ds.backend_proto; ds.backend_device; ds.backend_state; "->"; ds.frontend_state; ds.frontend_type; ds.frontend_device; int ds.device.frontend.domid; ]
223
let frontend_state = try xs.Xs.read (sprintf "%s/state" (frontend_path_of_device ~xs d)) with Xenbus.Xb.Noent -> "??" in
224
let backend_state = try xs.Xs.read (sprintf "%s/state" (backend_path_of_device ~xs d)) with Xenbus.Xb.Noent -> "??" in
225
(* The params string can be very long, truncate to a more reasonable width *)
226
let truncate params =
229
let len = String.length params in
233
let take = limit - (String.length dots) in
234
dots ^ (String.sub params (len - take) take) in
235
let backend_proto = match d.backend.kind with
238
| x -> string_of_kind x in
239
let frontend_type = match d.frontend.kind with
241
let be = frontend_path_of_device ~xs d in
242
(try if xs.Xs.read (sprintf "%s/device-type" be) = "cdrom" then "cdrom" else "disk" with _ -> "??")
243
| x -> string_of_kind x in
244
let backend_device = match d.backend.kind with
246
let be = backend_path_of_device ~xs d in
247
(try xs.Xs.read (sprintf "%s/physical-device" be)
248
with Xenbus.Xb.Noent ->
249
(try truncate (xs.Xs.read (sprintf "%s/params" be))
250
with Xenbus.Xb.Noent -> "??"))
252
| _ -> string_of_int d.backend.devid in
253
let frontend_device = match d.frontend.kind with
254
| Vbd | Tap -> Device_number.to_linux_device (Device_number.of_xenstore_key d.frontend.devid)
255
| _ -> string_of_int d.frontend.devid in
256
{ device = d; frontend_state = frontend_state; backend_state = backend_state; frontend_device = frontend_device; frontend_type = frontend_type; backend_proto = backend_proto; backend_device = backend_device }
258
let list_devices ~xc ~xs =
259
let header = [ "be"; "proto"; "dev"; "state"; "->"; "state"; "kind"; "dev"; "fe" ] in
260
let of_device (d: device) : string list =
261
device_state_to_sl (stat ~xs d) in
262
let l = Xenctrl.domain_getinfolist xc 0 in
263
let domids = List.map (fun x -> x.Xenctrl.domid) l in
265
Listext.List.setify (
269
list_backends ~xs domid @ (list_frontends ~xs domid)
273
let infos = List.map of_device devices in
274
print_table (header :: infos)
276
let add_vbd ~xs ~hvm ~domid ~device_number ~phystype ~params ~backend_domid ~dev_type ~mode=
277
let phystype = Device.Vbd.physty_of_string phystype in
278
let dev_type = Device.Vbd.devty_of_string dev_type in
279
Device.Vbd.add ~xs ~hvm ~mode:(Device.Vbd.mode_of_string mode)
280
~device_number ~phystype ~params ~backend_domid ~dev_type domid
282
let find_device ~xs (frontend: endpoint) (backend: endpoint) =
283
let all = list_devices_between ~xs backend.domid frontend.domid in
284
match List.filter (fun x -> x.frontend = frontend) all with
286
| _ -> failwith "failed to find device"
288
let del_vbd ~xs ~domid ~backend_domid ~device_number ~phystype =
289
let devid = Device_number.to_xenstore_key device_number in
290
let frontend = { domid = domid; kind = Vbd; devid = devid } in
291
let backend = { domid = backend_domid; kind = Vbd; devid = devid } in
292
let device = find_device ~xs frontend backend in
293
Device.clean_shutdown ~xs device
295
let add_vif ~xs ~domid ~netty ~devid ~mac ~backend_domid =
296
ignore(Device.Vif.add ~xs ~devid ~netty ~mac ~carrier:true ~backend_domid domid)
298
let del_vif ~xs ~domid ~backend_domid ~devid =
299
let frontend = { domid = domid; kind = Vif; devid = devid } in
300
let backend = { domid = backend_domid; kind = Vif; devid = devid } in
301
let device = find_device ~xs frontend backend in
302
Device.clean_shutdown ~xs device
304
let pci_of_string x = Scanf.sscanf x "%04x:%02x:%02x.%1x" (fun a b c d -> (a, b, c, d))
306
let add_pci ~xc ~xs ~hvm ~domid ~devid ~pci =
307
Printf.printf "pci: %s\n" pci;
308
let pcidevs = List.map pci_of_string (String.split ',' pci) in
309
Device.PCI.add ~xc ~xs ~hvm ~msitranslate:0 ~pci_power_mgmt:0 pcidevs domid devid;
312
let plug_pci ~xc ~xs ~domid ~devid ~pci =
313
let pcidev = pci_of_string pci in
314
Device.PCI.plug ~xc ~xs pcidev domid
316
let unplug_pci ~xc ~xs ~domid ~devid ~pci =
317
let pcidev = pci_of_string pci in
318
Device.PCI.unplug ~xc ~xs pcidev domid
320
let del_pci ~xc ~xs ~hvm ~domid ~devid ~pci =
321
let pcidevs = List.map (fun d ->
322
Scanf.sscanf d "%04x:%02x:%02x.%1x" (fun a b c d -> (a, b, c, d))
323
) (String.split ',' pci) in
324
Device.PCI.release ~xc ~xs ~hvm pcidevs domid devid;
328
let pcidevs = List.map (fun d ->
329
Scanf.sscanf d "%04x:%02x:%02x.%1x" (fun a b c d -> (a, b, c, d))
330
) (String.split ',' pci) in
331
Device.PCI.bind pcidevs
333
let list_pci ~xc ~xs ~domid =
334
let pcidevs = Device.PCI.list ~xc ~xs domid in
335
List.iter (fun (id, (domain, bus, dev, func)) ->
336
Printf.printf "dev-%d %04x:%02x:%02x.%1x\n" id domain bus dev func
339
let add_dm ~xs ~domid ~static_max_kib ~vcpus ~boot =
340
let dmpath = Xapi_globs.base_path ^ "/libexec/qemu-dm-wrapper" in
342
Device.Dm.memory = static_max_kib;
343
Device.Dm.boot = boot;
344
Device.Dm.serial = "pty";
345
Device.Dm.vcpus = vcpus;
347
Device.Dm.disks = [];
348
Device.Dm.pci_emulations = [];
349
Device.Dm.pci_passthrough = false;
351
Device.Dm.acpi = true;
352
Device.Dm.disp = Device.Dm.NONE;
354
Device.Dm.xenclient_enabled=false;
356
Device.Dm.sound=None;
357
Device.Dm.power_mgmt=None;
358
Device.Dm.oem_features=None;
359
Device.Dm.inject_sci=None;
360
Device.Dm.video_mib=0;
362
Device.Dm.extras = []
364
Device.Dm.start ~xs ~dmpath info domid
366
let add_ioport ~xc ~domid ~ioport_start ~ioport_end =
367
Domain.add_ioport ~xc domid ioport_start ioport_end
369
let del_ioport ~xc ~domid ~ioport_start ~ioport_end =
370
Domain.del_ioport ~xc domid ioport_start ioport_end
372
let add_iomem ~xc ~domid ~iomem_start ~iomem_end =
373
Domain.add_iomem ~xc domid iomem_start iomem_end
375
let del_iomem ~xc ~domid ~iomem_start ~iomem_end =
376
Domain.del_iomem ~xc domid iomem_start iomem_end
378
let add_irq ~xc ~domid ~irq =
379
Domain.add_irq ~xc domid irq
381
let del_irq ~xc ~domid ~irq =
382
Domain.del_irq ~xc domid irq
384
let sched_domain ~xc ~domid ~weight ~cap =
385
if Xenctrl.sched_id xc <> 5 then
386
failwith "not using credit scheduler";
387
match weight, cap with
388
| Some wei, Some cap ->
389
Xenctrl.sched_credit_domain_set xc domid
390
{ Xenctrl.weight = wei; Xenctrl.cap = cap }
392
let old = Xenctrl.sched_credit_domain_get xc domid in
393
Xenctrl.sched_credit_domain_set xc domid
394
{ old with Xenctrl.cap = cap }
396
let old = Xenctrl.sched_credit_domain_get xc domid in
397
Xenctrl.sched_credit_domain_set xc domid
398
{ old with Xenctrl.weight = wei }
401
let sched_domain_get ~xc ~domid =
402
if Xenctrl.sched_id xc <> 5 then
403
failwith "not using credit scheduler";
404
let params = Xenctrl.sched_credit_domain_get xc domid in
405
params.Xenctrl.weight, params.Xenctrl.cap
408
let affinity_set ~xc ~domid ~vcpu ~bitmap =
410
match bitmap.[i] with
413
| c -> failwith (sprintf "Unknown character '%c' in bitmap" c) in
414
let cpumap = Array.init (String.length bitmap) init_fct in
415
Domain.vcpu_affinity_set ~xc domid vcpu cpumap
417
let affinity_get ~xc ~domid ~vcpu =
418
let cpumap = Domain.vcpu_affinity_get ~xc domid vcpu in
419
let s = String.make (Array.length cpumap) '0' in
420
Array.iteri (fun i b -> s.[i] <- if b then '1' else '0') cpumap;
425
| "init" -> "create_domain"
426
| "shutdown" -> "shutdown_domain"
427
| "sysrq" -> "sysrq_domain"
428
| "pause" -> "pause_domain"
429
| "unpause" -> "unpause_domain"
430
| "list" | "li" -> "list_domains"
431
| "destroy" | "del" -> "destroy_domain"
432
| "chkpoint" | "checkpoint" -> "chkpoint_domain"
433
| "restore" -> "restore_domain"
434
| "build" -> "build_domain"
435
| "hvmbuild" -> "build_hvm"
436
| "suspend" -> "save_domain"
437
| "disk-add" -> "add_vbd"
438
| "pci-bind" -> "bind_pci"
439
| "getuuid_domain" -> "dom-uuid"
443
let usage subcmd allcommands =
445
let l = List.map (fun (cmd, _) -> "\t" ^ cmd) allcommands in
446
sprintf "%s\n" (String.concat "\n" ("usage:" :: l)) in
447
(* Unfortunately we can not reuse Arg.usage since it always output to stdout *)
449
let spec = List.assoc c allcommands in
450
let l = List.map (fun (opt, _, doc) -> sprintf " %s %s" opt doc) spec in
451
sprintf "%s\n" (String.concat "\n" (c :: l)) in
453
| None -> Arg.Help (usage_all ())
455
try Arg.Help (usage_sub c)
457
Arg.Bad (sprintf "Unknown subcommand: %s\n%s" c (usage_all ()))
459
let do_cmd_parsing subcmd init_pos =
461
and backend_domid = ref (0)
465
and kernel = ref "/boot/vmlinuz-2.6-xenU"
466
and ramdisk = ref None
467
and cmdline = ref "root=/dev/sda1 ro"
468
and mem_max_kib = ref 262144
474
and viridian = ref false
475
and verbose = ref false
478
and phystype = ref ""
480
and device_number = ref (Device_number.make (Device_number.Xen(0, 0)))
481
and dev_type = ref "disk"
483
and reason = ref None
484
and script = ref "/etc/xen/scripts/vif"
486
and netty = ref (Netman.Bridge "xenbr0")
487
and weight = ref None
490
and cooperative = ref true
492
and sysrq = ref '\000'
495
and ioport_start = ref (-1)
496
and ioport_end = ref (-1)
497
and iomem_start = ref (-1L)
498
and iomem_end = ref (-1L)
500
and otherargs = ref []
502
and timeout = ref (-1l) in
505
try r := Int64.of_string s
506
with _ -> eprintf "cannot parse %s at integer\n" s
509
match String.split ':' s with
510
| "DriverDomain" :: [] -> netty := Netman.DriverDomain
511
| "bridge" :: bname :: [] -> netty := Netman.Bridge bname
512
| _ -> eprintf "not a valid network type: %s\n" s
516
"-debug", Arg.Unit (fun () -> Logs.set_default Log.Debug [ "stderr" ]),
518
"-domid", Arg.Set_int domid, "Domain ID to be built";
520
and setmaxmem_args = [
521
"-memory", Arg.Set_int mem_max_kib, "memory in kilobytes";
524
"-vcpus", Arg.Set_int vcpus, "vcpus available";
525
"-memory", Arg.Set_int mem_max_kib, "memory in kilobytes";
528
"-kernel", Arg.Set_string kernel, "kernel to build with";
531
"-kernel", Arg.Set_string kernel, "kernel to build with";
532
"-cmdline", Arg.Set_string cmdline, "Set kernel command line";
533
"-ramdisk", Arg.String (fun x -> ramdisk := Some x), "Set ramdisk to use (leave blank for none)";
536
"-hvm", Arg.Set hvm, "specify to create hvm domain";
538
and common_suspend = [
539
"-file", Arg.Set_string file, "Suspend/Restore file";
542
"-uncooperative", Arg.Clear cooperative, "Set that the VM is cooperative in resume";
545
"-mode", Arg.Set_string mode, "Vbd Mode";
546
"-phystype", Arg.Set_string phystype, "Vbd set physical type (file|phy)";
547
"-params", Arg.Set_string params, "Vbd set params (i.e. block device)";
548
"-device-number", Arg.String (fun x -> device_number := (Device_number.of_string false x)), "Vbd set device_number";
549
"-devtype", Arg.Set_string dev_type, "Vbd dev type";
552
"-devid", Arg.Set_int devid, "Vif dev id";
553
"-mac", Arg.Set_string mac, "Vif mac address (mandatory)";
554
"-netty", Arg.String set_netty, "type of network";
557
"-boot", Arg.Set_string boot, "Set boot string of device model";
560
"-memory", Arg.Set_int mem_mib, "memory in megabytes";
563
"-v", Arg.Set verbose, "activate verbose";
566
"-weight", Arg.Int (fun i -> weight := Some i), "Set scheduler weight";
567
"-cap", Arg.Int (fun i -> cap := Some i), "Set scheduler cap";
569
and affinity_args = [
570
"-vcpu", Arg.Set_int vcpu, "vcpu number";
572
and affinity_set_args = [
573
"-bitmap", Arg.Set_string bitmap, "affinity bitmap";
575
and shutdown_args = [
576
"-poweroff", Arg.Unit (fun () -> reason := Some Domain.PowerOff), "Poweroff guest";
577
"-reboot", Arg.Unit (fun () -> reason := Some Domain.Reboot), "Reboot guest";
578
"-suspend", Arg.Unit (fun () -> reason := Some Domain.Suspend), "Suspend guest";
579
"-halt", Arg.Unit (fun () -> reason := Some Domain.Halt), "Halt guest";
580
"-sync", Arg.Set sync, "Wait operation to complete";
583
"-key", Arg.String (fun s -> if String.length s = 1 then sysrq := s.[0]), "sysrq key";
586
"-pci", Arg.Set_string pci, "Pci address (format: 0000:00:00.0)";
587
"-devid", Arg.Set_int devid, "Pci dev id";
590
"-start", Arg.Set_int ioport_start, "Start port";
591
"-end", Arg.Set_int ioport_end, "End port";
594
"-start", Arg.String (set_int64 iomem_start), "Start address";
595
"-end", Arg.String (set_int64 iomem_end), "End address";
598
"-irq", Arg.Set_int irq, "irq";
600
and watchdog_args = [
601
"-slot", Arg.Set_int slot, "slot";
602
"-timeout", Arg.String (fun x -> timeout := Int32.of_string x), "timeout";
605
"-backend-domid", Arg.Set_int backend_domid, "Domain ID of backend domain (default: 0)";
608
("create_domain" , create);
609
("destroy_domain" , common);
610
("build_domain" , common @ common_build @ normal_build);
611
("build_hvm" , common @ common_build @ hvm_build);
612
("setmaxmem" , common @ setmaxmem_args);
613
("save_domain" , common @ common_suspend);
614
("restore_domain" , common @ common_suspend @ common_build);
615
("chkpoint_domain", common @ common_suspend @ resume_args);
616
("shutdown_domain", common @ shutdown_args);
617
("hard_shutdown_domain", common @ shutdown_args);
618
("sysrq_domain" , common @ sysrq_args);
619
("pause_domain" , common);
620
("unpause_domain" , common);
621
("sched_domain" , common @ sched_args);
622
("sched_get" , common);
623
("affinity_set" , common @ affinity_args @ affinity_set_args);
624
("affinity_get" , common @ affinity_args);
625
("list_domains" , list_args);
626
("list_devices" , []);
627
("add_vbd" , common @ vbd_args @ backend_args);
628
("del_vbd" , common @ vbd_args @ backend_args);
629
("add_vif" , common @ vif_args @ backend_args);
630
("del_vif" , common @ vif_args @ backend_args);
631
("add_pci" , common @ pci_args);
632
("del_pci" , common @ pci_args);
633
("bind_pci" , pci_args);
634
("plug_pci" , common @ pci_args);
635
("unplug_pci" , common @ pci_args);
636
("list_pci" , common);
637
("add_dm" , common @ common_build @ dm_args);
638
("add_ioport" , common @ ioport_args);
639
("del_ioport" , common @ ioport_args);
640
("add_iomem" , common @ iomem_args);
641
("del_iomem" , common @ iomem_args);
642
("add_irq" , common @ irq_args);
643
("del_irq" , common @ irq_args);
644
("balloon" , common @ balloon_args);
645
("dom-uuid" , common);
646
("squeeze" , balloon_args);
648
("watchdog" , watchdog_args);
649
("send-s3resume" , common);
650
("trigger-power" , common);
651
("trigger-sleep" , common);
660
match usage (Some subcmd) allcommands with
661
| Arg.Help _ -> () | e -> raise e in
662
let spec = List.assoc subcmd allcommands in
663
Arg.current := init_pos;
664
Arg.parse_argv Sys.argv spec
667
eprintf "Warning, ignoring unknown argument: %s\n" x
669
otherargs := x :: !otherargs
671
!domid, !backend_domid, !hvm, !vcpus, !vcpu, !kernel,
672
!ramdisk, !cmdline, Int64.of_int !mem_max_kib, Int64.of_int !mem_mib,
673
!pae, !apic, !acpi, !nx, !viridian, !verbose, !file,
674
!mode, !phystype, !params, !device_number, !dev_type, !devid, !mac, !pci,
675
!reason, !sysrq, !script, !sync, !netty, !weight, !cap, !bitmap, !cooperative,
676
!boot, !ioport_start, !ioport_end, !iomem_start, !iomem_end, !irq,
677
!slot, !timeout, List.rev !otherargs, allcommands
681
let subcmd, init_pos =
682
let cmd = Filename.basename Sys.argv.(0) in
683
if cmd <> "xenops" then cmd, 0
684
else if Array.length Sys.argv > 1 then Sys.argv.(1), 1
687
let subcmd = cmd_alias subcmd in
688
let domid, backend_domid, hvm, vcpus, vcpu, kernel, ramdisk, cmdline,
689
max_kib, mem_mib, pae, apic, acpi, nx, viridian, verbose, file, mode,
690
phystype, params, device_number, dev_type, devid, mac, pci, reason, sysrq,
691
script, sync, netty, weight, cap, bitmap, cooperative,
692
boot, ioport_start, ioport_end, iomem_start, iomem_end, irq,
693
slot, timeout, otherargs, allcommands = do_cmd_parsing subcmd init_pos in
695
let is_domain_hvm xc domid = (Xenctrl.domain_getinfo xc domid).Xenctrl.hvm_guest in
698
let target_kib = max_kib in
699
let static_max_kib = max_kib in
701
let error s = eprintf "error: \"%s\" argument is not valid\n" s; exit 1 in
702
let assert_domid () = if domid < 0 then error "domid"
703
and assert_vcpus () = if vcpus <= 0 then error "vcpus"
704
and assert_vcpu () = if vcpu < 0 then error "vcpu"
705
and assert_file () = if file = "" then error "file"
706
and assert_bitmap () = if bitmap = "" then error "bitmap"
711
with_xc_and_xs (fun xc xs -> create_domain ~xc ~xs ~hvm)
712
| "destroy_domain" ->
714
with_xc_and_xs (fun xc xs -> destroy_domain ~xc ~xs ~domid)
716
assert_domid (); assert_vcpus ();
717
with_xc_and_xs (fun xc xs ->
718
build_domain ~xc ~xs ~kernel ~ramdisk ~cmdline ~vcpus ~static_max_kib ~target_kib ~domid)
720
assert_domid (); assert_vcpus ();
721
with_xc_and_xs (fun xc xs -> build_hvm ~xc ~xs ~kernel ~vcpus ~static_max_kib ~target_kib ~domid)
724
with_xc (fun xc -> Xenctrl.domain_setmaxmem xc domid max_kib) (* call takes pages *)
726
assert_domid (); assert_file ();
727
with_xc_and_xs (fun xc xs -> suspend_domain_and_destroy ~xc ~xs ~domid ~file)
728
| "restore_domain" ->
729
assert_domid (); assert_vcpus ();
730
with_xc_and_xs (fun xc xs -> restore_domain ~xc ~xs ~domid ~vcpus ~static_max_kib ~target_kib ~file)
731
| "chkpoint_domain" ->
732
assert_domid (); assert_file ();
733
with_xc_and_xs (fun xc xs -> suspend_domain_and_resume ~xc ~xs ~domid ~file ~cooperative)
734
| "shutdown_domain" -> (
737
| None -> error "no shutdown reason specified"
739
with_xal (fun xal -> clean_shutdown_domain ~xal ~domid ~reason ~sync)
741
| "hard_shutdown_domain" -> (
744
| None -> error "no shutdown reason specified"
746
with_xc (fun xc -> hard_shutdown_domain ~xc ~domid ~reason)
750
with_xs (fun xs -> sysrq_domain ~xs ~domid ~sysrq)
753
with_xc (fun xc -> pause_domain ~xc ~domid)
754
| "unpause_domain" ->
756
with_xc (fun xc -> unpause_domain ~xc ~domid)
758
with_xc (fun xc -> list_domains ~xc ~verbose)
760
with_xc_and_xs (fun xc xs -> list_devices ~xc ~xs)
763
with_xc (fun xc -> sched_domain ~xc ~domid ~weight ~cap)
766
let w, c = with_xc (fun xc -> sched_domain_get ~xc ~domid) in
772
with_xc (fun xc -> affinity_set ~xc ~domid ~vcpu ~bitmap);
776
with_xc (fun xc -> affinity_get ~xc ~domid ~vcpu);
779
with_xc_and_xs (fun xc xs ->
780
let hvm = is_domain_hvm xc domid in
781
ignore(add_vbd ~xs ~hvm ~domid ~device_number ~phystype ~params ~dev_type ~unpluggable:true ~mode ~backend_domid)
785
with_xs (fun xs -> del_vbd ~xs ~domid ~backend_domid ~device_number ~phystype)
788
with_xs (fun xs -> add_vif ~xs ~domid ~netty ~devid ~mac ~backend_domid)
791
with_xs (fun xs -> del_vif ~xs ~domid ~backend_domid ~devid)
794
with_xc_and_xs (fun xc xs -> add_pci ~xc ~xs ~hvm:(is_domain_hvm xc domid) ~domid ~devid ~pci)
797
with_xc_and_xs (fun xc xs -> del_pci ~xc ~xs ~hvm:(is_domain_hvm xc domid) ~domid ~devid ~pci)
800
with_xc_and_xs (fun xc xs -> plug_pci ~xc ~xs ~domid ~devid ~pci)
803
with_xc_and_xs (fun xc xs -> unplug_pci ~xc ~xs ~domid ~devid ~pci)
808
with_xc_and_xs (fun xc xs -> list_pci ~xc ~xs ~domid)
811
with_xc (fun xc -> add_ioport ~xc ~domid ~ioport_start ~ioport_end)
814
with_xc (fun xc -> del_ioport ~xc ~domid ~ioport_start ~ioport_end)
817
with_xc (fun xc -> add_iomem ~xc ~domid ~iomem_start ~iomem_end)
820
with_xc (fun xc -> del_iomem ~xc ~domid ~iomem_start ~iomem_end)
823
with_xc (fun xc -> add_irq ~xc ~domid ~irq)
826
with_xc (fun xc -> del_irq ~xc ~domid ~irq)
830
add_dm ~xs ~domid ~static_max_kib ~vcpus ~boot
834
with_xs (fun xs -> balloon_domain ~xs ~domid ~mem_mib)
836
let mem_kib = Int64.mul mem_mib 1024L in
837
with_xc (fun xc -> with_xs (fun xs -> Squeeze_xen.free_memory ~xc ~xs mem_kib))
839
with_xc (fun xc -> with_xs (fun xs -> Squeeze_xen.balance_memory ~xc ~xs))
842
with_xc (fun xc -> domain_get_uuid ~xc ~domid);
844
if slot < 0 then error "slot";
845
if timeout = -1l then error "timeout";
846
Printf.printf "%d\n" (with_xc (fun xc -> Xenctrl.watchdog xc slot timeout))
849
with_xc (fun xc -> Domain.send_s3resume ~xc domid);
852
with_xc (fun xc -> Domain.trigger_power ~xc domid);
855
with_xc (fun xc -> Domain.trigger_sleep ~xc domid);
857
with_xc (fun xc -> print_xen_dmesg ~xc);
859
with_xc (fun xc -> debugkeys ~xc otherargs);
861
with_xc (fun xc -> print_xen_physinfo ~xc);
863
with_xc (fun xc -> print_pcpus_info ~xc);
865
with_xc (fun xc -> print_endline (Xenctrl.version_capabilities xc))
867
raise (usage (try Some (List.hd otherargs) with _ -> None) allcommands)
869
raise (usage (Some s) allcommands)
871
| Arg.Help msg -> printf "%s\n" msg; exit 0
872
| Arg.Bad msg -> eprintf "%s\n" msg; exit 1
added
removed
ocaml/xenops/xenops.ml
