Merge pull request #7551 from MinaProtocol/fix/gc-compact

call Gc.compact periodically
MinaProtocol · Jan 21, 2021 · 018b1d0 · 018b1d0
2 parents fbee8f0 + 4acf01a
commit 018b1d0
Show file tree

Hide file tree

Showing 31 changed files with 131 additions and 5 deletions.
diff --git a/src/config/debug.mlh b/src/config/debug.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/dev.mlh b/src/config/dev.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/dev_medium_curves.mlh b/src/config/dev_medium_curves.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/dev_snark.mlh b/src/config/dev_snark.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/fake_hash.mlh b/src/config/fake_hash.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/fuzz_medium.mlh b/src/config/fuzz_medium.mlh
@@ -29,3 +29,4 @@
 [%%define pending_coinbase_hack false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/fuzz_small.mlh b/src/config/fuzz_small.mlh
@@ -29,3 +29,4 @@
 [%%define pending_coinbase_hack false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/nonconsensus_medium_curves.mlh b/src/config/nonconsensus_medium_curves.mlh
@@ -29,3 +29,4 @@
 [%%undef consensus_mechanism]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/print_versioned_types.mlh b/src/config/print_versioned_types.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_archive_processor.mlh b/src/config/test_archive_processor.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake.mlh b/src/config/test_postake.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_catchup.mlh b/src/config/test_postake_catchup.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_five_even_txns.mlh b/src/config/test_postake_five_even_txns.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_full_epoch.mlh b/src/config/test_postake_full_epoch.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch true]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_holy_grail.mlh b/src/config/test_postake_holy_grail.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_medium_curves.mlh b/src/config/test_postake_medium_curves.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_snarkless.mlh b/src/config/test_postake_snarkless.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%define compaction_interval 360000]
diff --git a/src/config/test_postake_snarkless_medium_curves.mlh b/src/config/test_postake_snarkless_medium_curves.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_split.mlh b/src/config/test_postake_split.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_split_medium_curves.mlh b/src/config/test_postake_split_medium_curves.mlh
@@ -30,3 +30,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/test_postake_three_producers.mlh b/src/config/test_postake_three_producers.mlh
@@ -31,3 +31,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/testnet_postake.mlh b/src/config/testnet_postake.mlh
@@ -31,3 +31,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/testnet_postake_many_producers.mlh b/src/config/testnet_postake_many_producers.mlh
@@ -29,3 +29,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/testnet_postake_many_producers_medium_curves.mlh b/src/config/testnet_postake_many_producers_medium_curves.mlh
@@ -31,3 +31,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/testnet_postake_medium_curves.mlh b/src/config/testnet_postake_medium_curves.mlh
@@ -40,3 +40,5 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/mainnet.mlh"]
+(* 2*block_window_duration *)
+[%%define compaction_interval 360000]
diff --git a/src/config/testnet_postake_snarkless.mlh b/src/config/testnet_postake_snarkless.mlh
@@ -31,3 +31,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/testnet_postake_snarkless_fake_hash.mlh b/src/config/testnet_postake_snarkless_fake_hash.mlh
@@ -32,3 +32,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/config/testnet_public.mlh b/src/config/testnet_public.mlh
@@ -31,3 +31,4 @@
 [%%define test_full_epoch false]
 [%%import "/src/config/fork.mlh"]
 [%%import "/src/config/features/dev.mlh"]
+[%%undef compaction_interval]
diff --git a/src/lib/block_producer/block_producer.ml b/src/lib/block_producer/block_producer.ml
@@ -383,7 +383,7 @@ let time ~logger ~time_controller label f =
   let span = Time.diff (Time.now time_controller) t0 in
   [%log info]
     ~metadata:[("time", `Int (Time.Span.to_ms span |> Int64.to_int_exn))]
-    !"%s%!" label ;
+    !"%s: $time %!" label ;
   x
 
 let run ~logger ~prover ~verifier ~trust_system ~get_completed_work

diff --git a/src/lib/mina_compile_config/mina_compile_config.ml b/src/lib/mina_compile_config/mina_compile_config.ml
@@ -29,6 +29,20 @@ module Currency = Currency_nonconsensus.Currency
 [%%inject
 "minimum_user_command_fee_string", minimum_user_command_fee]
 
+[%%ifndef
+compaction_interval]
+
+let compaction_interval_ms = None
+
+[%%else]
+
+[%%inject
+"compaction_interval", compaction_interval]
+
+let compaction_interval_ms = Some compaction_interval
+
+[%%endif]
+
 let minimum_user_command_fee =
   Currency.Fee.of_formatted_string minimum_user_command_fee_string
 

diff --git a/src/lib/mina_lib/mina_lib.ml b/src/lib/mina_lib/mina_lib.ml
@@ -109,7 +109,9 @@ type t =
   ; mutable next_producer_timing: Consensus.Hooks.block_producer_timing option
   ; subscriptions: Coda_subscriptions.t
   ; sync_status: Sync_status.t Mina_incremental.Status.Observer.t
-  ; precomputed_block_writer: ([`Path of string] option * [`Log] option) ref }
+  ; precomputed_block_writer: ([`Path of string] option * [`Log] option) ref
+  ; block_production_status:
+      [`Producing | `Producing_in_ms of float | `Free] ref }
 [@@deriving fields]
 
 let time_controller t = t.config.time_controller
