Merge branch 'talex5-tracing2'

Conflicts:
	_oasis
	_tags
	lib/META
	setup.ml

_oasis

@@ -19,7 +19,7 @@ Library tcpip
   Modules:            Wire_structs, Tcpip_checksum
   CSources:           checksum_stubs.c
   CCOpt:              -O2 -fno-stack-protector
-  BuildDepends:       io-page,mirage-types,ipaddr,cstruct
+  BuildDepends:       io-page,mirage-types,ipaddr,cstruct,mirage-profile
   XMETAExtraLines:    xen_linkopts = "-ltcpip_xen_stubs"
 
 Library tcpip_xen

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: b06b7a14d338a8fea8172e34c3e0c0a0)
+# DO NOT EDIT (digest: 79d6c9ed0b8e11fef32f21eb0e5294c4)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -22,6 +22,7 @@ true: annot, bin_annot
 "lib/checksum_stubs.c": pkg_cstruct
 "lib/checksum_stubs.c": pkg_io-page
 "lib/checksum_stubs.c": pkg_ipaddr
+"lib/checksum_stubs.c": pkg_mirage-profile
 "lib/checksum_stubs.c": pkg_mirage-types
 # Library tcpip_xen
 "lib/tcpip_xen.cmxs": use_tcpip_xen
