├── .ocamlformat ├── test ├── generated │ └── .gitkeep ├── fixtures │ ├── io_readv.txt │ ├── tls.crt │ └── tls.key ├── gen-servers │ ├── dune │ └── main.ml ├── terminate_when_main_terminates_test.ml ├── application_test.ml ├── link_processes.erl ├── port_finder.ml ├── readme_example.ml ├── receive_timeout_test.ml ├── telemetry_test.ml ├── net_addr_uri_test.ml ├── send_interval_test.ml ├── spawn_and_exit_test.ml ├── io_readv_test.ml ├── add_monitor_test.ml ├── task_test.ml ├── cancel_timer_test.ml ├── io_writer_test.ml ├── io_writev_test.ml ├── link_processes_test.ml ├── send_order_test.ml ├── selective_receive_test.ml ├── send_after_test.ml ├── process_stealing_test.ml ├── process_priority_test.ml ├── io_reader_test.ml ├── supervisor_shutdown_test.ml ├── io_reader_large_test.ml ├── net_timeout_test.ml ├── net_reader_writer_timeout_test.ml ├── process_registration_test.ml ├── net_test.ml ├── net_reader_writer_test.ml ├── dune └── ssl_test.ml ├── examples ├── 9-logger │ ├── main.ml │ ├── README.md │ └── dune ├── 6-supervisors │ ├── main.ml │ ├── dune │ └── README.md ├── 8-applications │ ├── main.ml │ ├── README.md │ └── dune ├── 7-supervision-trees │ ├── main.ml │ ├── dune │ └── README.md ├── .gitignore ├── 1-hello-world │ ├── dune │ ├── main.ml │ └── README.md ├── 2-spawn-process │ ├── dune │ ├── main.ml │ └── README.md ├── 3-message-passing │ ├── dune │ ├── main.ml │ └── README.md ├── 4-long-lived-processes │ ├── dune │ ├── main.ml │ └── README.md ├── 5-links-and-monitors │ ├── dune │ ├── main.ml │ └── README.md └── README.md ├── packages ├── riot-stdlib │ ├── fd.ml │ ├── pid.ml │ ├── ref.ml │ ├── queue.ml │ ├── hashmap.ml │ ├── message.ml │ ├── timeout.ml │ ├── dune │ ├── application.ml │ ├── global │ │ └── global.ml │ ├── lib_io.ml │ ├── stream.ml │ ├── riot_stdlib.ml │ ├── telemetry_app.ml │ ├── process.ml │ ├── key_value_store.ml │ ├── task.ml │ ├── dynamic_supervisor.ml │ ├── file.ml │ ├── runtime_lib.ml │ ├── logger_app.ml │ ├── crypto.ml │ ├── gen_server.ml │ ├── logger │ │ └── logger.ml │ ├── supervisor.ml │ ├── net.ml │ └── SSL.ml ├── riot-runtime │ ├── time │ │ ├── time.ml │ │ ├── timer_wheel.mli │ │ └── timer_wheel.ml │ ├── util │ │ ├── timeout.ml │ │ ├── thread_local.mli │ │ ├── weak_ref.mli │ │ ├── uid.mli │ │ ├── weak_ref.ml │ │ ├── util.ml │ │ ├── lf_queue.mli │ │ ├── uid.ml │ │ ├── thread_local.ml │ │ ├── trace.ml │ │ ├── dashmap.ml │ │ └── lf_queue.ml │ ├── core │ │ ├── message.ml │ │ ├── scheduler_uid.mli │ │ ├── proc_set.mli │ │ ├── proc_queue.mli │ │ ├── mailbox.mli │ │ ├── proc_table.mli │ │ ├── proc_registry.mli │ │ ├── pid.mli │ │ ├── ref.mli │ │ ├── core.ml │ │ ├── scheduler_uid.ml │ │ ├── proc_effect.ml │ │ ├── mailbox.ml │ │ ├── proc_table.ml │ │ ├── pid.ml │ │ ├── proc_state.mli │ │ ├── proc_set.ml │ │ ├── ref.ml │ │ ├── proc_registry.ml │ │ ├── proc_queue.ml │ │ └── proc_state.ml │ ├── riot_runtime.ml │ ├── scheduler │ │ ├── tracer.mli │ │ └── tracer.ml │ ├── rc.mli │ ├── dune │ ├── log │ │ ├── log.mli │ │ └── log.ml │ ├── Config.ml │ ├── rc.ml │ └── import.ml └── riot │ ├── dune │ └── riot.ml ├── .gitattributes ├── riot.opam.template ├── bench ├── dune ├── spawn_many.erl ├── spawn_many.ml └── http_server.ml ├── .gitignore ├── CODE_OF_CONDUCT.md ├── dune-project ├── riot.opam ├── .github └── workflows │ └── main.yml ├── README.md ├── LICENSE.md ├── flake.nix ├── CONTRIBUTING.md └── CHANGES.md /.ocamlformat: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /test/generated/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /examples/9-logger/main.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /examples/6-supervisors/main.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /examples/8-applications/main.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /examples/7-supervision-trees/main.ml: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | esy.lock 2 | _esy 3 | -------------------------------------------------------------------------------- /test/fixtures/io_readv.txt: -------------------------------------------------------------------------------- 1 | hello world 2 | -------------------------------------------------------------------------------- /examples/9-logger/README.md: -------------------------------------------------------------------------------- 1 | # `9-logger` 2 | -------------------------------------------------------------------------------- /packages/riot-stdlib/fd.ml: -------------------------------------------------------------------------------- 1 | include Gluon.Fd 2 | -------------------------------------------------------------------------------- /examples/8-applications/README.md: -------------------------------------------------------------------------------- 1 | # `8-applications` 2 | -------------------------------------------------------------------------------- /packages/riot-stdlib/pid.ml: -------------------------------------------------------------------------------- 1 | include Riot_runtime.Core.Pid 2 | -------------------------------------------------------------------------------- /packages/riot-stdlib/ref.ml: -------------------------------------------------------------------------------- 1 | include Riot_runtime.Core.Ref 2 | -------------------------------------------------------------------------------- /packages/riot-stdlib/queue.ml: -------------------------------------------------------------------------------- 1 | include Riot_runtime.Util.Lf_queue 2 | -------------------------------------------------------------------------------- /packages/riot-runtime/time/time.ml: -------------------------------------------------------------------------------- 1 | module Timer_wheel = Timer_wheel 2 | -------------------------------------------------------------------------------- /packages/riot-stdlib/hashmap.ml: -------------------------------------------------------------------------------- 1 | include Riot_runtime.Util.Dashmap 2 | -------------------------------------------------------------------------------- /packages/riot-stdlib/message.ml: -------------------------------------------------------------------------------- 1 | include Riot_runtime.Core.Message 2 | -------------------------------------------------------------------------------- /examples/9-logger/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /packages/riot-stdlib/timeout.ml: -------------------------------------------------------------------------------- 1 | type t = [ `infinity | `after of int64 ] 2 | -------------------------------------------------------------------------------- /test/gen-servers/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /examples/1-hello-world/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /examples/6-supervisors/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/timeout.ml: -------------------------------------------------------------------------------- 1 | type t = [ `infinity | `after of int64 ] 2 | -------------------------------------------------------------------------------- /examples/1-hello-world/main.ml: -------------------------------------------------------------------------------- 1 | Riot.run @@ fun () -> print_endline "Hello, Joe!" 2 | -------------------------------------------------------------------------------- /examples/2-spawn-process/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /examples/3-message-passing/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /examples/8-applications/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /examples/4-long-lived-processes/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /examples/5-links-and-monitors/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /examples/7-supervision-trees/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries riot)) 4 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | tools/trace_processor linguist-vendored 2 | test/fixtures/ liguist-vendored 3 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/thread_local.mli: -------------------------------------------------------------------------------- 1 | val make : name:string -> (unit -> 'a) * ('a -> unit) 2 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/weak_ref.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val make : 'a -> 'a t 4 | val get : 'a t -> 'a option 5 | -------------------------------------------------------------------------------- /riot.opam.template: -------------------------------------------------------------------------------- 1 | available: arch != "x86_32" & arch != "arm32" & arch != "ppc64" & arch != "s390x" & os != "freebsd" 2 | -------------------------------------------------------------------------------- /bench/dune: -------------------------------------------------------------------------------- 1 | (executables 2 | (names spawn_many http_server) 3 | (preprocess 4 | (pps config.ppx bytestring.ppx)) 5 | (libraries riot)) 6 | -------------------------------------------------------------------------------- /packages/riot-stdlib/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (library 4 | (package riot) 5 | (name riot_stdlib) 6 | (libraries riot_runtime)) 7 | -------------------------------------------------------------------------------- /packages/riot/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (library 4 | (name riot) 5 | (public_name riot) 6 | (libraries riot_runtime riot_stdlib)) 7 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/uid.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val next : unit -> int64 4 | val equal : int64 -> int64 -> bool 5 | val pp : Format.formatter -> int64 -> unit 6 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/weak_ref.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 'a Weak.t 2 | 3 | let make x = 4 | let t = Weak.create 1 in 5 | Weak.set t 0 (Some x); 6 | t 7 | 8 | let get t = Weak.get t 0 9 | -------------------------------------------------------------------------------- /examples/2-spawn-process/main.ml: -------------------------------------------------------------------------------- 1 | Riot.run @@ fun () -> 2 | let open Riot in 3 | let pid = spawn (fun () -> Format.printf "Hello, %a!" Pid.pp (self ())) in 4 | wait_pids [ pid ]; 5 | shutdown () 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.install 2 | *.bin 3 | _build 4 | *.beam 5 | *.trace 6 | test/generated/* 7 | _opam 8 | 9 | # nix ignores 10 | .direnv 11 | result 12 | .envrc 13 | dune.lock 14 | dev-tools.locks 15 | -------------------------------------------------------------------------------- /packages/riot-stdlib/application.ml: -------------------------------------------------------------------------------- 1 | module type Intf = sig 2 | val start : 3 | unit -> 4 | ( Pid.t, 5 | ([> `Application_error of string | `Supervisor_error ] as 'err) ) 6 | result 7 | end 8 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/message.ml: -------------------------------------------------------------------------------- 1 | type t = .. 2 | type 'msg selector = t -> [ `select of 'msg | `skip ] 3 | type envelope = { msg : t; uid : unit Ref.t } 4 | 5 | let envelope msg = { uid = Ref.make (); msg } 6 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/scheduler_uid.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val to_int : t -> int 4 | val equal : t -> t -> bool 5 | val next : unit -> t 6 | val pp : Format.formatter -> t -> unit 7 | val reset : unit -> unit 8 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_set.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val create : unit -> t 4 | val remove : t -> Process.t -> unit 5 | val contains : t -> Process.t -> bool 6 | val size : t -> int 7 | val add : t -> Process.t -> unit 8 | -------------------------------------------------------------------------------- /examples/6-supervisors/README.md: -------------------------------------------------------------------------------- 1 | # `6-supervisors` 2 | 3 | 4 | ## Next Steps 5 | 6 | * the [next step](../7-supervision-trees/) will show you how to use supervisors 7 | to build hierarchies of processes that collaborate to get work done. 8 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_queue.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val create : unit -> t 4 | val size : t -> int 5 | val is_empty : t -> bool 6 | val queue : t -> Process.t -> unit 7 | val next : t -> Process.t option 8 | val remove : t -> Process.t -> unit 9 | -------------------------------------------------------------------------------- /test/terminate_when_main_terminates_test.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* start the runtime with a function that will immediately return *) 3 | Riot.run @@ fun () -> 4 | (); 5 | (* print that everything is OK *) 6 | print_string "termination_test: OK" 7 | -------------------------------------------------------------------------------- /packages/riot-stdlib/global/global.ml: -------------------------------------------------------------------------------- 1 | include Riot_runtime.Import 2 | 3 | (* TODO(@leostera): move these into the Runtime module below *) 4 | include Riot_runtime.Core.Process.Exn 5 | include Riot_runtime.Core.Proc_registry.Exn 6 | 7 | let ( let* ) = Result.bind 8 | -------------------------------------------------------------------------------- /packages/riot-runtime/riot_runtime.ml: -------------------------------------------------------------------------------- 1 | module Config = Config 2 | module Core = Core 3 | module Import = Import 4 | module Log = Log 5 | module Scheduler = Scheduler 6 | module Time = Time 7 | module Util = Util 8 | 9 | let set_log_level = Log.set_log_level 10 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/mailbox.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val create : unit -> t 4 | val queue : t -> Message.envelope -> unit 5 | val queue_front : t -> Message.envelope -> unit 6 | val next : t -> Message.envelope option 7 | val size : t -> int 8 | val is_empty : t -> bool 9 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/util.ml: -------------------------------------------------------------------------------- 1 | module Dashmap = Dashmap 2 | module Lf_queue = Lf_queue 3 | module Min_heap = Min_heap 4 | module Thread_local = Thread_local 5 | module Timeout = Timeout 6 | module Trace = Trace 7 | module Uid = Uid 8 | module Util = Util 9 | module Weak_ref = Weak_ref 10 | -------------------------------------------------------------------------------- /examples/7-supervision-trees/README.md: -------------------------------------------------------------------------------- 1 | # `7-supervision-trees` 2 | 3 | 4 | ## Next Steps 5 | 6 | * the [next step](../8-applications/) will show you how to encapsulate your 7 | supervision trees into _applications_, which can be used to orchestrate 8 | startup and shutdown of your entire system. 9 | -------------------------------------------------------------------------------- /packages/riot-runtime/scheduler/tracer.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | val tracer_send : (Pid.t -> Process.t -> Message.t -> unit) ref 4 | val trace_send : (Pid.t -> Process.t -> Message.t -> unit) -> unit 5 | val tracer_proc_run : (int -> Process.t -> unit) ref 6 | val trace_proc_run : (int -> Process.t -> unit) -> unit 7 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/lf_queue.mli: -------------------------------------------------------------------------------- 1 | exception Closed 2 | 3 | type 'a t 4 | 5 | val push : 'a t -> 'a -> unit 6 | val push_head : 'a t -> 'a -> unit 7 | val close : 'a t -> unit 8 | val peek : 'a t -> 'a 9 | val pop : 'a t -> 'a option 10 | val is_empty : 'a t -> bool 11 | val create : unit -> 'a t 12 | -------------------------------------------------------------------------------- /packages/riot-runtime/rc.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val drop : 'a t -> unit 4 | val set : 'a t -> prev:'a -> next:'a -> bool 5 | val make : 'a -> release:('a t -> 'a) -> 'a t 6 | val get : 'a t -> 'a 7 | val peek : 'a t -> 'a 8 | val refc : 'a t -> int 9 | val take : 'a t -> unit 10 | val use : 'a t -> ('a -> 'b) -> 'b 11 | -------------------------------------------------------------------------------- /examples/3-message-passing/main.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | type Message.t += Hello_world 4 | 5 | let () = 6 | Riot.run @@ fun () -> 7 | let pid = 8 | spawn (fun () -> 9 | match[@warning "-8"] receive_any () with 10 | | Hello_world -> print_endline "Hello, World! :D") 11 | in 12 | send pid Hello_world 13 | -------------------------------------------------------------------------------- /packages/riot-stdlib/lib_io.ml: -------------------------------------------------------------------------------- 1 | include Rio 2 | 3 | module Logger = Logger.Make (struct 4 | let namespace = [ "riot"; "io" ] 5 | end) 6 | 7 | (* let await_readable fd fn = syscall "custom" `r fd fn *) 8 | (* let await_writeable fd fn = syscall "custom" `w fd fn *) 9 | (* let await fd mode fn = syscall "custom" mode fd fn *) 10 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_table.mli: -------------------------------------------------------------------------------- 1 | exception Reregistering_process of Process.t 2 | 3 | type t 4 | 5 | val create : unit -> t 6 | val get : t -> Pid.t -> Process.t option 7 | val register_process : t -> Process.t -> unit 8 | val processes : t -> (Pid.t * Process.t) Seq.t 9 | val remove : t -> Pid.t -> unit 10 | val size : t -> int 11 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_registry.mli: -------------------------------------------------------------------------------- 1 | module Exn : sig 2 | exception Name_already_registered of string * Pid.t 3 | end 4 | 5 | type t 6 | 7 | val create : unit -> t 8 | val register : t -> string -> Pid.t -> unit 9 | val unregister : t -> string -> unit 10 | val find_pid : t -> string -> Pid.t option 11 | val remove : t -> Pid.t -> unit 12 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/pid.mli: -------------------------------------------------------------------------------- 1 | type t 2 | 3 | val main : t 4 | val zero : t 5 | val equal : t -> t -> bool 6 | val next : unit -> t 7 | val pp : Format.formatter -> t -> unit 8 | val to_string : t -> string 9 | val reset : unit -> unit 10 | val compare : t -> t -> int 11 | val hash : t -> int 12 | 13 | module Map : Util.Dashmap.Intf with type key = t 14 | -------------------------------------------------------------------------------- /packages/riot-runtime/scheduler/tracer.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let tracer_send : (Pid.t -> Process.t -> Message.t -> unit) ref = 4 | ref (fun _sender _proc _msg -> ()) 5 | 6 | let trace_send fn = tracer_send := fn 7 | 8 | let tracer_proc_run : (int -> Process.t -> unit) ref = 9 | ref (fun _sch _proc -> ()) 10 | 11 | let trace_proc_run fn = tracer_proc_run := fn 12 | -------------------------------------------------------------------------------- /packages/riot-runtime/dune: -------------------------------------------------------------------------------- 1 | (include_subdirs qualified) 2 | 3 | (library 4 | (package riot) 5 | (name riot_runtime) 6 | (libraries 7 | bytestring 8 | gluon 9 | mirage-crypto 10 | mirage-crypto-rng 11 | mirage-crypto-rng.unix 12 | mtime 13 | mtime.clock.os 14 | ptime 15 | ptime.clock.os 16 | rio 17 | runtime_events 18 | telemetry 19 | tls 20 | unix)) 21 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/uid.ml: -------------------------------------------------------------------------------- 1 | type t = int64 2 | 3 | let __current__ = Atomic.make 0L 4 | 5 | let rec next () = 6 | let last = Atomic.get __current__ in 7 | let current = Int64.succ last in 8 | if Atomic.compare_and_set __current__ last current then last else next () 9 | 10 | let equal a b = Int64.equal a b 11 | let pp ppf t = Format.fprintf ppf "%s" (Int64.to_string t) 12 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/ref.mli: -------------------------------------------------------------------------------- 1 | type 'a t 2 | 3 | val make : unit -> 'a t 4 | val equal : 'a t -> 'b t -> bool 5 | val hash : 'a t -> int 6 | val type_equal : 'a 'b. 'a t -> 'b t -> ('a, 'b) Type.eq option 7 | val cast : 'a 'b. 'a t -> 'b t -> 'a -> 'b option 8 | val pp : Format.formatter -> 'a t -> unit 9 | val is_newer : 'a t -> 'b t -> bool 10 | 11 | module Map : Util.Dashmap.Intf with type key = unit t 12 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/thread_local.ml: -------------------------------------------------------------------------------- 1 | exception Uninitialized_thread_local of string 2 | 3 | let make ~name = 4 | let value = Atomic.make None in 5 | let key = Domain.DLS.new_key (fun () -> Atomic.get value) in 6 | let get () = 7 | match Domain.DLS.get key with 8 | | Some x -> x 9 | | None -> raise (Uninitialized_thread_local name) 10 | in 11 | let set x = Domain.DLS.set key (Some x) in 12 | (get, set) 13 | -------------------------------------------------------------------------------- /test/application_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | module Test = struct 4 | let start () = 5 | Logger.set_log_level (Some Info); 6 | let pid = 7 | spawn (fun () -> 8 | Logger.info (fun f -> f "application_test: OK"); 9 | 10 | shutdown ()) 11 | in 12 | Ok pid 13 | end 14 | 15 | let () = 16 | Riot.start 17 | ~apps:[ (module Riot.Telemetry); (module Riot.Logger); (module Test) ] 18 | () 19 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/core.ml: -------------------------------------------------------------------------------- 1 | module Core = Core 2 | module Mailbox = Mailbox 3 | module Message = Message 4 | module Pid = Pid 5 | module Proc_effect = Proc_effect 6 | module Proc_queue = Proc_queue 7 | module Proc_registry = Proc_registry 8 | module Proc_set = Proc_set 9 | module Proc_state = Proc_state 10 | module Proc_table = Proc_table 11 | module Process = Process 12 | module Ref = Ref 13 | module Scheduler_uid = Scheduler_uid 14 | -------------------------------------------------------------------------------- /packages/riot-stdlib/stream.ml: -------------------------------------------------------------------------------- 1 | include Stdlib.Seq 2 | 3 | type 'v t = 'v Seq.t 4 | 5 | let next = uncons 6 | let unfold fn data = Seq.unfold (fun data -> fn data) data 7 | 8 | type 'acc control_flow = [ `continue of 'acc | `halt of 'acc ] 9 | 10 | let rec reduce_while init fn t = 11 | match t () with 12 | | Seq.Nil -> init 13 | | Seq.Cons (v, t') -> ( 14 | match fn v init with 15 | | `continue acc -> reduce_while acc fn t' 16 | | `halt acc -> acc) 17 | -------------------------------------------------------------------------------- /examples/4-long-lived-processes/main.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | type Message.t += Hello of string 4 | 5 | let () = 6 | Riot.run @@ fun () -> 7 | let rec loop () = 8 | (match receive_any () with 9 | | Hello name -> print_endline ("Hello, " ^ name ^ "! :D") 10 | | _ -> print_endline "Oh no, an unhandled message! D:"); 11 | loop () 12 | in 13 | let pid = spawn loop in 14 | send pid (Hello "Joe"); 15 | send pid (Hello "Mike"); 16 | send pid (Hello "Robert") 17 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | # Code of Conduct 2 | 3 | This project has adopted the [OCaml Code of 4 | Conduct](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md). 5 | 6 | # Enforcement 7 | 8 | This project follows the OCaml Code of Conduct 9 | [enforcement policy](https://github.com/ocaml/code-of-conduct/blob/main/CODE_OF_CONDUCT.md#enforcement). 10 | 11 | To report any violations, please contact: 12 | 13 | * Leandro Ostera 14 | -------------------------------------------------------------------------------- /packages/riot-runtime/log/log.mli: -------------------------------------------------------------------------------- 1 | type level = Debug | Error | Info | Trace | Warn 2 | 3 | val set_log_level : level option -> unit 4 | 5 | type ('a, 'b) message_format = 6 | (('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b 7 | 8 | val trace : ('a, unit) message_format -> unit 9 | val debug : ('a, unit) message_format -> unit 10 | val info : ('a, unit) message_format -> unit 11 | val warn : ('a, unit) message_format -> unit 12 | val error : ('a, unit) message_format -> unit 13 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/scheduler_uid.ml: -------------------------------------------------------------------------------- 1 | type t = int 2 | 3 | let __current__ = Atomic.make 0 4 | 5 | let rec next () = 6 | let last = Atomic.get __current__ in 7 | let current = Int.succ last in 8 | if Atomic.compare_and_set __current__ last current then last else next () 9 | 10 | let equal a b = Int.equal a b 11 | let pp ppf t = Format.fprintf ppf "%02d" t 12 | let to_int t = t 13 | 14 | let reset () = 15 | Log.debug (fun f -> f "Resetting Scheduler Uids"); 16 | Atomic.set __current__ 0 17 | -------------------------------------------------------------------------------- /test/link_processes.erl: -------------------------------------------------------------------------------- 1 | -module(link_processes). 2 | -export([main/1]). 3 | 4 | loop() -> receive _ -> ok end. 5 | 6 | wait_pids([]) -> ok; 7 | wait_pids([P|T]=Pids) -> 8 | case is_process_alive(P) of 9 | true -> wait_pids(Pids); 10 | false -> wait_pids(T) 11 | end. 12 | 13 | main(_Args) -> 14 | Pid1 = spawn (fun () -> loop() end), 15 | Pid2 = spawn (fun () -> link(Pid1), loop() end), 16 | Pid1 ! exit, 17 | wait_pids([ Pid1, Pid2 ]), 18 | io:format("linked processes terminated\n"). 19 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_effect.ml: -------------------------------------------------------------------------------- 1 | open Gluon 2 | open Util 3 | 4 | type _ Effect.t += 5 | | Receive : { 6 | ref : 'a Ref.t option; 7 | timeout : Timeout.t; 8 | selector : Message.t -> [ `select of 'msg | `skip ]; 9 | } 10 | -> 'msg Effect.t 11 | 12 | type _ Effect.t += Yield : unit Effect.t 13 | 14 | type _ Effect.t += 15 | | Syscall : { 16 | name : string; 17 | interest : Interest.t; 18 | source : Source.t; 19 | timeout : Timeout.t; 20 | } 21 | -> unit Effect.t 22 | -------------------------------------------------------------------------------- /test/port_finder.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | exception No_ports_available 4 | 5 | let rec next_open_port ?(port = 10001) () = 6 | if port > 65_000 then raise_notrace No_ports_available 7 | else 8 | let opts = 9 | Net.Tcp_listener. 10 | { 11 | reuse_addr = true; 12 | reuse_port = false; 13 | backlog = 100; 14 | addr = Net.Addr.loopback; 15 | } 16 | in 17 | match Net.Tcp_listener.bind ~opts ~port () with 18 | | Ok socket -> (socket, port) 19 | | Error _ -> next_open_port ~port:(port + 1) () 20 | -------------------------------------------------------------------------------- /test/readme_example.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | (* $MDX part-begin=main *) 4 | open Riot 5 | 6 | type Message.t += Hello_world 7 | 8 | let () = 9 | Riot.run @@ fun () -> 10 | let pid = 11 | spawn (fun () -> 12 | let selector msg = 13 | match msg with Hello_world -> `select `hello_world | _ -> `skip 14 | in 15 | match receive ~selector () with 16 | | `hello_world -> 17 | Logger.info (fun f -> f "hello world from %a!" Pid.pp (self ())); 18 | shutdown ()) 19 | in 20 | send pid Hello_world 21 | (* $MDX part-end *) 22 | -------------------------------------------------------------------------------- /test/receive_timeout_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | type Message.t += Unexpected 4 | 5 | let () = 6 | Riot.run @@ fun () -> 7 | let _ = Logger.start () |> Result.get_ok in 8 | Logger.set_log_level (Some Info); 9 | let _ = Timer.send_after (self ()) Unexpected ~after:100L |> Result.get_ok in 10 | 11 | match receive_any ~after:1L () with 12 | | exception Receive_timeout -> 13 | Logger.info (fun f -> f "receive_timeout_test: OK"); 14 | 15 | shutdown () 16 | | _ -> 17 | Logger.error (fun f -> f "receive_timeout_test: unexpected message"); 18 | 19 | Stdlib.exit 1 20 | -------------------------------------------------------------------------------- /test/telemetry_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | module Test = struct 4 | type Telemetry.event += Boot 5 | 6 | let start () = 7 | Telemetry.attach (fun ev -> 8 | match ev with 9 | | Boot -> 10 | Logger.info (fun f -> f "telemetry_test: telemetry received"); 11 | 12 | shutdown () 13 | | _ -> ()); 14 | 15 | let pid = 16 | spawn (fun () -> 17 | Telemetry.emit Boot; 18 | sleep 100.0) 19 | in 20 | Ok pid 21 | end 22 | 23 | let () = 24 | Riot.start 25 | ~apps:[ (module Riot.Telemetry); (module Riot.Logger); (module Test) ] 26 | () 27 | -------------------------------------------------------------------------------- /test/net_addr_uri_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let main () = 4 | let _ = Logger.start () |> Result.get_ok in 5 | Logger.set_log_level (Some Info); 6 | let addr = 7 | Net.Addr.of_uri (Uri.of_string "http://ocaml.org") |> Result.get_ok 8 | in 9 | Logger.debug (fun f -> f "got addr: %a" Net.Addr.pp addr); 10 | match Net.Tcp_stream.connect addr with 11 | | Ok _ | Error `Closed -> 12 | Logger.info (fun f -> f "net_addr_uri_test: OK"); 13 | 14 | shutdown () 15 | | Error err -> 16 | Logger.error (fun f -> f "net_addr_uri_test: %a" IO.pp_err err); 17 | Stdlib.exit 1 18 | 19 | let () = Riot.run @@ main 20 | -------------------------------------------------------------------------------- /packages/riot-runtime/time/timer_wheel.mli: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | module Timer : sig 4 | type t 5 | 6 | val pp : Format.formatter -> t -> unit 7 | val make : int64 -> [ `interval | `one_off ] -> (unit -> unit) -> t 8 | val equal : t -> t -> bool 9 | end 10 | 11 | type t 12 | 13 | val create : unit -> t 14 | val is_finished : t -> unit Ref.t -> bool 15 | val remove_timer : t -> unit Ref.t -> unit 16 | 17 | val make_timer : 18 | t -> int64 -> [ `interval | `one_off ] -> (unit -> unit) -> unit Ref.t 19 | 20 | val clear_timer : t -> unit Ref.t -> unit 21 | val tick : t -> unit 22 | val can_tick : t -> bool 23 | val size : t -> int 24 | -------------------------------------------------------------------------------- /test/send_interval_test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open Riot 4 | 5 | type Message.t += A 6 | 7 | let main () = 8 | let (Ok _) = Logger.start () in 9 | (* Runtime.set_log_level (Some Trace); *) 10 | Logger.set_log_level (Some Info); 11 | let this = self () in 12 | 13 | let (Ok _timer) = Timer.send_interval this A ~every:50L in 14 | 15 | let A = receive_any ~after:2000L () in 16 | let A = receive_any ~after:2000L () in 17 | 18 | Logger.debug (fun f -> f "send_interval_test: messages sent with interval"); 19 | Logger.info (fun f -> f "send_interval_test: OK"); 20 | 21 | shutdown () 22 | 23 | let () = Riot.run @@ main 24 | -------------------------------------------------------------------------------- /test/spawn_and_exit_test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open Riot 4 | 5 | let rec loop () = 6 | yield (); 7 | loop () 8 | 9 | let main () = 10 | let (Ok _) = Logger.start () in 11 | 12 | (* spin up and wait for 1 second before terminating *) 13 | let pid1 = spawn (fun () -> loop ()) in 14 | 15 | (* once we send this exit signal to pid1, and it dies, it should take pid2 down with it *) 16 | exit pid1 Normal; 17 | 18 | (* so we'll wait for both pids to be dead *) 19 | wait_pids [ pid1 ]; 20 | 21 | Logger.info (fun f -> f "spawn_and_exit: OK"); 22 | 23 | shutdown () 24 | 25 | let () = 26 | Logger.set_log_level (Some Info); 27 | Riot.run @@ main 28 | -------------------------------------------------------------------------------- /test/io_readv_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | open IO 3 | 4 | exception Fail 5 | 6 | let () = 7 | Riot.run @@ fun () -> 8 | let _ = Logger.start () |> Result.get_ok in 9 | Logger.set_log_level (Some Info); 10 | let fd = File.open_read "fixtures/io_readv.txt" in 11 | let reader = File.to_reader fd in 12 | let buf = Bytes.with_capacity 8 in 13 | let len = IO.read reader buf |> Result.get_ok in 14 | let str = Bytes.(sub ~pos:0 ~len buf |> to_string) in 15 | match str with 16 | | "hello wo" -> Logger.info (fun f -> f "io_readv_test: OK") 17 | | _ -> 18 | Logger.error (fun f -> f "io_readv_test: unexpected input %S" str); 19 | 20 | sleep 0.1; 21 | raise Fail 22 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/mailbox.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | type t = { size : int Atomic.t; queue : Message.envelope Lf_queue.t } 4 | 5 | let create () = { size = Atomic.make 0; queue = Lf_queue.create () } 6 | 7 | let queue t msg = 8 | Atomic.incr t.size; 9 | Lf_queue.push t.queue msg 10 | 11 | let queue_front t msg = 12 | Atomic.incr t.size; 13 | Lf_queue.push_head t.queue msg 14 | 15 | let next (t : t) = 16 | match Lf_queue.pop t.queue with 17 | | Some msg -> 18 | Atomic.decr t.size; 19 | Some msg 20 | | None -> 21 | Atomic.set t.size 0; 22 | None 23 | 24 | let size (t : t) = Atomic.get t.size 25 | let is_empty (t : t) = Lf_queue.is_empty t.queue 26 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_table.ml: -------------------------------------------------------------------------------- 1 | type t = { processes : (Pid.t, Process.t) Hashtbl.t; lock : Mutex.t } 2 | 3 | let create () = { lock = Mutex.create (); processes = Hashtbl.create 16_000 } 4 | let get t pid = Hashtbl.find_opt t.processes pid 5 | let remove t pid = Hashtbl.remove t.processes pid 6 | let size t = Hashtbl.length t.processes 7 | 8 | exception Reregistering_process of Process.t 9 | 10 | let register_process t (proc : Process.t) = 11 | Mutex.protect t.lock @@ fun () -> 12 | let pid = Process.pid proc in 13 | if Hashtbl.mem t.processes pid then raise (Reregistering_process proc) 14 | else Hashtbl.replace t.processes pid proc 15 | 16 | let processes t = Hashtbl.to_seq t.processes 17 | -------------------------------------------------------------------------------- /packages/riot-stdlib/riot_stdlib.ml: -------------------------------------------------------------------------------- 1 | module Application = Application 2 | module Bytestring = Bytestring 3 | module Dynamic_supervisor = Dynamic_supervisor 4 | module Crypto = Crypto 5 | module Fd = Fd 6 | module File = File 7 | module Gen_server = Gen_server 8 | module Hashmap = Hashmap 9 | module IO = Lib_io 10 | module Logger = Logger_app 11 | module Message = Message 12 | module Net = Net 13 | module Pid = Pid 14 | module Process = Process 15 | module Queue = Queue 16 | module Ref = Ref 17 | module Runtime = Runtime_lib 18 | module SSL = SSL 19 | module Store = Key_value_store 20 | module Stream = Stream 21 | module Supervisor = Supervisor 22 | module Task = Task 23 | module Telemetry = Telemetry_app 24 | module Timeout = Timeout 25 | include Global 26 | -------------------------------------------------------------------------------- /test/add_monitor_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | exception Fail 4 | 5 | let main () = 6 | let _ = Logger.start () |> Result.get_ok in 7 | Logger.set_log_level (Some Info); 8 | let pid = spawn (fun () -> ()) in 9 | Process.monitor pid; 10 | 11 | match receive_any ~after:500_000L () with 12 | | Process.Messages.Monitor (Process_down pid2) when Pid.equal pid pid2 -> 13 | Logger.debug (fun f -> f "add_monitor: was notified of process death"); 14 | Logger.info (fun f -> f "add_monitor: OK"); 15 | sleep 0.2 16 | | (exception _) | _ -> 17 | Logger.error (fun f -> f "add_monitor: was NOT notified of process death"); 18 | sleep 0.2; 19 | raise Fail 20 | 21 | let () = Riot.run ~config:(Config.make ~workers:1 ()) @@ main 22 | -------------------------------------------------------------------------------- /bench/spawn_many.erl: -------------------------------------------------------------------------------- 1 | -module(reference). 2 | -export([main/1]). 3 | 4 | loop(N) -> 5 | receive 6 | loop_stop -> ok; 7 | _ -> loop(N+1) 8 | end. 9 | 10 | spawn_processes(ProcCount) -> 11 | [ spawn(fun () -> loop(0) end) || _ <- lists:seq(0, ProcCount) ]. 12 | 13 | do_start(ProcCount) -> 14 | Pids = spawn_processes(ProcCount), 15 | [ Pid ! loop_stop || Pid <- Pids ], 16 | wait_pids(Pids). 17 | 18 | wait_pids([]) -> ok; 19 | wait_pids([P|T]=Pids) -> 20 | case is_process_alive(P) of 21 | true -> wait_pids(Pids); 22 | false -> wait_pids(T) 23 | end. 24 | 25 | main(_Args) -> 26 | ProcCount = 10_000, 27 | {Time, _} = timer:tc(fun () -> do_start(ProcCount) end), 28 | io:format("spawned/awaited ~p processes in ~p ms\n", [ProcCount, Time/1_000]). 29 | -------------------------------------------------------------------------------- /packages/riot-stdlib/telemetry_app.ml: -------------------------------------------------------------------------------- 1 | open Global 2 | 3 | type event = Telemetry.event = .. 4 | 5 | let name = "Riot.Telemetry" 6 | 7 | module Dispatcher = struct 8 | type Riot_runtime.Core.Message.t += Event of Telemetry.event 9 | 10 | let __main_dispatcher__ : Pid.t ref = ref Pid.zero 11 | 12 | let rec loop () = 13 | match receive_any () with 14 | | Event e -> 15 | Telemetry.emit e; 16 | loop () 17 | | _ -> loop () 18 | 19 | let start_link () = 20 | let pid = spawn_link (fun () -> loop ()) in 21 | __main_dispatcher__ := pid; 22 | Ok pid 23 | 24 | let emit ev = send !__main_dispatcher__ (Event ev) 25 | end 26 | 27 | let start () = Dispatcher.start_link () 28 | let emit = Dispatcher.emit 29 | let attach = Telemetry.attach 30 | -------------------------------------------------------------------------------- /test/task_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | exception Fail 4 | 5 | let rec count_to x n = 6 | if x = n then n 7 | else ( 8 | yield (); 9 | count_to (x + 1) n) 10 | 11 | let () = 12 | Riot.run @@ fun () -> 13 | let _ = Logger.start () |> Result.get_ok in 14 | Logger.set_log_level (Some Info); 15 | 16 | let task = Task.async (fun () -> count_to 0 1_000) in 17 | 18 | match Task.await ~timeout:100_000L task with 19 | | Ok n -> 20 | Logger.debug (fun f -> f "task_test: finished with %d" n); 21 | Logger.info (fun f -> f "task_test: OK"); 22 | shutdown () 23 | | Error `Timeout -> 24 | Logger.error (fun f -> f "task_test: timeout"); 25 | raise Fail 26 | | _ -> 27 | Logger.error (fun f -> f "net_test: unexpected message"); 28 | raise Fail 29 | -------------------------------------------------------------------------------- /test/cancel_timer_test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open Riot 4 | 5 | exception Fail 6 | 7 | type Message.t += A | B 8 | 9 | let main () = 10 | let (Ok _) = Logger.start () in 11 | Runtime.set_log_level (Some Info); 12 | let this = self () in 13 | 14 | let (Ok _) = Timer.send_after this A ~after:100L in 15 | let (Ok t) = Timer.send_after this B ~after:10L in 16 | Timer.cancel t; 17 | match receive_any ~after:10_000L () with 18 | | A -> 19 | Logger.debug (fun f -> 20 | f "cancel_timer_test: timer successfully cancelled"); 21 | Logger.info (fun f -> f "cancel_timer_test: OK") 22 | | B -> 23 | Logger.error (fun f -> f "timer not cancelled"); 24 | raise Fail 25 | | _ -> 26 | Logger.error (fun f -> f "no message sent"); 27 | raise Fail 28 | 29 | let () = Riot.run @@ main 30 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/pid.ml: -------------------------------------------------------------------------------- 1 | type t = { _id : int64 } [@@unboxed] 2 | 3 | let pp ppf pid = Format.fprintf ppf "<0.%s.0>" (Int64.to_string pid._id) 4 | let to_string t = Format.asprintf "%a" pp t 5 | let make _id = { _id } 6 | let zero : t = make 0L 7 | let main : t = make 1L 8 | let __current__ = Atomic.make 1L 9 | 10 | let rec next () = 11 | let last = Atomic.get __current__ in 12 | let current = last |> Int64.succ in 13 | if Atomic.compare_and_set __current__ last current then make last else next () 14 | 15 | let equal a b = Int64.equal a._id b._id 16 | let compare a b = Int64.compare a._id b._id 17 | let hash t = Int64.hash t._id 18 | 19 | let reset () = 20 | Log.debug (fun f -> f "Resetting Process Ids"); 21 | Atomic.set __current__ 1L 22 | 23 | module Map = Util.Dashmap.Make (struct 24 | type key = t 25 | 26 | let hash = hash 27 | let equal = equal 28 | end) 29 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_state.mli: -------------------------------------------------------------------------------- 1 | exception Unwind 2 | 3 | type ('a, 'b) continuation 4 | 5 | type 'a t = 6 | | Finished of ('a, exn) result 7 | | Suspended : ('a, 'b) continuation * 'a Effect.t -> 'b t 8 | | Unhandled : ('a, 'b) continuation * 'a -> 'b t 9 | 10 | type 'a step = 11 | | Continue of 'a 12 | | Discontinue of exn 13 | | Reperform : 'a Effect.t -> 'a step 14 | | Delay : 'a step 15 | | Suspend : 'a step 16 | | Yield : unit step 17 | | Terminate : 'a step 18 | 19 | type ('a, 'b) step_callback = ('a step -> 'b t) -> 'a Effect.t -> 'b t 20 | type perform = { perform : 'a 'b. ('a, 'b) step_callback } [@@unboxed] 21 | 22 | val pp : Format.formatter -> 'a t -> unit 23 | val make : ('a -> 'b) -> 'a Effect.t -> 'b t 24 | val run : reductions:int -> perform:perform -> 'a t -> 'a t option 25 | val is_finished : 'a t -> bool 26 | val unwind : id:string -> 'a t -> unit 27 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_set.ml: -------------------------------------------------------------------------------- 1 | module PidSet = Set.Make (struct 2 | type t = Process.t 3 | 4 | let compare (a : t) (b : t) = Pid.compare (Process.pid a) (Process.pid b) 5 | end) 6 | 7 | type t = { _set : PidSet.t Atomic.t } [@@unboxed] 8 | 9 | let create () = { _set = Atomic.make PidSet.empty } 10 | 11 | let rec remove t proc = 12 | let old_set = Atomic.get t._set in 13 | let new_set = PidSet.remove proc old_set in 14 | if Atomic.compare_and_set t._set old_set new_set then () else remove t proc 15 | 16 | let contains t proc = PidSet.mem proc (Atomic.get t._set) 17 | let size t = PidSet.cardinal (Atomic.get t._set) 18 | 19 | (* NOTE(leostera): `PidSet.add` actually keeps duplicates! we want to use `replace` to drop the old one *) 20 | let rec add t proc = 21 | let old_set = Atomic.get t._set in 22 | let new_set = PidSet.add proc old_set in 23 | if Atomic.compare_and_set t._set old_set new_set then () else add t proc 24 | -------------------------------------------------------------------------------- /examples/5-links-and-monitors/main.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let rec await_monitor_message () = 4 | match receive_any () with 5 | | Process.Messages.Monitor (Process_down pid) -> 6 | Format.printf "uh-oh! Process %a terminated\n%!" Pid.pp pid 7 | | _ -> await_monitor_message () 8 | 9 | let rec loop () = 10 | yield (); 11 | loop () 12 | 13 | let () = 14 | Riot.run @@ fun () -> 15 | (* monitor *) 16 | let pid1 = spawn loop in 17 | let pid2 = 18 | spawn (fun () -> 19 | monitor pid1; 20 | await_monitor_message ()) 21 | in 22 | sleep 0.1; 23 | exit pid1 Normal; 24 | wait_pids [ pid1; pid2 ]; 25 | 26 | (* link *) 27 | let pid3 = spawn loop in 28 | let pid4 = 29 | spawn (fun () -> 30 | link pid3; 31 | loop ()) 32 | in 33 | sleep 0.2; 34 | exit pid3 Normal; 35 | wait_pids [ pid3; pid4 ]; 36 | Format.printf "both processes (%a,%a) have terminated\n%!" Pid.pp pid3 Pid.pp 37 | pid4 38 | -------------------------------------------------------------------------------- /examples/1-hello-world/README.md: -------------------------------------------------------------------------------- 1 | # `1-hello-world` 2 | 3 | A project so basic that fits on a single line! 4 | 5 | ```ocaml 6 | Riot.run @@ fun () -> print_endline "Hello, Joe!" 7 | ``` 8 | 9 | Every Riot program begins with a call to `Riot.run`. `Riot.run` takes a single 10 | function as input, and _does not terminate_. This is because Riot programs are 11 | expected to _run forever_. 12 | 13 | If you want to terminate the Riot runtime, you can call `Riot.shutdown ()` from 14 | anywhere in the program. Keep in mind that this will not await for all 15 | processes to terminate. We will cover graceful-shutdowns of applications later 16 | in this tutorial. 17 | 18 | ```ocaml 19 | Riot.run @@ fun () -> 20 | print_endline "Hello, Joe!"; 21 | Riot.shutdown () 22 | ``` 23 | 24 | The smallest Riot program, that starts and ends immediately, is then: 25 | 26 | ```ocaml 27 | Riot.(run shutdown) 28 | ``` 29 | 30 | ## Next Steps 31 | 32 | * the [next step](../2-spawn-process/) introduces you to Processes 33 | -------------------------------------------------------------------------------- /test/io_writer_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let () = 4 | Riot.run @@ fun () -> 5 | let _ = Logger.start () |> Result.get_ok in 6 | Logger.set_log_level (Some Info); 7 | let now = Ptime_clock.now () in 8 | let path = 9 | Format.asprintf "./generated/%a.io_writer_test.txt" (Ptime.pp_rfc3339 ()) 10 | now 11 | in 12 | let file = File.open_write path in 13 | let writer = File.to_writer file in 14 | let buf = {| this is some data |} in 15 | let () = IO.write_all writer ~buf |> Result.get_ok in 16 | 17 | let file = File.open_read path in 18 | let reader = File.to_reader file in 19 | let buf = IO.Bytes.with_capacity 19 in 20 | let _read = IO.read reader buf in 21 | let str = IO.Bytes.to_string buf in 22 | 23 | match str with 24 | | {| this is some data |} -> 25 | File.remove path; 26 | Logger.info (fun f -> f "io_writer_test: OK"); 27 | 28 | shutdown () 29 | | str -> 30 | Logger.error (fun f -> f "io_writer_test: unexpected input %S" str); 31 | 32 | Stdlib.exit 1 33 | -------------------------------------------------------------------------------- /packages/riot-runtime/Config.ml: -------------------------------------------------------------------------------- 1 | type t = { 2 | rnd : Random.State.t; 3 | max_workers : int; 4 | workers : int; 5 | supervisor_restart_limit : int; 6 | supervisor_restart_period : int; 7 | } 8 | 9 | let pp fmt t = 10 | Format.fprintf fmt "== RIOT CONFIG ==\n"; 11 | Format.fprintf fmt "* max_wokers=%d\n" t.max_workers; 12 | Format.fprintf fmt "* workers=%d\n" t.workers; 13 | Format.fprintf fmt "* supervisor_restart_limit=%d\n" t.supervisor_restart_limit; 14 | Format.fprintf fmt "* supervisor_restart_period=%d\n" t.supervisor_restart_period; 15 | Format.fprintf fmt "\n%!" 16 | ;; 17 | 18 | let make ?(supervisor_restart_limit = 1) ?(supervisor_restart_period = 0) 19 | ?workers () = 20 | let max_workers = Int.max 0 (Stdlib.Domain.recommended_domain_count () - 2) in 21 | let workers = 22 | match workers with Some w -> Int.min w max_workers | None -> max_workers 23 | in 24 | let rnd = Random.State.make_self_init () in 25 | { 26 | rnd; 27 | max_workers; 28 | workers; 29 | supervisor_restart_limit; 30 | supervisor_restart_period; 31 | } 32 | 33 | let default () = make () 34 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/ref.ml: -------------------------------------------------------------------------------- 1 | type 'a t = Ref of int64 [@@unboxed] 2 | 3 | let __current__ = Atomic.make 0L 4 | let pp ppf (Ref pid) = Format.fprintf ppf "#Ref<%s>" (Int64.to_string pid) 5 | 6 | let rec make () = 7 | let last = Atomic.get __current__ in 8 | let current = last |> Int64.succ in 9 | if Atomic.compare_and_set __current__ last current then Ref last else make () 10 | 11 | let equal (Ref a) (Ref b) = Int64.equal a b 12 | 13 | let type_equal : type a b. a t -> b t -> (a, b) Type.eq option = 14 | fun a b -> 15 | match (a, b) with 16 | | Ref a', Ref b' when Int64.equal a' b' -> Some (Obj.magic Type.Equal) 17 | | _ -> None 18 | 19 | let cast (type a b) (Type.Equal : (a, b) Type.eq) (a : a) : b = a 20 | 21 | let cast : type a b. a t -> b t -> a -> b option = 22 | fun a b value -> 23 | match type_equal a b with 24 | | Some witness -> Some (cast witness value) 25 | | None -> None 26 | 27 | let is_newer (Ref a) (Ref b) = Int64.compare a b = 1 28 | let hash (Ref a) = Int64.hash a 29 | 30 | module Map = Util.Dashmap.Make (struct 31 | type key = unit t 32 | 33 | let hash = hash 34 | let equal = equal 35 | end) 36 | -------------------------------------------------------------------------------- /test/io_writev_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | exception Fail 4 | 5 | let () = 6 | Riot.run @@ fun () -> 7 | let _ = Logger.start () |> Result.get_ok in 8 | Logger.set_log_level (Some Info); 9 | let now = Ptime_clock.now () in 10 | let file = 11 | Format.asprintf "./generated/%a.io_writev.txt" (Ptime.pp_rfc3339 ()) now 12 | in 13 | 14 | (* write to the file *) 15 | let fd = File.open_write file in 16 | let writer = File.to_writer fd in 17 | let bufs = IO.Iovec.from_string {| this is some data |} in 18 | let len = IO.write_owned_vectored writer ~bufs |> Result.get_ok in 19 | File.close fd; 20 | 21 | (* read from the file *) 22 | let buf = IO.Bytes.with_capacity len in 23 | let fd = File.open_read file in 24 | let reader = File.to_reader fd in 25 | let len = IO.read reader buf |> Result.get_ok in 26 | File.close fd; 27 | match IO.Bytes.(sub ~pos:0 ~len buf |> to_string) with 28 | | {| this is some data |} -> 29 | File.remove file; 30 | Logger.info (fun f -> f "io_readv_test: OK") 31 | | str -> 32 | Logger.error (fun f -> f "io_readv_test: unexpected input %S" str); 33 | 34 | raise Fail 35 | -------------------------------------------------------------------------------- /test/link_processes_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let rec loop () = 4 | yield (); 5 | loop () 6 | 7 | let main () = 8 | let _ = Logger.start () |> Result.get_ok in 9 | (* Runtime.set_log_level (Some Debug); *) 10 | Logger.set_log_level (Some Info); 11 | 12 | Logger.debug (fun f -> f "spawning processes from %a" Pid.pp (self ())); 13 | 14 | (* spin up and wait for 1 second before terminating *) 15 | let pid1 = 16 | spawn (fun () -> 17 | Logger.debug (fun f -> f "spawned %a" Pid.pp (self ())); 18 | loop ()) 19 | in 20 | 21 | (* spin up, link to pid1, and then loop infinitely *) 22 | let pid2 = 23 | spawn (fun () -> 24 | Logger.debug (fun f -> f "spawned %a" Pid.pp (self ())); 25 | link pid1; 26 | loop ()) 27 | in 28 | 29 | let _ = 30 | spawn (fun () -> 31 | sleep 0.5; 32 | (* once we send this exit signal to pid1, and it dies, it should take pid2 down with it *) 33 | exit pid1 Normal) 34 | in 35 | 36 | (* so we'll wait for both pids to be dead *) 37 | wait_pids [ pid1; pid2 ]; 38 | 39 | Logger.info (fun f -> f "link_procesess_test: OK") 40 | 41 | let () = Riot.run @@ main 42 | -------------------------------------------------------------------------------- /test/send_order_test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open Riot 4 | 5 | type Riot.Message.t += 6 | | A of int 7 | | End 8 | | Collected_messages of Riot.Message.t list 9 | 10 | type state = { messages : Riot.Message.t list; main : Pid.t } 11 | 12 | let rec loop state = 13 | match receive_any ~after:500_000L () with 14 | | End -> send state.main (Collected_messages (List.rev state.messages)) 15 | | A _ as msg -> loop { state with messages = msg :: state.messages } 16 | | _ -> loop state 17 | 18 | let main () = 19 | let (Ok _) = Logger.start () in 20 | 21 | let this = self () in 22 | let pid = spawn (fun () -> loop { messages = []; main = this }) in 23 | send pid (A 1); 24 | send pid (A 2); 25 | send pid (A 3); 26 | send pid End; 27 | 28 | match receive_any ~after:500_000L () with 29 | | Collected_messages [ A 1; A 2; A 3 ] -> 30 | Logger.debug (fun f -> f "send_order_test: received messages in order"); 31 | Logger.info (fun f -> f "send_order_test: OK"); 32 | 33 | shutdown () 34 | | _ -> 35 | Logger.info (fun f -> f "send_order_test: received messages out of order"); 36 | 37 | Stdlib.exit 1 38 | 39 | let () = 40 | Logger.set_log_level (Some Info); 41 | Riot.run @@ main 42 | -------------------------------------------------------------------------------- /test/selective_receive_test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open Riot 4 | 5 | type Message.t += A | B | C | Continue 6 | 7 | let loop pid = 8 | send pid A; 9 | receive_any ~after:500_000L () |> ignore; 10 | send pid B; 11 | send pid C 12 | 13 | let main () = 14 | let (Ok _) = Logger.start () in 15 | Logger.set_log_level (Some Info); 16 | let this = self () in 17 | 18 | let pid1 = spawn (fun () -> loop this) in 19 | (* we will wait so the first message from the process gets sent *) 20 | sleep 0.1; 21 | 22 | let ref = Ref.make () in 23 | send pid1 Continue; 24 | 25 | let m1 = receive_any ~ref ~after:50_000L () in 26 | let m2 = receive_any ~ref ~after:50_000L () in 27 | let m3 = receive_any ~after:50_000L () in 28 | 29 | match (m1, m2, m3) with 30 | | B, C, A -> 31 | Logger.info (fun f -> f "selective_receive: OK"); 32 | 33 | shutdown () 34 | | m1, m2, m3 -> 35 | Logger.error (fun f -> 36 | f "selective_receive: messages arrived out of order?\n%S\n%S\n%S" 37 | (Marshal.to_string m1 []) (Marshal.to_string m2 []) 38 | (Marshal.to_string m3 [])); 39 | 40 | sleep 1.; 41 | Stdlib.exit 1 42 | 43 | let () = Riot.run ~config:(Config.make ~workers:0 ()) @@ main 44 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_registry.ml: -------------------------------------------------------------------------------- 1 | module Exn = struct 2 | exception Name_already_registered of string * Pid.t 3 | end 4 | 5 | type t = { 6 | processes : (string, Pid.t) Hashtbl.t; 7 | names : (Pid.t, string) Hashtbl.t; 8 | lock : Mutex.t; 9 | } 10 | 11 | let create () = 12 | { 13 | lock = Mutex.create (); 14 | processes = Hashtbl.create 16_000; 15 | names = Hashtbl.create 16_000; 16 | } 17 | 18 | let register t name pid = 19 | Mutex.lock t.lock; 20 | if Hashtbl.mem t.processes name then ( 21 | Mutex.unlock t.lock; 22 | raise (Exn.Name_already_registered (name, pid))) 23 | else ( 24 | Hashtbl.add t.processes name pid; 25 | Hashtbl.add t.names pid name; 26 | Mutex.unlock t.lock) 27 | 28 | let unregister t name = 29 | Mutex.lock t.lock; 30 | let pid = Hashtbl.find t.processes name in 31 | Hashtbl.remove t.processes name; 32 | Hashtbl.remove t.names pid; 33 | Mutex.unlock t.lock 34 | 35 | let remove t pid = 36 | Mutex.lock t.lock; 37 | (match Hashtbl.find_opt t.names pid with 38 | | Some name -> Hashtbl.remove t.processes name 39 | | None -> ()); 40 | Hashtbl.remove t.names pid; 41 | Mutex.unlock t.lock 42 | 43 | let find_pid t name = 44 | Mutex.lock t.lock; 45 | let pid = Hashtbl.find_opt t.processes name in 46 | Mutex.unlock t.lock; 47 | pid 48 | -------------------------------------------------------------------------------- /packages/riot-runtime/rc.ml: -------------------------------------------------------------------------------- 1 | type 'a t = { 2 | refc : int Atomic.t; 3 | value : 'a Atomic.t; 4 | release : 'a t -> 'a; 5 | (** this release function will be called once we are sure the last reference 6 | to this resource is dropped. 7 | 8 | note that the entire instance is passed to this release function 9 | to allow for more uniform APIs. *) 10 | } 11 | 12 | let make value ~release = 13 | { refc = Atomic.make 1; value = Atomic.make value; release } 14 | 15 | let set t ~prev ~next = Atomic.compare_and_set t.value prev next 16 | let refc t = Atomic.get t.refc 17 | 18 | let get t = 19 | Atomic.incr t.refc; 20 | Atomic.get t.value 21 | 22 | let peek t = Atomic.get t.value 23 | 24 | let release t = 25 | let new_value = t.release t in 26 | Atomic.set t.value new_value 27 | 28 | let take t = Atomic.incr t.refc 29 | 30 | let drop t = 31 | let old_refc = Atomic.fetch_and_add t.refc (-1) in 32 | if old_refc = 1 then release t else assert (old_refc > 1) 33 | 34 | let use t fn = 35 | (* bump refc: so noone can close the resource while fn runs *) 36 | take t; 37 | match fn (Atomic.get t.value) with 38 | | value -> 39 | drop t; 40 | value 41 | | exception exn -> 42 | let backtrace = Printexc.get_raw_backtrace () in 43 | drop t; 44 | Printexc.raise_with_backtrace exn backtrace 45 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.11) 2 | (using mdx 0.4) 3 | 4 | (name riot) 5 | 6 | (generate_opam_files true) 7 | (cram enable) 8 | 9 | (source 10 | (github riot-ml/riot)) 11 | 12 | (authors "Leandro Ostera ") 13 | 14 | (maintainers "Leandro Ostera ") 15 | 16 | (license MIT) 17 | 18 | (pin 19 | (url "git+https://github.com/riot-ml/rio.git") 20 | (package (name rio))) 21 | 22 | (pin 23 | (url "git+https://github.com/riot-ml/bytestring.git") 24 | (package (name bytestring))) 25 | 26 | (package 27 | (name riot) 28 | (synopsis "An actor-model multi-core scheduler for OCaml 5") 29 | (description 30 | "Riot is an actor-model multi-core scheduler for OCaml 5. It brings Erlang-style concurrency to the language, where lighweight process communicate via message passing") 31 | (depends 32 | bytestring 33 | (castore (and :with-test (>= "0.0.2"))) 34 | (config (>= "0.0.1")) 35 | (gluon (>= "0.0.1")) 36 | (mdx (and :with-test (>= "2.3.1"))) 37 | (mirage-crypto (>= "0.11.2")) 38 | (mirage-crypto-rng (>= "0.11.2")) 39 | (mtime (>= "2.0.0")) 40 | (ocaml (>= "5.1")) 41 | (odoc (and :with-doc (>= "2.2.2"))) 42 | (ptime (>= "1.1.0")) 43 | rio 44 | (telemetry (>= "0.0.1")) 45 | (tls (>= "1.0.0")) 46 | (uri (>= "4.4.0")) 47 | dune) 48 | (tags 49 | (multicore erlang actor "message-passing" processes))) 50 | -------------------------------------------------------------------------------- /examples/README.md: -------------------------------------------------------------------------------- 1 | # Learning by Example 2 | 3 | Hi! 👋 Excited to have you here. Riot's examples serve as a tutorial for 4 | building libraries and applications. Each example is a small complete project, 5 | with its own README, and next steps to take. 6 | 7 | You can start at [./1-hello-world](./1-hello-world) and work your way up. 8 | 9 | * [1-hello-world](./1-hello-world) – a small program to get you started 10 | * [2-spawn-process](./2-spawn-process) - creating your first process 11 | * [3-message-passing](./3-message-passing) - sending a message to a process 12 | * [4-long-lived-processes](./4-long-lived-processes) - creating a process that runs forever 13 | * [5-links-and-monitors](./5-links-and-monitors/) - getting to know when a process terminates 14 | 15 | ### Coming Up 16 | 17 | The following tutorials are in the works: 18 | 19 | * [6-supervisors](./6-supervisors/) - how to keep processes alive 20 | * [7-supervision-trees](./7-supervision-trees/) - using supervisors to structure work 21 | * [8-applications](./8-applications/) - packaging an application 22 | * [9-logger](./9-logger) - using the built-in Logger 23 | 24 | And in future releases, as new work is done on the runtime and the Riot 25 | standard libraries, we'll be covering more topics such as: 26 | 27 | * Gen servers 28 | * Agents 29 | * Binary-string matching 30 | * Best-practices around typing messages 31 | * Application-level tracing 32 | -------------------------------------------------------------------------------- /packages/riot-stdlib/process.ml: -------------------------------------------------------------------------------- 1 | open Riot_runtime.Import 2 | module P = Riot_runtime.Core.Process 3 | 4 | open Logger.Make (struct 5 | let namespace = [ "riot"; "process" ] 6 | end) 7 | 8 | type t = P.t 9 | type priority = P.priority = High | Normal | Low 10 | type process_flag = P.process_flag = Trap_exit of bool | Priority of priority 11 | 12 | let pp_flag fmt t = 13 | match t with 14 | | Trap_exit b -> Format.fprintf fmt "trap_exit <- %b" b 15 | | Priority p -> Format.fprintf fmt "priority <- %s" (P.priority_to_string p) 16 | 17 | type exit_reason = P.exit_reason = 18 | | Normal 19 | | Exit_signal 20 | | Bad_link 21 | | Link_down of Pid.t 22 | | Exception of exn 23 | 24 | let pp_reason = P.pp_reason 25 | 26 | module Messages = P.Messages 27 | 28 | let pp = P.pp 29 | let where_is = where_is 30 | let sid = P.sid 31 | 32 | let rec await_name name = 33 | match where_is name with 34 | | Some pid -> pid 35 | | None -> 36 | yield (); 37 | await_name name 38 | 39 | let flag flag = 40 | trace (fun f -> f "%a updated flag: %a" Pid.pp (self ()) pp_flag flag); 41 | process_flag flag 42 | 43 | let monitor pid = 44 | trace (fun f -> f "%a is now monitoring %a" Pid.pp (self ()) Pid.pp pid); 45 | monitor pid 46 | 47 | let demonitor pid = 48 | trace (fun f -> f "%a is no longer monitoring %a" Pid.pp (self ()) Pid.pp pid); 49 | demonitor pid 50 | 51 | let is_alive pid = is_process_alive pid 52 | let register ~name pid = register name pid 53 | -------------------------------------------------------------------------------- /test/send_after_test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open Riot 4 | 5 | type Message.t += A | B | C | D | E 6 | 7 | let msg_to_str = function 8 | | A -> "a" 9 | | B -> "b" 10 | | C -> "c" 11 | | D -> "d" 12 | | E -> "e" 13 | | _ -> "other" 14 | 15 | let main () = 16 | let (Ok _) = Logger.start () in 17 | (* Runtime.set_log_level (Some Trace); *) 18 | Logger.set_log_level (Some Info); 19 | let this = self () in 20 | 21 | let (Ok _timer) = Timer.send_after this A ~after:1_000L in 22 | let (Ok _timer) = Timer.send_after this C ~after:2_000L in 23 | let (Ok _timer) = Timer.send_after this D ~after:3_000L in 24 | let (Ok _timer) = Timer.send_after this E ~after:4_000L in 25 | send this B; 26 | 27 | let after = 10_000L in 28 | let messages = 29 | [ 30 | receive_any ~after (); 31 | receive_any ~after (); 32 | receive_any ~after (); 33 | receive_any ~after (); 34 | receive_any ~after (); 35 | ] 36 | |> List.rev 37 | in 38 | 39 | match messages with 40 | | [ B; A; C; D; E ] -> 41 | Logger.debug (fun f -> 42 | f "send_after_test: messages respected send_after time"); 43 | Logger.info (fun f -> f "send_after_test: OK") 44 | | _ -> 45 | let messages = messages |> List.map msg_to_str |> String.concat "," in 46 | Riot_runtime.Log.error (fun f -> f "bad message sequence: %s" messages); 47 | sleep 0.1; 48 | shutdown ~status:1 () 49 | 50 | let () = Riot.run ~config:(Config.make ~workers:0 ()) @@ main 51 | -------------------------------------------------------------------------------- /riot.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "An actor-model multi-core scheduler for OCaml 5" 4 | description: 5 | "Riot is an actor-model multi-core scheduler for OCaml 5. It brings Erlang-style concurrency to the language, where lighweight process communicate via message passing" 6 | maintainer: ["Leandro Ostera "] 7 | authors: ["Leandro Ostera "] 8 | license: "MIT" 9 | tags: ["multicore" "erlang" "actor" "message-passing" "processes"] 10 | homepage: "https://github.com/riot-ml/riot" 11 | bug-reports: "https://github.com/riot-ml/riot/issues" 12 | depends: [ 13 | "bytestring" 14 | "castore" {with-test & >= "0.0.2"} 15 | "config" {>= "0.0.1"} 16 | "gluon" {>= "0.0.1"} 17 | "mdx" {with-test & >= "2.3.1"} 18 | "mirage-crypto" {>= "0.11.2"} 19 | "mirage-crypto-rng" {>= "0.11.2"} 20 | "mtime" {>= "2.0.0"} 21 | "ocaml" {>= "5.1"} 22 | "odoc" {with-doc & >= "2.2.2"} 23 | "ptime" {>= "1.1.0"} 24 | "rio" 25 | "telemetry" {>= "0.0.1"} 26 | "tls" {>= "1.0.0"} 27 | "uri" {>= "4.4.0"} 28 | "dune" {>= "3.11"} 29 | ] 30 | build: [ 31 | ["dune" "subst"] {dev} 32 | [ 33 | "dune" 34 | "build" 35 | "-p" 36 | name 37 | "-j" 38 | jobs 39 | "@install" 40 | "@runtest" {with-test} 41 | "@doc" {with-doc} 42 | ] 43 | ] 44 | dev-repo: "git+https://github.com/riot-ml/riot.git" 45 | available: arch != "x86_32" & arch != "arm32" & arch != "ppc64" & arch != "s390x" & os != "freebsd" 46 | -------------------------------------------------------------------------------- /packages/riot-stdlib/key_value_store.ml: -------------------------------------------------------------------------------- 1 | module type Base = sig 2 | type key 3 | type value 4 | end 5 | 6 | module MakeServer (B : Base) = struct 7 | include Gen_server.Default 8 | 9 | type _ Gen_server.req += 10 | | Get : B.key -> B.value option Gen_server.req 11 | | Put : B.key * B.value -> unit Gen_server.req 12 | 13 | type args = unit 14 | type state = { tbl : (B.key, B.value) Hashtbl.t } 15 | 16 | let init () = Gen_server.Ok { tbl = Hashtbl.create 0 } 17 | 18 | let handle_call : 19 | type res. 20 | res Gen_server.req -> 21 | Pid.t -> 22 | state -> 23 | (res, state) Gen_server.call_result = 24 | fun req _from state -> 25 | match req with 26 | | Get k -> Gen_server.Reply (Hashtbl.find_opt state.tbl k, state) 27 | | Put (k, v) -> Gen_server.Reply (Hashtbl.replace state.tbl k v, state) 28 | | _ -> failwith "invalid call" 29 | end 30 | 31 | module type Intf = sig 32 | type key 33 | type value 34 | 35 | val start_link : unit -> (Pid.t, [> `Exn of exn ]) result 36 | val get : Pid.t -> key -> value option 37 | val put : Pid.t -> key -> value -> unit 38 | val child_spec : Supervisor.child_spec 39 | end 40 | 41 | module Make (B : Base) = struct 42 | module Server = MakeServer (B) 43 | 44 | type key = B.key 45 | type value = B.value 46 | 47 | let start_link () = Gen_server.start_link (module Server) () 48 | let get pid key = Gen_server.call pid Server.(Get key) 49 | let put pid key value = Gen_server.call pid Server.(Put (key, value)) 50 | let child_spec = Supervisor.child_spec start_link () 51 | end 52 | -------------------------------------------------------------------------------- /test/process_stealing_test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open Riot 4 | 5 | exception Fail 6 | 7 | let get_sid pid = 8 | match Seq.find (fun (p, _proc) -> Pid.equal pid p) (processes ()) with 9 | | Some (_pid, proc) -> Process.sid proc 10 | | None -> raise Not_found 11 | 12 | let main () = 13 | let _ = Logger.start () |> Result.get_ok in 14 | (* Runtime.set_log_level (Some Debug); *) 15 | Logger.set_log_level (Some Debug); 16 | Runtime.Stats.start ~every:1_000_000L (); 17 | 18 | let _scheduler_hogger = 19 | spawn_pinned (fun () -> 20 | Logger.info (fun f -> f "hogger %a" Pid.pp (self ())); 21 | let i = ref 0 in 22 | while true do 23 | i := !i + 1; 24 | if !i mod 100000 = 0 then yield () 25 | done) 26 | in 27 | 28 | let pid = 29 | spawn_pinned (fun () -> 30 | Logger.info (fun f -> f "pid %a" Pid.pp (self ())); 31 | let rec sleep_loop () = 32 | yield (); 33 | sleep_loop () 34 | in 35 | sleep_loop ()) 36 | in 37 | Logger.info (fun f -> f "spinning up processes"); 38 | 39 | let last_sid = get_sid pid in 40 | let rec check_loop iters = 41 | if iters = 0 then ( 42 | Logger.error (fun f -> 43 | f "process_stealing_test: process was not stolen by another scheduler"); 44 | raise Fail); 45 | let current_sid = get_sid pid in 46 | if not (Core.Scheduler_uid.equal last_sid current_sid) then 47 | Logger.info (fun f -> f "process_stealing_test: OK") 48 | else check_loop (iters - 1) 49 | in 50 | check_loop 10000 51 | 52 | let () = run ~workers:2 @@ main 53 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: Build & Test 2 | 3 | on: 4 | pull_request: 5 | push: 6 | schedule: 7 | # Prime the caches every Monday 8 | - cron: 0 1 * * MON 9 | 10 | permissions: read-all 11 | 12 | jobs: 13 | build: 14 | strategy: 15 | fail-fast: false 16 | matrix: 17 | os: 18 | - macos-latest 19 | - ubuntu-latest 20 | ocaml-compiler: 21 | - "5.1" 22 | - "5.2" 23 | allow-prerelease-opam: 24 | - true 25 | opam-repositories: 26 | - |- 27 | default: https://github.com/ocaml/opam-repository.git 28 | # include: 29 | # - os: windows-latest 30 | # ocaml-compiler: ocaml-variants.5.1.0+options,ocaml-option-mingw 31 | # allow-prerelease-opam: false 32 | # opam-repositories: |- 33 | # windows-5.0: https://github.com/dra27/opam-repository.git#windows-5.0 34 | # sunset: https://github.com/ocaml-opam/opam-repository-mingw.git#sunset 35 | # default: https://github.com/ocaml/opam-repository.git 36 | 37 | runs-on: ${{ matrix.os }} 38 | 39 | steps: 40 | - name: Checkout tree 41 | uses: actions/checkout@v4 42 | 43 | - name: Set-up OCaml 44 | uses: ocaml/setup-ocaml@v2 45 | with: 46 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 47 | allow-prerelease-opam: ${{ matrix.allow-prerelease-opam }} 48 | opam-repositories: ${{ matrix.opam-repositories }} 49 | 50 | - run: opam install . --deps-only --with-test 51 | 52 | - run: opam exec -- dune build 53 | 54 | - run: opam exec -- dune test 55 | -------------------------------------------------------------------------------- /bench/spawn_many.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | module Test_app = struct 4 | [@@@warning "-8"] 5 | 6 | type Riot.Message.t += Loop_stop 7 | 8 | let loop count = 9 | match receive_any () with 10 | | Loop_stop -> Riot_runtime.Log.debug (fun f -> f "dead at %d%!" count) 11 | 12 | let main t0 () = 13 | Logger.info (fun f -> f "boot test app"); 14 | let pids = 15 | List.init 1_000_000 (fun _i -> 16 | spawn (fun () -> 17 | Logger.debug (fun f -> f "spawned %a" Pid.pp (self ())); 18 | loop 0)) 19 | in 20 | Logger.info (fun f -> 21 | let t1 = Ptime_clock.now () in 22 | let delta = Ptime.diff t1 t0 in 23 | let delta = Ptime.Span.to_float_s delta in 24 | f "spawned %d processes in %.3fs" (List.length pids) delta); 25 | 26 | List.iter (fun pid -> send pid Loop_stop) pids; 27 | 28 | Logger.info (fun f -> 29 | let t1 = Ptime_clock.now () in 30 | let delta = Ptime.diff t1 t0 in 31 | let delta = Ptime.Span.to_float_s delta in 32 | f "sent %d messages in %.3fs" (List.length pids) delta); 33 | 34 | wait_pids pids; 35 | 36 | Logger.info (fun f -> 37 | let t1 = Ptime_clock.now () in 38 | let delta = Ptime.diff t1 t0 in 39 | let delta = Ptime.Span.to_float_s delta in 40 | f "spawned/awaited %d processes in %.3fs" (List.length pids) delta); 41 | sleep 0.001; 42 | shutdown () 43 | 44 | let start () = 45 | Logger.set_log_level (Some Info); 46 | let t0 = Ptime_clock.now () in 47 | Ok (spawn_link (main t0)) 48 | end 49 | 50 | let () = Riot.start ~apps:[ (module Logger); (module Test_app) ] () 51 | -------------------------------------------------------------------------------- /test/process_priority_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | type Message.t += A | B | C 4 | 5 | let rec loop pid msg n = 6 | if n = 0 then send pid msg 7 | else ( 8 | yield (); 9 | loop pid msg (n - 1)) 10 | 11 | let main () = 12 | let _ = Logger.start () |> Result.get_ok in 13 | Logger.set_log_level (Some Info); 14 | let this = self () in 15 | 16 | let _ = 17 | spawn (fun () -> 18 | process_flag (Priority Low); 19 | loop this A 100) 20 | in 21 | let _ = 22 | spawn (fun () -> 23 | process_flag (Priority Normal); 24 | loop this B 100) 25 | in 26 | let _ = 27 | spawn (fun () -> 28 | process_flag (Priority High); 29 | loop this C 100) 30 | in 31 | 32 | let m1 = receive_any ~after:50_000L () in 33 | let m2 = receive_any ~after:50_000L () in 34 | let m3 = receive_any ~after:50_000L () in 35 | 36 | match (m1, m2, m3) with 37 | | C, B, A -> 38 | Logger.info (fun f -> f "process_priority_test: OK"); 39 | 40 | shutdown () 41 | | m1, m2, m3 -> 42 | Logger.error (fun f -> 43 | f "process_priority_test: messages arrived out of order?\n%S\n%S\n%S" 44 | (Marshal.to_string m1 []) (Marshal.to_string m2 []) 45 | (Marshal.to_string m3 [])); 46 | 47 | Stdlib.exit 1 48 | 49 | (* NOTE(@leostera): this test NEEDS to run on just one scheduler, so we spin up 50 | no additional workers. The reason is that if we do, then other schedulers 51 | may pick up lower priority process earlier, and so the message order will be 52 | different. 53 | 54 | That behavior _is expected_. 55 | *) 56 | let () = Riot.run ~config:(Config.make ~workers:0 ()) @@ main 57 | -------------------------------------------------------------------------------- /test/io_reader_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let test_with_buffer capacity = 4 | let file = File.open_read "./fixtures/io_readv.txt" in 5 | let reader = File.to_reader file in 6 | 7 | let buf = IO.Bytes.with_capacity 8 in 8 | 9 | let op1 = IO.read reader buf |> Result.get_ok in 10 | let str1 = IO.Bytes.(sub buf ~pos:0 ~len:op1 |> to_string) in 11 | Logger.debug (fun f -> f "read #1: %d bytes - %S" op1 str1); 12 | 13 | let op2 = IO.read reader buf |> Result.get_ok in 14 | let str2 = IO.Bytes.(sub buf ~pos:0 ~len:op2 |> to_string) in 15 | Logger.debug (fun f -> f "read #2: %d bytes - %S" op2 str2); 16 | 17 | let op3 = IO.read reader buf |> Result.get_ok in 18 | let str3 = IO.Bytes.(sub buf ~pos:0 ~len:op3 |> to_string) in 19 | Logger.debug (fun f -> f "read #3: %d bytes - %S" op3 str3); 20 | 21 | let final_str = str1 ^ str2 ^ str3 in 22 | if String.equal final_str "hello world\n" then 23 | Logger.info (fun f -> f "io_reader_test(%d): OK" capacity) 24 | else ( 25 | Logger.error (fun f -> 26 | f "io_readv_test(%d): unexpected input %S %S %S" capacity str1 str2 27 | str3); 28 | 29 | let exception Fail in 30 | raise Fail) 31 | 32 | let () = 33 | Riot.run @@ fun () -> 34 | let _ = Logger.start () |> Result.get_ok in 35 | Logger.set_log_level (Some Info); 36 | (* smallest buffer that will work than the target and the source*) 37 | test_with_buffer 4; 38 | (* smallest than the target and the source*) 39 | test_with_buffer 7; 40 | (* larger than the target but smaller than the and smaller than the sourcesrc *) 41 | test_with_buffer 10; 42 | (* larger than the target and the source *) 43 | test_with_buffer 100; 44 | 45 | shutdown () 46 | -------------------------------------------------------------------------------- /test/supervisor_shutdown_test.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | 3 | open Riot 4 | 5 | type Message.t += Ping_me of Pid.t 6 | 7 | module Ping = struct 8 | let loop reply = 9 | send reply (Ping_me (self ())); 10 | let rec loop () = 11 | yield (); 12 | loop () 13 | in 14 | loop () 15 | 16 | let start_link n = 17 | let pid = spawn_link (fun () -> loop n) in 18 | Ok pid 19 | end 20 | 21 | let main () = 22 | let _ = Logger.start () in 23 | Logger.set_log_level (Some Info); 24 | sleep 0.1; 25 | process_flag (Trap_exit true); 26 | let this = self () in 27 | let sup = 28 | Supervisor.start_link ~restart_limit:2 29 | ~child_specs:[ Supervisor.child_spec Ping.start_link this ] 30 | () 31 | |> Result.get_ok 32 | in 33 | 34 | let (Ping_me child_pid) = receive_any ~after:500_000L () in 35 | Logger.debug (fun f -> f "#1 received pid %a" Pid.pp child_pid); 36 | 37 | exit child_pid Process.Exit_signal; 38 | 39 | let (Ping_me child_pid) = receive_any ~after:500_000L () in 40 | Logger.debug (fun f -> f "#2 received pid %a" Pid.pp child_pid); 41 | 42 | exit child_pid Process.Exit_signal; 43 | 44 | let (Ping_me child_pid) = receive_any ~after:500_000L () in 45 | Logger.debug (fun f -> f "#3 received pid %a" Pid.pp child_pid); 46 | 47 | exit child_pid Process.Exit_signal; 48 | 49 | match receive_any ~after:500_000L () with 50 | | Process.Messages.Exit (pid, _reason) when Pid.equal pid sup -> 51 | Logger.info (fun f -> 52 | f "supervisor_shutdown_test: supervisor finished as expected"); 53 | 54 | shutdown () 55 | | _ -> failwith "supervisor_shutdown_test: expected supervisor failure" 56 | 57 | let () = Riot.run @@ main 58 | -------------------------------------------------------------------------------- /test/io_reader_large_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let test_with_buffer capacity = 4 | let file = File.open_read "./fixtures/ocaml_org.html" in 5 | let reader = File.to_reader file in 6 | let buf = IO.Bytes.with_capacity 57946 in 7 | 8 | let len = IO.read reader buf |> Result.get_ok in 9 | let str1 = IO.Bytes.(sub buf ~pos:0 ~len |> to_string) in 10 | Logger.debug (fun f -> f "read #1: %d bytes" len); 11 | 12 | let len = IO.read reader buf |> Result.get_ok in 13 | let str2 = IO.Bytes.(sub buf ~pos:0 ~len |> to_string) in 14 | Logger.debug (fun f -> f "read #2: %d bytes" len); 15 | 16 | let len = IO.read reader buf |> Result.get_ok in 17 | let str3 = IO.Bytes.(sub buf ~pos:0 ~len |> to_string) in 18 | Logger.debug (fun f -> f "read #3: %d bytes" len); 19 | 20 | File.close file; 21 | let final_str = str1 ^ str2 ^ str3 in 22 | if String.length final_str = 57946 then 23 | Logger.info (fun f -> f "io_reader_large_test(%d): OK" capacity) 24 | else ( 25 | Logger.error (fun f -> 26 | f "io_reader_large_test(%d): %d unexpected input %S %S %S" 27 | (String.length final_str) capacity str1 str2 str3); 28 | 29 | let exception Fail in 30 | raise Fail) 31 | 32 | let () = 33 | Riot.run @@ fun () -> 34 | let _ = Logger.start () |> Result.get_ok in 35 | Logger.set_log_level (Some Info); 36 | (* smallest buffer that will work than the target and the source*) 37 | test_with_buffer 4; 38 | (* smallest than the target and the source*) 39 | test_with_buffer 7; 40 | (* larger than the target but smaller than the and smaller than the sourcesrc *) 41 | test_with_buffer 10; 42 | (* larger than the target and the source *) 43 | test_with_buffer 100; 44 | 45 | shutdown () 46 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/trace.ml: -------------------------------------------------------------------------------- 1 | open Runtime_events 2 | open User 3 | 4 | type tag += 5 | | Scheduler_loop 6 | | Step_process 7 | | Handle_run_proc 8 | | Handle_exit_proc 9 | | Handle_wait_proc 10 | | Handle_syscall 11 | | Handle_receive 12 | | Poll_io 13 | 14 | let span name event = 15 | let span = register name event Type.span in 16 | let start () = write span Type.Begin in 17 | let finish () = write span Type.End in 18 | (start, finish) 19 | 20 | let scheduler_loop_span = 21 | register "riot.scheduler.loop" Scheduler_loop Type.span 22 | 23 | let scheduler_loop_begin () = write scheduler_loop_span Type.Begin 24 | let scheduler_loop_end () = write scheduler_loop_span Type.End 25 | 26 | let handle_run_proc_start, handle_run_proc_finish = 27 | span "riot.scheduler.handle_run_proc" Handle_run_proc 28 | 29 | let start, finish = span "riot.scheduler.handle_exit_proc" Handle_exit_proc 30 | 31 | let handle_exit_proc_span fn = 32 | start (); 33 | let value = fn () in 34 | finish (); 35 | value 36 | 37 | let start, finish = span "riot.scheduler.handle_wait_proc" Handle_wait_proc 38 | 39 | let handle_wait_proc_span fn = 40 | start (); 41 | let value = fn () in 42 | finish (); 43 | value 44 | 45 | let start, finish = span "riot.scheduler.handle_syscall" Handle_syscall 46 | 47 | let handle_syscall_span fn = 48 | start (); 49 | let value = fn () in 50 | finish (); 51 | value 52 | 53 | let start, finish = span "riot.scheduler.handle_receive" Handle_receive 54 | 55 | let handle_receive_span fn = 56 | start (); 57 | let value = fn () in 58 | finish (); 59 | value 60 | 61 | let start, finish = span "riot.io.poll_io_span" Poll_io 62 | 63 | let poll_io_span fn = 64 | start (); 65 | let value = fn () in 66 | finish (); 67 | value 68 | -------------------------------------------------------------------------------- /packages/riot-stdlib/task.ml: -------------------------------------------------------------------------------- 1 | open Global 2 | 3 | module Logger = Logger.Make (struct 4 | let namespace = [ "riot"; "task" ] 5 | end) 6 | 7 | type 'a t = { pid : Pid.t; ref : 'a Ref.t } 8 | type Message.t += Reply : 'a Ref.t * 'a -> Message.t 9 | 10 | let async fn = 11 | let ref = Ref.make () in 12 | let this = self () in 13 | let pid = 14 | spawn (fun () -> 15 | Logger.trace (fun f -> f "spawned task %a" Pid.pp (self ())); 16 | let value = fn () in 17 | let reply = Reply (ref, value) in 18 | Logger.trace (fun f -> f "sending message back: %a" Pid.pp (self ())); 19 | send this reply) 20 | in 21 | Process.monitor pid; 22 | { pid; ref } 23 | 24 | let await : 25 | type res. 26 | ?timeout:int64 -> res t -> (res, [> `Timeout | `Process_down ]) result = 27 | fun ?timeout:after t -> 28 | Logger.trace (fun f -> 29 | f "Process %a is awaing for task %a with timeout %Ld" Pid.pp (self ()) 30 | Pid.pp t.pid 31 | (Option.value ~default:(-1L) after)); 32 | let selector : [ `reply of res | `process_down ] Message.selector = 33 | fun msg -> 34 | match msg with 35 | | Reply (ref', res) when Ref.equal t.ref ref' -> ( 36 | match Ref.type_equal t.ref ref' with 37 | | Some Type.Equal -> `select (`reply res) 38 | | None -> failwith "bad message") 39 | | Process.Messages.Monitor (Process_down pid) when Pid.equal pid t.pid -> 40 | `select `process_down 41 | | _ -> `skip 42 | in 43 | match receive ~selector ?after () with 44 | | exception Receive_timeout -> 45 | Logger.trace (fun f -> f "task %a timeout" Pid.pp t.pid); 46 | Error `Timeout 47 | | `reply res -> 48 | Process.demonitor t.pid; 49 | Ok res 50 | | `process_down -> Error `Process_down 51 | -------------------------------------------------------------------------------- /examples/3-message-passing/README.md: -------------------------------------------------------------------------------- 1 | # `3-message-passing` 2 | 3 | Now that we've learned to spawn processes, we can start sending messages to 4 | them. 5 | 6 | Every message in Riot is _typed_. And all messages form part of the `Message.t` 7 | type. To define a new message, you can write: 8 | 9 | ```ocaml 10 | type Message.t += Hello_world 11 | ``` 12 | 13 | Your message can have any shape you want, so long as it fits into this message 14 | type. Once a message is defined, we can start a process that knows how to 15 | receive them. To receive a message we use the `receive_any` function, like this: 16 | 17 | ```ocaml 18 | match receive_any () with 19 | | Hello_world -> print_endline "Hello, World! :D" 20 | ``` 21 | 22 | `receive_any ()` will try to get a message from the _current process mailbox_. If 23 | the mailbox is empty, `receive_any ()` _will suspend the process_ until a message 24 | is delivered. 25 | 26 | Since messages are represented with an open variant, when we pattern match on 27 | `receive_any ()` we will have to make sure to handle or ignore _other messages_. 28 | 29 | ```ocaml 30 | match receive_any () with 31 | | Hello_world -> print_endline "Hello, World! :D" 32 | | _ -> print_endline "Oh no, an unhandled message! D:" 33 | ``` 34 | 35 | Within a process, it is okay for us to do a _partial match_, since a process crashing isn't going to take the runtime down. So an alternative way to write this is: 36 | 37 | ```ocaml 38 | match[@warning "-8"] receive () with 39 | | Hello_world -> print_endline "Hello, World! :D" 40 | ``` 41 | 42 | Although I would recommend you to be careful where you disable this warning, 43 | since exhaustive pattern-matching is one of OCaml's best features. 44 | 45 | ## Next Steps 46 | 47 | * the [next step](../4-long-lived-processes/) introduces you to long lived processes 48 | -------------------------------------------------------------------------------- /bench/http_server.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let ( let* ) = Result.bind 4 | 5 | let data = 6 | {%b| "HTTP/1.1 200 OK\r\nContent-Length: 12\r\n\r\nhello world!" |} 7 | |> Bytestring.to_iovec 8 | 9 | let bufs = IO.Iovec.create ~size:1024 () 10 | 11 | let rec conn_loop conn () = 12 | let rec handle_request () = 13 | match receive_any ~after:10L () with 14 | | exception Receive_timeout -> 15 | let* _req = Net.Tcp_stream.receive ~timeout:1_000_000L conn ~bufs in 16 | let* _written = 17 | Net.Tcp_stream.send ~timeout:1_000_000L conn ~bufs:data 18 | in 19 | handle_request () 20 | | _ -> failwith "somehow received a message?" 21 | in 22 | match handle_request () with 23 | | Ok _ -> conn_loop conn () 24 | | Error _err -> Net.Tcp_stream.close conn 25 | 26 | let main () = 27 | let _ = Logger.start () |> Result.get_ok in 28 | Runtime.set_log_level (Some Info); 29 | Logger.set_log_level (Some Info); 30 | 31 | (* Runtime.Stats.start ~every:10_000_000L (); *) 32 | let port = 2113 in 33 | let socket = Net.Tcp_listener.bind ~port () |> Result.get_ok in 34 | Logger.debug (fun f -> f "Started server on %d" port); 35 | Process.flag (Trap_exit true); 36 | 37 | let rec accept_loop () = 38 | let* conn, addr = Net.Tcp_listener.accept socket in 39 | Logger.debug (fun f -> 40 | f "Accepted client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn); 41 | spawn (conn_loop conn) |> ignore; 42 | accept_loop () 43 | in 44 | let acceptor () = 45 | match accept_loop () with 46 | | Ok () -> () 47 | | Error err -> 48 | Logger.error (fun f -> f "error: %a" IO.pp_err (Obj.magic err)) 49 | in 50 | 51 | let _ = List.init 99 (fun _ -> spawn_link acceptor) in 52 | acceptor () 53 | 54 | let () = Riot.run ~config:(Config.make ~workers:0 ()) @@ main 55 | -------------------------------------------------------------------------------- /test/net_timeout_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let server port socket = 4 | Logger.debug (fun f -> f "Started server on %d" port); 5 | process_flag (Trap_exit true); 6 | let _conn, _addr = Net.Tcp_listener.accept socket |> Result.get_ok in 7 | receive () |> ignore; 8 | () 9 | 10 | let () = 11 | Riot.run @@ fun () -> 12 | let _ = Logger.start () |> Result.get_ok in 13 | Logger.set_log_level (Some Info); 14 | let socket, server_port = Port_finder.next_open_port () in 15 | let _server = spawn (fun () -> server server_port socket) in 16 | 17 | let addr = Net.Addr.(tcp loopback server_port) in 18 | let socket = Net.Tcp_stream.connect addr |> Result.get_ok in 19 | 20 | let bufs = IO.Iovec.create ~size:12 () in 21 | (match Net.Tcp_stream.receive ~timeout:10L ~bufs socket with 22 | | exception Syscall_timeout -> 23 | Logger.debug (fun f -> f "receive timeout works") 24 | | Ok _ -> 25 | Logger.error (fun f -> f "receive timeout received something?"); 26 | sleep 0.2; 27 | Stdlib.exit 1 28 | | Error err -> 29 | Logger.error (fun f -> f "receive timeout errored: %a" IO.pp_err err); 30 | sleep 0.2; 31 | Stdlib.exit 1); 32 | 33 | (* NOTE(@leostera): sending small things is way faster than our minimum timer wheel ticks *) 34 | let bytes = Bytes.make (1_024 * 1_024 * 1_024) 'a' in 35 | let bufs = IO.Iovec.of_bytes bytes in 36 | (match Net.Tcp_stream.send ~timeout:10L ~bufs socket with 37 | | exception Receive_timeout -> Logger.debug (fun f -> f "send timeout works") 38 | | Ok len -> 39 | Logger.error (fun f -> f "send timeout sent something?: %d bytes" len); 40 | sleep 0.2; 41 | Stdlib.exit 1 42 | | Error err -> 43 | Logger.error (fun f -> f "send timeout errored: %a" IO.pp_err err); 44 | sleep 0.2; 45 | Stdlib.exit 1); 46 | 47 | Logger.info (fun f -> f "net_timeout_test: OK") 48 | -------------------------------------------------------------------------------- /test/net_reader_writer_timeout_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let server port socket = 4 | Logger.debug (fun f -> f "Started server on %d" port); 5 | let _conn, _addr = Net.Tcp_listener.accept socket |> Result.get_ok in 6 | Logger.debug (fun f -> f "accepted connection"); 7 | receive () |> ignore; 8 | () 9 | 10 | let () = 11 | Riot.run @@ fun () -> 12 | let _ = Logger.start () |> Result.get_ok in 13 | Logger.set_log_level (Some Info); 14 | let socket, server_port = Port_finder.next_open_port () in 15 | let _server = spawn (fun () -> server server_port socket) in 16 | 17 | let addr = Net.Addr.(tcp loopback server_port) in 18 | let socket = Net.Tcp_stream.connect addr |> Result.get_ok in 19 | Logger.debug (fun f -> f "connected"); 20 | 21 | let buf = IO.Bytes.with_capacity 10 in 22 | let reader = Net.Tcp_stream.to_reader ~timeout:10L socket in 23 | (match IO.read reader buf with 24 | | exception Syscall_timeout -> 25 | Logger.debug (fun f -> f "receive timeout works") 26 | | Ok _ -> 27 | Logger.error (fun f -> f "receive timeout received something?"); 28 | sleep 0.2; 29 | Stdlib.exit 1 30 | | Error err -> 31 | Logger.error (fun f -> f "receive timeout errored: %a" IO.pp_err err); 32 | sleep 0.2; 33 | Stdlib.exit 1); 34 | 35 | let bufs = IO.Iovec.with_capacity 1024 in 36 | let writer = Net.Tcp_stream.to_writer ~timeout:10L socket in 37 | (match IO.write_owned_vectored ~bufs writer with 38 | | exception Syscall_timeout -> Logger.debug (fun f -> f "send timeout works") 39 | | Ok bytes -> 40 | Logger.error (fun f -> f "send timeout sent %d bytes?" bytes); 41 | sleep 0.2; 42 | Stdlib.exit 1 43 | | Error err -> 44 | Logger.error (fun f -> f "send timeout errored: %a" IO.pp_err err); 45 | sleep 0.2; 46 | Stdlib.exit 1); 47 | 48 | Logger.info (fun f -> f "net_reader_writer_timeout: OK"); 49 | shutdown () 50 | -------------------------------------------------------------------------------- /examples/2-spawn-process/README.md: -------------------------------------------------------------------------------- 1 | # `2-spawn-process` 2 | 3 | A _Process_ is a long-lived function, that has access to a mailbox to receive 4 | messages. 5 | 6 | Here's how we can create a process to print out the message from the last tutorial: 7 | 8 | ```ocaml 9 | Riot.run @@ fun () -> 10 | let open Riot in 11 | let pid = spawn (fun () -> print_endline "Hello, Joe!") in 12 | ``` 13 | 14 | Riot has a `spawn` function that can be used to create a new process. Riot 15 | processes are _cheap_, and Riot programs can have millions of processes. They 16 | are not like Operating System processes (or threads), and are closer to 17 | green-threads or fibers. 18 | 19 | `spawn` takes a `unit -> unit` function as an input, and will give us back a 20 | _pid_. A `Pid` is a Process Identifier. Pids are unique during the execution of a 21 | program and can be used to send messages to processes, to check if they are 22 | still alive, and to terminate them. 23 | 24 | ```ocaml 25 | let pid = spawn (fun () -> print_endline "Hello, Joe!") in 26 | ``` 27 | 28 | Inside of a process, we can get the pid of the process by calling `self ()`. A 29 | Pid can also be pretty-printed with `Pid.pp` but it is not serializable. 30 | 31 | ```ocaml 32 | let pid = spawn (fun () -> Format.printf "Hello, %a!" Pid.pp (self ())) in 33 | ``` 34 | 35 | A common scenario is waiting for a number of pids to terminate. For this Riot 36 | offers a `wait_pids` function that will return after all the pids are finished. 37 | 38 | Be mindful that if the pids do not terminate, this function will get the caller 39 | process stuck in that wait loop. We will see later in this tutorial more 40 | flexible mechanisms for detecting when other processes terminate. 41 | 42 | ```ocaml 43 | wait_pids [pid] 44 | ``` 45 | 46 | And as before, if we want the runtime to finish, we should call `shutdown ()`. 47 | 48 | ## Next Steps 49 | 50 | * the [next step](../3-message-passing/) introduces you to communicating processes and Message passing 51 | -------------------------------------------------------------------------------- /test/fixtures/tls.crt: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIFSzCCAzOgAwIBAgIUDqxfiGDtqNRUH4jtEy/0rzWRlOkwDQYJKoZIhvcNAQEL 3 | BQAwNTESMBAGA1UEAwwJbG9jYWxob3N0MQswCQYDVQQGEwJTRTESMBAGA1UEBwwJ 4 | U3RvY2tob2xtMB4XDTIzMTIyNzAyMTczN1oXDTMzMTIyNDAyMTczN1owNTESMBAG 5 | A1UEAwwJbG9jYWxob3N0MQswCQYDVQQGEwJTRTESMBAGA1UEBwwJU3RvY2tob2xt 6 | MIICIjANBgkqhkiG9w0BAQEFAAOCAg8AMIICCgKCAgEAx9Z2zhjg5SyUX85WMkhs 7 | kajgRR5bqGKPhqglbdtslxwG4lgL6tzPWAEJ0i9L2vBkdGNg27EdwFrui3VJYjRe 8 | 5T8w2h83hQ8P4IEq2LEhuhFHEeC7DSf11dESFZ/HEa9am6d3Xv0qAdg+5S1GSmjU 9 | 1eBx53o2jlQc2eEcZ8488Nf/+61MDufKZDr1yCOXzudXJO+O41h+S7I1XSVPlN7r 10 | ouRq5U+e37GoRdTnuyLIQ1XnHgXELNwG1LKDJstdsOwl6Z7o1Mtb/R3Ja+3YHwfW 11 | pDNyt0a8WAPPM6bzMFNjCml+8h1SfBX7uYEz9PTxY9WYLyy/Dg9Vwi6qnlkG8XbL 12 | yYCV4sg/IRXy32kg3mHZd10rcKbJp7Jx4nZ25teg8/s9WEIz64CfPvyapS3PIJbl 13 | nwPzsi6G2MDy1ZM6J9OlFpAAu2kjvocs9dwmiVutHEWGyJ2VN5ykV5NgPzd0p+x+ 14 | C4kQGie/engXwgM7Xz20zmJk4Atfe7r8FTxD6lwuGGdSG4nVZy+ugodXWLUq7ROi 15 | DM4cxTgq1ZEydoXTvCQ6Vds5mcA/hBZjggkXpyqRuUFKTMsL+FF9nMRtA2IwKXlg 16 | 5VNiXNS+p2oW7z75SOoKJtK5G7EwOMxv3OCdSqCSK1Qd4Rz4a6E9McxbmV99J838 17 | RKOwocMXiv6VMsVC6+tuyfUCAwEAAaNTMFEwHQYDVR0OBBYEFOneKxyRtEPYqcc1 18 | iCD+bCZmXg0/MB8GA1UdIwQYMBaAFOneKxyRtEPYqcc1iCD+bCZmXg0/MA8GA1Ud 19 | EwEB/wQFMAMBAf8wDQYJKoZIhvcNAQELBQADggIBAJ/mACwlugqWYMjLO2JjUGe0 20 | NMTCrvelfZI+GIJXZJj5zWHNng5XpcJ+kTtG5nm763RbWs6Whl7fqScel06fwoD7 21 | oYQ1GOE4boCwo0rA8cGtxKOAmkAx+LPuo+Id2pYQTT9SR6GvngaBhvY6gbbaWOkp 22 | jk6vlrUGXd0lP7TtwH8j1ijewKQBpEEAuZOP17R9r9R6j9e3qvrqIMP9s6Cr0wLW 23 | PMQaPPHV0priuQyMq1B4EIAZKqXVL4E6r+YW/hOl3MiU7XTyxjY2xfT50S7Q/Es5 24 | Hl7c9dZDGzs8CnObOPqRUTGkQjKGWpDajQp1+h44wqwoIEgHrmKQArK5yrAgYqhj 25 | MP3hy1MqYaIPkHBn1q7p6SJVdp3WWVhU6MhwgcKFF5W13MBOvunhqscVq1nhbMoq 26 | kGWYNFoP/Ocbjfex1pnxPTxZWcXNWVa/jHBorwiOPYw2vcktz2CJlxKpAVrDrJzE 27 | Tr0shvWuqDqqZdlLmTH61VMPCj+H0cJnqmaDPf1utq6nD8oAyrVocI88brIeloWg 28 | Kjla/4Nt1pqlg47hmgWzS8a4WFsUMICWWOcqDiPh6qFQlqyt0TE5kjlK1odUrfG9 29 | /oaMUlOgg7VI4zkAetp4mqjHdQ9EQsgr7gCeaohFO27pgiOwf9fC58Td9g01Q9Mr 30 | KXM1CjcPdn+GO3MMPZFe 31 | -----END CERTIFICATE----- 32 | -------------------------------------------------------------------------------- /packages/riot-stdlib/dynamic_supervisor.ml: -------------------------------------------------------------------------------- 1 | open Global 2 | 3 | open Logger.Make (struct 4 | let namespace = [ "riot"; "dynamic_supervisor" ] 5 | end) 6 | 7 | type state = { max_children : int; curr_children : int; name : string } 8 | 9 | type Message.t += 10 | | Start_child of Pid.t * Supervisor.child_spec 11 | | Started_child of Pid.t 12 | | Max_children 13 | 14 | let rec loop state = 15 | match receive_any () with 16 | | Process.Messages.Monitor _ -> 17 | trace (fun f -> f "child finished"); 18 | loop { state with curr_children = Int.max 0 (state.curr_children - 1) } 19 | | Start_child (reply, spec) -> handle_start_child state reply spec 20 | | _ -> loop state 21 | 22 | and handle_start_child state reply child_spec = 23 | let curr_children = state.curr_children + 1 in 24 | if curr_children < state.max_children then ( 25 | let pid = Supervisor.start_child child_spec in 26 | Process.monitor pid; 27 | trace (fun f -> f "started child %d" curr_children); 28 | send reply (Started_child pid); 29 | loop { state with curr_children }) 30 | else ( 31 | send reply Max_children; 32 | loop state) 33 | 34 | let init ({ max_children; name; _ } as state) = 35 | register name (self ()); 36 | Process.flag (Trap_exit true); 37 | trace (fun f -> f "max %d children" max_children); 38 | loop state 39 | 40 | let start_link state = 41 | let pid = spawn_link (fun () -> init state) in 42 | Ok pid 43 | 44 | let child_spec ?(max_children = 50) ~name () = 45 | let state = { max_children; curr_children = 0; name } in 46 | Supervisor.child_spec start_link state 47 | 48 | let start_child pid spec = 49 | let ref = Ref.make () in 50 | send pid (Start_child (self (), spec)); 51 | let selector msg = 52 | match msg with 53 | | Started_child pid -> `select (`started_child pid) 54 | | Max_children -> `select `max_children 55 | | _ -> `skip 56 | in 57 | match receive ~selector ~ref () with 58 | | `started_child pid -> Ok pid 59 | | `max_children -> Error `Max_children 60 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_queue.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | 3 | module Lf_queue = struct 4 | type 'a t = 'a Queue.t 5 | 6 | let create () = Queue.create () 7 | let push q el = Queue.push el q 8 | let pop q = Queue.take_opt q 9 | end 10 | 11 | type priority_queues = { 12 | high : Process.t Weak_ref.t Lf_queue.t; 13 | normal : Process.t Weak_ref.t Lf_queue.t; 14 | low : Process.t Weak_ref.t Lf_queue.t; 15 | } 16 | 17 | let make_priority_queues () = 18 | { 19 | high = Lf_queue.create (); 20 | normal = Lf_queue.create (); 21 | low = Lf_queue.create (); 22 | } 23 | 24 | type t = { alive : Proc_set.t; queue : priority_queues; lock : Mutex.t } 25 | 26 | let create () = 27 | { 28 | queue = make_priority_queues (); 29 | alive = Proc_set.create (); 30 | lock = Mutex.create (); 31 | } 32 | 33 | let size t = Proc_set.size t.alive 34 | let is_empty t = size t = 0 35 | 36 | let rec queue t proc = 37 | if Mutex.try_lock t.lock then ( 38 | if Proc_set.contains t.alive proc then () 39 | else ( 40 | Proc_set.add t.alive proc; 41 | let wref = Weak_ref.make proc in 42 | match Atomic.get proc.flags.priority with 43 | | High -> Lf_queue.push t.queue.high wref 44 | | Normal -> Lf_queue.push t.queue.normal wref 45 | | Low -> Lf_queue.push t.queue.low wref); 46 | Mutex.unlock t.lock) 47 | else queue t proc 48 | 49 | let do_pop t queue = 50 | match Lf_queue.pop queue with 51 | | Some proc -> ( 52 | match Weak_ref.get proc with 53 | | Some proc when Proc_set.contains t.alive proc -> 54 | Proc_set.remove t.alive proc; 55 | Some proc 56 | | _ -> None) 57 | | None -> None 58 | 59 | let next t = 60 | if Mutex.try_lock t.lock then ( 61 | let proc = 62 | match do_pop t t.queue.high with 63 | | Some proc -> Some proc 64 | | None -> ( 65 | match do_pop t t.queue.normal with 66 | | Some proc -> Some proc 67 | | None -> do_pop t t.queue.low) 68 | in 69 | Mutex.unlock t.lock; 70 | proc) 71 | else None 72 | 73 | let remove t proc = Proc_set.remove t.alive proc 74 | -------------------------------------------------------------------------------- /examples/4-long-lived-processes/README.md: -------------------------------------------------------------------------------- 1 | # `4-long-lived-processes` 2 | 3 | Up until now, we have only dealt with processes that start, do some work, and 4 | immediately die: either prints something and terminates, or waits for a message 5 | and once the message arrives, it terminates. 6 | 7 | But real systems are built out of long-living processes that can handle more 8 | than a single message. How do we build those? Recursion, baby! 9 | 10 | ```ocaml 11 | let pid = spawn (fun () -> loop ()) in 12 | (* ... *) 13 | ``` 14 | 15 | To make a process that will live indefinitely, you just need to make a 16 | recursive function. This has some advantages: 17 | 18 | 1. it is a very familiar way of programming in OCaml 19 | 2. it gives us State in a functional way (no mutation required!) 20 | 21 | So let's do this! We'll write a process that recieves a message, says Hello to 22 | someone, and continues awaiting. 23 | 24 | ```ocaml 25 | let rec loop () = 26 | (match receive_any () with 27 | | Hello name -> print_endline ("Hello, " ^ name ^ "! :D") 28 | | _ -> print_endline "Oh no, an unhandled message! D:"); 29 | loop () 30 | ``` 31 | 32 | As we saw on the [message-passing tutorial](/3-message-passing/), processes can 33 | receive all sorts of messages that we don't know about, although they will all 34 | be typed, so we include a little catch-all to ignore unhandleable messages. 35 | 36 | One caveat is that because function application can't be interrupted, we need 37 | to make sure we _yield_ control back to the scheduler at some point before 38 | recursing. Otherwise one of the cores will be _blocked_ by this process until it yields. 39 | 40 | In our example, this is done automatically when we call `receive_any` 41 | 42 | In fact, we are strategically placing yields all through the standard library 43 | to make it as seamless as possible to write Riot programs without thinking 44 | about scheduler starvation. 45 | 46 | ## Next Steps 47 | 48 | * the [next step](../5-links-and-monitors/) introduces you to links and 49 | monitors, to keep track of the lifecycle of a process or to make the 50 | lifecycle of a process be linked to another 51 | -------------------------------------------------------------------------------- /packages/riot-runtime/log/log.ml: -------------------------------------------------------------------------------- 1 | (** Low-level mutex-coordinated logs for the Riot engine. 2 | These are super slow, and are intended for usage within the engine alone. 3 | 4 | If you're looking for logs for your application, look into 5 | {!module:Riot.Logger} instead. 6 | *) 7 | 8 | type level = Debug | Error | Info | Trace | Warn 9 | 10 | let level_to_int = function 11 | | Trace -> 5 12 | | Debug -> 4 13 | | Info -> 2 14 | | Warn -> 1 15 | | Error -> 0 16 | 17 | let level_to_color_string t = 18 | match t with 19 | | Error -> "\x1b[31m" 20 | | Warn -> "\x1b[33m" 21 | | Debug -> "\x1b[36m" 22 | | Info -> "" 23 | | Trace -> "" 24 | 25 | let log_level = Atomic.make (Some Error) 26 | let set_log_level x = Atomic.set log_level x 27 | 28 | let should_log x = 29 | match Atomic.get log_level with 30 | | None -> false 31 | | Some log_level -> level_to_int x <= level_to_int log_level 32 | 33 | let pp_level ppf t = 34 | match t with 35 | | Error -> Format.fprintf ppf "ERROR " 36 | | Warn -> Format.fprintf ppf "WARN " 37 | | Debug -> Format.fprintf ppf "DEBUG " 38 | | Info -> Format.fprintf ppf "INFO " 39 | | Trace -> Format.fprintf ppf "TRACE " 40 | 41 | type ('a, 'b) message_format = 42 | (('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b 43 | 44 | let log_lock = Mutex.create () 45 | 46 | let stdout = 47 | Format.make_formatter (output_substring stdout) (fun () -> flush stdout) 48 | 49 | let msg : type a. level -> (a, unit) message_format -> unit = 50 | fun level msgf -> 51 | msgf @@ fun fmt -> 52 | Mutex.lock log_lock; 53 | let domain = (Domain.self () :> int) in 54 | Format.kfprintf 55 | (fun _ -> Mutex.unlock log_lock) 56 | stdout 57 | ("%s%a %a[thread=%d] @[" ^^ fmt ^^ "@]@.\x1b[0m%!") 58 | (level_to_color_string level) 59 | (Ptime.pp_rfc3339 ~frac_s:5 ~space:true ~tz_offset_s:0 ()) 60 | (Ptime_clock.now ()) pp_level level domain 61 | 62 | let trace msgf = if should_log Trace then msg Trace msgf 63 | let debug msgf = if should_log Debug then msg Debug msgf 64 | let info msgf = if should_log Info then msg Info msgf 65 | let warn msgf = if should_log Warn then msg Warn msgf 66 | let error msgf = if should_log Error then msg Error msgf 67 | -------------------------------------------------------------------------------- /packages/riot-stdlib/file.ml: -------------------------------------------------------------------------------- 1 | open Gluon 2 | open Global 3 | 4 | type 'kind file = { fd : Fd.t; path : string } 5 | type read_file = [ `r ] file 6 | type write_file = [ `w ] file 7 | type rw_file = [ `w | `r ] file 8 | 9 | let fd t = t.fd 10 | let base_permissions = 0o640 11 | 12 | let do_open ?(permissions = base_permissions) path flags = 13 | let raw_fd = Unix.openfile path flags permissions in 14 | { fd = Fd.make raw_fd; path } 15 | 16 | let open_read ?permissions path = do_open ?permissions path Unix.[ O_RDONLY ] 17 | 18 | let open_write ?permissions path = 19 | do_open ?permissions path Unix.[ O_WRONLY; O_CREAT ] 20 | 21 | let close t = Fd.close t.fd 22 | let remove path = Unix.unlink path 23 | let seek t ~off = Fd.seek t.fd off Unix.SEEK_SET 24 | let stat path = Unix.stat path 25 | 26 | let exists path = 27 | match Unix.stat path with 28 | | exception Unix.Unix_error (Unix.ENOENT, _, _) -> false 29 | | (exception _) | _ -> true 30 | 31 | module Read = struct 32 | type t = read_file 33 | 34 | let rec read t ?timeout buf = 35 | match File.read t.fd buf ~pos:0 ~len:(Rio.Bytes.length buf) with 36 | | Ok n -> Ok n 37 | | Error `Would_block -> 38 | syscall ?timeout "File.read" Interest.readable (File.to_source t.fd) 39 | @@ fun _ -> read t ?timeout buf 40 | | Error err -> Error err 41 | 42 | let rec read_vectored t bufs = 43 | match File.read_vectored t.fd bufs with 44 | | Ok n -> Ok n 45 | | Error `Would_block -> 46 | syscall "File.read_vectored" Interest.readable (File.to_source t.fd) 47 | @@ fun _ -> read_vectored t bufs 48 | | Error err -> Error err 49 | end 50 | 51 | let to_reader t = Rio.Reader.of_read_src (module Read) t 52 | 53 | module Write = struct 54 | type t = write_file 55 | 56 | let size t = (stat t).st_size 57 | 58 | let rec write_owned_vectored t ~bufs = 59 | match File.write_vectored t.fd bufs with 60 | | Ok n -> Ok n 61 | | Error `Would_block -> 62 | syscall "File.write_vectored" Interest.writable (File.to_source t.fd) 63 | @@ fun _ -> write_owned_vectored t ~bufs 64 | | Error err -> Error err 65 | 66 | let write t ~buf = 67 | let bufs = Rio.Iovec.from_string buf in 68 | write_owned_vectored t ~bufs 69 | 70 | let flush _t = Ok () 71 | end 72 | 73 | let to_writer t = Rio.Writer.of_write_src (module Write) t 74 | -------------------------------------------------------------------------------- /packages/riot-stdlib/runtime_lib.ml: -------------------------------------------------------------------------------- 1 | open Global 2 | 3 | let set_log_level = Riot_runtime.Log.set_log_level 4 | 5 | let syscalls () = 6 | let pool = _get_pool () in 7 | ( pool.io_scheduler.calls_accept, 8 | pool.io_scheduler.calls_receive, 9 | pool.io_scheduler.calls_send, 10 | pool.io_scheduler.calls_connect ) 11 | 12 | module Stats = struct 13 | open Logger.Make (struct 14 | let namespace = [ "riot"; "runtime"; "stats" ] 15 | end) 16 | 17 | type Message.t += Print_stats 18 | 19 | let mb b = Int.to_float b /. 1024.0 /. 1024.0 20 | 21 | let print_scheduler_stats () = 22 | let pool = _get_pool () in 23 | let total_processes = pool.proc_count in 24 | let processes = processes () |> List.of_seq in 25 | let live_process_count = processes |> List.length in 26 | let total_schedulers = pool.schedulers |> List.length in 27 | let breakdown = 28 | pool.schedulers 29 | |> List.map (fun (sch : Riot_runtime.Scheduler.t) -> 30 | Format.asprintf " sch #%a [live_procs=%d; timers=%d]" 31 | Riot_runtime.Core.Scheduler_uid.pp sch.uid 32 | (Riot_runtime.Core.Proc_queue.size sch.run_queue) 33 | (Riot_runtime.Time.Timer_wheel.size sch.timers)) 34 | |> String.concat "\n" 35 | in 36 | info (fun f -> 37 | f 38 | {|pool: 39 | 40 | live_processes: %d 41 | total_processes: %d 42 | total_schedulers: %d 43 | %s 44 | |} 45 | live_process_count total_processes total_schedulers breakdown) 46 | 47 | let print_gc_stats () = 48 | let stat = Gc.stat () in 49 | info (fun f -> 50 | f 51 | {|gc_stats: 52 | live_bytes=%f mb in %d blocks 53 | free_bytes=%f mb in %d blocks 54 | heap_bytes=%f mb in %d chunks 55 | max_heap_size=%f mb 56 | fragments=%d 57 | compactions=%d 58 | |} 59 | (stat.live_words * 8 |> mb) 60 | stat.live_blocks 61 | (stat.free_words * 8 |> mb) 62 | stat.free_blocks 63 | (stat.heap_words * 8 |> mb) 64 | stat.heap_chunks 65 | (stat.top_heap_words * 8 |> mb) 66 | stat.fragments stat.compactions) 67 | 68 | let rec loop () = 69 | print_scheduler_stats (); 70 | print_gc_stats (); 71 | receive_any () |> ignore; 72 | loop () 73 | 74 | let start ?(every = 2_000_000L) () = 75 | let stats = spawn loop in 76 | Timer.send_interval stats Print_stats ~every |> ignore 77 | end 78 | -------------------------------------------------------------------------------- /packages/riot-stdlib/logger_app.ml: -------------------------------------------------------------------------------- 1 | open Global 2 | include Logger 3 | 4 | open Logger.Make (struct 5 | let namespace = [ "riot"; "logger" ] 6 | end) 7 | 8 | type Message.t += Logger_ready 9 | 10 | module Formatter = struct 11 | type Message.t += Log of log 12 | 13 | let stdout = 14 | Format.make_formatter (output_substring stdout) (fun () -> flush stdout) 15 | 16 | let rec formatter_loop config = 17 | match receive_any () with 18 | | Log { message; ts; src = sch, pid; level; ns } -> 19 | let pp_now = Ptime.pp_rfc3339 ~frac_s:5 ~space:true ~tz_offset_s:0 () in 20 | 21 | let ns_str = 22 | match ns with [] -> "" | _ -> String.concat "." ns ^ "::" 23 | in 24 | 25 | let buf = Buffer.create 128 in 26 | let fmt = Format.formatter_of_buffer buf in 27 | 28 | if config.color_output then 29 | Format.fprintf fmt "%s" (Level.to_color_string level); 30 | if config.print_time then ( 31 | let parts = 32 | Format.asprintf "%a" pp_now ts |> String.split_on_char ' ' 33 | in 34 | let time = List.nth parts 1 in 35 | Format.fprintf fmt "%s " time; 36 | if config.print_source then 37 | Format.fprintf fmt "[thread=%a,pid=%a] " Scheduler_uid.pp sch Pid.pp 38 | pid; 39 | Format.fprintf fmt "[%s%a] %s\x1b[0m\n%!" ns_str Level.pp level 40 | message; 41 | 42 | Format.fprintf fmt "%!"; 43 | Format.printf "%s%!" (Buffer.contents buf); 44 | 45 | formatter_loop config) 46 | | _ -> formatter_loop config 47 | 48 | let start_link config = 49 | let pid = 50 | spawn_link (fun () -> 51 | Process.flag (Priority High); 52 | send config.started_by Logger_ready; 53 | formatter_loop config.opts) 54 | in 55 | set_on_log (fun log -> send pid (Log log)); 56 | Ok pid 57 | 58 | let child_spec config = Supervisor.child_spec start_link config 59 | end 60 | 61 | let default_opts = 62 | { print_time = true; print_source = false; color_output = true } 63 | 64 | let start () = 65 | let this = self () in 66 | let config = { opts = default_opts; started_by = this } in 67 | let child_specs = [ Formatter.child_spec config ] in 68 | let result = Supervisor.start_link ~child_specs () in 69 | let `ready = 70 | let selector msg = if msg = Logger_ready then `select `ready else `skip in 71 | receive ~selector () 72 | in 73 | result 74 | -------------------------------------------------------------------------------- /packages/riot/riot.ml: -------------------------------------------------------------------------------- 1 | include Riot_stdlib 2 | 3 | open struct 4 | open Riot_runtime 5 | module Config = Config 6 | module Log = Log 7 | module Core = Core 8 | module Import = Import 9 | module Util = Util 10 | module Scheduler = Scheduler 11 | module Time = Time 12 | end 13 | 14 | module Config = Config 15 | 16 | open Logger.Make (struct 17 | let namespace = [ "riot" ] 18 | end) 19 | 20 | exception Riot_already_started 21 | 22 | let shutdown ?(status = 0) () = 23 | debug (fun f -> f "RIOT IS SHUTTING DOWN!"); 24 | let pool = _get_pool () in 25 | Scheduler.Pool.shutdown pool status 26 | 27 | let started = ref false 28 | 29 | let run ?(config = Config.default ()) main = 30 | if !started then raise Riot_already_started else started := true; 31 | 32 | let Config.{ workers; rnd; _ } = config in 33 | 34 | Log.debug (fun f -> f "Initializing Riot runtime...\n%a" Config.pp config); 35 | 36 | Printexc.record_backtrace true; 37 | Core.Pid.reset (); 38 | Scheduler.Uid.reset (); 39 | 40 | let sch0 = Scheduler.make ~rnd () in 41 | let pool, _domains = Scheduler.Pool.make ~main:sch0 ~domains:workers () in 42 | 43 | Scheduler.set_current_scheduler sch0; 44 | Scheduler.Pool.set_pool pool; 45 | 46 | let _pid = _spawn ~pool ~scheduler:sch0 main in 47 | Scheduler.run pool sch0 (); 48 | 49 | Log.debug (fun f -> f "Riot runtime shutdown"); 50 | Stdlib.exit pool.status 51 | 52 | let on_error (error : [ `Msg of string ]) = 53 | let backtrace = Printexc.get_backtrace () in 54 | let error_string = 55 | match error with `Msg reason -> Printf.sprintf "%s\n%s" reason backtrace 56 | in 57 | Log.error (fun f -> f "Riot raised an error: %s\n" error_string); 58 | 1 59 | 60 | let run_with_status ?config ~on_error main = 61 | run ?config @@ fun _ -> 62 | let status = 63 | match main () with Ok code -> code | Error reason -> on_error reason 64 | in 65 | shutdown ~status () 66 | 67 | let start ?(config = Config.default ()) ~apps () = 68 | run ~config @@ fun () -> 69 | let child_specs = 70 | List.map 71 | (fun (module App : Application.Intf) -> 72 | Supervisor.child_spec App.start ()) 73 | apps 74 | in 75 | let restart_limit = config.supervisor_restart_limit in 76 | let restart_period = config.supervisor_restart_period in 77 | Supervisor.( 78 | start_supervisor 79 | { 80 | strategy = One_for_one; 81 | restart_limit; 82 | restart_period; 83 | child_specs; 84 | children = []; 85 | restarts = []; 86 | }) 87 | -------------------------------------------------------------------------------- /test/gen-servers/main.ml: -------------------------------------------------------------------------------- 1 | [@@@warning "-8"] 2 | [@@@warning "-37"] 3 | [@@@warning "-69"] 4 | [@@@warning "-32"] 5 | 6 | open Riot 7 | 8 | module Twitch = struct 9 | module Logger = Logger.Make (struct 10 | let namespace = [ "twitch" ] 11 | end) 12 | 13 | let info = Logger.info 14 | 15 | type user = { name : string; email : string } 16 | type profile_req = { id : int } 17 | type error = [ `Bad_user_id of int ] 18 | 19 | type _ Gen_server.req += 20 | | Is_connected : bool Gen_server.req 21 | | Status_value : int Gen_server.req 22 | | Profile : 23 | profile_req 24 | -> (user, [ `Twitch_error of error ]) result Gen_server.req 25 | 26 | type Gen_server.cont_req += Update_status : int -> Gen_server.cont_req 27 | type args = { verbose : bool } 28 | 29 | module Server : Gen_server.Impl with type args = args = struct 30 | type nonrec args = args 31 | type state = { status : int } 32 | 33 | let init _args = Gen_server.Ok { status = 1 } 34 | 35 | let handle_call : 36 | type res. 37 | res Gen_server.req -> 38 | Pid.t -> 39 | state -> 40 | (res, state) Gen_server.call_result = 41 | fun req _from state -> 42 | match req with 43 | | Is_connected -> Gen_server.Reply (true, state) 44 | | Status_value -> Gen_server.Reply (state.status, state) 45 | | Profile _ -> 46 | Gen_server.Reply_continue 47 | ( Ok { name = "Jonathan Archer"; email = "archer4eva@starfl.it" }, 48 | state, 49 | Update_status 2 ) 50 | 51 | let handle_info _msg _state = () 52 | 53 | let handle_continue cont_req _state = 54 | match cont_req with Update_status n -> { status = n } 55 | 56 | let handle_cast _cast_req _state = failwith "unimplemented" 57 | end 58 | 59 | let start_link ?(verbose = false) () = 60 | Gen_server.start_link (module Server) { verbose } 61 | 62 | let is_connected pid = Gen_server.call pid Is_connected 63 | let profile pid ~id = Gen_server.call pid (Profile { id }) 64 | let status pid = Gen_server.call pid Status_value 65 | end 66 | 67 | let main () = 68 | let (Ok _) = Logger.start () in 69 | let (Ok pid) = Twitch.start_link () in 70 | if Twitch.is_connected pid then Logger.info (fun f -> f "connected to twitch"); 71 | let status = Twitch.status pid in 72 | Logger.info (fun f -> f "Status is %d" status); 73 | let (Ok user) = Twitch.profile pid ~id:1 in 74 | Logger.info (fun f -> f "Welcome, %s!" user.name); 75 | let status = Twitch.status pid in 76 | Logger.info (fun f -> f "Status is %d" status) 77 | 78 | let () = Riot.run @@ main 79 | -------------------------------------------------------------------------------- /packages/riot-stdlib/crypto.ml: -------------------------------------------------------------------------------- 1 | let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) 2 | 3 | (* Some of the code from below is based on the randomconv repository. 4 | Source: https://github.com/hannesm/randomconv/ 5 | The original code is licensed under the following license: 6 | 7 | Copyright (c) 2016 Hannes Mehnert hannes@mehnert.org 8 | 9 | Permission to use, copy, modify, and distribute this software for any 10 | purpose with or without fee is hereby granted, provided that the above 11 | copyright notice and this permission notice appear in all copies. 12 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 13 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 14 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 15 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 16 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 17 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 18 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 19 | *) 20 | 21 | module Random = struct 22 | let string n = Mirage_crypto_rng.generate n 23 | let int8 () = Bytes.get_uint8 (Bytes.unsafe_of_string (string 1)) 0 24 | let int16 () = Bytes.get_uint16_le (Bytes.unsafe_of_string (string 2)) 0 25 | let int32 () = Bytes.get_int32_le (Bytes.unsafe_of_string (string 4)) 0 26 | let int64 () = Bytes.get_int64_le (Bytes.unsafe_of_string (string 8)) 0 27 | 28 | let bitmask n = 29 | let rec go c = function 0 -> c | n -> go (c lsl 1) (n lsr 1) in 30 | go 1 n - 1 31 | 32 | let rec int ?(max = max_int) () = 33 | if max <= 0 then invalid_arg "bound smaller or equal 0 not supported"; 34 | if max = 1 then 0 35 | else 36 | let r = 37 | if max <= 256 then int8 () 38 | else if max <= 65536 then int16 () 39 | else 40 | match Sys.word_size with 41 | | 32 -> Int32.to_int (int32 ()) 42 | | 64 -> Int64.to_int (int64 ()) 43 | | _ -> invalid_arg "unknown word size" 44 | in 45 | let r = r land bitmask (pred max) in 46 | if r < max then r else int ~max () 47 | 48 | let float ?(max = 1.) () = 49 | if max <= 0. then invalid_arg "bound smaller or equal 0 not supported"; 50 | let scale = float_of_int max_int and r1 = int () and r2 = int () in 51 | max *. (((float_of_int r1 /. scale) +. float_of_int r2) /. scale) 52 | 53 | let char () = Char.chr (int8 ()) 54 | let bytes n = string n |> Bytes.unsafe_of_string 55 | let bytestring n = string n |> Bytestring.of_string 56 | let alphanum () = Char.chr (48 + int ~max:74 ()) 57 | let seq n gen = List.init n (fun _ -> gen ()) |> List.to_seq |> String.of_seq 58 | end 59 | -------------------------------------------------------------------------------- /test/process_registration_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | module Registry_test = struct 4 | type Message.t += Hello 5 | 6 | let test () = 7 | Logger.set_log_level (Some Info); 8 | let pid = self () in 9 | let pid_name = "my pid" in 10 | 11 | (* send to unregistered process raises *) 12 | (try send_by_name ~name:pid_name Hello with 13 | | Invalid_destination "my pid" -> 14 | Logger.debug (fun f -> 15 | f "process_registration_test: unregistered send raises correctly") 16 | | Invalid_destination name2 -> 17 | Logger.error (fun f -> 18 | f "process_registration_test: invalid destination! %s" name2); 19 | Stdlib.exit 1); 20 | 21 | (* register the process once *) 22 | register pid_name pid; 23 | 24 | send_by_name ~name:pid_name Hello; 25 | 26 | (match[@warning "-8"] receive_any ~after:500_000L () with 27 | | Hello -> 28 | Logger.debug (fun f -> 29 | f "process_registration_test: send_by_name works")); 30 | 31 | (* try to register it again *) 32 | (try register pid_name pid with 33 | | Name_already_registered ("my pid", pid2) when Pid.equal pid pid2 -> 34 | Logger.debug (fun f -> 35 | f "process_registration_test: double register disallowed") 36 | | Name_already_registered (name, pid2) -> 37 | Logger.error (fun f -> 38 | f "process_registration_test: double registered! %s <-> %a" name 39 | Pid.pp pid2); 40 | Stdlib.exit 1); 41 | 42 | (* unregister/register again *) 43 | unregister pid_name; 44 | register pid_name pid; 45 | Logger.debug (fun f -> f "process_registration_test: unregistering works"); 46 | 47 | (* test sending a message by name to a registered process that died *) 48 | let pid2 = spawn (fun () -> sleep 0.1) in 49 | let pid2_name = "another-name" in 50 | register pid2_name pid2; 51 | 52 | (* wait at least the same amount as it will be alive *) 53 | sleep 0.2; 54 | 55 | (* send to unregistered process raises *) 56 | (match send_by_name ~name:pid2_name Hello with 57 | | exception Invalid_destination "another-name" -> 58 | Logger.debug (fun f -> 59 | f "process_registration_test: dead send by name raises correctly") 60 | | _ -> 61 | Logger.error (fun f -> 62 | f 63 | "process_registration_test: send to dead process by name \ 64 | should've raised!"); 65 | Stdlib.exit 1); 66 | 67 | Logger.info (fun f -> f "process_registration_test: OK"); 68 | 69 | shutdown () 70 | 71 | let start () = 72 | let pid = spawn_link test in 73 | Ok pid 74 | end 75 | 76 | let () = 77 | Riot.start 78 | ~apps: 79 | [ (module Riot.Telemetry); (module Riot.Logger); (module Registry_test) ] 80 | () 81 | -------------------------------------------------------------------------------- /packages/riot-stdlib/gen_server.ml: -------------------------------------------------------------------------------- 1 | open Global 2 | 3 | type 'res req = .. 4 | type cast_req = .. 5 | type cont_req = .. 6 | 7 | type Message.t += 8 | | Call : Pid.t * 'res Ref.t * 'res req -> Message.t 9 | | Cast : cast_req -> Message.t 10 | | Reply : 'res Ref.t * 'res -> Message.t 11 | 12 | type 'state init_result = Ok of 'state | Error | Ignore 13 | 14 | type ('res, 'state) call_result = 15 | | Reply of ('res * 'state) 16 | | Reply_continue of ('res * 'state * cont_req) 17 | 18 | type 'state cast_result = No_reply of 'state 19 | 20 | module type Impl = sig 21 | type args 22 | type state 23 | 24 | val init : args -> state init_result 25 | 26 | val handle_call : 27 | 'res. 'res req -> Pid.t -> state -> ('res, state) call_result 28 | 29 | val handle_cast : cast_req -> state -> state cast_result 30 | val handle_continue : cont_req -> state -> state 31 | val handle_info : Message.t -> state -> unit 32 | end 33 | 34 | type ('args, 'state) impl = 35 | (module Impl with type args = 'args and type state = 'state) 36 | 37 | let call : type res. Pid.t -> res req -> res = 38 | fun pid req -> 39 | let ref = Ref.make () in 40 | send pid (Call (self (), ref, req)); 41 | let selector : res Message.selector = 42 | fun msg -> 43 | match msg with 44 | | Reply (ref', res) -> ( 45 | match Ref.type_equal ref ref' with 46 | | Some Type.Equal -> `select res 47 | | None -> failwith "bad message") 48 | | _ -> `skip 49 | in 50 | receive ~selector () 51 | 52 | let cast pid req = send pid (Cast req) 53 | 54 | let rec loop : type args state. (args, state) impl -> state -> unit = 55 | fun impl state -> 56 | let (module I : Impl with type args = args and type state = state) = impl in 57 | match receive_any () with 58 | | Call (pid, ref, req) -> ( 59 | match I.handle_call req pid state with 60 | | Reply (res, state) -> 61 | send pid (Reply (ref, res)); 62 | loop impl state 63 | | Reply_continue (res, state, cont_req) -> 64 | send pid (Reply (ref, res)); 65 | let state = I.handle_continue cont_req state in 66 | loop impl state) 67 | | Cast req -> ( 68 | match I.handle_cast req state with No_reply state -> loop impl state) 69 | | msg -> 70 | let _res = I.handle_info msg state in 71 | loop impl state 72 | 73 | let start_link : 74 | type args state. 75 | (args, state) impl -> args -> (Pid.t, [> `Exn of exn ]) result = 76 | fun impl args -> 77 | let pid = 78 | spawn_link (fun () -> 79 | let (module I : Impl with type args = args and type state = state) = 80 | impl 81 | in 82 | match I.init args with 83 | | Ok state -> loop impl state 84 | | Error | Ignore -> ()) 85 | in 86 | Ok pid 87 | 88 | module Default = struct 89 | let init _args = Ignore 90 | let handle_call _req _from _state = failwith "unimplemented" 91 | let handle_cast _req _state = failwith "unimplemented" 92 | let handle_continue _req _state = failwith "unimplemented" 93 | let handle_info _msg _state = failwith "unimplemented" 94 | end 95 | -------------------------------------------------------------------------------- /packages/riot-stdlib/logger/logger.ml: -------------------------------------------------------------------------------- 1 | module Scheduler_uid = Riot_runtime.Core.Scheduler_uid 2 | module Log = Riot_runtime.Log 3 | open Global 4 | 5 | type opts = { print_source : bool; print_time : bool; color_output : bool } 6 | type config = { opts : opts; started_by : Riot_runtime.Core.Pid.t } 7 | 8 | type ('a, 'b) logger_format = 9 | (('a, Format.formatter, unit, 'b) format4 -> 'a) -> 'b 10 | 11 | type namespace = string list 12 | type level = Log.level = Debug | Error | Info | Trace | Warn 13 | 14 | module Level = struct 15 | let to_int = function 16 | | Trace -> 5 17 | | Debug -> 4 18 | | Info -> 2 19 | | Warn -> 1 20 | | Error -> 0 21 | 22 | let should_log current x = 23 | match current with 24 | | None -> false 25 | | Some log_level -> to_int x <= to_int log_level 26 | 27 | let to_color_string t = 28 | match t with 29 | | Error -> "\x1b[31m" 30 | | Warn -> "\x1b[33m" 31 | | Debug -> "\x1b[36m" 32 | | Info -> "" 33 | | Trace -> "\x1b[35m" 34 | 35 | let pp ppf t = 36 | match t with 37 | | Error -> Format.fprintf ppf "error" 38 | | Warn -> Format.fprintf ppf "warn" 39 | | Debug -> Format.fprintf ppf "debug" 40 | | Info -> Format.fprintf ppf "info" 41 | | Trace -> Format.fprintf ppf "trace" 42 | end 43 | 44 | type log = { 45 | level : level; 46 | ts : Ptime.t; 47 | src : Scheduler_uid.t * Riot_runtime.Core.Pid.t; 48 | ns : namespace; 49 | message : string; 50 | } 51 | 52 | let __on_log__ : (log -> unit) ref = ref (fun _ -> ()) 53 | let set_on_log log = __on_log__ := log 54 | let on_log log = !__on_log__ log 55 | 56 | let write : type a. level -> namespace -> (a, unit) logger_format -> unit = 57 | fun level ns msgf -> 58 | let ts = Ptime_clock.now () in 59 | let sch = Riot_runtime.Scheduler.get_current_scheduler () in 60 | let pid = self () in 61 | let src = (sch.uid, pid) in 62 | let buf = Buffer.create 128 in 63 | 64 | msgf @@ fun fmt -> 65 | Format.kfprintf 66 | (fun _ -> 67 | let message = Buffer.contents buf in 68 | on_log { ts; level; ns; src; message }; 69 | 70 | ()) 71 | (Format.formatter_of_buffer buf) 72 | (fmt ^^ "%!") 73 | 74 | module type Intf = sig 75 | val set_log_level : level option -> unit 76 | val debug : ('a, unit) logger_format -> unit 77 | val error : ('a, unit) logger_format -> unit 78 | val info : ('a, unit) logger_format -> unit 79 | val trace : ('a, unit) logger_format -> unit 80 | val warn : ('a, unit) logger_format -> unit 81 | end 82 | 83 | module type Namespace = sig 84 | val namespace : namespace 85 | end 86 | 87 | let log_level = ref None 88 | 89 | module Make (B : Namespace) : Intf = struct 90 | let set_log_level x = log_level := x 91 | 92 | let debug msgf = 93 | if Level.should_log !log_level Debug then write Debug B.namespace msgf 94 | 95 | let info msgf = 96 | if Level.should_log !log_level Info then write Info B.namespace msgf 97 | 98 | let trace msgf = 99 | if Level.should_log !log_level Trace then write Trace B.namespace msgf 100 | 101 | let warn msgf = 102 | if Level.should_log !log_level Warn then write Warn B.namespace msgf 103 | 104 | let error msgf = 105 | if Level.should_log !log_level Error then write Error B.namespace msgf 106 | end 107 | 108 | include Make (struct 109 | let namespace = [] 110 | end) 111 | -------------------------------------------------------------------------------- /test/fixtures/tls.key: -------------------------------------------------------------------------------- 1 | -----BEGIN PRIVATE KEY----- 2 | MIIJQwIBADANBgkqhkiG9w0BAQEFAASCCS0wggkpAgEAAoICAQDH1nbOGODlLJRf 3 | zlYySGyRqOBFHluoYo+GqCVt22yXHAbiWAvq3M9YAQnSL0va8GR0Y2DbsR3AWu6L 4 | dUliNF7lPzDaHzeFDw/ggSrYsSG6EUcR4LsNJ/XV0RIVn8cRr1qbp3de/SoB2D7l 5 | LUZKaNTV4HHnejaOVBzZ4Rxnzjzw1//7rUwO58pkOvXII5fO51ck747jWH5LsjVd 6 | JU+U3uui5GrlT57fsahF1Oe7IshDVeceBcQs3AbUsoMmy12w7CXpnujUy1v9Hclr 7 | 7dgfB9akM3K3RrxYA88zpvMwU2MKaX7yHVJ8Ffu5gTP09PFj1ZgvLL8OD1XCLqqe 8 | WQbxdsvJgJXiyD8hFfLfaSDeYdl3XStwpsmnsnHidnbm16Dz+z1YQjPrgJ8+/Jql 9 | Lc8gluWfA/OyLobYwPLVkzon06UWkAC7aSO+hyz13CaJW60cRYbInZU3nKRXk2A/ 10 | N3Sn7H4LiRAaJ796eBfCAztfPbTOYmTgC197uvwVPEPqXC4YZ1IbidVnL66Ch1dY 11 | tSrtE6IMzhzFOCrVkTJ2hdO8JDpV2zmZwD+EFmOCCRenKpG5QUpMywv4UX2cxG0D 12 | YjApeWDlU2Jc1L6nahbvPvlI6gom0rkbsTA4zG/c4J1KoJIrVB3hHPhroT0xzFuZ 13 | X30nzfxEo7ChwxeK/pUyxULr627J9QIDAQABAoICAAW8Hx0zhBK3mIt2T61yPCFi 14 | /AqnwCAhMfa+kRJpw2BDxuPMfI0RKKchIn/EaTQfhXZ8mp07ZDvusB1S8JfvolCI 15 | Y3XDAxQftkguVMUysiHVmJlH/n42aRzpetAhjXQxuNMyN2ADumaips1rYvLENuVr 16 | Y0FuFa44djp/dhH5jnCn9jnqA36DAuEk+wQzF0pyA6N094AJPFieRN9HMJU4X4FF 17 | dlbd1dScE9TrMvpBGYerKa6IIlTaPJzygYaFvArVgBIIBC0FJ/7n0a21/eeIEU4V 18 | huOBFWseMt5L2ntGzVcRZ3n5wvH6LIbqkQvk0p+Xk944tcPox0CDF9Ti/6rCyr7Q 19 | 3jaJYi4q2VaA8uWKs6FOOrvcOBS6iwABMb9lOxhWud46g2lgcyNjZuNlcdNmLr4r 20 | mppKZ2aE9md4cNYIPCCFdjxxP0TisJXb1PF0+hYnv0UCY00IGRxOwysN66h82kzS 21 | Os5HYgIux74AWxwkm+3EEM+zdlof+i61uRi6d+MAsm+WvQnXiy2PCvBoLNdAOaA6 22 | tbCDFXL3/RJdF9wx2julyEihF0jjBafxQwZKqFlPbCwZc08kDSjozCMwork9CSA8 23 | T5pSMxS7aq6zHrFoWqypB+8QH16YpkmwzDQKkVhc97Va6kZMGk697JscUpG5bPXp 24 | VzRH+k4q0E8C0QX5eRV5AoIBAQDxXhpS8DZ7bXPGCjldYF1FO9S4pT7li/XPkXwS 25 | EFwJhci0FM4kB/B5F8gMiXhUZP7iqDriLEXRdlaeZHBGO3PcjRltfauqXBKQ1sSk 26 | C775v52xaIHjFtZ867wqHlBs+uh836fK55FjAqaEwyjZTBi/i9wB6IAltZjOFZ7N 27 | avmqLFgPAe2k9bkZiYsSImsfI3ZFT9VQewjLZgMd9gk7uXaQ8Vg1FWOU4e0Jp/L5 28 | s++sdyIw3JJCiHXULAsVZONKb5dIIbLZ2w66jhLRFkn70pjH4Wbcmd0GHvt2jKV3 29 | 1LLPZUO09Q/9RvMhL5WH/KQOmPERxeznRHuVVv8qPanORpB9AoIBAQDT89cT2pB9 30 | qfQfTssvQhN6Gq12Kf9LLr1tYwozTz+YZZdUdRY8BfT6XuwxirB1qaaDq1+/0nfv 31 | ZQZprsHr7Gh3HgdkQlESuMnrepsK7Wa17LNkL8iOfJrMAMUxPjGWnN+Hsnhk5zbv 32 | dOUIyD+vtJO+d/8znpSieIRn8iN2cyfqT/RjxWjssEQBWpaHRBGDq9GY1tfpU01O 33 | /3r4w9Tog2Pu2xGukP/l/Ohp/E3otK9O3RmSM2bTd9Qm3SomN4mX8MHr1PG9ci/p 34 | KEVeE+z9p62pTYB8diMl2d5xMQdUcuN/O5Ue1Umwmz0JqDdNqQCz5SKYZo4tT+SN 35 | a0ehr3/pOJDZAoIBAQDi89/+sn4YKr+crIpqAa1R50NK554vix30MdEezyErlw80 36 | PQfkG08DHdht6Wkqudhs2VCc0JJJtWMXBkwHzelQraAGMw+SXYbbiAZYVe8ZuRIW 37 | +bSACj5eMe65D84B2x92I3sLsBglqB1ZYoRrZkEzAtg5Nxwf2RQ4W135uyfM2mtm 38 | mSKSZLbKi2koARMGsXqJC9sBFN8dGeu+ZVUjQm15NmYBa/45xQH0fWZbYtTvLwoI 39 | Na6VPujEOzGkyTtrB2iRW5ZngLHluqd40ON6FPixoYDt1wNbuRAr1W3VMjt8BbTX 40 | V0LUnb0JLEwHFQhR7X9nfdsXTm6B6s59MoQTQIilAoIBAGbZupKdyuPP5vCSUbKb 41 | A8yKyYW/l2yqP62nE7oWSKvxEGAheSqjUV91VHQt8rcGHhFixdHVlfGLOnNqJBwR 42 | 2heDcN7L9394QDOOiVHiJac+N0b0kQPjn1JDRW1B2tpVQXsdtaJxOI02UjXSxmTC 43 | 4bbZj/NCjqnQhZ/TNjYyZzoillsb3nCMkFN/2+/DriQQ6mKaTqegjrE49Dlm/hfe 44 | Ok4b7BajsimucjGMB1pW44MHc3MokksnqME7LUriRFiAsfl4md3uXSVtL0wZqzTj 45 | ezferey3fxLNCE4xFnd6UL7a8N/HbDzQ9+uJv1xmGDszg3gku/VtAWFGn7nr6cwI 46 | cPECggEBANoHlBJofeYArwgzZdkA7kCyspdcR1Kmk6W6pFVSWMTA5S3ow8FYaxd4 47 | MxouBMoro8QhkdszwnCyvwOxghykTLT9W5jdRGSBCnHYg7GZImVWhFxKSBIc7vHb 48 | T0xHfLkAD8GYhux9mgLTVZDijB/Gj3//E26kT6eFpJR0s5Xj0kSGcIChHBoGJTmW 49 | dyWarF/v/wpjMiGHF1HQ1I9jF70Ly4WQhDcVlCLIpnM6ChNqdSJDwNDEnL7Gexjq 50 | +bRaTqSkUU++H+E78kcw+U0hC+Ac5wy2B32H5E32ghhWkVYDGlLn5oBsZcbCmqAE 51 | 7/kQTUM7p6ZquKZ2RYCmBlpyKZ7iP38= 52 | -----END PRIVATE KEY----- 53 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 |