@@ -778,10 +780,89 @@ let last_epoch_delegators t ~pk =
   in
   find_delegators last_epoch_delegatee_table pk
 
+let perform_compaction t =
+  match Mina_compile_config.compaction_interval_ms with
+  | None ->
+      ()
+  | Some compaction_interval_compiled ->
+      let slot_duration_ms =
+        let leeway = 1000 in
+        t.config.precomputed_values.constraint_constants
+          .block_window_duration_ms + leeway
+      in
+      let expected_time_for_compaction =
+        match Sys.getenv "MINA_COMPACTION_MS" with
+        | Some ms ->
+            Float.of_string ms
+        | None ->
+            6000.
+      in
+      let span ?(incr = 0.) ms =
+        Float.(of_int ms +. incr) |> Time.Span.of_ms
+      in
+      let interval_configured =
+        match Sys.getenv "MINA_COMPACTION_INTERVAL_MS" with
+        | Some ms ->
+            Time.Span.of_ms (Float.of_string ms)
+        | None ->
+            span compaction_interval_compiled
+      in
+      if Time.Span.(interval_configured <= of_ms expected_time_for_compaction)
+      then (
+        [%log' fatal t.config.logger]
+          "Time between compactions %f should be greater than the expected \
+           time for compaction %f"
+          (Time.Span.to_ms interval_configured)
+          expected_time_for_compaction ;
+        failwith
+          (sprintf
+             "Time between compactions %f should be greater than the expected \
+              time for compaction %f"
+             (Time.Span.to_ms interval_configured)
+             expected_time_for_compaction) ) ;
+      let call_compact () =
+        let start = Time.now () in
+        Gc.compact () ;
+        let span = Time.diff (Time.now ()) start in
+        [%log' debug t.config.logger]
+          ~metadata:[("time", `Float (Time.Span.to_ms span))]
+          "Gc.compact took $time ms"
+      in
+      let rec perform interval =
+        upon (after interval) (fun () ->
+            match !(t.block_production_status) with
+            | `Free ->
+                call_compact () ;
+                perform interval_configured
+            | `Producing ->
+                perform (span slot_duration_ms)
+            | `Producing_in_ms ms ->
+                if ms < expected_time_for_compaction then
+                  (*too close to block production; perform compaction after block production*)
+                  perform (span slot_duration_ms ~incr:ms)
+                else (
+                  call_compact () ;
+                  perform interval_configured ) )
+      in
+      perform interval_configured
+
 let start t =
+  let set_next_producer_timing timing =
+    let block_production_status =
+      match timing with
+      | `Check_again _ ->
+          `Free
+      | `Produce_now _ ->
+          `Producing
+      | `Produce (time, _, _) ->
+          `Producing_in_ms (Int64.to_float time)
+    in
+    t.block_production_status := block_production_status ;
+    t.next_producer_timing <- Some timing
+  in
   Block_producer.run ~logger:t.config.logger ~verifier:t.processes.verifier
-    ~set_next_producer_timing:(fun p -> t.next_producer_timing <- Some p)
-    ~prover:t.processes.prover ~trust_system:t.config.trust_system
+    ~set_next_producer_timing ~prover:t.processes.prover
+    ~trust_system:t.config.trust_system
     ~transaction_resource_pool:
       (Network_pool.Transaction_pool.resource_pool
          t.components.transaction_pool)
@@ -795,6 +876,7 @@ let start t =
     ~transition_writer:t.pipes.producer_transition_writer
     ~log_block_creation:t.config.log_block_creation
     ~precomputed_values:t.config.precomputed_values ;
+  perform_compaction t ;
   Snark_worker.start t
 
 let start_with_precomputed_blocks t blocks =
@@ -1480,6 +1562,7 @@ let create ?wallets (config : Config.t) =
             ; snark_job_state= snark_jobs_state
             ; subscriptions
             ; sync_status
-            ; precomputed_block_writer } ) )
+            ; precomputed_block_writer
+            ; block_production_status= ref `Free } ) )
 
 let net {components= {net; _}; _} = net