@@ -52,6 +53,7 @@ true: annot, bin_annot
 <tcp/*.ml{,i,y}>: pkg_io-page
 <tcp/*.ml{,i,y}>: pkg_ipaddr
 <tcp/*.ml{,i,y}>: pkg_lwt
+<tcp/*.ml{,i,y}>: pkg_mirage-profile
 <tcp/*.ml{,i,y}>: pkg_mirage-types
 <tcp/*.ml{,i,y}>: use_ipv4
 <tcp/*.ml{,i,y}>: use_tcpip
@@ -68,6 +70,7 @@ true: annot, bin_annot
 <dhcp/*.ml{,i,y}>: pkg_io-page
 <dhcp/*.ml{,i,y}>: pkg_ipaddr
 <dhcp/*.ml{,i,y}>: pkg_lwt
+<dhcp/*.ml{,i,y}>: pkg_mirage-profile
 <dhcp/*.ml{,i,y}>: pkg_mirage-types
 <dhcp/*.ml{,i,y}>: use_tcpip
 <dhcp/*.ml{,i,y}>: use_udpv4
@@ -77,6 +80,7 @@ true: annot, bin_annot
 <lib/*.ml{,i,y}>: pkg_io-page
 <lib/*.ml{,i,y}>: pkg_ipaddr
 <lib/*.ml{,i,y}>: pkg_lwt
+<lib/*.ml{,i,y}>: pkg_mirage-profile
 <lib/*.ml{,i,y}>: pkg_mirage-types
 <lib/*.ml{,i,y}>: use_dhcpv4
 <lib/*.ml{,i,y}>: use_ethif
@@ -123,6 +127,7 @@ true: annot, bin_annot
 <unix/*.ml{,i,y}>: pkg_ipaddr.unix
 <unix/*.ml{,i,y}>: pkg_lwt
 <unix/*.ml{,i,y}>: pkg_lwt.unix
+<unix/*.ml{,i,y}>: pkg_mirage-profile
 <unix/*.ml{,i,y}>: pkg_mirage-types
 <unix/*.ml{,i,y}>: use_tcpip
 <unix/*.ml{,i,y}>: use_tcpv4-socket

lib/META

@@ -1,8 +1,8 @@
 # OASIS_START
-# DO NOT EDIT (digest: a48d2b236a8f5a25886b3bdbe795c245)
+# DO NOT EDIT (digest: 25db43984f5ffcb4a49edc8f99b7b633)
 version = "2.0.3"
 description = "Ethernet, TCP/IPv4 and DHCPv4 library"
-requires = "io-page mirage-types ipaddr cstruct"
+requires = "io-page mirage-types ipaddr cstruct mirage-profile"
 archive(byte) = "tcpip.cma"
 archive(byte, plugin) = "tcpip.cma"
 archive(native) = "tcpip.cmxa"
@@ -189,3 +189,4 @@ package "channel" (
  exists_if = "channel.cma"
 )
 # OASIS_STOP
+

lib/arpv4.ml

@@ -71,6 +71,7 @@ let prettyprint t =
 
 (* Input handler for an ARP packet, registered through attach() *)
 let rec input t frame =
+  MProf.Trace.label "arpv4.input";
   match get_arp_op frame with
   |1 -> (* Request *)
     (* Received ARP request, check if we can satisfy it from
@@ -174,7 +175,7 @@ let query t ip =
   if Hashtbl.mem t.cache ip then (
     Hashtbl.find t.cache ip
   ) else (
-    let response, waker = wait () in
+    let response, waker = MProf.Trace.named_wait "Wait for ARP response" in
     (* printf "ARP query: %s -> [probe]\n%!" (Ipaddr.V4.to_string ip); *)
     Hashtbl.add t.cache ip response;
     Hashtbl.add t.pending ip waker;

lib/ethif.ml

@@ -39,6 +39,7 @@ module Make(Netif : V1_LWT.NETWORK) = struct
   let id t = t.netif
 
   let input ~ipv4 ~ipv6 t frame =
+    MProf.Trace.label "ethif.input";
     match Wire_structs.get_ethernet_ethertype frame with
     | 0x0806 -> Arpv4.input t.arp frame (* ARP *)
     | 0x0800 -> (* IPv4 *)
@@ -53,12 +54,15 @@ module Make(Netif : V1_LWT.NETWORK) = struct
       return_unit
 
   let write t frame =
+    MProf.Trace.label "ethif.write";
     Netif.write t.netif frame
 
   let writev t bufs =
+    MProf.Trace.label "ethif.writev";
     Netif.writev t.netif bufs
 
   let connect netif =
+    MProf.Trace.label "ethif.connect";
     let arp =
       let get_mac () = Netif.mac netif in
       let get_etherbuf () = return (Io_page.to_cstruct (Io_page.get 1)) in

lib/ipv4.ml

@@ -131,6 +131,7 @@ module Make(Ethif : V1_LWT.ETHIF) = struct
     Ethif.writev t.ethif (ethernet_frame::bufs)
 
   let icmp_input t src _hdr buf =
+    MProf.Trace.label "icmp_input";
     match Wire_structs.get_icmpv4_ty buf with
     |0 -> (* echo reply *)
       return (printf "ICMP: discarding echo reply\n%!")

opam

@@ -28,6 +28,7 @@ depends: [
   "mirage-clock-unix" {>= "1.0.0"}
   "mirage-net-unix" {>= "1.1.0"}
   "ipaddr" {>= "2.2.0"}
+  "mirage-profile"
 ]
 depopts: [
   "mirage-xen"

setup.ml

@@ -1,7 +1,7 @@
-(* setup.ml generated for the first time by OASIS v0.4.4 *)
+(* setup.ml generated for the first time by OASIS v0.4.5 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: 07e8e114639c4bacf8d94cf1f4ad3149) *)
+(* DO NOT EDIT (digest: ad24a24c050483bf1c7ffc1b45f2a4fb) *)
 (*
    Regenerated by OASIS v0.4.5
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -6753,7 +6753,8 @@ let setup_t =
                            FindlibPackage ("io-page", None);
                            FindlibPackage ("mirage-types", None);
                            FindlibPackage ("ipaddr", None);
-                           FindlibPackage ("cstruct", None)
+                           FindlibPackage ("cstruct", None);
+                           FindlibPackage ("mirage-profile", None)
                         ];
                       bs_build_tools = [ExternalTool "ocamlbuild"];
                       bs_c_sources = ["checksum_stubs.c"];
@@ -7413,14 +7414,14 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.5";
-     oasis_digest = Some "\239e\147\184G\002@\245\031t\0308\131\1308>";
+     oasis_digest = Some "-\001\228.\187`pX\231\139\193x|\018n%";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
   };;
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 7425 "setup.ml"
+# 7426 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;

tcp/pcb.ml

@@ -308,7 +308,7 @@ struct
     (* The user application receive buffer and close notification *)
     let rx_buf_size = Window.rx_wnd wnd in
     let urx = User_buffer.Rx.create ~max_size:rx_buf_size ~wnd in
-    let urx_close_t, urx_close_u = Lwt.task () in
+    let urx_close_t, urx_close_u = MProf.Trace.named_task "urx_close" in
     (* The window handling thread *)
     let tx_wnd_update = Lwt_mvar.create_empty () in
     (* Set up transmit and receive queues *)
@@ -587,7 +587,7 @@ struct
       Options.MSS 1460 :: Options.Window_size_shift rx_wnd_scaleoffer :: []
     in
     let window = 5840 in
-    let th, wakener = Lwt.task () in
+    let th, wakener = MProf.Trace.named_task "TCP connect" in
     if Hashtbl.mem t.connects id then
       printf "WARNING: connection already being attempted\n%!";
     Hashtbl.replace t.connects id (wakener, tx_isn);

tcp/user_buffer.ml

@@ -54,7 +54,7 @@ module Rx = struct
 
   let add_r t s =
     if t.cur_size > t.max_size then
-      let th,u = Lwt.task () in
+      let th,u = MProf.Trace.named_task "User_buffer.add_r" in
       let node = Lwt_sequence.add_r u t.writers in
       Lwt.on_cancel th (fun _ -> Lwt_sequence.remove node);
       (* Update size before blocking, which may push cur_size above max_size *)
@@ -73,7 +73,7 @@ module Rx = struct
 
   let take_l t =
     if Lwt_sequence.is_empty t.q then begin
-      let th,u = Lwt.task () in
+      let th,u = MProf.Trace.named_task "User_buffer.take_l" in
       let node = Lwt_sequence.add_r u t.readers in
       Lwt.on_cancel th (fun _ -> Lwt_sequence.remove node);
       th
@@ -147,7 +147,7 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct
       return_unit
     end
     else begin
-      let th,u = Lwt.task () in
+      let th,u = MProf.Trace.named_task "User_buffer.wait_for" in
       let node = Lwt_sequence.add_r u t.writers in
       Lwt.on_cancel th (fun _ -> Lwt_sequence.remove node);
       th >>= fun () ->
@@ -175,7 +175,7 @@ module Tx(Time:V1_LWT.TIME)(Clock:V1.CLOCK) = struct
       return_unit
     end
     else begin
-      let th,u = Lwt.task () in
+      let th,u = MProf.Trace.named_task "User_buffer.wait_for_flushed" in
       let node = Lwt_sequence.add_r u t.writers in
       Lwt.on_cancel th (fun _ -> Lwt_sequence.remove node);
       th >>= fun () ->

tcp/window.ml

@@ -52,6 +52,8 @@ type t = {
   mutable backoff_count: int;
 }
 
+let count_ackd_segs = MProf.Counter.make ~name:"tcp-ackd-segs"
+
 let default_mss = 536
 let max_mss = 1460
 
@@ -132,7 +134,9 @@ let ack_seq t = t.ack_seq
 let ack_win t = t.ack_win
 
 let set_ack_serviced t v = t.ack_serviced <- v
-let set_ack_seq t s = t.ack_seq <- s
+let set_ack_seq t s =
+  MProf.Counter.increase count_ackd_segs (Sequence.(sub s t.ack_seq |> to_int));
+  t.ack_seq <- s
 let set_ack_win t w = t.ack_win <- w
 
 (* TODO: scale the window down so we can advertise it correctly with

tcp/wire.ml

@@ -18,6 +18,8 @@ open Lwt
 
 module Tcp_wire = Wire_structs.Tcp_wire
 
+let count_tcp_to_ip = MProf.Counter.make ~name:"tcp-to-ip"
+
 let get_options buf =
   if Tcp_wire.get_data_offset buf > 20 then
     Options.unmarshal (Cstruct.shift buf Tcp_wire.sizeof_tcpv4) else []
@@ -101,5 +103,6 @@ module Make (Ipv4:V1_LWT.IPV4) = struct
     rst syn fin psh sequence ack_number (Options.prettyprint options)
     (Cstruct.lenv datav) (List.length datav) data_off options_len;
   *)
+    MProf.Counter.increase count_tcp_to_ip (Cstruct.lenv datav);
     Ipv4.writev ip ethernet_frame datav
 end