mirage · Nov 18, 2014 · Nov 18, 2014
Showing with 77 additions and 7 deletions.

+3 −0 CHANGES

+60 −5 lib/mirage.ml

+14 −2 lib/mirage.mli
diff --git a/CHANGES b/CHANGES
@@ -1,3 +1,6 @@
+trunk (unreleased):
+* Add `register ~tracing` to enable tracing with mirage-profile at start-up.
+
 2.0.0 (2014-11-05):
 * [types]: backwards incompatible change: CONSOLE is now a FLOW;
   'write' has a different signature and 'write_all' has been removed.

diff --git a/lib/mirage.ml b/lib/mirage.ml
@@ -1811,10 +1811,54 @@ module Job = struct
 
 end
 
+module Tracing = struct
+  type t = {
+    size : int;
+  }
+
+  let unix_trace_file = "trace.ctf"
+
+  let packages _ = StringSet.singleton "mirage-profile"
+
+  let libraries _ =
+    match !mode with
+    | `Unix -> StringSet.singleton "mirage-profile.unix"
+    | `Xen  -> StringSet.singleton "mirage-profile.xen"
+
+  let configure t =
+    if Sys.command "ocamlfind query lwt.tracing 2>/dev/null" <> 0 then (
+      flush stdout;
+      error "lwt.tracing module not found. Hint:\n\
+             opam pin add lwt https://github.com/mirage/lwt.git#tracing"
+    );
+
+    append_main "let () = ";
+    begin match !mode with
+    | `Unix ->
+        append_main "  let buffer = MProf_unix.mmap_buffer ~size:%d %S in" t.size unix_trace_file;
+        append_main "  let trace_config = MProf.Trace.Control.make buffer MProf_unix.timestamper in";
+        append_main "  MProf.Trace.Control.start trace_config";
+    | `Xen  ->
+        append_main "  let trace_pages = MProf_xen.make_shared_buffer ~size:%d in" t.size;
+        append_main "  let buffer = trace_pages |> Io_page.to_cstruct |> Cstruct.to_bigarray in";
+        append_main "  let trace_config = MProf.Trace.Control.make buffer MProf_xen.timestamper in";
+        append_main "  MProf.Trace.Control.start trace_config;";
+        append_main "  MProf_xen.share_with (module Gnt.Gntshr) (module OS.Xs) ~domid:0 trace_pages";
+        append_main "  |> OS.Main.run";
+    end;
+    newline_main ()
+end
+
+type tracing = Tracing.t
+
+let mprof_trace ~size () =
+  { Tracing.size }
+
 type t = {
   name: string;
   root: string;
   jobs: job impl list;
+  tracing: tracing option;
 }
 
 let t = ref None
@@ -1836,15 +1880,15 @@ let get_config_file () =
 let update_path t root =
   { t with jobs = List.map (fun j -> Impl.update_path j root) t.jobs }
 
-let register name jobs =
+let register ?tracing name jobs =
   let root = match !config_file with
     | None   -> failwith "no config file"
     | Some f -> Filename.dirname f in
-  t := Some { name; jobs; root }
+  t := Some { name; jobs; root; tracing }
 
 let registered () =
   match !t with
-  | None   -> { name = "empty"; jobs = []; root = Sys.getcwd () }
+  | None   -> { name = "empty"; jobs = []; root = Sys.getcwd (); tracing = None }
   | Some t -> t
 
 let ps = ref StringSet.empty
@@ -1856,10 +1900,14 @@ let packages t =
   let m = match !mode with
     | `Unix -> "mirage-unix"
     | `Xen  -> "mirage-xen" in
+  let ps = StringSet.add m !ps in
+  let ps = match t.tracing with
+    | None -> ps
+    | Some tracing -> StringSet.union (Tracing.packages tracing) ps in
   let ps = List.fold_left (fun set j ->
       let ps = StringSet.of_list (Impl.packages j) in
       StringSet.union ps set
-    ) (StringSet.add m !ps) t.jobs in
+    ) ps t.jobs in
   StringSet.elements ps
 
 let ls = ref StringSet.empty
@@ -1871,10 +1919,14 @@ let libraries t =
   let m = match !mode with
     | `Unix -> "mirage-types.lwt"
     | `Xen  -> "mirage-types.lwt" in
+  let ls = StringSet.add m !ls in
+  let ls = match t.tracing with
+    | None -> ls
+    | Some tracing -> StringSet.union (Tracing.libraries tracing) ls in
   let ls = List.fold_left (fun set j ->
       let ls = StringSet.of_list (Impl.libraries j) in
       StringSet.union ls set
-    ) (StringSet.add m !ls) t.jobs in
+    ) ls t.jobs in
   StringSet.elements ls
 
 let configure_myocamlbuild_ml t =
@@ -2218,6 +2270,9 @@ let configure_main t =
   newline_main ();
   append_main "let _ = Printexc.record_backtrace true";
   newline_main ();
+  begin match t.tracing with
+  | None -> ()
+  | Some tracing -> Tracing.configure tracing end;
   List.iter (fun j -> Impl.configure j) t.jobs;
   List.iter configure_job t.jobs;
   let names = List.map (fun j -> Printf.sprintf "%s ()" (Impl.name j)) t.jobs in

diff --git a/lib/mirage.mli b/lib/mirage.mli
@@ -352,6 +352,16 @@ val http: http typ
 val http_server: conduit_server -> conduit impl -> http impl
 
 
+(** {2 Tracing} *)
+
+type tracing
+
+val mprof_trace : size:int -> unit -> tracing
+(** Use mirage-profile to trace the unikernel.
+   On Unix, this creates and mmaps a file called "trace.ctf".
+   On Xen, it shares the trace buffer with dom0. *)
+
+
 (** {2 Jobs} *)
 
 type job
@@ -360,14 +370,16 @@ type job
 val job: job typ
 (** Reprensention of [JOB]. *)
 
-val register: string -> job impl list -> unit
+val register: ?tracing:tracing -> string -> job impl list -> unit
 (** [register name jobs] registers the application named by [name]
-    which will executes the given [jobs]. *)
+    which will executes the given [jobs].
+    @param tracing enables tracing if present (see {!mprof_trace}). *)
 
 type t = {
   name: string;
   root: string;
   jobs: job impl list;
+  tracing: tracing option;
 }
 (** Type for values representing a project description. *)