diff --git a/bin/lwt_to_direct_style/ast_rewrite.ml b/bin/lwt_to_direct_style/ast_rewrite.ml index 9887cc3..b50c77b 100644 --- a/bin/lwt_to_direct_style/ast_rewrite.ml +++ b/bin/lwt_to_direct_style/ast_rewrite.ml @@ -280,6 +280,8 @@ let rewrite_apply_lwt ~backend ~state ident args = ("[] can't be automatically translated." ^ backend#choose_comment_hint); return None + | "wrap" -> + take @@ fun f -> return (Some (Exp.apply f [ (Nolabel, mk_unit_val) ])) | _ -> return None let string_drop_suffix ~suffix s = @@ -312,6 +314,17 @@ let rewrite_apply ~backend ~state full_ident args = (( "printf" | "eprintf" | "stdout" | "stderr" | "fprintf" | "kfprintf" | "ifprintf" | "ikfprintf" ) as ident) ) -> transparent [ "Format"; ident ] + | ( "Lwt_unix", + (( "socket" | "socketpair" | "listen" | "shutdown" | "getsockname" + | "getpeername" | "waitpid" | "wait4" | "wait" ) as ident) ) -> + transparent [ "Unix"; ident ] + | "Lwt_io", "read_value" -> transparent [ "Marshal"; "from_channel" ] + | "Lwt_io", "write_value" -> transparent [ "Marshal"; "to_channel" ] + | "Lwt_unix", (("connect" | "accept" | "bind") as ident) -> + Printf.ksprintf (add_comment state) + "This call to [Unix.%s] was [Lwt_unix.%s] before. It's now blocking." + ident ident; + transparent [ "Unix"; ident ] | "Lwt_list", ident -> ( match string_drop_suffix ~suffix:"_s" ident with | Some ident -> transparent [ "List"; ident ] @@ -356,12 +369,13 @@ let rewrite_apply ~backend ~state full_ident args = | "Lwt_mutex", "with_lock" -> take @@ fun t -> take @@ fun f -> return (Some (backend#mutex_with_lock t f)) - | "Lwt_io", "read_into" -> + | "Lwt_io", (("read_into" | "read_into_exactly") as ident) -> + let exactly = ident = "read_into_exactly" in take @@ fun input -> take @@ fun buffer -> take @@ fun buf_off -> take @@ fun buf_len -> - return (Some (backend#io_read input buffer buf_off buf_len)) + return (Some (backend#io_read ~exactly input buffer buf_off buf_len)) | "Lwt_io", "of_fd" -> ignore_lblarg "buffer" @@ ignore_lblarg ~cmt:"Will behave as if it was [true]." "close" @@ -384,8 +398,20 @@ let rewrite_apply ~backend ~state full_ident args = take @@ fun str -> return (Some (backend#io_write_str chan str)) | "Lwt_io", "length" -> take @@ fun fd -> return (Some (backend#io_length fd)) | "Lwt_io", "close" -> take @@ fun fd -> return (Some (backend#io_close fd)) + | "Lwt_io", "flush" -> take @@ fun fd -> return (Some (backend#io_flush fd)) + | "Lwt_io", "with_connection" -> + ignore_lblarg "fd" @@ ignore_lblarg "in_buffer" + @@ ignore_lblarg "out_buffer" @@ take + @@ fun sockaddr -> + take @@ fun f -> return (Some (backend#net_with_connection sockaddr f)) | "Lwt_main", "run" -> take @@ fun promise -> return (Some (backend#main_run promise)) + | "Lwt_preemptive", "detach" -> + take @@ fun f -> + take @@ fun arg -> + return + (Some + (backend#domain_detach (mk_thunk (Exp.apply f [ (Nolabel, arg) ])))) | _ -> return None (** Transform a [binding_op] into a [pattern] and an [expression] while @@ -550,6 +576,7 @@ let rewrite_type ~backend ~state typ = | "group_entry" ) as tname) ), params ) -> Some (mk_typ_constr ~params [ "Unix"; tname ]) + | ("Lwt_io", "input_channel"), [] -> Some backend#type_in_channel | ("Lwt_io", "output_channel"), [] -> Some backend#type_out_channel | _ -> None) | _ -> None diff --git a/bin/lwt_to_direct_style/concurrency_backend.ml b/bin/lwt_to_direct_style/concurrency_backend.ml index 4e32f7c..a0b741f 100644 --- a/bin/lwt_to_direct_style/concurrency_backend.ml +++ b/bin/lwt_to_direct_style/concurrency_backend.ml @@ -18,9 +18,10 @@ let eio ~eio_sw_as_fiber_var ~eio_env_as_fiber_var add_comment = [ i ] in let add_comment fmt = Format.kasprintf add_comment fmt in - let add_comment_dropped_exp ~label exp = - add_comment "Dropped expression (%s): [%s]." label + let add_comment_dropped_exp ~label ?(cmt = "") exp = + add_comment "Dropped expression (%s): [%s].%s" label (Ocamlformat_utils.format_expression exp) + cmt in (* If [--eio-sw-as-fiber-var] is passed on the command line, this will query the current switch. Otherwise, this will generate a comment. @@ -206,7 +207,7 @@ let eio ~eio_sw_as_fiber_var ~eio_env_as_fiber_var add_comment = (* ]) *) fd - method io_read input buffer buf_offset buf_len = + method io_read ~exactly input buffer buf_offset buf_len = add_comment "[%s] should be a [Cstruct.t]." (Ocamlformat_utils.format_expression buffer); add_comment @@ -215,9 +216,12 @@ let eio ~eio_sw_as_fiber_var ~eio_env_as_fiber_var add_comment = contains an internal buffer) or change the call to \ [Eio.Buf_read.of_flow] used to create the buffer." (Ocamlformat_utils.format_expression input); - add_comment_dropped_exp ~label:"buffer offset" buf_offset; - add_comment_dropped_exp ~label:"buffer length" buf_len; - mk_apply_simple [ "Eio"; "Flow"; "single_read" ] [ input; buffer ] + add_comment_dropped_exp ~label:"buffer offset" + ~cmt:" This will behave as if it was [0]." buf_offset; + add_comment_dropped_exp ~label:"buffer length" + ~cmt:" This will behave as if it was [Cstruct.length buffer]." buf_len; + let fun_ = if exactly then "read_exact" else "single_read" in + mk_apply_simple [ "Eio"; "Flow"; fun_ ] [ input; buffer ] method io_read_all input = mk_apply_simple [ "Eio"; "Buf_read"; "take_all" ] [ input ] @@ -229,6 +233,9 @@ let eio ~eio_sw_as_fiber_var ~eio_env_as_fiber_var add_comment = unbuffered IO."; None + method io_flush output = + mk_apply_simple [ "Eio"; "Buf_write"; "flush" ] [ output ] + method fd_close fd = (* TODO: See [of_unix_file_descr]. mk_apply_simple [ "Eio_unix"; "Fd" ] [ fd ] *) mk_apply_simple [ "Unix"; "close" ] [ fd ] @@ -250,7 +257,8 @@ let eio ~eio_sw_as_fiber_var ~eio_env_as_fiber_var add_comment = in mk_apply_ident (switch_ident "run") [ - (Labelled (mk_loc "name"), mk_const_string "main"); + (* TODO: Add the [~name] argument. Currently commented-out because added in a too recent version of eio. + (Labelled (mk_loc "name"), mk_const_string "main"); *) (Nolabel, fun_sw); ] | None -> k @@ -310,6 +318,7 @@ let eio ~eio_sw_as_fiber_var ~eio_env_as_fiber_var add_comment = mk_apply_simple [ "Eio"; "Buf_write"; "string" ] [ chan; str ] method io_close fd = mk_apply_simple [ "Eio"; "Resource"; "close" ] [ fd ] + method type_in_channel = mk_typ_constr [ "Eio"; "Buf_read"; "t" ] method type_out_channel = mk_typ_constr [ "Eio"; "Buf_write"; "t" ] method path_stat ~follow path = @@ -318,4 +327,37 @@ let eio ~eio_sw_as_fiber_var ~eio_env_as_fiber_var add_comment = (Labelled (mk_loc "follow"), mk_constr_of_bool follow); (Nolabel, mk_apply_simple [ "Eio"; "Path"; "/" ] [ env "cwd"; path ]); ] + + method domain_detach thunk = + mk_apply_ident + (fiber_ident "fork_promise") + [ + get_current_switch_arg (); + ( Nolabel, + mk_thunk + (mk_apply_simple + [ "Eio"; "Domain_manager"; "run" ] + [ env "domain_mgr"; thunk ]) ); + ] + + method net_with_connection sockaddr f = + add_comment + "[%s] is of type [Unix.sockaddr] but it should be a \ + [Eio.Net.Sockaddr.stream]." + (Ocamlformat_utils.format_expression sockaddr); + mk_apply_simple (switch_ident "run") + [ + mk_fun ~arg_name:"sw" (fun sw -> + Exp.apply f + [ + ( Nolabel, + mk_apply_ident + [ "Eio"; "Net"; "connect" ] + [ + (Labelled (mk_loc "sw"), sw); + (Nolabel, env "net"); + (Nolabel, sockaddr); + ] ); + ]); + ] end diff --git a/test/lwt_to_direct_style/eio-switch.t/run.t b/test/lwt_to_direct_style/eio-switch.t/run.t index 198d2d2..e47b1f2 100644 --- a/test/lwt_to_direct_style/eio-switch.t/run.t +++ b/test/lwt_to_direct_style/eio-switch.t/run.t @@ -44,7 +44,7 @@ Make a writable directory tree: let () = Eio_main.run (fun env -> Fiber.with_binding Fiber_var.env env (fun () -> - Switch.run ~name:"main" (fun sw -> + Switch.run (fun sw -> Fiber.with_binding Fiber_var.sw sw (fun () -> (* TODO: lwt-to-direct-style: [Eio_main.run] argument used to be a [Lwt] promise and is now a [fun]. Make sure no asynchronous or IO calls are done outside of this [fun]. *) main ())))) diff --git a/test/lwt_to_direct_style/to_direct_style.t/run.t b/test/lwt_to_direct_style/to_direct_style.t/run.t index ac72ec5..e64e49c 100644 --- a/test/lwt_to_direct_style/to_direct_style.t/run.t +++ b/test/lwt_to_direct_style/to_direct_style.t/run.t @@ -50,7 +50,7 @@ Make a writable directory tree: Lwt_unix.sleep (line 31 column 9) Lwt_unix.Timeout (line 37 column 15) Lwt_unix.with_timeout (line 35 column 16) - lib/test.ml: (177 occurrences) + lib/test.ml: (179 occurrences) Lwt (line 36 column 12) Lwt (line 55 column 18) Lwt (line 64 column 13) @@ -145,6 +145,8 @@ Make a writable directory tree: Lwt.Sleep (line 148 column 5) Lwt.Sleep (line 178 column 9) Lwt.state (line 145 column 9) + Lwt.wrap (line 189 column 3) + Lwt.wrap (line 191 column 9) Lwt.pause (line 114 column 9) Lwt.(>>=) (line 32 column 3) Lwt.(>>=) (line 33 column 27) @@ -228,45 +230,64 @@ Make a writable directory tree: Lwt_mutex.lock (line 136 column 9) Lwt_mutex.unlock (line 137 column 9) Lwt_mutex.with_lock (line 138 column 9) - lib/test_lwt_unix.ml: (38 occurrences) + lib/test_lwt_unix.ml: (57 occurrences) Lwt_io (line 7 column 8) - Lwt.return (line 11 column 3) + Lwt.return (line 12 column 3) + Lwt.return (line 46 column 11) + Lwt.return (line 61 column 65) + Lwt.return_unit (line 44 column 43) Lwt.let* (line 10 column 3) - Lwt.let* (line 31 column 3) - Lwt.let* (line 35 column 3) + Lwt.let* (line 11 column 3) + Lwt.let* (line 30 column 3) + Lwt.let* (line 34 column 3) Lwt.Syntax (line 1 column 6) Lwt_io.Input (line 22 column 32) Lwt_io.Output (line 23 column 32) Lwt_io.input (line 7 column 28) - Lwt_io.input (line 31 column 36) + Lwt_io.input (line 30 column 36) Lwt_io.output (line 21 column 32) - Lwt_io.output (line 35 column 36) + Lwt_io.output (line 34 column 36) + Lwt_io.input_channel (line 25 column 9) Lwt_io.output_channel (line 26 column 9) - Lwt_io.close (line 32 column 3) + Lwt_io.close (line 31 column 3) Lwt_io.of_fd (line 7 column 16) Lwt_io.of_fd (line 21 column 13) Lwt_io.of_fd (line 22 column 13) Lwt_io.of_fd (line 23 column 13) - Lwt_io.read_line (line 28 column 15) + Lwt_io.read_line (line 27 column 15) + Lwt_io.read (line 39 column 15) + Lwt_io.read (line 40 column 15) Lwt_io.read (line 41 column 15) - Lwt_io.read (line 42 column 15) - Lwt_io.read (line 43 column 15) - Lwt_io.read_into (line 10 column 19) + Lwt_io.read_into (line 10 column 21) + Lwt_io.read_into_exactly (line 11 column 13) + Lwt_io.read_value (line 57 column 12) + Lwt_io.flush (line 42 column 15) Lwt_io.write (line 24 column 19) - Lwt_io.length (line 36 column 3) + Lwt_io.write_value (line 58 column 14) + Lwt_io.length (line 35 column 3) + Lwt_io.stdin (line 25 column 32) Lwt_io.stdout (line 26 column 33) - Lwt_io.open_file (line 31 column 13) - Lwt_io.open_file (line 35 column 13) - Lwt_unix.Timeout (line 13 column 9) + Lwt_io.open_file (line 30 column 13) + Lwt_io.open_file (line 34 column 13) + Lwt_io.with_connection (line 61 column 3) + Lwt_preemptive.detach (line 44 column 10) + Lwt_preemptive.detach (line 47 column 3) + Lwt_unix.Timeout (line 14 column 9) Lwt_unix.of_unix_file_descr (line 6 column 8) - Lwt_unix.stat (line 38 column 16) - Lwt_unix.lstat (line 39 column 16) - Lwt_unix.sockaddr (line 14 column 9) - Lwt_unix.ADDR_UNIX (line 14 column 29) - Lwt_unix.ADDR_UNIX (line 16 column 6) - Lwt_unix.ADDR_INET (line 16 column 29) - Lwt_unix.ADDR_INET (line 17 column 3) - Lwt_unix.getaddrinfo (line 19 column 9) + Lwt_unix.stat (line 37 column 16) + Lwt_unix.lstat (line 38 column 16) + Lwt_unix.sockaddr (line 15 column 9) + Lwt_unix.ADDR_UNIX (line 15 column 29) + Lwt_unix.ADDR_UNIX (line 17 column 6) + Lwt_unix.ADDR_INET (line 17 column 29) + Lwt_unix.ADDR_INET (line 18 column 3) + Lwt_unix.socket (line 50 column 3) + Lwt_unix.socketpair (line 51 column 16) + Lwt_unix.accept (line 53 column 12) + Lwt_unix.connect (line 52 column 14) + Lwt_unix.bind (line 54 column 14) + Lwt_unix.listen (line 55 column 14) + Lwt_unix.getaddrinfo (line 20 column 9) lib/test.mli: (17 occurrences) Lwt (line 12 column 26) Lwt.t (line 1 column 35) @@ -297,10 +318,11 @@ Make a writable directory tree: Lwt.Fail (line 147 column 5) Lwt.let* (line 163 column 21) Lwt.Fail (line 179 column 9) - Warning: lib/test_lwt_unix.ml: 3 occurrences have not been rewritten. + Warning: lib/test_lwt_unix.ml: 4 occurrences have not been rewritten. + Lwt_io.stdin (line 25 column 32) Lwt_io.stdout (line 26 column 33) - Lwt_io.read (line 42 column 15) - Lwt_io.read (line 43 column 15) + Lwt_io.read (line 40 column 15) + Lwt_io.read (line 41 column 15) Warning: lib/test.mli: 2 occurrences have not been rewritten. Lwt_mutex.t (line 2 column 10) Lwt_mutex.t (line 3 column 10) @@ -657,6 +679,12 @@ Make a writable directory tree: let _f () : unit = () in let _f (x : unit Promise.t) = x in () + + let _ = + let f () = () in + f () + + let _ = (fun () -> ()) () $ cat lib/test.mli open Eio.Std @@ -691,12 +719,20 @@ Make a writable directory tree: : [ `R | `Flow | `Close ] r) in let buf = Bytes.create 1024 in - let _n : int = + let (_n : int) = Eio.Flow.single_read (* TODO: lwt-to-direct-style: [buf] should be a [Cstruct.t]. *) (* TODO: lwt-to-direct-style: [Eio.Flow.single_read] operates on a [Flow.source] but [inp] is likely of type [Eio.Buf_read.t]. Rewrite this code to use [Buf_read] (which contains an internal buffer) or change the call to [Eio.Buf_read.of_flow] used to create the buffer. *) - (* TODO: lwt-to-direct-style: Dropped expression (buffer offset): [0]. *) - (* TODO: lwt-to-direct-style: Dropped expression (buffer length): [1024]. *) + (* TODO: lwt-to-direct-style: Dropped expression (buffer offset): [0]. This will behave as if it was [0]. *) + (* TODO: lwt-to-direct-style: Dropped expression (buffer length): [1024]. This will behave as if it was [Cstruct.length buffer]. *) + inp buf + in + let () = + Eio.Flow.read_exact + (* TODO: lwt-to-direct-style: [buf] should be a [Cstruct.t]. *) + (* TODO: lwt-to-direct-style: [Eio.Flow.single_read] operates on a [Flow.source] but [inp] is likely of type [Eio.Buf_read.t]. Rewrite this code to use [Buf_read] (which contains an internal buffer) or change the call to [Eio.Buf_read.of_flow] used to create the buffer. *) + (* TODO: lwt-to-direct-style: Dropped expression (buffer offset): [0]. This will behave as if it was [0]. *) + (* TODO: lwt-to-direct-style: Dropped expression (buffer length): [1024]. This will behave as if it was [Cstruct.length buffer]. *) inp buf in () @@ -738,6 +774,7 @@ Make a writable directory tree: (fun outbuf -> `Move_writing_code_here) let _f out_chan = Eio.Buf_write.string out_chan "str" + let _ : Eio.Buf_read.t = Lwt_io.stdin let _ : Eio.Buf_write.t = Lwt_io.stdout let _f chan = Eio.Buf_read.line chan @@ -791,3 +828,50 @@ Make a writable directory tree: (* TODO: lwt-to-direct-style: Eio doesn't have a direct equivalent of [Lwt_io.read ~count]. Rewrite the code using [Eio.Buf_read]'s lower level API or switch to unbuffered IO. *) (* TODO: lwt-to-direct-style: Eio doesn't have a direct equivalent of [Lwt_io.read ~count]. Rewrite the code using [Eio.Buf_read]'s lower level API or switch to unbuffered IO. *) ?count:(Some 42) chan + + let _f chan = Eio.Buf_write.flush chan + + let _f = + Fiber.fork_promise ~sw (fun () -> + Eio.Domain_manager.run env#domain_mgr (fun () -> + (* TODO: lwt-to-direct-style: [sw] (of type Switch.t) must be propagated here. *) + (* TODO: lwt-to-direct-style: [env] must be propagated from the main loop *) + (fun () -> ()) ())) + + let _f = + let f = fun x1 -> x1 in + Fiber.fork_promise ~sw (fun () -> + Eio.Domain_manager.run env#domain_mgr (fun () -> + (* TODO: lwt-to-direct-style: [env] must be propagated from the main loop *) + (* TODO: lwt-to-direct-style: [sw] (of type Switch.t) must be propagated here. *) + f 12)) + + let _f a b c = Unix.socket a b c + let _f a b c = Unix.socketpair a b c + + let _f a b = + Unix.connect + (* TODO: lwt-to-direct-style: This call to [Unix.connect] was [Lwt_unix.connect] before. It's now blocking. *) + a b + + let _f a = + Unix.accept + (* TODO: lwt-to-direct-style: This call to [Unix.accept] was [Lwt_unix.accept] before. It's now blocking. *) + a + + let _f a b = + Unix.bind + (* TODO: lwt-to-direct-style: This call to [Unix.bind] was [Lwt_unix.bind] before. It's now blocking. *) + a b + + let _f a b = Unix.listen a b + let _f a = Marshal.from_channel a + let _f a b = Marshal.to_channel a b + + let _f sockaddr = + Switch.run (fun sw -> + (fun (_in_chan, _out_chan) -> ()) + (Eio.Net.connect ~sw env#net + (* TODO: lwt-to-direct-style: [sockaddr] is of type [Unix.sockaddr] but it should be a [Eio.Net.Sockaddr.stream]. *) + (* TODO: lwt-to-direct-style: [env] must be propagated from the main loop *) + sockaddr)) diff --git a/test/lwt_to_direct_style/to_direct_style.t/src/lib/test.ml b/test/lwt_to_direct_style/to_direct_style.t/src/lib/test.ml index aec0622..6a4f920 100644 --- a/test/lwt_to_direct_style/to_direct_style.t/src/lib/test.ml +++ b/test/lwt_to_direct_style/to_direct_style.t/src/lib/test.ml @@ -183,3 +183,9 @@ let _ = let _f () : unit Lwt.t = Lwt.return_unit in let _f (x : unit Lwt.t) = x in () + +let _ = + let f () = () in + Lwt.wrap f + +let _ = Lwt.wrap (fun () -> ()) diff --git a/test/lwt_to_direct_style/to_direct_style.t/src/lib/test_lwt_unix.ml b/test/lwt_to_direct_style/to_direct_style.t/src/lib/test_lwt_unix.ml index d2759de..85d559b 100644 --- a/test/lwt_to_direct_style/to_direct_style.t/src/lib/test_lwt_unix.ml +++ b/test/lwt_to_direct_style/to_direct_style.t/src/lib/test_lwt_unix.ml @@ -7,7 +7,8 @@ let _f fname = |> Lwt_io.(of_fd ~mode:input) in let buf = Bytes.create 1024 in - let* _n : int = Lwt_io.read_into inp buf 0 1024 in + let* (_n : int) = Lwt_io.read_into inp buf 0 1024 in + let* () = Lwt_io.read_into_exactly inp buf 0 1024 in Lwt.return () let _ = Lwt_unix.Timeout @@ -17,14 +18,12 @@ let (Lwt_unix.ADDR_UNIX _ | ADDR_INET _) = Lwt_unix.ADDR_INET (Unix.inet_addr_any, 0) let _ = Lwt_unix.getaddrinfo - let _f fd = Lwt_io.of_fd ~mode:Lwt_io.output fd let _f fd = Lwt_io.of_fd ~mode:Lwt_io.Input fd let _f fd = Lwt_io.of_fd ~mode:Lwt_io.Output fd let _f out_chan = Lwt_io.write out_chan "str" - +let _ : Lwt_io.input_channel = Lwt_io.stdin let _ : Lwt_io.output_channel = Lwt_io.stdout - let _f chan = Lwt_io.read_line chan let _f fname = @@ -37,7 +36,27 @@ let _f fname = let _f fname = Lwt_unix.stat fname let _f fname = Lwt_unix.lstat fname - let _f chan = Lwt_io.read chan let _f chan = Lwt_io.read ~count:42 chan let _f chan = Lwt_io.read ?count:(Some 42) chan +let _f chan = Lwt_io.flush chan + +let _f = Lwt_preemptive.detach (fun () -> Lwt.return_unit) () +let _f = + let f = Lwt.return in + Lwt_preemptive.detach f 12 + +let _f a b c = + Lwt_unix.socket a b c +let _f a b c = Lwt_unix.socketpair a b c +let _f a b = Lwt_unix.connect a b +let _f a = Lwt_unix.accept a +let _f a b = Lwt_unix.bind a b +let _f a b = Lwt_unix.listen a b + +let _f a = Lwt_io.read_value a +let _f a b = Lwt_io.write_value a b + +let _f sockaddr = + Lwt_io.with_connection sockaddr (fun (_in_chan, _out_chan) -> Lwt.return ()) +