robur/opam-mirror
4
0
Fork 0
Code Issues 5 Pull requests 2 Projects Releases Packages Wiki Activity Actions

use the gc every now and then

Browse source
This commit is contained in:
Hannes Mehnert 2022-09-26 13:46:23 +02:00
parent 069643465f
commit 9b7e9e5485
1 changed files with 5 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
mirage/unikernel.ml
View file

@ -244,7 +244,8 @@ module Make
| Error e -> Logs.err (fun m -> m "error %a listing kv" KV.pp_error e); assert false | Error e -> Logs.err (fun m -> m "error %a listing kv" KV.pp_error e); assert false
| Ok entries -> | Ok entries ->
let t = empty dev in let t = empty dev in
Lwt_list.iter_s (fun (name, typ) -> Lwt_list.iteri_s (fun idx (name, typ) ->
if idx mod 10 = 0 then Gc.full_major () ;
match typ with match typ with
| `Dictionary -> | `Dictionary ->
Logs.warn (fun m -> m "unexpected dictionary at %s" name); Logs.warn (fun m -> m "unexpected dictionary at %s" name);
@ -630,6 +631,7 @@ stamp: %S
k)) urls k)) urls
in in
let pool = Lwt_pool.create (Key_gen.parallel_downloads ()) (Fun.const Lwt.return_unit) in let pool = Lwt_pool.create (Key_gen.parallel_downloads ()) (Fun.const Lwt.return_unit) in
let idx = ref 0 in
Lwt_list.iter_p (fun (url, csums) -> Lwt_list.iter_p (fun (url, csums) ->
Lwt_pool.use pool @@ fun () -> Lwt_pool.use pool @@ fun () ->
HM.fold (fun h v r -> HM.fold (fun h v r ->
@ -641,6 +643,8 @@ stamp: %S
Logs.debug (fun m -> m "ignoring %s (already present)" url); Logs.debug (fun m -> m "ignoring %s (already present)" url);
Lwt.return_unit Lwt.return_unit
| false -> | false ->
incr idx;
if !idx mod 10 = 0 then Gc.full_major () ;
Logs.info (fun m -> m "downloading %s" url); Logs.info (fun m -> m "downloading %s" url);
Http_mirage_client.one_request Http_mirage_client.one_request
~alpn_protocol:HTTP.alpn_protocol ~alpn_protocol:HTTP.alpn_protocol