├── LICENSE.md ├── .gitignore ├── lib ├── env.ml ├── lifecycle.ml ├── OS.ml ├── esp32.ml ├── esp.h ├── MM.ml ├── dune ├── mm_stubs.c ├── clock_stubs.c ├── caml_poll.c ├── event.ml ├── alloc_pages_stubs.c ├── main.ml └── time.ml ├── dune-project ├── CHANGES.md ├── README.md └── mirage-esp32.opam /LICENSE.md: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | .merlin 3 | *.install -------------------------------------------------------------------------------- /lib/env.ml: -------------------------------------------------------------------------------- 1 | let argv () = Lwt.return [| "mirage" |] -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.7) 2 | (name mirage-esp32) 3 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # pending 2 | 3 | * rename mirage-impl-esp32 to mirage-esp32 4 | -------------------------------------------------------------------------------- /lib/lifecycle.ml: -------------------------------------------------------------------------------- 1 | let await_shutdown_request ?can_poweroff:_ ?can_reboot:_ () = 2 | fst (Lwt.wait ()) -------------------------------------------------------------------------------- /lib/OS.ml: -------------------------------------------------------------------------------- 1 | module Lifecycle = Os_esp32.Lifecycle 2 | module Main = Os_esp32.Main 3 | module Time = Os_esp32.Time 4 | -------------------------------------------------------------------------------- /lib/esp32.ml: -------------------------------------------------------------------------------- 1 | (** ESP32 API calls results **) 2 | type esp32_result = 3 | | ESP32_OK 4 | | ESP32_AGAIN 5 | | ESP32_EINVAL 6 | | ESP32_EUNSPEC -------------------------------------------------------------------------------- /lib/esp.h: -------------------------------------------------------------------------------- 1 | 2 | typedef enum esp32_result_t { 3 | ESP32_OK = 0, 4 | ESP32_AGAIN, 5 | ESP32_EINVAL, 6 | ESP32_EUNSPEC 7 | } esp32_result_t; 8 | 9 | -------------------------------------------------------------------------------- /lib/MM.ml: -------------------------------------------------------------------------------- 1 | module Heap_pages = struct 2 | external total: unit -> int = "stub_heap_get_pages_total" [@@noalloc] 3 | external used: unit -> int = "stub_heap_get_pages_used" [@@noalloc] 4 | end 5 | -------------------------------------------------------------------------------- /lib/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name os_esp32) 3 | (public_name mirage-esp32.internals) 4 | (modules :standard \ OS) 5 | (c_names alloc_pages_stubs caml_poll clock_stubs mm_stubs) 6 | (no_dynlink) 7 | (libraries lwt psq logs)) 8 | 9 | (library 10 | (name OS) 11 | (public_name mirage-esp32) 12 | (implements mirage-os-shim) 13 | (libraries mirage-esp32.internals) 14 | (modules OS)) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mirage-esp32 -- ESP32 core platform libraries for MirageOS 2 | 3 | This package provides the MirageOS `OS` library for 4 | esp32 targets, which handles the main loop and timers. It also provides 5 | the low level C startup code and C stubs required by the OCaml code. 6 | 7 | 8 | The OCaml runtime and C runtime required to support it are provided separately 9 | by the [ocaml-esp32][2] package. 10 | 11 | [2]: https://github.com/well-typed-lightbulbs/ocaml-esp32 12 | -------------------------------------------------------------------------------- /mirage-esp32.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | maintainer: "lucas.pluvinage@ens.fr" 3 | homepage: "https://github.com/well-typed-lightbulbs/mirage-esp32" 4 | bug-reports: "https://github.com/well-typed-lightbulbs/mirage-esp32/issues" 5 | dev-repo: "git+https://github.com/well-typed-lightbulbs/mirage-esp32.git" 6 | license: "ISC" 7 | version: "4.0.0" 8 | authors: ["Lucas Pluvinage"] 9 | tags: [] 10 | build: [ "dune" "build" "-x" "esp32" "-p" "mirage-esp32"] 11 | depends: [ 12 | "dune" {build} 13 | "ocaml" {>= "4.07.1"} 14 | "ocaml-esp32" 15 | "lwt" {>= "2.4.3"} 16 | "psq" 17 | "logs" 18 | "esp32-idf-headers" 19 | ] 20 | 21 | -------------------------------------------------------------------------------- /lib/mm_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | #include 5 | 6 | #include 7 | #include 8 | 9 | CAMLprim value 10 | stub_heap_get_pages_total(__attribute__((unused)) value unit) // noalloc 11 | { 12 | multi_heap_info_t info; 13 | heap_caps_get_info(&info, MALLOC_CAP_DEFAULT); 14 | return Val_long(info.total_free_bytes + info.total_allocated_bytes); 15 | } 16 | 17 | CAMLprim value 18 | stub_heap_get_pages_used(__attribute__((unused)) value unit) // noalloc 19 | { 20 | multi_heap_info_t info; 21 | heap_caps_get_info(&info, MALLOC_CAP_DEFAULT); 22 | return Val_long(info.total_allocated_bytes); 23 | } -------------------------------------------------------------------------------- /lib/clock_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | 7 | #include 8 | #include 9 | 10 | /* 11 | Returns time since boot in microseconds. 12 | */ 13 | CAMLprim value 14 | caml_get_monotonic_time(value v_unit) 15 | { 16 | CAMLparam1(v_unit); 17 | CAMLreturn(caml_copy_int64(esp_timer_get_time())); 18 | } 19 | 20 | /* 21 | Use gettimeofday custom implementation. 22 | */ 23 | CAMLprim value unix_gettimeofday(value unit) 24 | { 25 | struct timeval tp; 26 | if (gettimeofday(&tp, NULL) == -1) { 27 | caml_failwith("gettimeofday"); 28 | } 29 | return copy_double((double) tp.tv_sec + (double) tp.tv_usec / 1e6); 30 | } 31 | -------------------------------------------------------------------------------- /lib/caml_poll.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | #include "freertos/FreeRTOS.h" 5 | #include "freertos/task.h" 6 | #include "esp_system.h" 7 | #include "freertos/event_groups.h" 8 | 9 | #include 10 | #include 11 | #include 12 | #include 13 | 14 | #include 15 | #include 16 | #include 17 | #include 18 | 19 | EventGroupHandle_t mirage_event_group; 20 | 21 | /* 22 | Use the polling feature of FreeRTOS to wait for a partical set of events given in argument. 23 | */ 24 | CAMLprim value 25 | caml_poll(value v_deadline, value v_events) 26 | { 27 | CAMLparam2(v_deadline, v_events); 28 | 29 | int64_t deadline = Int64_val(v_deadline); 30 | int events = Int_val(v_events); 31 | int64_t cur_time = esp_timer_get_time(); 32 | 33 | if (deadline <= cur_time) { 34 | CAMLreturn(Val_int(xEventGroupGetBits(mirage_event_group) & events)); 35 | } 36 | 37 | if (events == 0) { 38 | vTaskDelay((deadline - cur_time)*configTICK_RATE_HZ/(1000*1000)); 39 | } else { 40 | xEventGroupWaitBits(mirage_event_group, events, false, false, (deadline - cur_time)*configTICK_RATE_HZ/(1000*1000)); 41 | } 42 | 43 | CAMLreturn(Val_int(xEventGroupGetBits(mirage_event_group) & events)); 44 | 45 | } 46 | 47 | /* 48 | Polling mechanism rely on the creation of an event group. 49 | (https://www.freertos.org/FreeRTOS-Event-Groups.html) 50 | */ 51 | CAMLprim value 52 | caml_poll_initialize(value unit) { 53 | CAMLparam0(); 54 | mirage_event_group = xEventGroupCreate(); 55 | CAMLreturn(Val_unit); 56 | } 57 | 58 | -------------------------------------------------------------------------------- /lib/event.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Infix 2 | 3 | (* This event system encodes event as bits in a bitset. 4 | Thus allowing up to 31 events registered. *) 5 | 6 | (* Wait for a particular set of events with a given timeout. 7 | Events to wait for are given as a bitset. *) 8 | external c_poll : [`Time] Time.Monotonic.t -> int -> int = "caml_poll" 9 | 10 | (* Events that are waited for and haven't been triggered. *) 11 | let event_list = ref 0 12 | 13 | module EventMap = Map.Make( 14 | struct 15 | let compare = Pervasives.compare 16 | type t = int 17 | end 18 | ) 19 | 20 | (* Map from event number to Lwt.condition to wake lwt threads on event.*) 21 | let event_conditions = ref EventMap.empty 22 | 23 | (* Create a condition per event number. *) 24 | let register_event_number num = 25 | if EventMap.mem num !event_conditions then 26 | Printf.printf "Event already registered %d\n%!" num 27 | else 28 | event_conditions := EventMap.add num (Lwt_condition.create ()) !event_conditions 29 | 30 | (* Wait for an event number. *) 31 | let wait_for_event number = 32 | assert (number >= 0 && number < 31); 33 | event_list := !event_list lor (1 lsl number); 34 | Lwt_condition.wait (EventMap.find number !event_conditions) >>= fun _ -> 35 | Lwt.return_unit 36 | 37 | (* Check if some process can be waken up. *) 38 | let work_is_available () = c_poll (Time.Monotonic.time ()) !event_list != 0 39 | 40 | (* Wake up processes on events. *) 41 | let run () = 42 | let rec check evt = function 43 | | n when n < 31 -> 44 | if evt land (1 lsl n) != 0 then 45 | begin 46 | event_list := !event_list lxor (1 lsl n); 47 | Lwt_condition.broadcast (EventMap.find n !event_conditions) (); 48 | end; 49 | check evt (n+1) 50 | | _ -> () 51 | in 52 | let events = c_poll (Time.Monotonic.time ()) !event_list in 53 | check events 0 54 | 55 | (* Wait for an event. *) 56 | let poll timeout = 57 | ignore (c_poll timeout !event_list) 58 | -------------------------------------------------------------------------------- /lib/alloc_pages_stubs.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #define PAGE_SIZE 4096 5 | 6 | #include 7 | #include 8 | #include 9 | #include 10 | #include 11 | 12 | /* Allocate a page-aligned bigarray of length [n_pages] pages. 13 | Since CAML_BA_MANAGED is set the bigarray C finaliser will 14 | call free() whenever all sub-bigarrays are unreachable. 15 | */ 16 | CAMLprim value 17 | mirage_alloc_pages(value did_gc, value n_pages) 18 | { 19 | CAMLparam2(did_gc, n_pages); 20 | size_t len = Int_val(n_pages) * PAGE_SIZE; 21 | /* If the allocation fails, return None. The ocaml layer will 22 | be able to trigger a full GC which just might run finalizers 23 | of unused bigarrays which will free some memory. */ 24 | void* block = malloc(len); 25 | if (block == NULL) { 26 | if (Bool_val(did_gc)) 27 | printf("ERROR: Io_page: memalign(%d, %zu) failed, even after GC.\n", PAGE_SIZE, len); 28 | caml_raise_out_of_memory(); 29 | } 30 | /* Explicitly zero the page before returning it */ 31 | memset(block, 0, len); 32 | 33 | /* OCaml 4.02 introduced bigarray element type CAML_BA_CHAR, 34 | which needs to be used - otherwise type t in io_page.ml 35 | is different from the allocated bigarray and equality won't 36 | hold. 37 | Only since 4.02 there is a , thus we cannot 38 | include it in order to detect the version of the OCaml runtime. 39 | Instead, we use definitions which were introduced by 4.02 - and 40 | cross fingers that they'll stay there in the future. 41 | Once <4.02 support is removed, we should get rid of this hack. 42 | -- hannes, 16th Feb 2015 43 | */ 44 | #ifdef Caml_ba_kind_val 45 | CAMLreturn(caml_ba_alloc_dims(CAML_BA_CHAR | CAML_BA_C_LAYOUT | CAML_BA_MANAGED, 1, block, len)); 46 | #else 47 | CAMLreturn(caml_ba_alloc_dims(CAML_BA_UINT8 | CAML_BA_C_LAYOUT | CAML_BA_MANAGED, 1, block, len)); 48 | #endif 49 | } 50 | 51 | CAMLprim value 52 | mirage_get_addr(value page) 53 | { 54 | CAMLparam1(page); 55 | CAMLlocal1(nativeint); 56 | void *data = Caml_ba_data_val(page); 57 | nativeint = caml_copy_nativeint((intnat) data); 58 | CAMLreturn(nativeint); 59 | } 60 | -------------------------------------------------------------------------------- /lib/main.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | external initialize : unit -> unit = "caml_poll_initialize" 4 | 5 | (* Hacky *) 6 | [@@@ocaml.warning "-3"] 7 | module Lwt_sequence = Lwt_sequence 8 | [@@@ocaml.warning "+3"] 9 | 10 | let exit_hooks = Lwt_sequence.create () 11 | let enter_hooks = Lwt_sequence.create () 12 | let exit_iter_hooks = Lwt_sequence.create () 13 | let enter_iter_hooks = Lwt_sequence.create () 14 | 15 | let rec call_hooks hooks = 16 | match Lwt_sequence.take_opt_l hooks with 17 | | None -> 18 | return () 19 | | Some f -> 20 | (* Run the hooks in parallel *) 21 | let _ = 22 | Lwt.catch f 23 | (fun exn -> 24 | Printf.printf "ERROR: call_hooks(): Unhandled exception: %s\n%!" (Printexc.to_string exn); 25 | return ()) in 26 | call_hooks hooks 27 | 28 | 29 | let err exn = 30 | Printf.eprintf "main: %s\n%s" (Printexc.to_string exn) (Printexc.get_backtrace ()) ; 31 | exit 1 32 | 33 | (* Execute one iteration and register a callback function *) 34 | let run t = 35 | Printf.printf "Starting event loop.\n"; 36 | flush stdout; 37 | let t = call_hooks enter_hooks <&> t in 38 | let rec aux () = 39 | Lwt.wakeup_paused (); 40 | Time.restart_threads Time.Monotonic.time; 41 | match (try Lwt.poll t with exn -> err exn) with 42 | | Some () -> 43 | () 44 | | None -> 45 | if Event.work_is_available () then 46 | begin 47 | (* Call enter hooks. *) 48 | Lwt_sequence.iter_l (fun f -> f ()) enter_iter_hooks; 49 | (* Some I/O is possible, wake up threads and continue. *) 50 | Event.run (); 51 | (* Call leave hooks. *) 52 | Lwt_sequence.iter_l (fun f -> f ()) exit_iter_hooks; 53 | aux () 54 | end 55 | else 56 | begin 57 | let timeout = 58 | match Time.select_next () with 59 | |None -> Time.Monotonic.(time () + of_nanoseconds 86_400_000_000_000L) (* one day = 24 * 60 * 60 s *) 60 | |Some tm -> tm 61 | in 62 | Event.poll timeout; 63 | aux () 64 | end 65 | in 66 | aux (); 67 | Printf.printf "Leaving event loop.\n"; 68 | flush stdout 69 | 70 | let () = at_exit (fun () -> run (call_hooks exit_hooks)) 71 | let at_exit f = ignore (Lwt_sequence.add_l f exit_hooks) 72 | let at_enter f = ignore (Lwt_sequence.add_l f enter_hooks) 73 | let at_exit_iter f = ignore (Lwt_sequence.add_l f exit_iter_hooks) 74 | let at_enter_iter f = ignore (Lwt_sequence.add_l f enter_iter_hooks) 75 | 76 | let () = initialize () 77 | -------------------------------------------------------------------------------- /lib/time.ml: -------------------------------------------------------------------------------- 1 | open Lwt 2 | 3 | type +'a io = 'a Lwt.t 4 | 5 | module Monotonic = struct 6 | type time_kind = [`Time | `Interval] 7 | type 'a t = int64 constraint 'a = [< time_kind] 8 | (* Time in microseconds. *) 9 | external time : unit -> int64 = "caml_get_monotonic_time" 10 | 11 | let of_nanoseconds x = Int64.div x 1000L 12 | 13 | let ( + ) = ( Int64.add ) 14 | let ( - ) = ( Int64.sub ) 15 | let interval = ( Int64.sub ) 16 | end 17 | 18 | (* +-----------------------------------------------------------------+ 19 | | Sleepers | 20 | +-----------------------------------------------------------------+ *) 21 | 22 | type sleep = { 23 | time : [`Time] Monotonic.t; 24 | mutable canceled : bool; 25 | thread : unit Lwt.u; 26 | } 27 | 28 | module SleepQueue = 29 | Psq.Make 30 | (struct 31 | type t = int 32 | let compare a b = compare a b 33 | end) 34 | (struct 35 | type t = sleep 36 | let compare { time = t1; _} { time = t2; _} = compare t1 t2 37 | end) 38 | 39 | let sleep_queue = ref SleepQueue.empty 40 | 41 | (* Sleepers added since the last iteration of the main loop: 42 | They are not added immediatly to the main sleep queue in order to 43 | prevent them from being wakeup immediatly by [restart_threads]. 44 | *) 45 | let new_sleeps = ref [] 46 | 47 | let id = ref 0 48 | let new_id () = 49 | incr id; 50 | !id 51 | 52 | let sleep_ns d = 53 | let (res, w) = Lwt.task () in 54 | let t = Monotonic.(time () + of_nanoseconds d) in 55 | let sleeper = { time = t; canceled = false; thread = w } in 56 | new_sleeps := sleeper :: !new_sleeps; 57 | Lwt.on_cancel res (fun _ -> sleeper.canceled <- true); 58 | res 59 | 60 | exception Timeout 61 | 62 | let timeout d = sleep_ns d >>= fun () -> Lwt.fail Timeout 63 | 64 | let with_timeout d f = Lwt.pick [timeout d; Lwt.apply f ()] 65 | 66 | let in_the_past now t = 67 | t = 0L || t <= now () 68 | 69 | let unpack = function 70 | | Some t -> t 71 | | None -> failwith "time.ml: unpack failed." 72 | 73 | let rec restart_threads now = 74 | match SleepQueue.min !sleep_queue with 75 | | Some (_, { canceled = true; _ }) -> 76 | sleep_queue := unpack (SleepQueue.rest !sleep_queue); 77 | restart_threads now 78 | | Some (_, { time = time; thread = thread; _ }) when in_the_past now time -> 79 | sleep_queue := unpack (SleepQueue.rest !sleep_queue); 80 | Lwt.wakeup thread (); 81 | restart_threads now 82 | | _ -> 83 | () 84 | 85 | (* +-----------------------------------------------------------------+ 86 | | Event loop | 87 | +-----------------------------------------------------------------+ *) 88 | 89 | let min_timeout a b = match a, b with 90 | | None, b -> b 91 | | a, None -> a 92 | | Some a, Some b -> Some(min a b) 93 | 94 | let rec get_next_timeout () = 95 | match SleepQueue.min !sleep_queue with 96 | | Some (_, { canceled = true; _ }) -> 97 | sleep_queue := unpack (SleepQueue.rest !sleep_queue); 98 | get_next_timeout () 99 | | Some (_, { time = time; _ }) -> 100 | Some time 101 | | None -> 102 | None 103 | 104 | let select_next () = 105 | (* Transfer all sleepers added since the last iteration to the main 106 | sleep queue: *) 107 | sleep_queue := 108 | List.fold_left 109 | (fun q e -> SleepQueue.add (new_id ()) e q) !sleep_queue !new_sleeps; 110 | new_sleeps := []; 111 | get_next_timeout () --------------------------------------------------------------------------------