diff --git a/_oasis b/_oasis index bb86e1ed7..4c33dcccf 100644 --- a/_oasis +++ b/_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 diff --git a/_tags b/_tags index 7bb98e07d..a7de87ec6 100644 --- a/_tags +++ b/_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 : use_udpv4-socket : use_udpv6-socket # Executable test -"lib_test/test.byte": oasis_executable_test_byte +"lib_test/test.native": oasis_executable_test_byte : 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 : pkg_alcotest : pkg_bytes : pkg_channel @@ -197,7 +197,6 @@ true: annot, bin_annot : use_ipv6 : use_tcp : use_tcpip -"lib_test/test.byte": custom # OASIS_STOP true: annot, bin_annot, principal, strict_sequence, debug : pkg_cstruct.syntax diff --git a/lib_test/test.ml b/lib_test/test.ml index d92abacbe..7b6fc810c 100644 --- a/lib_test/test.ml +++ b/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 diff --git a/lib_test/vnetif_backends.ml b/lib_test/vnetif_backends.ml index 4832577b3..f905391bd 100644 --- a/lib_test/vnetif_backends.ml +++ b/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 () = diff --git a/setup.ml b/setup.ml index c3a586076..28f79bd7e 100644 --- a/setup.ml +++ b/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,7 +7871,7 @@ 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 @@ -7878,6 +7879,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7882 "setup.ml" +# 7883 "setup.ml" (* OASIS_STOP *) let () = setup ();; diff --git a/tcp/segment.ml b/tcp/segment.ml index b85149870..c8cc2b573 100644 --- a/tcp/segment.ml +++ b/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 ->