Merge pull request #158 from MagnusS/fix-tcp-timer

Fix timer issue from #157 + test improvements

_oasis

@@ -291,13 +291,13 @@ Library "tcpip-stack-socket"
                       io-page.unix
 
 Executable test
+  CompiledObject:     native
   Build$: flag(tests)
   Path: lib_test
-  Custom: true
   MainIs: test.ml
   ByteOpt: -g
-  BuildDepends: alcotest, oUnit, lwt, lwt.unix, io-page.unix, channel,
-                mirage-flow, mirage-vnetif, mirage-console.unix, tcpip.ethif,
+  BuildDepends: alcotest, oUnit, lwt, lwt.unix, io-page.unix, channel, mirage-profile,
+                mirage-flow, mirage-vnetif, mirage-console.unix, tcpip.ethif, 
                 tcpip.tcp, pcap-format
 
 Test test

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 07861bd4b671f3528e19559ae3d0d659)
+# DO NOT EDIT (digest: c29853b44d503443994beb236b619204)
 # 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
@@ -153,29 +153,29 @@ true: annot, bin_annot
 <unix/*.ml{,i,y}>: use_udpv4-socket
 <unix/*.ml{,i,y}>: use_udpv6-socket
 # Executable test
-"lib_test/test.byte": oasis_executable_test_byte
+"lib_test/test.native": oasis_executable_test_byte
 <lib_test/*.ml{,i,y}>: oasis_executable_test_byte
-"lib_test/test.byte": pkg_alcotest
-"lib_test/test.byte": pkg_bytes
-"lib_test/test.byte": pkg_channel
-"lib_test/test.byte": pkg_cstruct
-"lib_test/test.byte": pkg_io-page
-"lib_test/test.byte": pkg_io-page.unix
-"lib_test/test.byte": pkg_ipaddr
-"lib_test/test.byte": pkg_lwt
-"lib_test/test.byte": pkg_lwt.unix
-"lib_test/test.byte": pkg_mirage-console.unix
-"lib_test/test.byte": pkg_mirage-flow
-"lib_test/test.byte": pkg_mirage-profile
-"lib_test/test.byte": pkg_mirage-types
-"lib_test/test.byte": pkg_mirage-vnetif
-"lib_test/test.byte": pkg_oUnit
-"lib_test/test.byte": pkg_pcap-format
-"lib_test/test.byte": use_ethif
-"lib_test/test.byte": use_ipv4
-"lib_test/test.byte": use_ipv6
-"lib_test/test.byte": use_tcp
-"lib_test/test.byte": use_tcpip
+"lib_test/test.native": pkg_alcotest
+"lib_test/test.native": pkg_bytes
+"lib_test/test.native": pkg_channel
+"lib_test/test.native": pkg_cstruct
+"lib_test/test.native": pkg_io-page
+"lib_test/test.native": pkg_io-page.unix
+"lib_test/test.native": pkg_ipaddr
+"lib_test/test.native": pkg_lwt
+"lib_test/test.native": pkg_lwt.unix
+"lib_test/test.native": pkg_mirage-console.unix
+"lib_test/test.native": pkg_mirage-flow
+"lib_test/test.native": pkg_mirage-profile
+"lib_test/test.native": pkg_mirage-types
+"lib_test/test.native": pkg_mirage-vnetif
+"lib_test/test.native": pkg_oUnit
+"lib_test/test.native": pkg_pcap-format
+"lib_test/test.native": use_ethif
+"lib_test/test.native": use_ipv4
+"lib_test/test.native": use_ipv6
+"lib_test/test.native": use_tcp
+"lib_test/test.native": use_tcpip
 <lib_test/*.ml{,i,y}>: pkg_alcotest
 <lib_test/*.ml{,i,y}>: pkg_bytes
 <lib_test/*.ml{,i,y}>: pkg_channel
@@ -197,7 +197,6 @@ true: annot, bin_annot
 <lib_test/*.ml{,i,y}>: use_ipv6
 <lib_test/*.ml{,i,y}>: use_tcp
 <lib_test/*.ml{,i,y}>: use_tcpip
-"lib_test/test.byte": custom
 # OASIS_STOP
 true: annot, bin_annot, principal, strict_sequence, debug
 <tcp/pcb.ml>: pkg_cstruct.syntax

lib_test/test.ml

@@ -24,6 +24,16 @@ let run test () =
   Lwt_main.run (test ())
 
 let () =
+  (* Enable TCP debug output *)
+  let open Tcp in
+  [Segment.info; Segment.debug; Pcb.info; Pcb.debug] |> List.iter (fun log ->
+      Log.enable log;
+      Log.set_stats log false
+    );
+  (* Uncomment to enable tracing *)
+  (*let buffer = MProf_unix.mmap_buffer ~size:1000000 "trace.ctf" in
+  let trace_config = MProf.Trace.Control.make buffer MProf_unix.timestamper in
+  MProf.Trace.Control.start trace_config;*)
   let suite = List.map (fun (n, s) ->
       n, List.map (fun (d, s, f) -> d, s, run f) s
     ) suite

lib_test/vnetif_backends.ml

@@ -53,14 +53,18 @@ module Uniform_packet_loss : Backend = struct
 
   let write t id buffer =
     if Random.float 1.0 < drop_p then
+    begin
+        MProf.Trace.label "pkt_drop";
         Lwt.return_unit (* drop packet *)
-    else
+    end else
         X.write t id buffer (* pass to real write *)
 
   let writev t id buffers =
     if Random.float 1.0 < drop_p then
+    begin
+        MProf.Trace.label "pkt_drop";
         Lwt.return_unit (* drop packet *)
-    else
+    end else
         X.writev t id buffers (* pass to real writev *)
 
   let create () =

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.4.5 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: decf59a37589d91b7be632bb908e1b3a) *)
+(* DO NOT EDIT (digest: d477705c240c1631201701944b97f72c) *)
 (*
    Regenerated by OASIS v0.4.5
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -7807,7 +7807,7 @@ let setup_t =
                         ];
                       bs_install = [(OASISExpr.EBool true, true)];
                       bs_path = "lib_test";
-                      bs_compiled_object = Byte;
+                      bs_compiled_object = Native;
                       bs_build_depends =
                         [
                            FindlibPackage ("alcotest", None);
@@ -7816,6 +7816,7 @@ let setup_t =
                            FindlibPackage ("lwt.unix", None);
                            FindlibPackage ("io-page.unix", None);
                            FindlibPackage ("channel", None);
+                           FindlibPackage ("mirage-profile", None);
                            FindlibPackage ("mirage-flow", None);
                            FindlibPackage ("mirage-vnetif", None);
                            FindlibPackage ("mirage-console.unix", None);
@@ -7833,7 +7834,7 @@ let setup_t =
                       bs_byteopt = [(OASISExpr.EBool true, ["-g"])];
                       bs_nativeopt = [(OASISExpr.EBool true, [])]
                    },
-                   {exec_custom = true; exec_main_is = "test.ml"});
+                   {exec_custom = false; exec_main_is = "test.ml"});
                Test
                  ({
                      cs_name = "test";
@@ -7870,14 +7871,14 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.5";
-     oasis_digest = Some "\022½À\031©Ö\135u^îZ\016ëíÕC";
+     oasis_digest = Some "@xO\231\145LZ\156\178)|\149\149\165\187\140";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false
   };;
 
 let setup () = BaseSetup.setup setup_t;;
 
-# 7882 "setup.ml"
+# 7883 "setup.ml"
 (* OASIS_STOP *)
 let () = setup ();;

tcp/segment.ml

@@ -126,7 +126,6 @@ module Rx(Time:V1_LWT.TIME) = struct
      queue, update the window, extract any ready segments into the
      user receive queue, and signal any acks to the Tx queue *)
   let input (q:t) seg =
-    Log.s debug "input";
     (* Check that the segment fits into the valid receive window *)
     let force_ack = ref false in
     if not (Window.valid q.wnd seg.sequence) then Lwt.return_unit
@@ -297,8 +296,7 @@ module Tx (Time:V1_LWT.TIME) (Clock:V1.CLOCK) = struct
               Log.f info (fun fmt ->
                   Log.pf fmt "TCP retransmission on timer seq = %d"
                     (Sequence.to_int rexmit_seg.seq));
-              (* FIXME: suspicious ignore *)
-              xmit ~flags ~wnd ~options ~seq rexmit_seg.data >>= fun () ->
+              Lwt.async (fun () -> xmit ~flags ~wnd ~options ~seq rexmit_seg.data);
               Window.backoff_rto wnd;
               Log.f debug (fun fmt ->
                   Log.pf fmt "PUSHING TIMER - new time = %f, new seq = %a"
@@ -354,7 +352,8 @@ module Tx (Time:V1_LWT.TIME) (Clock:V1.CLOCK) = struct
             let { wnd; _ } = q in
             let flags=rexmit_seg.flags in
             let options=[] in (* TODO: put the right options *)
-            q.xmit ~flags ~wnd ~options ~seq rexmit_seg.data
+            Lwt.async ( fun () -> q.xmit ~flags ~wnd ~options ~seq rexmit_seg.data );
+            Lwt.return_unit
           end else
             Lwt.return_unit
         | false ->