diff --git a/core/src/core_pervasives.ml b/core/src/core_pervasives.ml index 88faf0dd..1f3143d2 100644 --- a/core/src/core_pervasives.ml +++ b/core/src/core_pervasives.ml @@ -18,3 +18,10 @@ external raise : exn -> 'a = "%reraise" let __FUNCTION__ = "<__FUNCTION__ not supported before OCaml 4.12>" [%%endif] + +[%%if ocaml_version >= (5, 0, 0)] + +external ( & ) : bool -> bool -> bool = "%sequand" +external ( or ) : bool -> bool -> bool = "%sequor" + +[%%endif] diff --git a/core/src/ephemeron.ml b/core/src/ephemeron.ml index 98c89ba4..52d6930f 100644 --- a/core/src/ephemeron.ml +++ b/core/src/ephemeron.ml @@ -1,29 +1 @@ -open! Import -open Std_internal -module Ephemeron = Caml.Ephemeron.K1 - -type ('a, 'b) t = ('a Heap_block.t, 'b Heap_block.t) Ephemeron.t - -let create = Ephemeron.create - -let set_key t = function - | None -> Ephemeron.unset_key t - | Some v -> Ephemeron.set_key t v -;; - -let get_key = Ephemeron.get_key - -let set_data t = function - | None -> Ephemeron.unset_data t - | Some v -> Ephemeron.set_data t v -;; - -let get_data = Ephemeron.get_data -let is_key_some t = Ephemeron.check_key t -let is_key_none t = not (is_key_some t) -let is_data_some t = Ephemeron.check_data t -let is_data_none t = not (is_data_some t) - -let sexp_of_t sexp_of_a sexp_of_b t = - [%sexp_of: a Heap_block.t option * b Heap_block.t option] (get_key t, get_data t) -;; +include Caml.Ephemeron diff --git a/core/src/ephemeron.mli b/core/src/ephemeron.mli index 59b288be..019fa416 100644 --- a/core/src/ephemeron.mli +++ b/core/src/ephemeron.mli @@ -1,26 +1 @@ -(** An ephemeron is a pair of pointers, one to a "key" and one to "data". - - The key pointer is a weak pointer: the garbage collector doesn't follow it when - determining liveness. The garbage collector follows an ephemeron's data pointer iff - the key is alive. If the garbage collector nulls an ephemeron's weak pointer then it - also nulls the data pointer. Ephemerons are more powerful than weak pointers because - they express conjunction of liveness -- the data in an ephemeron is live iff both the - key {e and} the ephemeron are live. See "Ephemerons: A New Finalization Mechanism", - Barry Hayes 1997. - - This module is like the OCaml standard library module [Ephemerons.K1], except that it - requires that the keys and data are heap blocks. *) - -open! Import - -type ('a, 'b) t [@@deriving sexp_of] - -val create : unit -> _ t -val set_key : ('a, _) t -> 'a Heap_block.t option -> unit -val get_key : ('a, _) t -> 'a Heap_block.t option -val set_data : (_, 'b) t -> 'b Heap_block.t option -> unit -val get_data : (_, 'b) t -> 'b Heap_block.t option -val is_key_some : _ t -> bool -val is_key_none : _ t -> bool -val is_data_some : _ t -> bool -val is_data_none : _ t -> bool +include module type of Caml.Ephemeron diff --git a/core/src/gc.ml b/core/src/gc.ml index bbc17bc7..4e402a76 100644 --- a/core/src/gc.ml +++ b/core/src/gc.ml @@ -110,6 +110,8 @@ module Stable = struct end module Control = struct + [%%if ocaml_version < (5, 0, 0)] + module V1 = struct [@@@ocaml.warning "-3"] @@ -128,6 +130,29 @@ module Stable = struct } [@@deriving bin_io, compare, equal, sexp] end + + [%% else] + + module V1 = struct + [@@@ocaml.warning "-3"] + + type t = Caml.Gc.control = + { minor_heap_size : int + ; major_heap_increment : int + ; space_overhead : int + ; verbose : int + ; max_overhead : int + ; stack_limit : int + ; allocation_policy : int + ; window_size : int + ; custom_major_ratio : int + ; custom_minor_ratio : int + ; custom_minor_max_size : int + } + [@@deriving bin_io, compare, equal, sexp] + end + + [%%endif] end end @@ -236,6 +261,8 @@ module Stat = struct end module Control = struct + [%%if ocaml_version < (5, 0, 0)] + module T = struct [@@@ocaml.warning "-3"] @@ -255,6 +282,29 @@ module Control = struct [@@deriving compare, sexp_of, fields] end + [%% else] + + module T = struct + [@@@ocaml.warning "-3"] + + type t = Caml.Gc.control = + { minor_heap_size : int + ; major_heap_increment : int + ; space_overhead : int + ; verbose : int + ; max_overhead : int + ; stack_limit : int + ; allocation_policy : int + ; window_size : int + ; custom_major_ratio : int + ; custom_minor_ratio : int + ; custom_minor_max_size : int + } + [@@deriving compare, sexp_of, fields] + end + + [%% endif] + include T include Comparable.Make_plain (T) end @@ -339,13 +389,9 @@ external major_words : unit -> int = "core_gc_major_words" [@@noalloc] external promoted_words : unit -> int = "core_gc_promoted_words" [@@noalloc] external minor_collections : unit -> int = "core_gc_minor_collections" [@@noalloc] external major_collections : unit -> int = "core_gc_major_collections" [@@noalloc] -external heap_words : unit -> int = "core_gc_heap_words" [@@noalloc] -external heap_chunks : unit -> int = "core_gc_heap_chunks" [@@noalloc] external compactions : unit -> int = "core_gc_compactions" [@@noalloc] -external top_heap_words : unit -> int = "core_gc_top_heap_words" [@@noalloc] external major_plus_minor_words : unit -> int = "core_gc_major_plus_minor_words" external allocated_words : unit -> int = "core_gc_allocated_words" -external run_memprof_callbacks : unit -> unit = "core_gc_run_memprof_callbacks" let zero = Sys.opaque_identity (int_of_string "0") @@ -466,11 +512,9 @@ module For_testing = struct (* Memprof.stop does not guarantee that all memprof callbacks are run (some may be delayed if they happened during C code and there has been no allocation since), so we explictly flush them *) - run_memprof_callbacks (); Caml.Gc.Memprof.stop (); x | exception e -> - run_memprof_callbacks (); Caml.Gc.Memprof.stop (); raise e in diff --git a/core/src/gc.mli b/core/src/gc.mli index 30aa3202..7b3ed512 100644 --- a/core/src/gc.mli +++ b/core/src/gc.mli @@ -123,6 +123,8 @@ type stat = Stat.t *) module Control : sig + [%%if ocaml_version < (5, 0, 0)] + type t = { mutable minor_heap_size : int (** The size (in words) of the minor heap. Changing this parameter will @@ -227,6 +229,115 @@ module Control : sig } [@@deriving sexp_of, fields] + [%% else] + + + type t = + { minor_heap_size : int + (** The size (in words) of the minor heap. Changing this parameter will + trigger a minor collection. + + Default: 262144 words / 1MB (32bit) / 2MB (64bit). + *) + ; major_heap_increment : int + (** How much to add to the major heap when increasing it. If this + number is less than or equal to 1000, it is a percentage of + the current heap size (i.e. setting it to 100 will double the heap + size at each increase). If it is more than 1000, it is a fixed + number of words that will be added to the heap. + + Default: 15%. + *) + ; space_overhead : int + (** The major GC speed is computed from this parameter. + This is the memory that will be "wasted" because the GC does not + immediately collect unreachable blocks. It is expressed as a + percentage of the memory used for live data. + The GC will work more (use more CPU time and collect + blocks more eagerly) if [space_overhead] is smaller. + + Default: 80. *) + ; verbose : int + (** This value controls the GC messages on standard error output. + It is a sum of some of the following flags, to print messages + on the corresponding events: + - [0x001] Start of major GC cycle. + - [0x002] Minor collection and major GC slice. + - [0x004] Growing and shrinking of the heap. + - [0x008] Resizing of stacks and memory manager tables. + - [0x010] Heap compaction. + - [0x020] Change of GC parameters. + - [0x040] Computation of major GC slice size. + - [0x080] Calling of finalisation functions. + - [0x100] Bytecode executable search at start-up. + - [0x200] Computation of compaction triggering condition. + + Default: 0. *) + ; max_overhead : int + (** Heap compaction is triggered when the estimated amount + of "wasted" memory is more than [max_overhead] percent of the + amount of live data. If [max_overhead] is set to 0, heap + compaction is triggered at the end of each major GC cycle + (this setting is intended for testing purposes only). + If [max_overhead >= 1000000], compaction is never triggered. + + Default: 500. *) + ; stack_limit : int + (** The maximum size of the stack (in words). This is only + relevant to the byte-code runtime, as the native code runtime + uses the operating system's stack. + + Default: 1048576 words / 4MB (32bit) / 8MB (64bit). *) + ; allocation_policy : int + (** The policy used for allocating in the heap. Possible + values are 0 and 1. 0 is the next-fit policy, which is + quite fast but can result in fragmentation. 1 is the + first-fit policy, which can be slower in some cases but + can be better for programs with fragmentation problems. + + Default: 0. *) + ; window_size : int + (** The size of the window used by the major GC for smoothing + out variations in its workload. This is an integer between + 1 and 50. + + Default: 1. @since 4.03.0 *) + ; custom_major_ratio : int + (** Target ratio of floating garbage to major heap size for + out-of-heap memory held by custom values located in the major + heap. The GC speed is adjusted to try to use this much memory + for dead values that are not yet collected. Expressed as a + percentage of major heap size. The default value keeps the + out-of-heap floating garbage about the same size as the + in-heap overhead. + Note: this only applies to values allocated with + [caml_alloc_custom_mem] (e.g. bigarrays). + Default: 44. + @since 4.08.0 *) + ; custom_minor_ratio : int + (** Bound on floating garbage for out-of-heap memory held by + custom values in the minor heap. A minor GC is triggered when + this much memory is held by custom values located in the minor + heap. Expressed as a percentage of minor heap size. + Note: this only applies to values allocated with + [caml_alloc_custom_mem] (e.g. bigarrays). + Default: 100. + @since 4.08.0 *) + ; custom_minor_max_size : int + (** Maximum amount of out-of-heap memory for each custom value + allocated in the minor heap. When a custom value is allocated + on the minor heap and holds more than this many bytes, only + this value is counted against [custom_minor_ratio] and the + rest is directly counted against [custom_major_ratio]. + Note: this only applies to values allocated with + [caml_alloc_custom_mem] (e.g. bigarrays). + Default: 8192 bytes. + @since 4.08.0 *) + } + [@@deriving sexp_of, fields] + + [%% endif] + include Comparable.S_plain with type t := t end @@ -267,10 +378,7 @@ external major_words : unit -> int = "core_gc_major_words" [@@noalloc] external promoted_words : unit -> int = "core_gc_promoted_words" [@@noalloc] external minor_collections : unit -> int = "core_gc_minor_collections" [@@noalloc] external major_collections : unit -> int = "core_gc_major_collections" [@@noalloc] -external heap_words : unit -> int = "core_gc_heap_words" [@@noalloc] -external heap_chunks : unit -> int = "core_gc_heap_chunks" [@@noalloc] external compactions : unit -> int = "core_gc_compactions" [@@noalloc] -external top_heap_words : unit -> int = "core_gc_top_heap_words" [@@noalloc] (** This function returns [major_words () + minor_words ()]. It exists purely for speed (one call into C rather than two). Like [major_words] and [minor_words], diff --git a/core/src/gc_stubs.c b/core/src/gc_stubs.c index 4b5f1108..f54c5f45 100644 --- a/core/src/gc_stubs.c +++ b/core/src/gc_stubs.c @@ -45,26 +45,12 @@ CAMLprim value core_gc_major_collections(value unit __attribute__((unused))) return Val_long(caml_stat_major_collections); } -CAMLprim value core_gc_heap_words(value unit __attribute__((unused))) -{ - return Val_long(caml_stat_heap_wsz); -} - -CAMLprim value core_gc_heap_chunks(value unit __attribute__((unused))) -{ - return Val_long(caml_stat_heap_chunks); -} CAMLprim value core_gc_compactions(value unit __attribute__((unused))) { return Val_long(caml_stat_compactions); } -CAMLprim value core_gc_top_heap_words(value unit __attribute__((unused))) -{ - return Val_long(caml_stat_top_heap_wsz); -} - CAMLprim value core_gc_major_plus_minor_words(value unit __attribute__((unused))) { return Val_long(minor_words() + major_words()); @@ -74,10 +60,3 @@ CAMLprim value core_gc_allocated_words(value unit __attribute__((unused))) { return Val_long(minor_words() + major_words() - promoted_words()); } - -CAMLprim value core_gc_run_memprof_callbacks(value unit __attribute__((unused))) -{ - value exn = caml_memprof_handle_postponed_exn(); - caml_raise_if_exception(exn); - return Val_unit; -} diff --git a/core/src/md5_stubs.c b/core/src/md5_stubs.c index 403f095b..c425588a 100644 --- a/core/src/md5_stubs.c +++ b/core/src/md5_stubs.c @@ -1,3 +1,4 @@ +#define CAML_INTERNALS #include #include #include @@ -7,10 +8,10 @@ #include #include -#define CAML_INTERNALS #if __GNUC__ < 8 #pragma GCC diagnostic ignored "-pedantic" #endif + #include #include #undef CAML_INTERNALS