3 | riot logo 4 |

5 | 6 |

7 | An actor-model multi-core scheduler for OCaml 5. 8 |

9 | 10 |

11 | Quick Start | 12 | 13 | Tutorial | 14 | Reference 15 |    16 |

17 | 18 | Riot is an [actor-model][actors] multi-core scheduler for OCaml 5. It brings 19 | [Erlang][erlang]-style concurrency to the language, where lightweight processes communicate via message-passing. 20 | 21 | 22 | ```ocaml 23 | open Riot 24 | 25 | type Message.t += Hello_world 26 | 27 | let () = 28 | Riot.run @@ fun () -> 29 | let pid = 30 | spawn (fun () -> 31 | match receive () with 32 | | Hello_world -> 33 | Logger.info (fun f -> f "hello world from %a!" Pid.pp (self ())); 34 | shutdown ()) 35 | in 36 | send pid Hello_world 37 | ``` 38 | 39 | At its core Riot aims to offer: 40 | 41 | * **Automatic multi-core scheduling** – when you spawn a new Riot process, it 42 | will automatically get allocated on a random scheduler. 43 | 44 | * **Lightweight processes** – spawn 10 or 10,000 processes as you see fit. 45 | 46 | * **Fast, type-safe message passing** 47 | 48 | * **Selective receive expressions** – when receiving messages, you can skim 49 | through a process mailbox to consume them in arbitrary order. 50 | 51 | * **Process links and monitors** to keep track of the lifecycle of processes 52 | 53 | Riot also includes: 54 | 55 | * **Supervisors** to build process hierarchies 56 | 57 | * **Logging** and **Telemetry** designed to be multicore friendly 58 | 59 | * an **Application** interface to orchestrate startup/shutdown of systems 60 | 61 | * **Generic Servers** for designing encapsulated services like with Elixir's [GenServer][genserver] 62 | 63 | ### Non-goals 64 | 65 | At the same time, there's a few things that Riot is not, and does not aim to be. 66 | 67 | Primarily, Riot is not a full port of the Erlang VM and it won't support 68 | several of its use-cases, like: 69 | * supporting Erlang or Elixir bytecode 70 | * hot-code reloading in live applications 71 | * function-call level tracing in live applications 72 | * ad-hoc distribution 73 | 74 | ## Quick Start 75 | 76 | ``` 77 | opam install riot 78 | ``` 79 | 80 | After that, you can use any of the [examples](./examples) as a base for your app, and run them: 81 | 82 | ``` 83 | dune exec ./my_app.exe 84 | ``` 85 | 86 | ## Acknowledgments 87 | 88 | Riot is the continuation of the work I started with 89 | [Caramel](https://github.com/leostera/caramel), an Erlang-backend for the OCaml 90 | compiler. 91 | 92 | It was heavily inspired by [eio][eio] by the OCaml Multicore team and 93 | [miou][miou] by [Calascibetta Romain](https://twitter.com/Dinoosaure) and the 94 | [Robur team](https://robur.coop/), as I learned more about Algebraic Effects. 95 | In particular the `Proc_state` is based on the `State` module in Miou. 96 | 97 | And a thousand thanks to [Calascibetta Romain](https://twitter.com/Dinoosaure) 98 | and [Antonio Monteiro](https://twitter.com/_anmonteiro) for the discussions and 99 | feedback. 100 | 101 | [actors]: https://en.wikipedia.org/wiki/Actor_model 102 | [erlang]: https://erlang.org 103 | [eio]: https://github.com/ocaml-multicore/eio 104 | [miou]: https://github.com/robur-coop/miou 105 | [genserver]: https://hexdocs.pm/elixir/1.12/GenServer.html 106 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2023, Leandro Ostera 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | 21 | -------------------------------------------------------------------------------- 22 | 23 | The `io_posix_stub.c` implementation is part of the `eio` OCaml package and is 24 | licensed under the folowing license: 25 | 26 | Copyright (C) 2021 Anil Madhavapeddy 27 | Copyright (C) 2022 Thomas Leonard 28 | 29 | Permission to use, copy, modify, and distribute this software for any 30 | purpose with or without fee is hereby granted, provided that the above 31 | copyright notice and this permission notice appear in all copies. 32 | 33 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 34 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 35 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 36 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 37 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 38 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 39 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 40 | 41 | -------------------------------------------------------------------------------- 42 | 43 | The Riot.SSL implementation is a derivate work from the `tls-eio` OCaml package 44 | and is licensed under the folowing license: 45 | 46 | Copyright (c) 2014, David Kaloper and Hannes Mehnert 47 | All rights reserved. 48 | 49 | Redistribution and use in source and binary forms, with or without modification, 50 | are permitted provided that the following conditions are met: 51 | 52 | * Redistributions of source code must retain the above copyright notice, this 53 | list of conditions and the following disclaimer. 54 | 55 | * Redistributions in binary form must reproduce the above copyright notice, this 56 | list of conditions and the following disclaimer in the documentation and/or 57 | other materials provided with the distribution. 58 | 59 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 60 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 61 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 62 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 63 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 64 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 65 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 66 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 67 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 68 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 69 | -------------------------------------------------------------------------------- /packages/riot-runtime/core/proc_state.ml: -------------------------------------------------------------------------------- 1 | exception Unwind 2 | 3 | type ('a, 'b) continuation = ('a, 'b) Effect.Shallow.continuation 4 | 5 | type 'a t = 6 | | Finished of ('a, exn) result 7 | | Suspended : ('a, 'b) continuation * 'a Effect.t -> 'b t 8 | | Unhandled : ('a, 'b) continuation * 'a -> 'b t 9 | 10 | let is_finished x = match x with Finished _ -> true | _ -> false 11 | 12 | type 'a step = 13 | | Continue of 'a 14 | | Discontinue of exn 15 | | Reperform : 'a Effect.t -> 'a step 16 | | Delay : 'a step 17 | | Suspend : 'a step 18 | | Yield : unit step 19 | | Terminate : 'a step 20 | 21 | type ('a, 'b) step_callback = ('a step -> 'b t) -> 'a Effect.t -> 'b t 22 | type perform = { perform : 'a 'b. ('a, 'b) step_callback } [@@unboxed] 23 | 24 | let pp fmt t = 25 | match t with 26 | | Finished (Ok _) -> Format.fprintf fmt "Finished(Ok _)" 27 | | Finished (Error exn) -> 28 | Format.fprintf fmt "Finished(Error %s)" (Printexc.to_string exn) 29 | | Suspended (_, _) -> Format.fprintf fmt "Suspended" 30 | | Unhandled (_, _) -> Format.fprintf fmt "Unhandled" 31 | 32 | let finished x = Finished x 33 | let suspended_with k e = Suspended (k, e) 34 | 35 | let handler_continue = 36 | let retc signal = finished (Ok signal) in 37 | let exnc exn = finished (Error exn) in 38 | let effc : type c. c Effect.t -> ((c, 'a) continuation -> 'b) option = 39 | fun e -> Some (fun k -> suspended_with k e) 40 | in 41 | Effect.Shallow.{ retc; exnc; effc } 42 | 43 | let continue_with k v = Effect.Shallow.continue_with k v handler_continue 44 | 45 | let discontinue_with k exn = 46 | Effect.Shallow.discontinue_with k exn handler_continue 47 | 48 | let unhandled_with k v = Unhandled (k, v) 49 | 50 | let make fn eff = 51 | let k = Effect.Shallow.fiber fn in 52 | Suspended (k, eff) 53 | 54 | let run : type a. reductions:int -> perform:perform -> a t -> a t option = 55 | fun ~reductions ~perform t -> 56 | let exception Yield of a t in 57 | let exception Unwind in 58 | let reductions = ref reductions in 59 | let t = ref t in 60 | try 61 | while true do 62 | if !reductions = 0 then raise_notrace (Yield !t); 63 | reductions := !reductions - 1; 64 | match !t with 65 | | Finished _ as finished -> raise_notrace (Yield finished) 66 | | Unhandled (fn, v) -> raise_notrace (Yield (continue_with fn v)) 67 | | Suspended (fn, e) as suspended -> 68 | let k : type c. (c, a) continuation -> c step -> a t = 69 | fun fn step -> 70 | match step with 71 | | Delay -> suspended 72 | | Continue v -> continue_with fn v 73 | | Discontinue exn -> discontinue_with fn exn 74 | | Reperform eff -> unhandled_with fn (Effect.perform eff) 75 | | Yield -> raise_notrace (Yield (continue_with fn ())) 76 | | Suspend -> raise_notrace (Yield suspended) 77 | | Terminate -> 78 | ignore (discontinue_with fn Unwind); 79 | raise Unwind 80 | in 81 | t := perform.perform (k fn) e 82 | done; 83 | Some !t 84 | with 85 | | Yield t -> Some t 86 | | Unwind -> None 87 | 88 | let drop k exn id = 89 | let retc _signal = 90 | Log.debug (fun f -> f "dropping continuation return: %s" id); 91 | () 92 | in 93 | let exnc _exn = 94 | Log.debug (fun f -> f "dropping continuation exception: %s" id); 95 | () 96 | in 97 | let effc _eff = 98 | Log.debug (fun f -> f "dropping continuation effect: %s" id); 99 | None 100 | in 101 | let handler = Effect.Shallow.{ retc; exnc; effc } in 102 | Effect.Shallow.discontinue_with k exn handler 103 | 104 | let unwind ~id (t : 'a t) = 105 | match t with 106 | | Finished result -> ignore result 107 | | Suspended (k, _) -> ignore (drop k Unwind id) 108 | | Unhandled (k, _) -> ignore (drop k Unwind id) 109 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "An actor-model multi-core scheduler for OCaml 5"; 3 | 4 | inputs = { 5 | nixpkgs.url = "github:nix-ocaml/nix-overlays"; 6 | 7 | bytestring = { 8 | url = "github:riot-ml/bytestring"; 9 | inputs.nixpkgs.follows = "nixpkgs"; 10 | inputs.minttea.follows = "minttea"; 11 | inputs.rio.follows = "rio"; 12 | }; 13 | 14 | castore = { 15 | url = "github:suri-framework/castore"; 16 | inputs.nixpkgs.follows = "nixpkgs"; 17 | }; 18 | 19 | config = { 20 | url = "github:ocaml-sys/config.ml"; 21 | inputs.nixpkgs.follows = "nixpkgs"; 22 | inputs.minttea.follows = "minttea"; 23 | }; 24 | 25 | gluon = { 26 | url = "github:riot-ml/gluon"; 27 | inputs.nixpkgs.follows = "nixpkgs"; 28 | inputs.bytestring.follows = "bytestring"; 29 | inputs.config.follows = "config"; 30 | inputs.minttea.follows = "minttea"; 31 | inputs.rio.follows = "rio"; 32 | }; 33 | 34 | minttea = { 35 | url = "github:leostera/minttea"; 36 | inputs.nixpkgs.follows = "nixpkgs"; 37 | }; 38 | 39 | rio = { 40 | url = "github:riot-ml/rio/e7ee9006d96fd91248599fa26c1982364375dd9e"; 41 | inputs.nixpkgs.follows = "nixpkgs"; 42 | }; 43 | 44 | telemetry = { 45 | url = "github:leostera/telemetry"; 46 | inputs.nixpkgs.follows = "nixpkgs"; 47 | }; 48 | }; 49 | 50 | outputs = inputs @ { 51 | self, 52 | flake-parts, 53 | ... 54 | }: 55 | flake-parts.lib.mkFlake {inherit inputs;} { 56 | systems = ["x86_64-linux" "aarch64-linux" "aarch64-darwin" "x86_64-darwin"]; 57 | perSystem = { 58 | config, 59 | self', 60 | inputs', 61 | pkgs, 62 | system, 63 | ... 64 | }: let 65 | inherit (pkgs) ocamlPackages mkShell; 66 | inherit (ocamlPackages) buildDunePackage; 67 | version = "0.0.9+dev"; 68 | in { 69 | devShells = { 70 | default = mkShell.override {stdenv = pkgs.clang17Stdenv;} { 71 | buildInputs = with ocamlPackages; [ 72 | dune_3 73 | ocaml 74 | utop 75 | ocamlformat 76 | ]; 77 | inputsFrom = [self'.packages.default]; 78 | packages = builtins.attrValues { 79 | inherit (pkgs) clang_17 clang-tools_17 pkg-config; 80 | inherit (ocamlPackages) ocaml-lsp ocamlformat-rpc-lib; 81 | }; 82 | }; 83 | }; 84 | packages = { 85 | randomconv = buildDunePackage { 86 | version = "0.2.0"; 87 | pname = "randomconv"; 88 | src = builtins.fetchGit { 89 | url = "git@github.com:hannesm/randomconv.git"; 90 | rev = "b2ce656d09738d676351f5a1c18aff0ff37a7dcc"; 91 | ref = "refs/tags/v0.2.0"; 92 | }; 93 | }; 94 | 95 | default = buildDunePackage { 96 | inherit version; 97 | pname = "riot"; 98 | propagatedBuildInputs = with ocamlPackages; [ 99 | inputs'.bytestring.packages.default 100 | inputs'.castore.packages.default 101 | inputs'.config.packages.default 102 | inputs'.gluon.packages.default 103 | inputs'.rio.packages.default 104 | (mdx.override { 105 | inherit logs; 106 | }) 107 | mirage-crypto 108 | mirage-crypto-rng 109 | mtime 110 | odoc 111 | ptime 112 | self'.packages.randomconv 113 | inputs'.telemetry.packages.default 114 | tls 115 | uri 116 | x509 117 | ]; 118 | src = ./.; 119 | }; 120 | }; 121 | formatter = pkgs.alejandra; 122 | }; 123 | }; 124 | } 125 | -------------------------------------------------------------------------------- /examples/5-links-and-monitors/README.md: -------------------------------------------------------------------------------- 1 | # `5-links-and-monitors` 2 | 3 | When dealing with long-lived processes, it is useful to know when they 4 | _terminate_ to either act upon it, or to have other processes terminate 5 | together as a unit. 6 | 7 | For these use-cases, Riot has _monitors_ and _links_. One key difference 8 | between these two is that _links_ are bidirectional and transitive. _Monitors_ 9 | are not. 10 | 11 | ## Monitors 12 | 13 | A *monitor* lets one process (`pid1`) be notified when another process (`pid2`) 14 | terminates. Monitors are created with the function `monitor pid1 pid2`, like 15 | this: 16 | 17 | ```ocaml 18 | let pid1 = spawn loop in 19 | let pid2 = 20 | spawn (fun () -> 21 | monitor (self ()) pid1; 22 | await_monitor_message ()) 23 | in 24 | (* ... *) 25 | ``` 26 | 27 | In our example, our second process is looping using a function that awaits a 28 | specific monitoring message called `Process_down`, which includes the Pid of 29 | the process that died. 30 | 31 | ```ocaml 32 | let rec await_monitor_message () = 33 | match receive () with 34 | | Process.Messages.Monitor (Process_down pid) -> 35 | Format.printf "uh-oh! Process %a terminated\n%!" Pid.pp pid 36 | | _ -> await_monitor_message () 37 | ``` 38 | 39 | If you've followed the tutorial so far, this should look familiar. `await_monitor_message` is: 40 | * a recursive function 41 | * that suspends the process until a message is received 42 | * and prints out a message when the monitored process goes down 43 | 44 | To actively terminate our first process here, we can use `exit pid Normal`, 45 | which tells the runtime to terminate this process with the reason `Normal`. 46 | Exit reasons are a way to capture _why_ a process terminated, and include: 47 | 48 | * `Normal` – used when a process' exit is expected, and is the default when a 49 | process function finishes 50 | * `Exception exn` – used when a process ended because of an unhandled exception 51 | 52 | ## Links 53 | 54 | A *link*, in contrast to a monitor, will actually link together the lifecycle 55 | of 2 processes. This means that if `pid1` goes down, _so does `pid2`_. 56 | 57 | This is incredibly useful to split up work into several processes while still 58 | being able to deal with all of them as a single unit of work. 59 | 60 | In our example, we create 2 more processes (`pid3` and `pid4`): 61 | 62 | ```ocaml 63 | let pid3 = spawn loop in 64 | let pid4 = 65 | spawn (fun () -> 66 | link pid3; 67 | loop ()) 68 | in 69 | (* ... *) 70 | ``` 71 | 72 | Two differences to note here are: 73 | 1. both of processes are using a regular infinite-loop function, no need to match on a specific message 74 | 2. the `link pid` function always links the _current process_ with another process. 75 | 76 | Since links are bidirectional, linking one end of 2 processes is enough. 77 | 78 | Links are also _transitive_, which means that if we add a new process `pid5` 79 | and link it to `pid4`, then exiting `pid3` will terminate `pid4` which will 80 | terminate `pid5`. 81 | 82 | Hopefully this gives you an idea of how links can be used to group processes 83 | and establish dependencies between them. 84 | 85 | ### Realistic Example 86 | 87 | For example, a "slack-to-discord" tunnel would need to read from slack, and 88 | write to discord. Each of those tasks can be done in a separate process. But if 89 | the slack connection goes down, it doesn't make sense to keep the discord 90 | connection open. We can model our tunnel with links like this: 91 | 92 | ```mermaid 93 | graph TD 94 | S2DT[Tunnel] 95 | SConn[Slack Connection] 96 | DConn[Discord Connection] 97 | S2DT -->|link| SConn & DConn 98 | ``` 99 | 100 | So that when the Slack Connection process terminates, it will also terminate 101 | the Tunnel process, which will also terminate the Discord Connection. 102 | 103 | In the next chapters we will learn about supervision, which will help us 104 | _restart_ this tunnel and recreate our processes from a known-state, using 105 | different strategies. 106 | 107 | ## Next Steps 108 | 109 | * the [next step](../6-supervisors) introduces you to supervisors, a concept 110 | built on top of links to orchestrate processes using certain strategies. 111 | -------------------------------------------------------------------------------- /test/net_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | exception Fail 4 | 5 | let fail () = 6 | sleep 0.2; 7 | raise Fail 8 | 9 | type Message.t += Received of string 10 | 11 | (* rudimentary tcp echo server *) 12 | let server port socket = 13 | Logger.debug (fun f -> f "Started server on %d" port); 14 | process_flag (Trap_exit true); 15 | let conn, addr = Net.Tcp_listener.accept socket |> Result.get_ok in 16 | Logger.debug (fun f -> 17 | f "Accepted client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn); 18 | let close () = 19 | Net.Tcp_stream.close conn; 20 | Logger.debug (fun f -> 21 | f "Closed client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn) 22 | in 23 | 24 | let bufs = IO.Iovec.create ~size:1024 () in 25 | let rec echo () = 26 | Logger.debug (fun f -> 27 | f "Reading from client client %a (%a)" Net.Addr.pp addr Net.Socket.pp 28 | conn); 29 | match Net.Tcp_stream.receive conn ~bufs with 30 | | Ok len -> ( 31 | Logger.debug (fun f -> f "Server received %d bytes" len); 32 | let bufs = IO.Iovec.sub ~len bufs in 33 | match Net.Tcp_stream.send conn ~bufs with 34 | | Ok bytes -> 35 | Logger.debug (fun f -> f "Server sent %d bytes" bytes); 36 | echo () 37 | | Error (`Closed | `Process_down | `Timeout) -> close () 38 | | Error err -> 39 | Logger.error (fun f -> f "error %a" IO.pp_err err); 40 | close ()) 41 | | Error (`Closed | `Timeout | `Process_down) -> close () 42 | | Error err -> 43 | Logger.error (fun f -> f "error %a" IO.pp_err err); 44 | close () 45 | in 46 | echo () 47 | 48 | let client server_port main = 49 | let addr = Net.Addr.(tcp loopback server_port) in 50 | let conn = Net.Tcp_stream.connect addr |> Result.get_ok in 51 | Logger.debug (fun f -> f "Connected to server on %d" server_port); 52 | let bufs = IO.Iovec.from_string "hello world" in 53 | let rec send_loop n = 54 | if n = 0 then Logger.error (fun f -> f "client retried too many times") 55 | else 56 | match Net.Tcp_stream.send ~bufs conn with 57 | | Ok bytes -> Logger.debug (fun f -> f "Client sent %d bytes" bytes) 58 | | Error `Closed -> Logger.debug (fun f -> f "connection closed") 59 | | Error (`Process_down | `Timeout) -> Logger.debug (fun f -> f "timeout") 60 | | Error (`Unix_error (ENOTCONN | EPIPE)) -> send_loop n 61 | | Error err -> 62 | Logger.error (fun f -> f "error %a" IO.pp_err err); 63 | send_loop (n - 1) 64 | in 65 | send_loop 10_000; 66 | 67 | let bufs = IO.Iovec.create ~size:1024 () in 68 | let recv_loop () = 69 | match Net.Tcp_stream.receive ~bufs conn with 70 | | Ok bytes -> 71 | Logger.debug (fun f -> f "Client received %d bytes" bytes); 72 | bytes 73 | | Error (`Closed | `Timeout | `Process_down) -> 74 | Logger.error (fun f -> f "Server closed the connection"); 75 | 0 76 | | Error err -> 77 | Logger.error (fun f -> f "error %a" IO.pp_err err); 78 | 0 79 | in 80 | let len = recv_loop () in 81 | let str = IO.Iovec.(sub bufs ~len |> into_string) in 82 | 83 | if len = 0 then send main (Received "empty paylaod") 84 | else send main (Received str) 85 | 86 | let () = 87 | Riot.run @@ fun () -> 88 | let _ = Logger.start () |> Result.get_ok in 89 | Logger.set_log_level (Some Info); 90 | let socket, port = Port_finder.next_open_port () in 91 | let main = self () in 92 | let server = spawn (fun () -> server port socket) in 93 | let client = spawn (fun () -> client port main) in 94 | monitor server; 95 | monitor client; 96 | match receive_any ~after:10_000_000L () with 97 | | exception Receive_timeout -> 98 | Logger.error (fun f -> f "net_test: test timed out"); 99 | fail () 100 | | Received "hello world" -> 101 | Logger.info (fun f -> f "net_test: OK"); 102 | sleep 0.1 103 | | Received other -> 104 | Logger.error (fun f -> f "net_test: bad payload: %S" other); 105 | fail () 106 | | Process.Messages.Monitor (Process_down pid) -> 107 | let who = if Pid.equal pid server then "server" else "client" in 108 | Logger.error (fun f -> 109 | f "net_test: %s(%a) died unexpectedly" who Pid.pp pid); 110 | fail () 111 | | _ -> 112 | Logger.error (fun f -> f "net_test: unexpected message"); 113 | 114 | fail () 115 | -------------------------------------------------------------------------------- /packages/riot-stdlib/supervisor.ml: -------------------------------------------------------------------------------- 1 | open Global 2 | 3 | open Logger.Make (struct 4 | let namespace = [ "riot"; "supervisor" ] 5 | end) 6 | 7 | type child_spec = 8 | | Child : { 9 | initial_state : 'state; 10 | start_link : 'state -> (Pid.t, [> `Exit of exn ]) result; 11 | } 12 | -> child_spec 13 | 14 | let child_spec start_link initial_state = Child { start_link; initial_state } 15 | 16 | type strategy = One_for_one | One_for_all | Rest_for_one | Simple_one_for_one 17 | type timestamp = float 18 | 19 | type state = { 20 | strategy : strategy; 21 | restart_limit : int; 22 | restart_period : int; 23 | child_specs : child_spec list; 24 | children : (Pid.t * child_spec) list; 25 | restarts : timestamp list; 26 | } 27 | [@@warning "-69"] 28 | 29 | let start_child (Child { start_link; initial_state }) = 30 | start_link initial_state |> Result.get_ok 31 | 32 | let init_child spec = 33 | let pid = start_child spec in 34 | trace (fun f -> 35 | let this = self () in 36 | f "Supervisor %a started child %a" Pid.pp this Pid.pp pid); 37 | (pid, spec) 38 | 39 | let init_children state = List.map init_child state.child_specs 40 | 41 | let add_restart state = 42 | let now = Unix.gettimeofday () in 43 | { state with restarts = now :: state.restarts } 44 | 45 | let max_restarts_reached state = 46 | List.length state.restarts > state.restart_limit 47 | 48 | let restart_child pid state = 49 | let state = add_restart state in 50 | if max_restarts_reached state then `terminate 51 | else ( 52 | trace (fun f -> f "child %a is down" Pid.pp pid); 53 | let spec = List.assoc pid state.children in 54 | let children = init_child spec :: List.remove_assoc pid state.children in 55 | `continue { state with children }) 56 | 57 | type sup_request = List_children_req of { reply : Pid.t; ref : unit Ref.t } 58 | 59 | type sup_response = 60 | | List_children_res of { children : Pid.t list; ref : unit Ref.t } 61 | 62 | type Message.t += 63 | | Supervisor_request of sup_request 64 | | Supervisor_response of sup_response 65 | 66 | let rec loop state = 67 | trace (fun f -> f "entered supervision loop"); 68 | let selector : _ Message.selector = 69 | fun msg -> 70 | match msg with 71 | | Process.Messages.Exit (pid, reason) when List.mem_assoc pid state.children 72 | -> 73 | `select (`child_exit (pid, reason)) 74 | | Supervisor_request msg -> `select (`req msg) 75 | | _ -> `skip 76 | in 77 | match receive ~selector () with 78 | | `child_exit (pid, Normal) -> 79 | trace (fun f -> f "child %a stopped normally" Pid.pp pid); 80 | let state = 81 | { state with children = List.remove_assoc pid state.children } 82 | in 83 | loop state 84 | | `child_exit (pid, reason) -> 85 | trace (fun f -> 86 | f "child %a stopped: %a" Pid.pp pid Process.pp_reason reason); 87 | handle_child_exit pid reason state 88 | | `req (List_children_req { reply; ref }) -> 89 | let children = List.map (fun (pid, _) -> pid) state.children in 90 | send reply (Supervisor_response (List_children_res { children; ref })); 91 | loop state 92 | 93 | and handle_child_exit pid _reason state = 94 | match restart_child pid state with 95 | | `continue state -> loop state 96 | | `terminate -> 97 | trace (fun f -> 98 | f "Supervisor %a reached max restarts of %d" Pid.pp (self ()) 99 | state.restart_limit) 100 | 101 | let start_supervisor state = 102 | trace (fun f -> 103 | f "Initializing supervisor %a with %d child specs" Pid.pp (self ()) 104 | (List.length state.child_specs)); 105 | Process.flag (Trap_exit true); 106 | let state = { state with children = init_children state } in 107 | loop state 108 | 109 | let start_link ?(strategy = One_for_one) ?(restart_limit = 1) 110 | ?(restart_period = 5) ~child_specs () = 111 | let state = 112 | { 113 | strategy; 114 | restart_limit; 115 | restart_period; 116 | child_specs; 117 | children = []; 118 | restarts = []; 119 | } 120 | in 121 | let sup_pid = spawn_link (fun () -> start_supervisor state) in 122 | Ok sup_pid 123 | 124 | let children pid = 125 | let ref = Ref.make () in 126 | send pid (Supervisor_request (List_children_req { reply = self (); ref })); 127 | let selector msg = 128 | match msg with 129 | | Supervisor_response (List_children_res { ref = ref'; _ } as msg) 130 | when Ref.equal ref ref' -> 131 | `select msg 132 | | _ -> `skip 133 | in 134 | match receive ~selector () with 135 | | List_children_res { children; _ } -> children 136 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/dashmap.ml: -------------------------------------------------------------------------------- 1 | type ('k, 'v) t = { tbl : ('k, 'v) Hashtbl.t; lock : Mutex.t } 2 | 3 | let create ?(size = 1024) () = 4 | { lock = Mutex.create (); tbl = Hashtbl.create size } 5 | 6 | let get_all t k = Mutex.protect t.lock (fun () -> Hashtbl.find_all t.tbl k) 7 | let get t k = Mutex.protect t.lock (fun () -> Hashtbl.find_opt t.tbl k) 8 | let remove t k = Mutex.protect t.lock (fun () -> Hashtbl.remove t.tbl k) 9 | 10 | let remove_all t ks = 11 | Mutex.protect t.lock (fun () -> List.iter (Hashtbl.remove t.tbl) ks) 12 | 13 | let entries t = 14 | Mutex.protect t.lock (fun () -> Hashtbl.to_seq t.tbl |> List.of_seq) 15 | 16 | let find_by t fn = 17 | Mutex.protect t.lock (fun () -> Hashtbl.to_seq t.tbl |> Seq.find fn) 18 | 19 | let find_all_by t fn = 20 | Mutex.protect t.lock (fun () -> 21 | Hashtbl.to_seq t.tbl |> Seq.filter fn |> List.of_seq) 22 | 23 | let iter t fn = Hashtbl.iter (fun k v -> fn (k, v)) t.tbl 24 | let has_key t k = Mutex.protect t.lock (fun () -> Hashtbl.mem t.tbl k) 25 | let is_empty t = Mutex.protect t.lock (fun () -> Hashtbl.length t.tbl = 0) 26 | 27 | let insert t k v = 28 | Mutex.protect t.lock (fun () -> Hashtbl.add t.tbl k v |> ignore) 29 | 30 | let remove_by t fn = 31 | Mutex.protect t.lock (fun () -> 32 | Hashtbl.to_seq t.tbl |> Seq.filter fn 33 | |> Seq.map (fun (k, _v) -> k) 34 | |> Seq.iter (fun k -> Hashtbl.remove t.tbl k)) 35 | 36 | let replace t k v = Mutex.protect t.lock (fun () -> Hashtbl.replace t.tbl k v) 37 | 38 | let pp k_pp fmt t = 39 | Format.pp_print_list 40 | ~pp_sep:(fun fmt _ -> Format.fprintf fmt ", ") 41 | (fun fmt (k, _) -> k_pp fmt k) 42 | fmt (entries t) 43 | 44 | module type Base = sig 45 | type key 46 | 47 | val hash : key -> int 48 | val equal : key -> key -> bool 49 | end 50 | 51 | module type Intf = sig 52 | type key 53 | type 'v t 54 | 55 | val create : ?size:int -> unit -> 'v t 56 | val keys : 'v t -> key Seq.t 57 | val get : 'v t -> key -> 'v option 58 | val get_all : 'v t -> key -> 'v list 59 | val is_empty : 'v t -> bool 60 | val find_by : 'v t -> (key * 'v -> bool) -> (key * 'v) option 61 | val remove : 'v t -> key -> unit 62 | val remove_all : 'v t -> key list -> unit 63 | val find_all_by : 'v t -> (key * 'v -> bool) -> (key * 'v) list 64 | val has_key : 'v t -> key -> bool 65 | val insert : 'v t -> key -> 'v -> unit 66 | val remove_by : 'v t -> (key * 'v -> bool) -> unit 67 | val replace : 'v t -> key -> 'v -> unit 68 | val iter : 'v t -> (key * 'v -> unit) -> unit 69 | val pp : (Format.formatter -> key -> unit) -> Format.formatter -> 'v t -> unit 70 | end 71 | 72 | module Make (B : Base) : Intf with type key = B.key = struct 73 | module Hashtbl = Hashtbl.Make (struct 74 | type t = B.key 75 | 76 | let hash = B.hash 77 | let equal = B.equal 78 | end) 79 | 80 | type key = B.key 81 | type 'v t = { tbl : 'v Hashtbl.t; lock : Mutex.t } 82 | 83 | let keys t = Hashtbl.to_seq_keys t.tbl 84 | 85 | let create ?(size = 1024) () = 86 | { lock = Mutex.create (); tbl = Hashtbl.create size } 87 | 88 | let get_all t k = Mutex.protect t.lock (fun () -> Hashtbl.find_all t.tbl k) 89 | let get t k = Mutex.protect t.lock (fun () -> Hashtbl.find_opt t.tbl k) 90 | let remove t k = Mutex.protect t.lock (fun () -> Hashtbl.remove t.tbl k) 91 | 92 | let remove_all t ks = 93 | Mutex.protect t.lock (fun () -> List.iter (Hashtbl.remove t.tbl) ks) 94 | 95 | let entries t = 96 | Mutex.protect t.lock (fun () -> Hashtbl.to_seq t.tbl |> List.of_seq) 97 | 98 | let find_by t fn = 99 | Mutex.protect t.lock (fun () -> Hashtbl.to_seq t.tbl |> Seq.find fn) 100 | 101 | let find_all_by t fn = 102 | Mutex.protect t.lock (fun () -> 103 | Hashtbl.to_seq t.tbl |> Seq.filter fn |> List.of_seq) 104 | 105 | let iter t fn = Hashtbl.iter (fun k v -> fn (k, v)) t.tbl 106 | let has_key t k = Mutex.protect t.lock (fun () -> Hashtbl.mem t.tbl k) 107 | let is_empty t = Mutex.protect t.lock (fun () -> Hashtbl.length t.tbl = 0) 108 | 109 | let insert t k v = 110 | Mutex.protect t.lock (fun () -> Hashtbl.add t.tbl k v |> ignore) 111 | 112 | let remove_by t fn = 113 | Mutex.protect t.lock (fun () -> 114 | Hashtbl.to_seq t.tbl |> Seq.filter fn 115 | |> Seq.map (fun (k, _v) -> k) 116 | |> Seq.iter (fun k -> Hashtbl.remove t.tbl k)) 117 | 118 | let replace t k v = Mutex.protect t.lock (fun () -> Hashtbl.replace t.tbl k v) 119 | 120 | let pp k_pp fmt t = 121 | Format.pp_print_list 122 | ~pp_sep:(fun fmt _ -> Format.fprintf fmt ", ") 123 | (fun fmt (k, _) -> k_pp fmt k) 124 | fmt (entries t) 125 | end 126 | -------------------------------------------------------------------------------- /test/net_reader_writer_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | type Message.t += Received of string 4 | 5 | (* rudimentary tcp echo server *) 6 | let server port socket = 7 | Logger.debug (fun f -> f "Started server on %d" port); 8 | process_flag (Trap_exit true); 9 | let conn, addr = Net.Tcp_listener.accept socket |> Result.get_ok in 10 | Logger.debug (fun f -> 11 | f "Accepted client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn); 12 | let close () = 13 | Net.Tcp_stream.close conn; 14 | Logger.debug (fun f -> 15 | f "Closed client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn) 16 | in 17 | 18 | let reader = Net.Tcp_stream.to_reader conn in 19 | let writer = Net.Tcp_stream.to_writer conn in 20 | 21 | let bufs = IO.Iovec.with_capacity 1024 in 22 | let rec echo () = 23 | Logger.debug (fun f -> 24 | f "Reading from client client %a (%a)" Net.Addr.pp addr Net.Socket.pp 25 | conn); 26 | match IO.read_vectored reader bufs with 27 | | Ok len -> ( 28 | Logger.debug (fun f -> f "Server received %d bytes" len); 29 | let bufs = IO.Iovec.sub ~len bufs in 30 | match IO.write_owned_vectored ~bufs writer with 31 | | Ok bytes -> 32 | Logger.debug (fun f -> f "Server sent %d bytes" bytes); 33 | echo () 34 | | Error (`Closed | `Timeout | `Process_down) -> close () 35 | | Error err -> 36 | Logger.error (fun f -> f "error: %a" IO.pp_err err); 37 | close ()) 38 | | Error err -> 39 | Logger.error (fun f -> f "error: %a" IO.pp_err err); 40 | close () 41 | in 42 | 43 | echo () 44 | 45 | let client server_port main = 46 | let addr = Net.Addr.(tcp loopback server_port) in 47 | let conn = Net.Tcp_stream.connect addr |> Result.get_ok in 48 | Logger.debug (fun f -> f "Connected to server on %d" server_port); 49 | 50 | let reader = Net.Tcp_stream.to_reader conn in 51 | let writer = Net.Tcp_stream.to_writer conn in 52 | 53 | let rec send_loop n bufs = 54 | if n = 0 then Logger.error (fun f -> f "client retried too many times") 55 | else 56 | match IO.write_owned_vectored ~bufs writer with 57 | | Ok bytes -> Logger.debug (fun f -> f "Client sent %d bytes" bytes) 58 | | Error (`Closed | `Timeout | `Process_down) -> 59 | Logger.debug (fun f -> f "connection closed") 60 | | Error (`Unix_error (ENOTCONN | EPIPE)) -> send_loop n bufs 61 | | Error err -> 62 | Logger.error (fun f -> f "error: %a" IO.pp_err err); 63 | send_loop (n - 1) bufs 64 | in 65 | let bufs = IO.Iovec.from_string "hello " in 66 | send_loop 10_000 bufs; 67 | let bufs = IO.Iovec.from_string "world\r\n" in 68 | send_loop 10_000 bufs; 69 | 70 | let rec recv_loop data = 71 | let buf = IO.Bytes.with_capacity 1024 in 72 | match IO.read reader buf with 73 | | Ok bytes -> 74 | Logger.debug (fun f -> f "Client received %d bytes" bytes); 75 | let bytes = IO.Bytes.sub buf ~pos:0 ~len:bytes in 76 | let data = data ^ IO.Bytes.to_string bytes in 77 | if String.ends_with ~suffix:"\r\n" data then data else recv_loop data 78 | | Error (`Closed | `Timeout | `Process_down) -> 79 | Logger.error (fun f -> f "Server closed the connection"); 80 | data 81 | | Error err -> 82 | Logger.error (fun f -> f "error: %a" IO.pp_err err); 83 | data 84 | in 85 | let data = recv_loop "" in 86 | 87 | if String.length data = 0 then send main (Received "empty paylaod") 88 | else send main (Received data) 89 | 90 | let () = 91 | Riot.run @@ fun () -> 92 | let _ = Logger.start () |> Result.get_ok in 93 | Logger.set_log_level (Some Info); 94 | let socket, port = Port_finder.next_open_port () in 95 | let main = self () in 96 | let server = spawn (fun () -> server port socket) in 97 | let client = spawn (fun () -> client port main) in 98 | monitor server; 99 | monitor client; 100 | match receive_any ~after:500_000L () with 101 | | Received "hello world\r\n" -> 102 | Logger.info (fun f -> f "net_reader_writer_test: OK"); 103 | 104 | shutdown () 105 | | Received other -> 106 | Logger.error (fun f -> f "net_reader_writer_test: bad payload: %S" other); 107 | sleep 1.; 108 | Stdlib.exit 1 109 | | Process.Messages.Monitor (Process_down pid) -> 110 | let who = if Pid.equal pid server then "server" else "client" in 111 | Logger.error (fun f -> 112 | f "net_test: %s(%a) died unexpectedly" who Pid.pp pid); 113 | sleep 1.; 114 | Stdlib.exit 1 115 | | _ -> 116 | Logger.error (fun f -> f "net_reader_writer_test: unexpected message"); 117 | sleep 1.; 118 | Stdlib.exit 1 119 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (package riot) 3 | (name port_finder) 4 | (modules port_finder) 5 | (libraries riot)) 6 | 7 | (test 8 | (package riot) 9 | (name ssl_test) 10 | (enabled_if 11 | (= %{env:OPAM_REPO_CI=false} false)) 12 | (modules ssl_test) 13 | (deps fixtures/tls.crt fixtures/tls.key) 14 | (libraries riot port_finder x509 mirage-crypto-rng mirage-crypto-rng.unix)) 15 | 16 | (test 17 | (package riot) 18 | (name io_writer_test) 19 | (enabled_if 20 | (= %{env:OPAM_REPO_CI=false} false)) 21 | (modules io_writer_test) 22 | (libraries riot)) 23 | 24 | (test 25 | (package riot) 26 | (name io_reader_test) 27 | (enabled_if 28 | (= %{env:OPAM_REPO_CI=false} false)) 29 | (modules io_reader_test) 30 | (deps fixtures/io_readv.txt) 31 | (libraries riot)) 32 | 33 | (test 34 | (package riot) 35 | (name io_reader_large_test) 36 | (enabled_if 37 | (= %{env:OPAM_REPO_CI=false} false)) 38 | (modules io_reader_large_test) 39 | (deps fixtures/ocaml_org.html) 40 | (libraries riot)) 41 | 42 | (test 43 | (package riot) 44 | (name io_readv_test) 45 | (enabled_if 46 | (= %{env:OPAM_REPO_CI=false} false)) 47 | (deps fixtures/io_readv.txt) 48 | (modules io_readv_test) 49 | (libraries riot)) 50 | 51 | (test 52 | (package riot) 53 | (name io_writev_test) 54 | (enabled_if 55 | (= %{env:OPAM_REPO_CI=false} false)) 56 | (modules io_writev_test) 57 | (deps generated/.gitkeep) 58 | (libraries riot)) 59 | 60 | ; (test 61 | ; (package riot) 62 | ; (name net_timeout_test) 63 | ; (enabled_if 64 | ; (= %{env:OPAM_REPO_CI=false} false)) 65 | ; (modules net_timeout_test) 66 | ; (libraries riot port_finder)) 67 | 68 | (test 69 | (package riot) 70 | (name net_addr_uri_test) 71 | (enabled_if 72 | (= %{env:OPAM_REPO_CI=false} false)) 73 | (modules net_addr_uri_test) 74 | (libraries riot port_finder)) 75 | 76 | (test 77 | (package riot) 78 | (name net_reader_writer_test) 79 | (enabled_if 80 | (= %{env:OPAM_REPO_CI=false} false)) 81 | (modules net_reader_writer_test) 82 | (libraries riot port_finder)) 83 | 84 | ; (test 85 | ; (package riot) 86 | ; (name net_reader_writer_timeout_test) 87 | ; (enabled_if 88 | ; (= %{env:OPAM_REPO_CI=false} false)) 89 | ; (modules net_reader_writer_timeout_test) 90 | ; (libraries riot port_finder)) 91 | 92 | (test 93 | (package riot) 94 | (name net_test) 95 | (enabled_if 96 | (= %{env:OPAM_REPO_CI=false} false)) 97 | (modules net_test) 98 | (libraries riot port_finder)) 99 | 100 | (test 101 | (package riot) 102 | (name add_monitor_test) 103 | (modules add_monitor_test) 104 | (libraries riot)) 105 | 106 | (test 107 | (package riot) 108 | (name application_test) 109 | (modules application_test) 110 | (libraries riot)) 111 | 112 | ; TODO(@leostera): fix this flakey test 113 | ; (test 114 | ; (package riot) 115 | ; (name link_processes_test) 116 | ; (modules link_processes_test) 117 | ; (libraries riot)) 118 | 119 | (test 120 | (package riot) 121 | (name process_registration_test) 122 | (modules process_registration_test) 123 | (libraries riot)) 124 | 125 | ; (test 126 | ; (package riot) 127 | ; (name process_stealing_test) 128 | ; (modules process_stealing_test) 129 | ; (libraries riot)) 130 | 131 | (test 132 | (package riot) 133 | (name process_priority_test) 134 | (modules process_priority_test) 135 | (libraries riot)) 136 | 137 | (test 138 | (package riot) 139 | (name readme_example) 140 | (modules readme_example) 141 | (libraries riot)) 142 | 143 | (test 144 | (package riot) 145 | (name selective_receive_test) 146 | (modules selective_receive_test) 147 | (libraries riot)) 148 | 149 | (test 150 | (package riot) 151 | (name send_after_test) 152 | (modules send_after_test) 153 | (libraries riot)) 154 | 155 | (test 156 | (package riot) 157 | (name cancel_timer_test) 158 | (modules cancel_timer_test) 159 | (libraries riot)) 160 | 161 | (test 162 | (package riot) 163 | (name send_interval_test) 164 | (modules send_interval_test) 165 | (libraries riot)) 166 | 167 | (test 168 | (package riot) 169 | (name send_order_test) 170 | (modules send_order_test) 171 | (libraries riot)) 172 | 173 | (test 174 | (package riot) 175 | (name spawn_and_exit_test) 176 | (modules spawn_and_exit_test) 177 | (libraries riot)) 178 | 179 | (test 180 | (package riot) 181 | (name supervisor_shutdown_test) 182 | (modules supervisor_shutdown_test) 183 | (libraries riot)) 184 | 185 | (test 186 | (package riot) 187 | (name telemetry_test) 188 | (modules telemetry_test) 189 | (libraries riot)) 190 | 191 | (test 192 | (package riot) 193 | (name receive_timeout_test) 194 | (modules receive_timeout_test) 195 | (libraries riot)) 196 | 197 | (test 198 | (package riot) 199 | (name task_test) 200 | (modules task_test) 201 | (libraries riot)) 202 | 203 | (test 204 | (package riot) 205 | (name terminate_when_main_terminates_test) 206 | (modules terminate_when_main_terminates_test) 207 | (libraries riot)) 208 | -------------------------------------------------------------------------------- /packages/riot-runtime/util/lf_queue.ml: -------------------------------------------------------------------------------- 1 | (* Copyright (c) 2016 KC Sivaramakrishnan 2 | Copyright (C) 2022 Thomas Leonard 3 | *) 4 | (* A lock-free multi-producer, single-consumer, thread-safe queue without support for cancellation. 5 | This makes a good data structure for a scheduler's run queue. 6 | 7 | See: "Implementing lock-free queues" 8 | https://people.cs.pitt.edu/~jacklange/teaching/cs2510-f12/papers/implementing_lock_free.pdf 9 | 10 | It is simplified slightly because we don't need multiple consumers. 11 | Therefore [head] is not atomic. *) 12 | 13 | exception Closed 14 | 15 | module Node : sig 16 | type 'a t = { next : 'a opt Atomic.t; mutable value : 'a } 17 | and +'a opt 18 | 19 | val make : next:'a opt -> 'a -> 'a t 20 | 21 | val none : 'a opt 22 | (** [t.next = none] means that [t] is currently the last node. *) 23 | 24 | val closed : 'a opt 25 | (** [t.next = closed] means that [t] will always be the last node. *) 26 | 27 | val some : 'a t -> 'a opt 28 | val fold : 'a opt -> none:(unit -> 'b) -> some:('a t -> 'b) -> 'b 29 | end = struct 30 | (* https://github.com/ocaml/RFCs/pull/14 should remove the need for magic here *) 31 | 32 | type +'a opt (* special | 'a t *) 33 | type 'a t = { next : 'a opt Atomic.t; mutable value : 'a } 34 | type special = Nothing | Closed 35 | 36 | let none : 'a. 'a opt = Obj.magic Nothing 37 | let closed : 'a. 'a opt = Obj.magic Closed 38 | let some (t : 'a t) : 'a opt = Obj.magic t 39 | 40 | let fold (opt : 'a opt) ~none:n ~some = 41 | if opt == none then n () 42 | else if opt == closed then raise Closed 43 | else some (Obj.magic opt : 'a t) 44 | 45 | let make ~next value = { value; next = Atomic.make next } 46 | end 47 | 48 | type 'a t = { tail : 'a Node.t Atomic.t; mutable head : 'a Node.t } 49 | (* [head] is the last node dequeued (or a dummy node, initially). 50 | [head.next] gives the real first node, if not [Node.none]. 51 | If [tail.next] is [none] then it is the last node in the queue. 52 | Otherwise, [tail.next] is a node that is closer to the tail. *) 53 | 54 | let push t x = 55 | let node = Node.(make ~next:none) x in 56 | let rec aux () = 57 | let p = Atomic.get t.tail in 58 | (* While [p.next == none], [p] is the last node in the queue. *) 59 | if Atomic.compare_and_set p.next Node.none (Node.some node) then 60 | (* [node] has now been added to the queue (and possibly even consumed). 61 | Update [tail], unless someone else already did it for us. *) 62 | ignore (Atomic.compare_and_set t.tail p node : bool) 63 | else 64 | (* Someone else added a different node first ([p.next] is not [none]). 65 | Make [t.tail] more up-to-date, if it hasn't already changed, and try again. *) 66 | Node.fold (Atomic.get p.next) 67 | ~none:(fun () -> assert false) 68 | ~some:(fun p_next -> 69 | ignore (Atomic.compare_and_set t.tail p p_next : bool); 70 | aux ()) 71 | in 72 | aux () 73 | 74 | let rec push_head t x = 75 | let p = t.head in 76 | let next = Atomic.get p.next in 77 | if next == Node.closed then raise Closed; 78 | let node = Node.make ~next x in 79 | if Atomic.compare_and_set p.next next (Node.some node) then 80 | if 81 | (* We don't want to let [tail] get too far behind, so if the queue was empty, move it to the new node. *) 82 | next == Node.none 83 | then ignore (Atomic.compare_and_set t.tail p node : bool) 84 | else 85 | ( (* If the queue wasn't empty, there's nothing to do. 86 | Either tail isn't at head or there is some [push] thread working to update it. 87 | Either [push] will update it directly to the new tail, or will update it to [node] 88 | and then retry. Either way, it ends up at the real tail. *) ) 89 | else ( 90 | (* Someone else changed it first. This can only happen if the queue was empty. *) 91 | assert (next == Node.none); 92 | push_head t x) 93 | 94 | let rec close (t : 'a t) = 95 | (* Mark the tail node as final. *) 96 | let p = Atomic.get t.tail in 97 | if not (Atomic.compare_and_set p.next Node.none Node.closed) then 98 | (* CAS failed because [p] is no longer the tail (or is already closed). *) 99 | Node.fold (Atomic.get p.next) 100 | ~none:(fun () -> assert false) 101 | (* Can't switch from another state to [none] *) 102 | ~some:(fun p_next -> 103 | (* Make [tail] more up-to-date if it hasn't changed already *) 104 | ignore (Atomic.compare_and_set t.tail p p_next : bool); 105 | (* Retry *) 106 | close t) 107 | 108 | let peek t = t.head.value 109 | 110 | let pop t = 111 | let p = t.head in 112 | (* [p] is the previously-popped item. *) 113 | let node = Atomic.get p.next in 114 | Node.fold node 115 | ~none:(fun () -> None) 116 | ~some:(fun node -> 117 | t.head <- node; 118 | let v = node.value in 119 | node.value <- Obj.magic (); 120 | (* So it can be GC'd *) 121 | Some v) 122 | 123 | let is_empty t = 124 | Node.fold (Atomic.get t.head.next) 125 | ~none:(fun () -> true) 126 | ~some:(fun _ -> false) 127 | 128 | let create () = 129 | let dummy = { Node.value = Obj.magic (); next = Atomic.make Node.none } in 130 | { tail = Atomic.make dummy; head = dummy } 131 | -------------------------------------------------------------------------------- /packages/riot-stdlib/net.ml: -------------------------------------------------------------------------------- 1 | open Gluon 2 | open Global 3 | 4 | open Logger.Make (struct 5 | let namespace = [ "riot"; "net" ] 6 | end) 7 | 8 | module Socket = Gluon.Net.Socket 9 | module Addr = Gluon.Net.Addr 10 | 11 | module Tcp_listener = struct 12 | include Gluon.Net.Tcp_listener 13 | 14 | type listen_opts = { 15 | reuse_addr : bool; 16 | reuse_port : bool; 17 | backlog : int; 18 | addr : Addr.tcp_addr; 19 | } 20 | 21 | let default_listen_opts = 22 | { 23 | reuse_addr = true; 24 | reuse_port = true; 25 | backlog = 128; 26 | addr = Addr.loopback; 27 | } 28 | 29 | let bind ?(opts = default_listen_opts) ~port () = 30 | let { reuse_addr; reuse_port; backlog; addr } = opts in 31 | let addr = Addr.tcp addr port in 32 | trace (fun f -> f "Listening on 0.0.0.0:%d" port); 33 | bind ~reuse_port ~reuse_addr ~backlog addr 34 | 35 | let accept ?timeout t = 36 | let this = self () in 37 | let rec accept_loop t = 38 | trace (fun f -> f "Socket is Accepting client at fd=%a" Fd.pp t); 39 | match accept t with 40 | | Ok (conn, addr) -> 41 | trace (fun f -> 42 | f "Accepted client %a / %a" Addr.pp addr Socket.pp conn); 43 | Ok (conn, addr) 44 | | Error `Would_block -> 45 | trace (fun f -> 46 | f "Socket not ready, %a is retrying at fd=%a" Pid.pp this Fd.pp t); 47 | syscall "accept" Interest.(add readable writable) (to_source t) 48 | @@ fun () -> accept_loop t 49 | | Error err -> Error err 50 | in 51 | 52 | match timeout with 53 | | None -> accept_loop t 54 | | Some timeout -> 55 | trace (fun f -> f "accept with timeout %Ld" timeout); 56 | let task = Task.async (fun () -> accept_loop t) in 57 | let* result = Task.await ~timeout task in 58 | result 59 | 60 | let close t = 61 | let this = self () in 62 | trace (fun f -> f "Process %a: Closing socket fd=%a" Pid.pp this Fd.pp t); 63 | close t 64 | end 65 | 66 | module Tcp_stream = struct 67 | include Gluon.Net.Tcp_stream 68 | 69 | let close t = 70 | let this = self () in 71 | trace (fun f -> f "Process %a: Closing socket fd=%a" Pid.pp this Fd.pp t); 72 | close t 73 | 74 | let with_timeout ?timeout fn = 75 | match timeout with 76 | | None -> fn () 77 | | Some timeout -> 78 | let task = Task.async fn in 79 | let* result = Task.await ~timeout task in 80 | result 81 | 82 | let connect ?timeout addr = 83 | let rec connect_loop addr = 84 | trace (fun f -> f "Attempting to connect to %a" Addr.pp addr); 85 | match connect addr with 86 | | Ok (`Connected t) -> 87 | trace (fun f -> f "Connected to %a" Addr.pp addr); 88 | Ok t 89 | | Ok (`In_progress t) -> 90 | trace (fun f -> f "In_progress %a" Addr.pp addr); 91 | syscall "connect" Interest.(writable) (to_source t) @@ fun () -> Ok t 92 | | Error `Would_block -> 93 | yield (); 94 | connect_loop addr 95 | | Error err -> Error err 96 | in 97 | with_timeout ?timeout @@ fun () -> connect_loop addr 98 | 99 | let rec receive ?timeout ~bufs t = 100 | trace (fun f -> 101 | f "receiving up to %d octets from %a" (Rio.Iovec.length bufs) Socket.pp 102 | t); 103 | match read_vectored t bufs with 104 | | Ok len -> 105 | trace (fun f -> f "received: %d octets from %a" len Socket.pp t); 106 | Ok len 107 | | Error `Would_block -> 108 | trace (fun f -> f "waiting on %a to receive" Socket.pp t); 109 | syscall ?timeout "receive" Interest.readable (to_source t) @@ fun () -> 110 | receive ?timeout ~bufs t 111 | | Error err -> Error err 112 | 113 | let rec send ?timeout ~bufs t = 114 | trace (fun f -> f "sending: %d octets" (Rio.Iovec.length bufs)); 115 | match write_vectored t bufs with 116 | | Ok bytes -> 117 | trace (fun f -> f "sent: %d" (Rio.Iovec.length bufs)); 118 | Ok bytes 119 | | Error `Would_block -> 120 | trace (fun f -> f "retrying"); 121 | syscall ?timeout "send" Interest.writable (to_source t) @@ fun () -> 122 | send ?timeout ~bufs t 123 | | Error err -> Error err 124 | 125 | let pp_err fmt = function 126 | | `Timeout -> Format.fprintf fmt "Timeout" 127 | | `Process_down -> Format.fprintf fmt "Process_down" 128 | | `System_limit -> Format.fprintf fmt "System_limit" 129 | | `Closed -> Format.fprintf fmt "Closed" 130 | | `Unix_error err -> 131 | Format.fprintf fmt "Unix_error(%s)" (Unix.error_message err) 132 | 133 | let to_reader ?timeout:global_timeout t = 134 | let module Read = struct 135 | type nonrec t = t 136 | 137 | let read t ?timeout buf = 138 | let timeout = 139 | match timeout with None -> global_timeout | Some _ -> timeout 140 | in 141 | receive ?timeout ~bufs:(Rio.Iovec.of_bytes buf) t 142 | 143 | let read_vectored t bufs = receive ?timeout:global_timeout ~bufs t 144 | end in 145 | Rio.Reader.of_read_src (module Read) t 146 | 147 | let to_writer ?timeout t = 148 | let module Write = struct 149 | type nonrec t = t 150 | 151 | let write_owned_vectored t ~bufs = send ?timeout ~bufs t 152 | 153 | let write t ~buf = 154 | let bufs = Rio.Iovec.from_string buf in 155 | write_owned_vectored t ~bufs 156 | 157 | let flush _t = Ok () 158 | end in 159 | Rio.Writer.of_write_src (module Write) t 160 | end 161 | -------------------------------------------------------------------------------- /test/ssl_test.ml: -------------------------------------------------------------------------------- 1 | open Riot 2 | 3 | let () = Mirage_crypto_rng_unix.initialize (module Mirage_crypto_rng.Fortuna) 4 | 5 | type Message.t += Received of string 6 | 7 | (* rudimentary tcp echo server *) 8 | let server port socket = 9 | Logger.debug (fun f -> f "Started server on %d" port); 10 | process_flag (Trap_exit true); 11 | let conn, addr = Net.Tcp_listener.accept socket |> Result.get_ok in 12 | Logger.debug (fun f -> 13 | f "Accepted client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn); 14 | let close () = 15 | Net.Tcp_stream.close conn; 16 | Logger.debug (fun f -> 17 | f "Closed client %a (%a)" Net.Addr.pp addr Net.Socket.pp conn) 18 | in 19 | 20 | let certificates = 21 | let crt = 22 | let buf = IO.Buffer.with_capacity 4_096 in 23 | let _len = 24 | File.open_read "fixtures/tls.crt" 25 | |> File.to_reader |> IO.read_to_end ~buf |> Result.get_ok 26 | in 27 | let cs = IO.Buffer.contents buf in 28 | X509.Certificate.decode_pem_multiple cs |> Result.get_ok 29 | in 30 | let pk = 31 | let buf = IO.Buffer.with_capacity 4_096 in 32 | let file = File.open_read "fixtures/tls.key" in 33 | let reader = File.to_reader file in 34 | assert (Result.is_ok (IO.read_to_end ~buf reader)); 35 | let cs = IO.Buffer.contents buf in 36 | X509.Private_key.decode_pem cs |> Result.get_ok 37 | in 38 | `Single (crt, pk) 39 | in 40 | let config = Tls.Config.server ~certificates () |> Result.get_ok in 41 | let ssl = SSL.of_server_socket ~config conn in 42 | let reader, writer = SSL.(to_reader ssl, to_writer ssl) in 43 | 44 | let buf = IO.Bytes.with_capacity 1024 in 45 | let rec echo () = 46 | Logger.debug (fun f -> 47 | f "Reading from client client %a (%a)" Net.Addr.pp addr Net.Socket.pp 48 | conn); 49 | match IO.read reader buf with 50 | | Ok len -> ( 51 | Logger.debug (fun f -> f "Server received %d bytes" len); 52 | let bufs = IO.Iovec.(of_bytes buf |> sub ~len) in 53 | match IO.write_owned_vectored ~bufs writer with 54 | | Ok bytes -> 55 | Logger.debug (fun f -> f "Server sent %d bytes" bytes); 56 | echo () 57 | | Error (`Closed | `Timeout | `Process_down) -> close () 58 | | Error err -> 59 | Logger.error (fun f -> f "error %a" IO.pp_err err); 60 | close ()) 61 | | Error err -> 62 | Logger.error (fun f -> f "error %a" IO.pp_err err); 63 | close () 64 | in 65 | echo () 66 | 67 | let client server_port main = 68 | let addr = Net.Addr.(tcp loopback server_port) in 69 | let conn = Net.Tcp_stream.connect addr |> Result.get_ok in 70 | Logger.debug (fun f -> f "Connected to server on %d" server_port); 71 | 72 | let host = 73 | let domain_name = Domain_name.of_string_exn "localhost" in 74 | Domain_name.host_exn domain_name 75 | in 76 | 77 | let null ?ip:_ ~host:_ _ = Ok None in 78 | let config = Tls.Config.client ~authenticator:null () |> Result.get_ok in 79 | let ssl = SSL.of_client_socket ~host ~config conn in 80 | let reader, writer = SSL.(to_reader ssl, to_writer ssl) in 81 | 82 | let data = IO.Bytes.of_string "hello world" in 83 | let bufs = IO.Iovec.of_bytes data in 84 | let rec send_loop n = 85 | if n = 0 then Logger.error (fun f -> f "client retried too many times") 86 | else 87 | match IO.write_owned_vectored ~bufs writer with 88 | | Ok bytes -> Logger.debug (fun f -> f "Client sent %d bytes" bytes) 89 | | Error (`Timeout | `Process_down | `Closed) -> 90 | Logger.debug (fun f -> f "connection closed") 91 | | Error (`Unix_error (ENOTCONN | EPIPE)) -> send_loop n 92 | | Error err -> 93 | Logger.error (fun f -> f "error %a" IO.pp_err err); 94 | send_loop (n - 1) 95 | in 96 | send_loop 10_000; 97 | 98 | let buf = IO.Bytes.with_capacity 1024 in 99 | let recv_loop () = 100 | match IO.read reader buf with 101 | | Ok bytes -> 102 | Logger.debug (fun f -> f "Client received %d bytes" bytes); 103 | bytes 104 | | Error err -> 105 | Logger.error (fun f -> f "Error: %a" IO.pp_err err); 106 | 0 107 | in 108 | let len = recv_loop () in 109 | let buf = IO.Bytes.sub buf ~pos:0 ~len in 110 | 111 | if len = 0 then send main (Received "empty paylaod") 112 | else send main (Received (IO.Bytes.to_string buf)) 113 | 114 | let () = 115 | Riot.run @@ fun () -> 116 | let _ = Logger.start () |> Result.get_ok in 117 | Logger.set_log_level (Some Info); 118 | let socket, port = Port_finder.next_open_port () in 119 | let main = self () in 120 | let server = 121 | spawn (fun () -> 122 | try server port socket 123 | with SSL.Tls_failure failure -> 124 | Logger.error (fun f -> 125 | f "server error: %a" Tls.Engine.pp_failure failure)) 126 | in 127 | let client = 128 | spawn (fun () -> 129 | try client port main 130 | with SSL.Tls_failure failure -> 131 | Logger.error (fun f -> 132 | f "client error: %a" Tls.Engine.pp_failure failure)) 133 | in 134 | monitor server; 135 | monitor client; 136 | match receive_any ~after:500_000L () with 137 | | Received "hello world" -> Logger.info (fun f -> f "ssl_test: OK") 138 | | Received other -> 139 | Logger.error (fun f -> f "ssl_test: bad payload: %S" other); 140 | 141 | Stdlib.exit 1 142 | | Process.Messages.Monitor (Process_down pid) -> 143 | let who = if Pid.equal pid server then "server" else "client" in 144 | Logger.error (fun f -> 145 | f "ssl_test: %s(%a) died unexpectedly" who Pid.pp pid); 146 | 147 | Stdlib.exit 1 148 | | _ -> 149 | Logger.error (fun f -> f "ssl_test: unexpected message"); 150 | 151 | Stdlib.exit 1 152 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Riot 2 | 3 | Thanks for taking the time to contribute to Riot ✨ All contributions are 4 | welcomed! This includes: 5 | 6 | * PRs with bug fixes or features 7 | * Examples 8 | * Doc fixes 9 | * Bug reports 10 | * Links blogs featuring Riot 11 | * Links to projects using Riot that can serve as large examples 12 | * Links to libraries that can be used with Riot 13 | 14 | ### Installing from Sources 15 | 16 | #### Opam 17 | 18 | To install Riot from sources, make sure to include all its dependencies: 19 | 20 | ```sh 21 | ; opam pin config.0.0.2 git+https://github.com/ocaml-sys/config.ml -y 22 | ; opam pin libc.0.0.1 git+https://github.com/ocaml-sys/libc.ml -y 23 | ; opam pin rio.0.0.8 git+https://github.com/riot-ml/riot -y 24 | ; opam pin bytestring.0.0.8 git+https://github.com/riot-ml/riot -y 25 | ; opam pin gluon.0.0.8 git+https://github.com/riot-ml/riot -y 26 | ; opam pin riot.0.0.8 git+https://github.com/riot-ml/riot -y 27 | ``` 28 | 29 | You can run builds with: 30 | 31 | ```sh 32 | ; dune build 33 | ``` 34 | 35 | You can run all tests with: 36 | 37 | ```sh 38 | ; dune test 39 | ``` 40 | 41 | #### Nix 42 | 43 | The only requirement is that you have nix installed with flakes enabled. 44 | 45 | To build the project you can run: 46 | 47 | ```sh 48 | ; nix build 49 | ``` 50 | 51 | To enter a dev shell with all deps, utop, lsp, and dune installed, simply run: 52 | 53 | ```sh 54 | ; nix develop 55 | ``` 56 | 57 | Or if you're using direnv: 58 | 59 | ```sh 60 | ; echo 'use flake' >> .envrc && direnv allow 61 | ``` 62 | 63 | An example repo for creating new projects using riot and nix intended for those new to nix can be found [here](https://github.com/metame/nix_riot_example). 64 | 65 | ### Adding tests 66 | 67 | If you want to add a test, you can do so by creating a new OCaml file in the 68 | `test` folder and updating `test/dune` to include a stanza for your test. The 69 | boilerplate we use for a test is: 70 | 71 | ```ocaml 72 | [@@@warning "-8"] 73 | open Riot 74 | 75 | let main () = 76 | let (Ok _) = Logger.start () in 77 | 78 | (* you can change this log level to Debug while you debug your tests *) 79 | Logger.set_log_level (Some Info); 80 | 81 | (* your test code *) 82 | let passed = true in 83 | 84 | match passed with 85 | | true -> 86 | Logger.info (fun f -> f "print that everything went well"); 87 | shutdown () 88 | | _ -> 89 | Logger.error (fun f -> f "print that something went wrong"); 90 | sleep 0.1; 91 | Stdlib.exit 1 92 | 93 | let () = Riot.run @@ main 94 | ``` 95 | 96 | Ideally tests will run `Riot.run` without configuring it too much, but it can 97 | be helpful to reduce the number of schedulers you use while you're creating a 98 | test to begin with, or if you're testing behavior of a single scheduler. To do 99 | that you can set the `~workers` argument to `0`, so that no new schedulers are 100 | created and you run only the main thread. 101 | 102 | ```ocaml 103 | let () = Riot.run ~workers:0 @@ main 104 | ``` 105 | 106 | ### Running tests 107 | 108 | For the moment we rely on `dune test` to execute the small battery of tests. 109 | Some of them take a long time (hello `spawn_many`), but they are helpful in 110 | determining if we have bugs in a moderate number of processes (eg. 1M of them). 111 | 112 | ### Debugging Concurrency/Parallel Bugs 113 | 114 | If you find or introduce a bug into Riot, a quick way to debug what is 115 | happening is to enable TRACE logging in the runtime. Right now this is done 116 | by manually setting the default log level to `(Some Trace)`. 117 | 118 | ``` 119 | Riot.Runtime.Log.set_log_level (Some Trace); 120 | ``` 121 | 122 | Once you do this, running your Riot program will emit _a lot of logs_. And it 123 | will also run a lot slower. Trace logs (and any low-level logs) are implemented 124 | using a lock over a stdout formatter, to ensure the outputs are consistent and 125 | isn't being overwritten by other threads. 126 | 127 | To make sense of these logs I recommend to: 128 | 129 | 1. Redirect this output to a file: `dune exec ./my_test.exe > logs` 130 | 2. Open the logs in your favorite editor to find the Pid that went bad (usually 131 | that got stuck in a loop) 132 | 3. Filter logs by pid: `cat logs | grep "0\.992\.0" | head -n 100` 133 | 134 | This usually helps me find the sequence of actions for a Pid that tell me how 135 | it got into its state. 136 | 137 | You may find you need more information than is available. Feel free to add more 138 | `Log.trace` calls all over Riot wherever you see fit, and submit them in a PR 139 | if you think they'll help other people find bugs too. 140 | 141 | `Log.*` functions are cheap if the logs are disabled, since the function you 142 | pass to them only is evaluated when that log level is enabled. 143 | 144 | ## Performance 145 | 146 | For doing performance work, it helps to use the `olly` tracer from the 147 | `runtime_events_tools` package. 148 | 149 | ``` 150 | ; opam install runtime_events_tools -y 151 | ; olly trace riot.trace _build/default/examples/http_server/main.exe 152 | ``` 153 | 154 | `olly` will crate a trace file called `riot.trace` and you can open this file 155 | in 2 steps: 156 | 157 | 1. run `./tools/trace_processor --httpd ./riot.trace` to preprocess the file 158 | (takes a bit) 159 | 2. go to `https://ui.perfetto.dev/` and click YES on the "Trace Processor 160 | Native Acceleration" dialogue 161 | 162 | #### Basic Usage 163 | 164 | Typically you'll want to find all the instances of a certain 165 | operation that is slow. You can most likely see them straight 166 | on in the viewer, like this: 167 | 168 | 1. click on a Process to see it expand 169 | 2. click on the trace name you're interested in (say `major_slice`) 170 | 3. in the details tab below click on the name 171 | 4. click on "Slices with the same name" 172 | 5. click on Duration and sort by Highest First 173 | 174 | That should show you the list of all the instances of the 175 | trace you're looking for, sorted by the slowest ones. 176 | -------------------------------------------------------------------------------- /packages/riot-runtime/time/timer_wheel.ml: -------------------------------------------------------------------------------- 1 | (** 2 | The Timer Wheel keeps track of all the timers per scheduler, and is in 3 | charge of triggering them and cleaning them up. 4 | 5 | It is structured as 2 lists of timers, and a lookup table of timers per 6 | [tid] (timer id) that can be used to mark a timer as cancelled before it 7 | triggers. 8 | 9 | The list of timers are used for appending timers and for traversing them, 10 | where [timers] is the left-to-right traversal of timers in the order they 11 | were created, and [next_timers] will reversed and appended to [timers] 12 | before every iteration, but allows creating a timer in constant time. 13 | 14 | On every iteration, the timer wheel will go through the list of timers: 15 | 16 | * When a timer is [`finished], it will be removed off the list. 17 | 18 | * When a timer is triggered, its associated function will be executed. If 19 | the timer mode is [`interval], then the timer will be updated to trigger 20 | again in the expected time. If the timer mode is [`one_off]) then it will 21 | be removed from the list. 22 | 23 | * Otheriwse, a timer with [`pending] status will be kept in the list for the 24 | next iteration of the timer wheel. 25 | 26 | *) 27 | 28 | open Core 29 | open Util 30 | 31 | (** A Timer in the Riot runtime. *) 32 | module Timer = struct 33 | type t = { 34 | id : unit Ref.t; 35 | mode : [ `interval | `one_off ]; 36 | mutable status : [ `pending | `finished ]; 37 | mutable started_at : Mtime.t; 38 | mutable timeouts_at : Mtime.t; 39 | ends_at : Mtime.Span.t; 40 | fn : unit -> unit; 41 | } 42 | 43 | let pp fmt t = 44 | let mode = if t.mode = `interval then "interval" else "one_off" in 45 | Format.fprintf fmt "Timer { id=%a; started_at=%a; ends_at=%a; mode=%s }" 46 | Ref.pp t.id Mtime.pp t.started_at Mtime.Span.pp t.ends_at mode 47 | 48 | let make time mode fn = 49 | let id = Ref.make () in 50 | let started_at = Mtime_clock.now () in 51 | let ends_at = Mtime.Span.of_uint64_ns Int64.(mul 1_000L time) in 52 | let timeouts_at = Mtime.add_span started_at ends_at |> Option.get in 53 | { id; started_at; ends_at; timeouts_at; fn; mode; status = `pending } 54 | 55 | let equal a b = Ref.equal a.id b.id 56 | let is_finished t = t.status = `finished 57 | 58 | let mark_as_cancelled t = 59 | Log.debug (fun f -> f "Cancelled timer %a" pp t); 60 | t.status <- `finished 61 | 62 | let leq a b = Mtime.compare a.timeouts_at b.timeouts_at <= 0 63 | end 64 | 65 | module TimeHeap = Min_heap.Make (Timer) 66 | 67 | type t = { 68 | lock : Mutex.t; 69 | mutable timers : TimeHeap.t; 70 | timer_count : int Atomic.t; 71 | ids : Timer.t Ref.Map.t; 72 | mutable last_t : Mtime.t; [@warning "-69"] 73 | } 74 | 75 | let create () = 76 | { 77 | lock = Mutex.create (); 78 | timers = TimeHeap.empty; 79 | ids = Ref.Map.create (); 80 | last_t = Mtime_clock.now (); 81 | timer_count = Atomic.make 0; 82 | } 83 | 84 | let can_tick t = Atomic.get t.timer_count > 0 85 | let size t = Atomic.get t.timer_count 86 | 87 | let is_finished t tid = 88 | match Ref.Map.get t.ids tid with 89 | | None -> true 90 | | Some timer -> Timer.is_finished timer 91 | 92 | let remove_timer t timer = 93 | Mutex.protect t.lock @@ fun () -> 94 | let timers = Ref.Map.get_all t.ids timer in 95 | List.iter Timer.mark_as_cancelled timers; 96 | Ref.Map.remove_by t.ids (fun (k, _) -> Ref.equal k timer) 97 | 98 | let add_timer t timer = 99 | Mutex.protect t.lock @@ fun () -> 100 | t.timers <- TimeHeap.insert timer t.timers; 101 | Atomic.incr t.timer_count; 102 | Ref.Map.insert t.ids timer.id timer; 103 | Log.debug (fun f -> f "Created timer %a" Timer.pp timer); 104 | timer.id 105 | 106 | let clear_timer t tid = 107 | Mutex.protect t.lock @@ fun () -> 108 | let timer = Ref.Map.get t.ids tid in 109 | Option.iter Timer.mark_as_cancelled timer; 110 | Ref.Map.remove t.ids tid 111 | 112 | let make_timer t time mode fn = 113 | let timer = Timer.make time mode fn in 114 | add_timer t timer 115 | 116 | let run_timer now timer = 117 | let open Timer in 118 | if Timer.is_finished timer then ( 119 | Log.debug (fun f -> f "Removing already finished timer: %a" Timer.pp timer); 120 | None) 121 | else 122 | let ends_at = Mtime.add_span timer.started_at timer.ends_at |> Option.get in 123 | let timeout = Mtime.is_later now ~than:ends_at || Mtime.equal now ends_at in 124 | Log.debug (fun f -> 125 | f "now(%a) > ends_at(%a) = %b" Mtime.pp now Mtime.pp ends_at timeout); 126 | Log.debug (fun f -> 127 | f "Running timer %a with ends_at=%a -> timeout? %b" Timer.pp timer 128 | Mtime.pp ends_at timeout); 129 | if timeout then ( 130 | Log.debug (fun f -> f "timer timedout!"); 131 | timer.fn (); 132 | match timer.mode with 133 | | `one_off -> 134 | Log.debug (fun f -> f "Removing timer"); 135 | Timer.mark_as_cancelled timer; 136 | None 137 | | `interval -> 138 | Log.debug (fun f -> f "Requeuing timer"); 139 | timer.started_at <- now; 140 | timer.timeouts_at <- 141 | Mtime.add_span timer.started_at timer.ends_at |> Option.get; 142 | Some timer) 143 | else ( 144 | Log.debug (fun f -> f "no timeout yet, continuing"); 145 | Some timer) 146 | 147 | let rec run_timers t now timers = 148 | match TimeHeap.take timers with 149 | | None -> TimeHeap.empty 150 | | Some (_, timer) when Mtime.is_later timer.timeouts_at ~than:now -> timers 151 | | Some (timers', timer) -> ( 152 | match run_timer now timer with 153 | | None -> 154 | Atomic.decr t.timer_count; 155 | run_timers t now timers' 156 | | Some timer -> 157 | let timers'' = TimeHeap.insert timer timers' in 158 | run_timers t now timers'') 159 | 160 | let tick t = 161 | Mutex.protect t.lock @@ fun () -> 162 | let now = Mtime_clock.now () in 163 | Log.trace (fun f -> 164 | f "Started Ticking %d timers %a" (Atomic.get t.timer_count) Mtime.pp now); 165 | t.timers <- run_timers t now t.timers; 166 | t.last_t <- now; 167 | Log.trace (fun f -> 168 | f "Done Ticking (%d timers left) %a" (Atomic.get t.timer_count) Mtime.pp 169 | (Mtime_clock.now ())) 170 | -------------------------------------------------------------------------------- /packages/riot-runtime/import.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let _get_pool = Scheduler.Pool.get_pool 4 | let _get_sch = Scheduler.get_current_scheduler 5 | 6 | let _get_proc pid = 7 | let pool = _get_pool () in 8 | let proc = Proc_table.get pool.processes pid |> Option.get in 9 | proc 10 | 11 | let self () = Scheduler.get_current_process_pid () 12 | 13 | let syscall ?timeout name interest source cb = 14 | let timeout = 15 | match timeout with None -> `infinity | Some after -> `after after 16 | in 17 | Effect.perform (Proc_effect.Syscall { name; interest; source; timeout }); 18 | cb () 19 | 20 | let receive : 21 | type msg. 22 | selector:(Message.t -> [ `select of msg | `skip ]) -> 23 | ?after:int64 -> 24 | ?ref:unit Ref.t -> 25 | unit -> 26 | msg = 27 | fun ~selector ?after ?ref () -> 28 | let timeout = 29 | match after with None -> `infinity | Some after -> `after after 30 | in 31 | Effect.perform (Proc_effect.Receive { ref; timeout; selector }) 32 | 33 | let receive_any ?after ?ref () = 34 | receive ~selector:(fun msg -> `select msg) ?after ?ref () 35 | 36 | let yield () = Effect.perform Proc_effect.Yield 37 | let random () = (_get_sch ()).rnd 38 | 39 | let sleep time = 40 | let now = Unix.gettimeofday () in 41 | let rec go finish = 42 | yield (); 43 | let now = Unix.gettimeofday () in 44 | if now > finish then () else go finish 45 | in 46 | go (now +. time) 47 | 48 | let process_flag flag = 49 | let this = self () in 50 | let proc = _get_proc this in 51 | Log.trace (fun f -> f "Process %a: updating process flag" Pid.pp this); 52 | Process.set_flag proc flag 53 | 54 | let exit pid reason = 55 | let pool = _get_pool () in 56 | match Proc_table.get pool.processes pid with 57 | | Some proc -> 58 | Log.debug (fun f -> f "%a exited by %a" Pid.pp proc.pid Pid.pp (self ())); 59 | Process.mark_as_exited proc reason 60 | | None -> () 61 | 62 | (* NOTE(leostera): to send a message, we will find the receiver process 63 | in the process table and queue at the back of their mailbox 64 | *) 65 | let send pid msg = 66 | let pool = _get_pool () in 67 | match Proc_table.get pool.processes pid with 68 | | Some proc -> 69 | Process.send_message proc msg; 70 | Scheduler.awake_process pool proc; 71 | Log.trace (fun f -> 72 | f "sent message from %a to %a" Pid.pp (self ()) Process.pp proc) 73 | | None -> 74 | Log.debug (fun f -> 75 | f "COULD NOT DELIVER message from %a to %a" Pid.pp (self ()) Pid.pp 76 | pid) 77 | 78 | exception Invalid_destination of string 79 | 80 | let send_by_name ~name msg = 81 | let pool = _get_pool () in 82 | match Proc_registry.find_pid pool.registry name with 83 | | Some pid -> send pid msg 84 | | None -> raise (Invalid_destination name) 85 | 86 | exception Link_no_process of Pid.t 87 | 88 | let _link (proc1 : Process.t) (proc2 : Process.t) = 89 | Process.add_link proc1 proc2.pid; 90 | Process.add_link proc2 proc1.pid 91 | 92 | let link pid = 93 | let this = self () in 94 | Log.debug (fun f -> f "linking %a <-> %a" Pid.pp this Pid.pp pid); 95 | let pool = _get_pool () in 96 | let this_proc = _get_proc this in 97 | match Proc_table.get pool.processes pid with 98 | | Some proc -> 99 | if Process.is_alive proc then _link this_proc proc 100 | else raise (Link_no_process pid) 101 | | None -> () 102 | 103 | let _spawn ?priority ?(do_link = false) ?(pool = _get_pool ()) 104 | ?(scheduler = Scheduler.get_random_scheduler pool) fn = 105 | let proc = 106 | Process.make scheduler.uid (fun () -> 107 | try 108 | fn (); 109 | Normal 110 | with 111 | | Proc_state.Unwind -> Normal 112 | | exn -> 113 | Log.error (fun f -> 114 | f "Process %a died with unhandled exception %s:\n%s" Pid.pp 115 | (self ()) (Printexc.to_string exn) 116 | (Printexc.get_backtrace ())); 117 | 118 | Exception exn) 119 | in 120 | 121 | (match priority with 122 | | Some p -> Process.set_flag proc (Priority p) 123 | | None -> ()); 124 | 125 | if do_link then ( 126 | let this = self () in 127 | Log.debug (fun f -> f "linking %a <-> %a" Pid.pp this Pid.pp proc.pid); 128 | let this_proc = _get_proc this in 129 | _link this_proc proc); 130 | 131 | Scheduler.Pool.register_process pool proc; 132 | Scheduler.awake_process pool proc; 133 | proc.pid 134 | 135 | let spawn fn = _spawn ~do_link:false fn 136 | 137 | let spawn_pinned fn = 138 | _spawn ~do_link:false ~scheduler:(Scheduler.get_current_scheduler ()) fn 139 | 140 | let spawn_link fn = _spawn ~do_link:true fn 141 | 142 | let monitor pid = 143 | let pool = _get_pool () in 144 | let this = _get_proc (self ()) in 145 | match Proc_table.get pool.processes pid with 146 | | Some proc -> 147 | Process.add_monitor proc this.pid; 148 | Process.add_monitored_by this proc.pid 149 | | None -> () 150 | 151 | let demonitor pid = 152 | let pool = _get_pool () in 153 | let this = _get_proc (self ()) in 154 | match Proc_table.get pool.processes pid with 155 | | Some proc -> 156 | Process.remove_monitor proc this.pid; 157 | Process.remove_monitored_by this proc.pid 158 | | None -> () 159 | 160 | let register pid name = 161 | let pool = _get_pool () in 162 | Proc_registry.register pool.registry pid name 163 | 164 | let unregister name = 165 | let pool = _get_pool () in 166 | Proc_registry.unregister pool.registry name 167 | 168 | let where_is name = 169 | let pool = _get_pool () in 170 | Proc_registry.find_pid pool.registry name 171 | 172 | let processes () = 173 | yield (); 174 | let pool = _get_pool () in 175 | Proc_table.processes pool.processes 176 | 177 | let is_process_alive pid = 178 | yield (); 179 | let pool = _get_pool () in 180 | match Proc_table.get pool.processes pid with 181 | | Some proc -> Process.is_alive proc 182 | | None -> false 183 | 184 | let wait_pids pids = 185 | (* First we make sure we are monitoring all the pids we are awaiting *) 186 | List.iter monitor pids; 187 | 188 | (* Immediately after monitoring, we want to make sure we remove 189 | from the list all the pids that are already terminated, since we won't 190 | receive monitoring messages for those. *) 191 | let pool = _get_pool () in 192 | let pids = 193 | List.filter 194 | (fun pid -> 195 | match Proc_table.get pool.processes pid with 196 | | Some proc -> Process.is_alive proc 197 | | None -> false) 198 | pids 199 | in 200 | 201 | (* Now we can create our selector function to select the monitoring 202 | messages for the pids we care about. *) 203 | let selector msg = 204 | let open Process.Messages in 205 | match msg with 206 | | Monitor (Process_down pid) when List.mem pid pids -> 207 | `select (Process_down pid) 208 | | _ -> `skip 209 | in 210 | 211 | (* And we can enter the receive loop, filtering out the pids as they come. 212 | When the list of pids becomes empty, we exit the recursion. *) 213 | let rec do_wait pids = 214 | if List.length pids = 0 then () 215 | else 216 | match receive ~selector () with 217 | | Process_down pid -> 218 | let pids = List.filter (fun pid' -> not (Pid.equal pid' pid)) pids in 219 | do_wait pids 220 | in 221 | do_wait pids 222 | 223 | module Timer = struct 224 | type timeout = Util.Timeout.t 225 | type timer = unit Ref.t 226 | 227 | let _set_timer pid msg time mode = 228 | let sch = _get_sch () in 229 | let timer_ref = 230 | Scheduler.set_timer sch time mode (fun () -> send pid msg) 231 | in 232 | Ok timer_ref 233 | 234 | let send_after pid msg ~after:time = _set_timer pid msg time `one_off 235 | let send_interval pid msg ~every:time = _set_timer pid msg time `interval 236 | 237 | let cancel timer = 238 | let sch = _get_sch () in 239 | Scheduler.remove_timer sch timer 240 | end 241 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 0.0.9 2 | 3 | * Introduce Message Selectors – selectors are functions from `Message.t` down 4 | to a specific subset of messages your process is currently interested in. 5 | Messages that aren't selected will be kept in the queue in place. This allows 6 | us to implement patterns where we scan the mailbox for specific messages, 7 | while allowing new messages to come in and not be accidentally discarded. 8 | 9 | * Several nix-flake improvements – thanks to @metame :clap: 10 | 11 | * Introduce a new `run_with_status` function that converts a Result into an 12 | exit status, and helps one-off programs be written more succintly – thanks 13 | @Dev380 :sparkles: 14 | 15 | * Add File.exists to the Riot lib 16 | 17 | * Fix TLS dependency to 0.17.3 18 | 19 | # 0.0.8 20 | 21 | This is the largest Riot release yet, and we are splitting the package into 4 sub-packages: 22 | 23 | * the Riot runtime+library 24 | * Bytestring – efficient and ergonomic bytestring manipulation 25 | * Gluon – a low-level, efficient async I/O engine 26 | * Rio – composable I/O streams for vectored operations 27 | 28 | ### Riot Runtime 29 | 30 | * Improved performance and memory usage by creating 95% smaller processes, 31 | ensuring fibers are always properly discontinued to release their resources, 32 | and moving to Weak references for processes to ensure they get garbage 33 | collected timely. 34 | 35 | * Introduce Process Priorities – the scheduler has been improved to support 36 | processes with different priorities (High, Normal, and Low). Thanks 37 | @LeedsJohn for the contribution! 👏 38 | 39 | * Introduce `receive` Timeouts – you can now call `receive ~after:10L ()` and 40 | if there are messages fetched in 10 microseconds `receive` will raise a 41 | `Receive_timeout` exception that you can match on. 42 | 43 | * Introduce `syscall` Timeouts – any syscall being made now can specify a 44 | timeout for an answer. If the syscall isn't ready to retry within the timeout 45 | period, a `Syscall_timeout` exception will be raised. 46 | 47 | * Improve `Timer_wheel` with support for clearing timers, iterating timers 48 | in the order in which they were created, and a MinHeap backend. 49 | 50 | ### Riot Lib 51 | 52 | * New `Dynamic_supervisor` to dynamically allocate pools of processes up to a 53 | maximum. 54 | 55 | * New `Runtime.Stats` server can be started to periodically print out 56 | statistics about the runtime and the garbage collector. 57 | 58 | * The `Net.Socket` module is now split into a `Tcp_listener` and a 59 | `Tcp_stream`, with their corresponding functions for listening, connecting, 60 | sending, and receiving. These also include support for timeouts. 61 | 62 | * New File and File Descriptor operations for seeking. Thanks to @diogomqbm! 👏 63 | 64 | * Introduce SSL module to turn sockets into SSL-backed Reader/Writer streams. 65 | This includes making a `Net.Socket.stream_socket` into a client or a server 66 | SSL-backed stream pair. 67 | 68 | * Introduce `Task` to quickly spin up processes that we can await. This is the 69 | closest we have to a future. A `Task` is typed, executes a single function, 70 | and MUST be awaited with `Task.await ?timeout task`. 71 | 72 | * Introduce `Crypto.Random` module with high-level utilities for creating 73 | random data of different types, including integers of different sizes, 74 | strings, bytestrings, bytes, characters, and ASCII strings. 75 | 76 | * Introduce new named pid functions `Process.where_is` and `Porcess.await_name` 77 | to make it easier to find pids by name, and await a name to be registered. 78 | 79 | * New `Process.is_alive` predicate to check if a process is alive 80 | 81 | * Improve logging on most modules with namespaces 82 | 83 | * Initializing the Riot runtime twice results in a runtime exception – thanks 84 | @julien-leclercq for the contribution! 👏 85 | 86 | * Introduce `Ref.cast` to do type-safe type-casting based on runtime 87 | information of a Ref at its instantiation time. 88 | 89 | * Introduce a `Stream` module that extends the stdlib Seq with a `reduce_while` combinator. 90 | 91 | * Introduce inmemory key-value `Store` that works in a process-friendly 92 | fashion, similar to Erlang's ETS. 93 | 94 | ### Bytestring 95 | 96 | * First implementation of efficient immutable byte strings with cheap view and 97 | concat operations. Thanks to @felipecrv for contributing! 👏 98 | 99 | * Iterators and Transient builders for efficiently examining, destructuring, 100 | and constructing byte strings from different sources. 101 | 102 | * Preliminary Bytestrings syntax support (via a ppx) for constructions and 103 | efficient pattern matching using the `%b` sigil. 104 | 105 | ### Gluon 106 | 107 | * First implementation of an efficient, low-level async I/O engine inspired by 108 | Rust's Mio. Gluon uses an opaque Token based approach that lets you directly 109 | reference an OCaml value as part of the polled events from the underlying 110 | async engine. Thanks to @diogomqbm and @emilpriver for contributing! 👏 111 | 112 | * Preliminary support for epoll on Linux and kqueue on macOS with conditional 113 | compilation via the `config` package. 114 | 115 | ### Rio 116 | 117 | * First implementation of composable I/O streams via a Read/Write interface 118 | inspired by Rust's Read/Write traits. 119 | 120 | # 0.0.7 121 | 122 | * Introduce IO module with low-level IO operations such as performing direct 123 | vectorized (or regular) reads/writes. New operations include: 124 | * `read`, `write` 125 | * `single_read`, `single_write` (vectorized) 126 | * `await_readable`, `await_writeable`, `await` 127 | * `write_all` 128 | * `copy` and `copy_buffered` 129 | 130 | * Introduce Buffer module with support for converting from and to CStruct and 131 | String, including position tracking. 132 | 133 | * Introduce Read/Reader interface for creating buffered and unbuffered readers 134 | of arbitrary sources. 135 | 136 | * Introduce Write/Writer interfaces for creating unbuffered writers into 137 | arbitrary destinations/sinks. 138 | 139 | * Introduce File module with Reader and Writer implementations 140 | 141 | * Implment Reader and Writer interfaces for Net.Socket 142 | 143 | * Dropped dependency on Bigstringaf and moved to Cstruct 144 | 145 | * Fix max number of domains to always be under the recommended domain count 146 | 147 | * Fix issue with tests where the runtime idled after the main would die. Now 148 | the main process finishing with an exception is considered reason enough to 149 | shutdown the system. 150 | 151 | * Refactor tests to always output `test_name: OK` when everything is fine and 152 | all modules to end in `_test`. 153 | 154 | * Add several IO tests. 155 | 156 | * Fix log levels for writing to sockets 157 | 158 | * Include proper license for C Stubs copied from `lib_eio_posix` for vectorized i/o. 159 | 160 | * Split test suite into io/non-io so io tests are left outside opam ci 161 | 162 | * Improved IO polling that removes heavy iterations over process/fds tables 163 | 164 | * Rewrite Dashmap internals to use a Hashtbl 165 | 166 | 167 | # 0.0.6 168 | 169 | * Redo packaging to expose a single public library: `riot` 170 | * Fix issue with schedulers busy-waiting 171 | * Introduce separate IO Schedulers for polling 172 | * Switch to `poll` to support kqueue on macOS 173 | * Reuse read-buffers on Rio.read loops 174 | * Broaden IO socket types to file descriptors 175 | * Improved polling with shorter poll timeouts and safety checks 176 | * Add `Dashmap.iter` to iterate over a collection 177 | * Add `net_test` with an echo tcp server/client 178 | * Fix bugs with syscall suspension that was introduced with reduction counting 179 | 180 | 181 | # 0.0.5 182 | 183 | * Add `register name pid` 184 | * Add `unregister name` 185 | * Add `send_by_name ~name msg` 186 | * Fix timer wheel making it remove timers correctly 187 | * Add better test for `Timer.send_after` 188 | 189 | # 0.0.4 190 | 191 | * Internally immediately suspend (bypassing reduction counts) when on a receive expression 192 | * Fix reads from closed Unix sockets 193 | * Fix writes to closed Unix sockets 194 | * Ignore SIGPIPEs on setup 195 | * Fix always mark connected sockets as nonblocking 196 | * Fix GC i/o process table 197 | * Surface pretty-printing of socket values 198 | 199 | # 0.0.3 200 | 201 | * Big namespace refactor. `Riot.Runtime` includes the lower-level runtime 202 | blocks, and everything else that is more user-friendly lives at the `Riot.*` 203 | level. 204 | * Introduce reduction counting, so processes will run up to N iterations unless 205 | they finish, or they execute an unhandled effect. 206 | * Introduce the `Application` interface for managing the lifecycle of the system 207 | * Fix `Riot.Logger` to fit the `Application` interface 208 | * Add a new `Riot.Telemetry` backend for doing async telemetry 209 | 210 | # 0.0.2 211 | 212 | * New `Riot.random ()` API to expose current scheduler's random state 213 | * Better logging in the `Net` module 214 | * Fix a bug where `Net.Socket` operations where hanging on I/O polling when they could have been eager 215 | 216 | # 0.0.1 217 | 218 | First release, including: 219 | 220 | * First working version of the scheduler 221 | * Support for process spawning, message passing, monitoring, and linking 222 | * Rudimentary supervisors 223 | * Basic (and incomplete) GenServer 224 | * Scheduling-aware I/O primitives 225 | * Scheduling-aware Logger 226 | * Timers 227 | 228 | -------------------------------------------------------------------------------- /packages/riot-stdlib/SSL.ml: -------------------------------------------------------------------------------- 1 | (****************************************************************************************** 2 | 3 | The Tls_unix below was ported from `ocaml-tls`, its `eio` subpackage, specifically from: 4 | * https://github.com/mirleft/ocaml-tls/blob/main/eio/tls_eio.ml 5 | * https://github.com/mirleft/ocaml-tls/blob/main/eio/x509_eio.ml 6 | 7 | under this license: 8 | 9 | Copyright (c) 2014, David Kaloper and Hannes Mehnert 10 | All rights reserved. 11 | 12 | Redistribution and use in source and binary forms, with or without modification, 13 | are permitted provided that the following conditions are met: 14 | 15 | * Redistributions of source code must retain the above copyright notice, this 16 | list of conditions and the following disclaimer. 17 | 18 | * Redistributions in binary form must reproduce the above copyright notice, this 19 | list of conditions and the following disclaimer in the documentation and/or 20 | other materials provided with the distribution. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 23 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 24 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 25 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR 26 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 27 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON 29 | ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | 33 | *******************************************************************************************) 34 | 35 | open Logger.Make (struct 36 | let namespace = [ "riot"; "net"; "ssl" ] 37 | end) 38 | 39 | module IO = Rio 40 | 41 | let ( let* ) = Result.bind 42 | 43 | type 'src t = { 44 | writer : 'src IO.Writer.t; 45 | reader : 'src IO.Reader.t; 46 | mutable state : [ `Active of Tls.Engine.state | `Eof | `Error of exn ]; 47 | mutable linger : string option; 48 | recv_buf : bytes; 49 | } 50 | 51 | exception Tls_alert of Tls.Packet.alert_type 52 | exception Tls_failure of Tls.Engine.failure 53 | 54 | module Tls_unix = struct 55 | exception Read_error of Rio.io_error 56 | exception Write_error of Rio.io_error 57 | 58 | let err_to_str err = Format.asprintf "%a" Rio.pp_err err 59 | 60 | let read_t t dst = 61 | let src = IO.Bytes.with_capacity (Bytes.length dst) in 62 | match IO.read t.reader src with 63 | | Ok len -> 64 | trace (fun f -> f "read_t: %d/%d" len (Bytes.length dst)); 65 | BytesLabels.blit ~src ~src_pos:0 ~dst ~dst_pos:0 ~len; 66 | len 67 | | Error (`Closed | `Eof) -> 68 | trace (fun f -> f "read_t: 0/%d" (Bytes.length dst)); 69 | raise End_of_file 70 | | Error err -> 71 | trace (fun f -> f "read_t: error: %s" (err_to_str err)); 72 | let exn = Read_error err in 73 | (match t.state with 74 | | `Error _ | `Eof -> () 75 | | `Active _ -> t.state <- `Error exn); 76 | raise exn 77 | 78 | let write_t t data = 79 | let bufs = IO.Iovec.from_string data in 80 | match IO.write_owned_vectored t.writer ~bufs with 81 | | Ok bytes -> trace (fun f -> f "write_t: %d/%d" bytes (String.length data)) 82 | | Error err -> 83 | trace (fun f -> f "write_t: error: %s" (err_to_str err)); 84 | let exn = Write_error err in 85 | (match t.state with 86 | | `Error _ | `Eof -> () 87 | | `Active _ -> t.state <- `Error exn); 88 | raise exn 89 | 90 | let try_write_t t cs = 91 | try write_t t cs with _ -> trace (fun f -> f "try_write_t failed") 92 | 93 | let inject_state tls = function 94 | | `Active _ -> `Active tls 95 | | `Eof -> `Eof 96 | | `Error _ as e -> e 97 | 98 | let rec read_react t = 99 | trace (fun f -> f "tls.read_react"); 100 | let handle tls cs = 101 | match Tls.Engine.handle_tls tls cs with 102 | | Ok (state', eof, `Response resp, `Data data) -> 103 | trace (fun f -> f "tls.read_react->ok"); 104 | let state' = 105 | match eof with 106 | | Some `Eof -> `Eof 107 | | _ -> inject_state state' t.state 108 | in 109 | t.state <- state'; 110 | Option.iter (try_write_t t) resp; 111 | data 112 | | Error (fail, `Response resp) -> 113 | let state' = 114 | match fail with 115 | | `Alert a -> 116 | trace (fun f -> f "tls.read_react->alert"); 117 | `Error (Tls_alert a) 118 | | f -> 119 | trace (fun f -> f "tls.read_react->error"); 120 | `Error (Tls_failure f) 121 | in 122 | t.state <- state'; 123 | write_t t resp; 124 | read_react t 125 | in 126 | 127 | match t.state with 128 | | `Error e -> raise e 129 | | `Eof -> raise End_of_file 130 | | `Active _ -> ( 131 | let n = read_t t t.recv_buf in 132 | match (t.state, n) with 133 | | `Active tls, n -> 134 | handle tls (String.of_bytes (Bytes.sub t.recv_buf 0 n)) 135 | | `Error e, _ -> raise e 136 | | `Eof, _ -> raise End_of_file) 137 | 138 | let rec single_read t (dst : bytes) = 139 | let writeout (data : string) = 140 | let rlen = String.length data in 141 | let n = min (Bytes.length dst) rlen in 142 | StringLabels.blit ~src:data ~src_pos:0 ~dst ~dst_pos:0 ~len:n; 143 | t.linger <- 144 | (if n < rlen then Some (String.sub data n (rlen - n)) else None); 145 | n 146 | in 147 | 148 | match t.linger with 149 | | Some res -> writeout res 150 | | None -> ( 151 | match read_react t with 152 | | None -> single_read t dst 153 | | Some res -> writeout res) 154 | 155 | exception Tls_socket_closed 156 | 157 | let writev t data = 158 | match t.state with 159 | | `Error err -> 160 | trace (fun f -> f "writev: failed"); 161 | raise err 162 | | `Eof -> raise Tls_socket_closed 163 | | `Active tls -> ( 164 | match Tls.Engine.send_application_data tls data with 165 | | Some (tls, tlsdata) -> 166 | t.state <- `Active tls; 167 | write_t t tlsdata 168 | | None -> invalid_arg "tls: write: socket not ready") 169 | 170 | let single_write t src = 171 | writev t [ src ]; 172 | let written = String.length src in 173 | Ok written 174 | 175 | let rec drain_handshake t = 176 | let push_linger t mcs = 177 | match (mcs, t.linger) with 178 | | None, _ -> () 179 | | scs, None -> t.linger <- scs 180 | | Some cs, Some l -> t.linger <- Some (l ^ cs) 181 | in 182 | match t.state with 183 | | `Active tls when not (Tls.Engine.handshake_in_progress tls) -> t 184 | | _ -> 185 | let cs = read_react t in 186 | push_linger t cs; 187 | drain_handshake t 188 | 189 | let epoch t = 190 | match t.state with 191 | | `Active tls -> 192 | Tls.Engine.epoch tls |> Result.map_error (fun () -> `No_session_data) 193 | | _ -> Error `Inactive_tls_engine 194 | 195 | let make_client ?host ~reader ~writer config = 196 | let config' = 197 | match host with 198 | | None -> config 199 | | Some host -> Tls.Config.peer config host 200 | in 201 | let t = 202 | { 203 | state = `Eof; 204 | writer; 205 | reader; 206 | linger = None; 207 | recv_buf = Bytes.create 4_096; 208 | } 209 | in 210 | let tls, init = Tls.Engine.client config' in 211 | let t = { t with state = `Active tls } in 212 | write_t t init; 213 | drain_handshake t 214 | 215 | let make_server ~reader ~writer config = 216 | let t = 217 | { 218 | state = `Active (Tls.Engine.server config); 219 | writer; 220 | reader; 221 | linger = None; 222 | recv_buf = Bytes.create 4_096; 223 | } 224 | in 225 | drain_handshake t 226 | 227 | let to_reader : type src. src t -> src t IO.Reader.t = 228 | fun t -> 229 | let module Read = struct 230 | type nonrec t = src t 231 | 232 | let read t ?timeout:_ dst = 233 | match single_read t dst with 234 | | exception End_of_file -> Ok 0 235 | | len -> Ok len 236 | 237 | let read_vectored _t _bufs = Ok 0 238 | end in 239 | IO.Reader.of_read_src (module Read) t 240 | 241 | let to_writer : type src. src t -> src t IO.Writer.t = 242 | fun t -> 243 | let module Write = struct 244 | type nonrec t = src t 245 | 246 | let write t ~buf = single_write t buf 247 | 248 | (* TODO: This seems like not what we want *) 249 | let write_owned_vectored t ~bufs = 250 | single_write t (IO.Iovec.into_string bufs) 251 | (* single_write t bufs *) 252 | 253 | let flush _t = Ok () 254 | end in 255 | IO.Writer.of_write_src (module Write) t 256 | end 257 | 258 | let negotiated_protocol t = 259 | let* epoch = Tls_unix.epoch t in 260 | Ok Tls.Core.(epoch.alpn_protocol) 261 | 262 | let to_reader = Tls_unix.to_reader 263 | let to_writer = Tls_unix.to_writer 264 | 265 | let of_server_socket ?read_timeout ?send_timeout ~config sock = 266 | let reader, writer = 267 | Net.Tcp_stream. 268 | ( to_reader ?timeout:read_timeout sock, 269 | to_writer ?timeout:send_timeout sock ) 270 | in 271 | Tls_unix.make_server ~reader ~writer config 272 | 273 | let of_client_socket ?read_timeout ?send_timeout ?host ~config sock = 274 | let reader, writer = 275 | Net.Tcp_stream. 276 | ( to_reader ?timeout:read_timeout sock, 277 | to_writer ?timeout:send_timeout sock ) 278 | in 279 | Tls_unix.make_client ?host ~reader ~writer config 280 | --------------------------------------------------------------------------------