Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

New ephemeron-free API for Memprof. 

The user can register several callbacks, which are called for various
events during the block's lifetime. We need to maintain a data
structure for tracked blocks in the runtime. When using threads,
callbacks can be called concurrently in a reentrant way, so the
functions manipulating this data structure need to be reentrant.
master
Jacques-Henri Jourdan 2019-09-04 14:36:23 +02:00
parent 0da925c68d
commit 7dbbfce890
30 changed files with 1163 additions and 632 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
Changes
View File

@ -16,6 +16,12 @@ Working version
API when the old block is NULL.
(Jacques-Henri Jourdan, review by Xavier Leroy)
- #8920: New API for statistical memory profiling in Memprof.Gc. The
new version does no longer use ephemerons and allows registering
callbacks for promotion and deallocation of memory blocks.
(Stephen Dolan and Jacques-Henri Jourdan, review by Damien Doligez
and Gabriel Scherer)
### Code generation and optimizations:
- #8637, #8805: Record debug info for each allocation

1
otherlibs/systhreads/st_stubs.c
View File

@ -228,6 +228,7 @@ static inline void caml_thread_restore_runtime_state(void)
Caml_state->backtrace_buffer = curr_thread->backtrace_buffer;
Caml_state->backtrace_last_exn = curr_thread->backtrace_last_exn;
caml_memprof_suspended = curr_thread->memprof_suspended;
caml_memprof_check_action_pending();
}
/* Hooks for caml_enter_blocking_section and caml_leave_blocking_section */

28
otherlibs/unix/.depend
View File

@ -109,11 +109,11 @@ cstringv.o: cstringv.c ../../runtime/caml/mlvalues.h \
../../runtime/caml/freelist.h ../../runtime/caml/minor_gc.h \
../../runtime/caml/address_class.h ../../runtime/caml/domain.h \
../../runtime/caml/osdeps.h ../../runtime/caml/memory.h unixsupport.h
dup.o: dup.c ../../runtime/caml/mlvalues.h ../../runtime/caml/config.h \
dup2.o: dup2.c ../../runtime/caml/mlvalues.h ../../runtime/caml/config.h \
../../runtime/caml/m.h ../../runtime/caml/s.h ../../runtime/caml/misc.h \
../../runtime/caml/domain_state.h ../../runtime/caml/mlvalues.h \
../../runtime/caml/domain_state.tbl unixsupport.h
dup2.o: dup2.c ../../runtime/caml/mlvalues.h ../../runtime/caml/config.h \
dup.o: dup.c ../../runtime/caml/mlvalues.h ../../runtime/caml/config.h \
../../runtime/caml/m.h ../../runtime/caml/s.h ../../runtime/caml/misc.h \
../../runtime/caml/domain_state.h ../../runtime/caml/mlvalues.h \
../../runtime/caml/domain_state.tbl unixsupport.h
@ -390,13 +390,6 @@ mkfifo.o: mkfifo.c ../../runtime/caml/fail.h ../../runtime/caml/misc.h \
../../runtime/caml/mlvalues.h ../../runtime/caml/memory.h \
../../runtime/caml/compatibility.h ../../runtime/caml/domain.h \
../../runtime/caml/signals.h unixsupport.h
mmap.o: mmap.c ../../runtime/caml/bigarray.h ../../runtime/caml/config.h \
../../runtime/caml/m.h ../../runtime/caml/s.h \
../../runtime/caml/mlvalues.h ../../runtime/caml/misc.h \
../../runtime/caml/domain_state.h ../../runtime/caml/domain_state.tbl \
../../runtime/caml/fail.h ../../runtime/caml/io.h \
../../runtime/caml/mlvalues.h ../../runtime/caml/signals.h \
../../runtime/caml/sys.h unixsupport.h
mmap_ba.o: mmap_ba.c ../../runtime/caml/alloc.h ../../runtime/caml/misc.h \
../../runtime/caml/config.h ../../runtime/caml/m.h \
../../runtime/caml/s.h ../../runtime/caml/mlvalues.h \
@ -406,6 +399,13 @@ mmap_ba.o: mmap_ba.c ../../runtime/caml/alloc.h ../../runtime/caml/misc.h \
../../runtime/caml/major_gc.h ../../runtime/caml/freelist.h \
../../runtime/caml/minor_gc.h ../../runtime/caml/address_class.h \
../../runtime/caml/domain.h ../../runtime/caml/misc.h
mmap.o: mmap.c ../../runtime/caml/bigarray.h ../../runtime/caml/config.h \
../../runtime/caml/m.h ../../runtime/caml/s.h \
../../runtime/caml/mlvalues.h ../../runtime/caml/misc.h \
../../runtime/caml/domain_state.h ../../runtime/caml/domain_state.tbl \
../../runtime/caml/fail.h ../../runtime/caml/io.h \
../../runtime/caml/mlvalues.h ../../runtime/caml/signals.h \
../../runtime/caml/sys.h unixsupport.h
nice.o: nice.c ../../runtime/caml/mlvalues.h ../../runtime/caml/config.h \
../../runtime/caml/m.h ../../runtime/caml/s.h ../../runtime/caml/misc.h \
../../runtime/caml/domain_state.h ../../runtime/caml/mlvalues.h \
@ -542,11 +542,6 @@ sleep.o: sleep.c ../../runtime/caml/mlvalues.h \
../../runtime/caml/domain_state.h ../../runtime/caml/mlvalues.h \
../../runtime/caml/domain_state.tbl ../../runtime/caml/signals.h \
unixsupport.h
socket.o: socket.c ../../runtime/caml/fail.h ../../runtime/caml/misc.h \
../../runtime/caml/config.h ../../runtime/caml/m.h \
../../runtime/caml/s.h ../../runtime/caml/mlvalues.h \
../../runtime/caml/domain_state.h ../../runtime/caml/domain_state.tbl \
../../runtime/caml/mlvalues.h unixsupport.h
socketaddr.o: socketaddr.c ../../runtime/caml/mlvalues.h \
../../runtime/caml/config.h ../../runtime/caml/m.h \
../../runtime/caml/s.h ../../runtime/caml/misc.h \
@ -555,6 +550,11 @@ socketaddr.o: socketaddr.c ../../runtime/caml/mlvalues.h \
../../runtime/caml/memory.h ../../runtime/caml/compatibility.h \
../../runtime/caml/domain.h unixsupport.h socketaddr.h \
../../runtime/caml/misc.h
socket.o: socket.c ../../runtime/caml/fail.h ../../runtime/caml/misc.h \
../../runtime/caml/config.h ../../runtime/caml/m.h \
../../runtime/caml/s.h ../../runtime/caml/mlvalues.h \
../../runtime/caml/domain_state.h ../../runtime/caml/domain_state.tbl \
../../runtime/caml/mlvalues.h unixsupport.h
socketpair.o: socketpair.c ../../runtime/caml/mlvalues.h \
../../runtime/caml/config.h ../../runtime/caml/m.h \
../../runtime/caml/s.h ../../runtime/caml/misc.h \

76
runtime/.depend
View File

@ -27,7 +27,8 @@ startup_aux_b.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
caml/domain_state.tbl caml/exec.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/callback.h caml/major_gc.h caml/dynlink.h \
caml/osdeps.h caml/memory.h caml/startup_aux.h
caml/osdeps.h caml/memory.h caml/startup_aux.h caml/memprof.h \
caml/roots.h
startup_byt_b.$(O): startup_byt.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
caml/misc.h caml/config.h caml/mlvalues.h caml/domain_state.h \
caml/domain_state.tbl caml/backtrace.h caml/exec.h caml/callback.h \
@ -51,7 +52,7 @@ major_gc_b.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/domain.h caml/freelist.h caml/gc.h \
caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \
caml/signals.h caml/weak.h
caml/signals.h caml/weak.h caml/memprof.h
minor_gc_b.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/config.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -233,7 +234,8 @@ compact_b.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
caml/config.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/freelist.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h \
caml/memprof.h
finalise_b.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/compact.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -281,7 +283,7 @@ memprof_b.$(O): memprof.c caml/memprof.h caml/config.h caml/m.h caml/s.h \
caml/minor_gc.h caml/address_class.h caml/domain.h caml/fail.h \
caml/alloc.h caml/callback.h caml/signals.h caml/memory.h \
caml/minor_gc.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h \
caml/weak.h caml/stack.h caml/misc.h
caml/weak.h caml/stack.h caml/misc.h caml/compact.h caml/printexc.h
domain_b.$(O): domain.c caml/domain_state.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
@ -322,7 +324,8 @@ startup_aux_bd.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
caml/domain_state.tbl caml/exec.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/callback.h caml/major_gc.h caml/dynlink.h \
caml/osdeps.h caml/memory.h caml/startup_aux.h
caml/osdeps.h caml/memory.h caml/startup_aux.h caml/memprof.h \
caml/roots.h
startup_byt_bd.$(O): startup_byt.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
caml/misc.h caml/config.h caml/mlvalues.h caml/domain_state.h \
caml/domain_state.tbl caml/backtrace.h caml/exec.h caml/callback.h \
@ -346,7 +349,7 @@ major_gc_bd.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/domain.h caml/freelist.h caml/gc.h \
caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \
caml/signals.h caml/weak.h
caml/signals.h caml/weak.h caml/memprof.h
minor_gc_bd.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/config.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -528,7 +531,8 @@ compact_bd.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h
caml/config.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/freelist.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h \
caml/memprof.h
finalise_bd.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/compact.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -576,7 +580,7 @@ memprof_bd.$(O): memprof.c caml/memprof.h caml/config.h caml/m.h caml/s.h \
caml/minor_gc.h caml/address_class.h caml/domain.h caml/fail.h \
caml/alloc.h caml/callback.h caml/signals.h caml/memory.h \
caml/minor_gc.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h \
caml/weak.h caml/stack.h caml/misc.h
caml/weak.h caml/stack.h caml/misc.h caml/compact.h caml/printexc.h
domain_bd.$(O): domain.c caml/domain_state.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
@ -622,7 +626,8 @@ startup_aux_bi.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
caml/domain_state.tbl caml/exec.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/callback.h caml/major_gc.h caml/dynlink.h \
caml/osdeps.h caml/memory.h caml/startup_aux.h
caml/osdeps.h caml/memory.h caml/startup_aux.h caml/memprof.h \
caml/roots.h
startup_byt_bi.$(O): startup_byt.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
caml/misc.h caml/config.h caml/mlvalues.h caml/domain_state.h \
caml/domain_state.tbl caml/backtrace.h caml/exec.h caml/callback.h \
@ -646,7 +651,7 @@ major_gc_bi.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/domain.h caml/freelist.h caml/gc.h \
caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \
caml/signals.h caml/weak.h
caml/signals.h caml/weak.h caml/memprof.h
minor_gc_bi.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/config.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -828,7 +833,8 @@ compact_bi.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h
caml/config.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/freelist.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h \
caml/memprof.h
finalise_bi.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/compact.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -876,7 +882,7 @@ memprof_bi.$(O): memprof.c caml/memprof.h caml/config.h caml/m.h caml/s.h \
caml/minor_gc.h caml/address_class.h caml/domain.h caml/fail.h \
caml/alloc.h caml/callback.h caml/signals.h caml/memory.h \
caml/minor_gc.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h \
caml/weak.h caml/stack.h caml/misc.h
caml/weak.h caml/stack.h caml/misc.h caml/compact.h caml/printexc.h
domain_bi.$(O): domain.c caml/domain_state.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
@ -917,7 +923,8 @@ startup_aux_bpic.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
caml/domain_state.tbl caml/exec.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/callback.h caml/major_gc.h caml/dynlink.h \
caml/osdeps.h caml/memory.h caml/startup_aux.h
caml/osdeps.h caml/memory.h caml/startup_aux.h caml/memprof.h \
caml/roots.h
startup_byt_bpic.$(O): startup_byt.c caml/config.h caml/m.h caml/s.h caml/alloc.h \
caml/misc.h caml/config.h caml/mlvalues.h caml/domain_state.h \
caml/domain_state.tbl caml/backtrace.h caml/exec.h caml/callback.h \
@ -941,7 +948,7 @@ major_gc_bpic.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/domain.h caml/freelist.h caml/gc.h \
caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \
caml/signals.h caml/weak.h
caml/signals.h caml/weak.h caml/memprof.h
minor_gc_bpic.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/config.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -1123,7 +1130,8 @@ compact_bpic.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.
caml/config.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/freelist.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h \
caml/memprof.h
finalise_bpic.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/compact.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -1171,7 +1179,7 @@ memprof_bpic.$(O): memprof.c caml/memprof.h caml/config.h caml/m.h caml/s.h \
caml/minor_gc.h caml/address_class.h caml/domain.h caml/fail.h \
caml/alloc.h caml/callback.h caml/signals.h caml/memory.h \
caml/minor_gc.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h \
caml/weak.h caml/stack.h caml/misc.h
caml/weak.h caml/stack.h caml/misc.h caml/compact.h caml/printexc.h
domain_bpic.$(O): domain.c caml/domain_state.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
@ -1188,7 +1196,7 @@ startup_aux_n.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
caml/domain_state.tbl caml/exec.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/callback.h caml/major_gc.h caml/osdeps.h \
caml/memory.h caml/startup_aux.h
caml/memory.h caml/startup_aux.h caml/memprof.h caml/roots.h
startup_nat_n.$(O): startup_nat.c caml/callback.h caml/mlvalues.h \
caml/config.h caml/m.h caml/s.h caml/misc.h caml/domain_state.h \
caml/domain_state.tbl caml/backtrace.h caml/exec.h caml/custom.h \
@ -1245,7 +1253,7 @@ major_gc_n.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/domain.h caml/freelist.h caml/gc.h \
caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \
caml/signals.h caml/weak.h
caml/signals.h caml/weak.h caml/memprof.h
minor_gc_n.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/config.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -1373,7 +1381,8 @@ compact_n.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h \
caml/config.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/freelist.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h \
caml/memprof.h
finalise_n.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/compact.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -1464,7 +1473,7 @@ memprof_n.$(O): memprof.c caml/memprof.h caml/config.h caml/m.h caml/s.h \
caml/minor_gc.h caml/address_class.h caml/domain.h caml/fail.h \
caml/alloc.h caml/callback.h caml/signals.h caml/memory.h \
caml/minor_gc.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h \
caml/weak.h caml/stack.h caml/misc.h
caml/weak.h caml/stack.h caml/misc.h caml/compact.h caml/printexc.h
domain_n.$(O): domain.c caml/domain_state.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
@ -1480,7 +1489,7 @@ startup_aux_nd.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
caml/domain_state.tbl caml/exec.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/callback.h caml/major_gc.h caml/osdeps.h \
caml/memory.h caml/startup_aux.h
caml/memory.h caml/startup_aux.h caml/memprof.h caml/roots.h
startup_nat_nd.$(O): startup_nat.c caml/callback.h caml/mlvalues.h \
caml/config.h caml/m.h caml/s.h caml/misc.h caml/domain_state.h \
caml/domain_state.tbl caml/backtrace.h caml/exec.h caml/custom.h \
@ -1537,7 +1546,7 @@ major_gc_nd.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/domain.h caml/freelist.h caml/gc.h \
caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \
caml/signals.h caml/weak.h
caml/signals.h caml/weak.h caml/memprof.h
minor_gc_nd.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/config.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -1665,7 +1674,8 @@ compact_nd.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h
caml/config.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/freelist.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h \
caml/memprof.h
finalise_nd.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/compact.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -1756,7 +1766,7 @@ memprof_nd.$(O): memprof.c caml/memprof.h caml/config.h caml/m.h caml/s.h \
caml/minor_gc.h caml/address_class.h caml/domain.h caml/fail.h \
caml/alloc.h caml/callback.h caml/signals.h caml/memory.h \
caml/minor_gc.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h \
caml/weak.h caml/stack.h caml/misc.h
caml/weak.h caml/stack.h caml/misc.h caml/compact.h caml/printexc.h
domain_nd.$(O): domain.c caml/domain_state.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
@ -1772,7 +1782,7 @@ startup_aux_ni.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
caml/domain_state.tbl caml/exec.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/callback.h caml/major_gc.h caml/osdeps.h \
caml/memory.h caml/startup_aux.h
caml/memory.h caml/startup_aux.h caml/memprof.h caml/roots.h
startup_nat_ni.$(O): startup_nat.c caml/callback.h caml/mlvalues.h \
caml/config.h caml/m.h caml/s.h caml/misc.h caml/domain_state.h \
caml/domain_state.tbl caml/backtrace.h caml/exec.h caml/custom.h \
@ -1829,7 +1839,7 @@ major_gc_ni.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/domain.h caml/freelist.h caml/gc.h \
caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \
caml/signals.h caml/weak.h
caml/signals.h caml/weak.h caml/memprof.h
minor_gc_ni.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/config.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -1957,7 +1967,8 @@ compact_ni.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.h
caml/config.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/freelist.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h \
caml/memprof.h
finalise_ni.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/compact.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -2048,7 +2059,7 @@ memprof_ni.$(O): memprof.c caml/memprof.h caml/config.h caml/m.h caml/s.h \
caml/minor_gc.h caml/address_class.h caml/domain.h caml/fail.h \
caml/alloc.h caml/callback.h caml/signals.h caml/memory.h \
caml/minor_gc.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h \
caml/weak.h caml/stack.h caml/misc.h
caml/weak.h caml/stack.h caml/misc.h caml/compact.h caml/printexc.h
domain_ni.$(O): domain.c caml/domain_state.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
@ -2064,7 +2075,7 @@ startup_aux_npic.$(O): startup_aux.c caml/backtrace.h caml/mlvalues.h \
caml/domain_state.tbl caml/exec.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/callback.h caml/major_gc.h caml/osdeps.h \
caml/memory.h caml/startup_aux.h
caml/memory.h caml/startup_aux.h caml/memprof.h caml/roots.h
startup_nat_npic.$(O): startup_nat.c caml/callback.h caml/mlvalues.h \
caml/config.h caml/m.h caml/s.h caml/misc.h caml/domain_state.h \
caml/domain_state.tbl caml/backtrace.h caml/exec.h caml/custom.h \
@ -2121,7 +2132,7 @@ major_gc_npic.$(O): major_gc.c caml/compact.h caml/config.h caml/m.h caml/s.h \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \
caml/address_class.h caml/domain.h caml/freelist.h caml/gc.h \
caml/gc_ctrl.h caml/major_gc.h caml/misc.h caml/mlvalues.h caml/roots.h \
caml/signals.h caml/weak.h
caml/signals.h caml/weak.h caml/memprof.h
minor_gc_npic.$(O): minor_gc.c caml/custom.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/config.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -2249,7 +2260,8 @@ compact_npic.$(O): compact.c caml/address_class.h caml/config.h caml/m.h caml/s.
caml/config.h caml/finalise.h caml/roots.h caml/memory.h caml/gc.h \
caml/major_gc.h caml/freelist.h caml/minor_gc.h caml/address_class.h \
caml/domain.h caml/freelist.h caml/gc.h caml/gc_ctrl.h caml/major_gc.h \
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h
caml/memory.h caml/mlvalues.h caml/roots.h caml/weak.h caml/compact.h \
caml/memprof.h
finalise_npic.$(O): finalise.c caml/callback.h caml/mlvalues.h caml/config.h \
caml/m.h caml/s.h caml/misc.h caml/domain_state.h caml/domain_state.tbl \
caml/compact.h caml/fail.h caml/finalise.h caml/roots.h caml/memory.h \
@ -2340,7 +2352,7 @@ memprof_npic.$(O): memprof.c caml/memprof.h caml/config.h caml/m.h caml/s.h \
caml/minor_gc.h caml/address_class.h caml/domain.h caml/fail.h \
caml/alloc.h caml/callback.h caml/signals.h caml/memory.h \
caml/minor_gc.h caml/backtrace_prim.h caml/backtrace.h caml/exec.h \
caml/weak.h caml/stack.h caml/misc.h
caml/weak.h caml/stack.h caml/misc.h caml/compact.h caml/printexc.h
domain_npic.$(O): domain.c caml/domain_state.h caml/misc.h caml/config.h caml/m.h \
caml/s.h caml/mlvalues.h caml/domain_state.h caml/domain_state.tbl \
caml/memory.h caml/gc.h caml/major_gc.h caml/freelist.h caml/minor_gc.h \

11
runtime/caml/memprof.h
View File

@ -24,7 +24,8 @@
extern int caml_memprof_suspended;
extern value caml_memprof_handle_postponed_exn();
extern value caml_memprof_handle_postponed_exn(void);
extern void caml_memprof_check_action_pending(void);
extern void caml_memprof_track_alloc_shr(value block);
extern void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml);
@ -33,7 +34,13 @@ extern void caml_memprof_track_interned(header_t* block, header_t* blockend);
extern void caml_memprof_renew_minor_sample(void);
extern value* caml_memprof_young_trigger;
extern void caml_memprof_scan_roots(scanning_action f);
extern void caml_memprof_oldify_young_roots(void);
extern void caml_memprof_minor_update(void);
extern void caml_memprof_do_roots(scanning_action f);
extern void caml_memprof_update_clean_phase(void);
extern void caml_memprof_invert_tracked(void);
extern void caml_memprof_shutdown(void);
#endif

3
runtime/compact.c
View File

@ -29,6 +29,7 @@
#include "caml/roots.h"
#include "caml/weak.h"
#include "caml/compact.h"
#include "caml/memprof.h"
extern uintnat caml_percent_free; /* major_gc.c */
extern void caml_shrink_heap (char *); /* memory.c */
@ -204,6 +205,8 @@ static void do_compaction (intnat new_allocation_policy)
caml_do_roots (caml_invert_root, 1);
/* The values to be finalised are not roots but should still be inverted */
caml_final_invert_finalisable_values ();
/* Idem for memprof tracked blocks */
caml_memprof_invert_tracked ();
ch = caml_heap_start;
while (ch != NULL){

2
runtime/major_gc.c
View File

@ -32,6 +32,7 @@
#include "caml/roots.h"
#include "caml/signals.h"
#include "caml/weak.h"
#include "caml/memprof.h"
#if defined (NATIVE_CODE) && defined (NO_NAKED_POINTERS)
#define NATIVE_CODE_AND_NO_NAKED_POINTERS
@ -498,6 +499,7 @@ static void mark_slice (intnat work)
this cycle. Start clean phase. */
caml_gc_phase = Phase_clean;
caml_final_update_clean_phase ();
caml_memprof_update_clean_phase ();
if (caml_ephe_list_head != (value) NULL){
/* Initialise the clean phase. */
ephes_to_check = &caml_ephe_list_head;

2
runtime/memory.c
View File

@ -664,7 +664,7 @@ CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
major GC treats it as an additional root.
The logic implemented below is duplicated in caml_array_fill to
avoid repated calls to caml_modify and repeated tests on the
avoid repeated calls to caml_modify and repeated tests on the
values. Don't forget to update caml_array_fill if the logic
below changes!
*/

791
runtime/memprof.c
View File

@ -28,8 +28,12 @@
#include "caml/weak.h"
#include "caml/stack.h"
#include "caml/misc.h"
#include "caml/compact.h"
#include "caml/printexc.h"
static uint32_t mt_state[624];
#define MT_STATE_SIZE 624
static uint32_t mt_state[MT_STATE_SIZE];
static uint32_t mt_index;
/* [lambda] is the mean number of samples for each allocated word (including
@ -41,8 +45,10 @@ static double lambda = 0;
static double one_log1m_lambda;
int caml_memprof_suspended = 0;
static intnat callstack_size = 0;
static value memprof_callback = Val_unit;
static intnat callstack_size;
static value callback_alloc_minor, callback_alloc_major,
callback_promote, callback_dealloc_minor, callback_dealloc_major;
/* Pointer to the word following the next sample in the minor
heap. Equals [Caml_state->young_alloc_start] if no sampling is planned in
@ -62,17 +68,18 @@ static double mt_generate_uniform(void)
uint32_t y;
/* Mersenne twister PRNG */
if (mt_index == 624) {
for(i = 0; i < 227; i++) {
if (mt_index == MT_STATE_SIZE) {
for (i = 0; i < 227; i++) {
y = (mt_state[i] & 0x80000000) + (mt_state[i+1] & 0x7fffffff);
mt_state[i] = mt_state[i+397] ^ (y >> 1) ^ ((-(y&1)) & 0x9908b0df);
}
for(i = 227; i < 623; i++) {
for (i = 227; i < MT_STATE_SIZE - 1; i++) {
y = (mt_state[i] & 0x80000000) + (mt_state[i+1] & 0x7fffffff);
mt_state[i] = mt_state[i-227] ^ (y >> 1) ^ ((-(y&1)) & 0x9908b0df);
}
y = (mt_state[623] & 0x80000000) + (mt_state[0] & 0x7fffffff);
mt_state[623] = mt_state[396] ^ (y >> 1) ^ ((-(y&1)) & 0x9908b0df);
y = (mt_state[MT_STATE_SIZE - 1] & 0x80000000) + (mt_state[0] & 0x7fffffff);
mt_state[MT_STATE_SIZE - 1] =
mt_state[396] ^ (y >> 1) ^ ((-(y&1)) & 0x9908b0df);
mt_index = 0;
}
@ -90,7 +97,7 @@ static double mt_generate_uniform(void)
/* Simulate a geometric variable of parameter [lambda].
The result is clipped in [1..Max_long]
Requires [lambda > 0]. */
static uintnat mt_generate_geom()
static uintnat mt_generate_geom(void)
{
/* We use the float versions of exp/log, since these functions are
significantly faster, and we really don't need much precision
@ -102,7 +109,7 @@ static uintnat mt_generate_geom()
return (uintnat)res;
}
static uintnat next_mt_generate_binom;
static uintnat next_mt_generate_geom;
/* Simulate a binomial variable of parameters [len] and [lambda].
This sampling algorithm has running time linear with [len *
lambda]. We could use more a involved algorithm, but this should
@ -119,257 +126,422 @@ static uintnat next_mt_generate_binom;
static uintnat mt_generate_binom(uintnat len)
{
uintnat res;
for(res = 0; next_mt_generate_binom < len; res++)
next_mt_generate_binom += mt_generate_geom();
next_mt_generate_binom -= len;
for (res = 0; next_mt_generate_geom < len; res++)
next_mt_generate_geom += mt_generate_geom();
next_mt_generate_geom -= len;
return res;
}
/**** Interface with the OCaml code. ****/
static void purge_postponed_queue(void);
CAMLprim value caml_memprof_set(value v)
{
CAMLparam1(v);
double l = Double_val(Field(v, 0));
intnat sz = Long_val(Field(v, 1));
if (sz < 0 || !(l >= 0.) || l > 1.) /* Checks that [l] is not NAN. */
caml_invalid_argument("caml_memprof_set");
/* This call to [caml_memprof_set] may stop sampling or change the
callback. We have to make sure that the postponed queue is empty
before continuing. */
if (!caml_memprof_suspended)
caml_raise_if_exception(caml_memprof_handle_postponed_exn());
else
/* But if we are currently running a callback, there is nothing
else we can do than purging the queue. */
purge_postponed_queue();
if (!init) {
int i;
init = 1;
mt_index = 624;
mt_state[0] = 42;
for(i = 1; i < 624; i++)
mt_state[i] = 0x6c078965 * (mt_state[i-1] ^ (mt_state[i-1] >> 30)) + i;
caml_register_generational_global_root(&memprof_callback);
}
lambda = l;
if (l > 0) {
one_log1m_lambda = l == 1 ? 0 : 1/caml_log1p(-l);
next_mt_generate_binom = mt_generate_geom();
}
caml_memprof_renew_minor_sample();
callstack_size = sz;
caml_modify_generational_global_root(&memprof_callback, Field(v, 2));
CAMLreturn(Val_unit);
}
/* Cf. Gc.Memprof.alloc_kind */
enum ml_alloc_kind {
Minor = Val_long(0),
Major = Val_long(1),
Unmarshalled = Val_long(2)
};
/* When we call do_callback_exn, we suspend/resume sampling. In order
to avoid a systematic unnecessary polling after each memprof
callback, we do not call [caml_set_action_pending] when resuming.
Therefore, any call to [do_callback_exn] has to also make sure the
postponed queue will be handled fully at some point. */
static value do_callback_exn(tag_t tag, uintnat wosize, uintnat occurrences,
value callstack, enum ml_alloc_kind cb_kind)
{
CAMLparam1(callstack);
CAMLlocal1(sample_info);
value res; /* Not a root, can be an exception result. */
CAMLassert(occurrences > 0 && !caml_memprof_suspended);
caml_memprof_suspended = 1;
sample_info = caml_alloc_small(5, 0);
Field(sample_info, 0) = Val_long(occurrences);
Field(sample_info, 1) = cb_kind;
Field(sample_info, 2) = Val_long(tag);
Field(sample_info, 3) = Val_long(wosize);
Field(sample_info, 4) = callstack;
res = caml_callback_exn(memprof_callback, sample_info);
caml_memprof_suspended = 0;
CAMLreturn(res);
}
/**** Capturing the call stack *****/
/* This function is called for postponed blocks, so it guarantees
that the GC is not called. */
/* This function is called in, e.g., [caml_alloc_shr], which
guarantees that the GC is not called. Clients may use it in a
context where the heap is in an invalid state, or when the roots
are not properly registered. Therefore, we do not use [caml_alloc],
which may call the GC, but prefer using [caml_alloc_shr], which
gives this guarantee. The return value is either a valid callstack
or 0 in out-of-memory scenarios. */
static value capture_callstack_postponed(void)
{
value res;
uintnat wosize = caml_current_callstack_size(callstack_size);
/* We do not use [caml_alloc] to make sure the GC will not get called. */
if (wosize == 0) return Atom (0);
if (wosize == 0) return Atom(0);
res = caml_alloc_shr_no_track_noexc(wosize, 0);
if (res != 0) caml_current_callstack_write(res);
return res;
}
/* In this version, we are allowed to call the GC, so we use
[caml_alloc], which is more efficient since it uses the minor
heap.
Should be called with [caml_memprof_suspended == 1] */
static value capture_callstack(void)
{
value res;
uintnat wosize = caml_current_callstack_size(callstack_size);
CAMLassert(!caml_memprof_suspended);
caml_memprof_suspended = 1; /* => no samples in the call stack. */
CAMLassert(caml_memprof_suspended);
res = caml_alloc(wosize, 0);
caml_memprof_suspended = 0;
caml_current_callstack_write(res);
return res;
}
/**** Handling postponed sampled blocks. ****/
/* When allocating in from C code, we cannot call the callback,
because the [caml_alloc_***] are guaranteed not to do so. These
functions make it possible to register a sampled block in a
todo-list so that the callback call is performed when possible. */
/* Note: the shorter the delay is, the better, because the block is
linked to a root during the delay, so that the reachability
properties of the sampled block are artificially modified. */
/**** Data structures for tracked blocks. ****/
#define POSTPONED_DEFAULT_QUEUE_SIZE 128
static struct postponed_block {
/* During the alloc callback for a minor allocation, the block being
sampled is not yet allocated. Instead, it's represented as this. */
#define Placeholder_value (Val_long(0x42424242))
/* When an entry is deleted, its index is replaced by that integer. */
#define Invalid_index (~(uintnat)0)
struct tracked {
/* Memory block being sampled. This is a weak GC root. */
value block;
value callstack;
uintnat occurrences;
enum ml_alloc_kind kind;
} default_postponed_queue[POSTPONED_DEFAULT_QUEUE_SIZE],
*postponed_queue = default_postponed_queue,
*postponed_queue_end = default_postponed_queue + POSTPONED_DEFAULT_QUEUE_SIZE,
*postponed_tl = default_postponed_queue, /* Pointer to next pop */
*postponed_hd = default_postponed_queue; /* Pointer to next push */
static struct postponed_block* postponed_next(struct postponed_block* p)
{
p++;
if (p == postponed_queue_end) return postponed_queue;
else return p;
/* Number of samples in this block. */
uintnat n_samples;
/* The header of this block (useful for tag and size) */
header_t header;
/* The value returned by the previous callback for this block, or
the callstack if the alloc callback has not been called yet.
This is a strong GC root. */
value user_data;
/* Whether this block has been initially allocated in the minor heap. */
unsigned int alloc_young : 1;
/* Whether this block comes from unmarshalling. */
unsigned int unmarshalled : 1;
/* Whether this block has been promoted. Implies [alloc_young]. */
unsigned int promoted : 1;
/* Whether this block has been deallocated. */
unsigned int deallocated : 1;
/* Whether the allocation callback has been called. */
unsigned int cb_alloc_called : 1;
/* Whether the promotion callback has been called. */
unsigned int cb_promote_called : 1;
/* Whether the deallocation callback has been called. */
unsigned int cb_dealloc_called : 1;
/* Whether this entry is deleted. */
unsigned int deleted : 1;
/* Whether a callback is currently running for this entry. */
unsigned int callback_running : 1;
/* Pointer to the [t_idx] variable in the [run_callback] frame which
is currently running the callback for this entry. This is needed
to make [run_callback] reetrant, in the case it is called
simultaneously by several threads. */
uintnat* idx_ptr;
};
static struct tracking_state {
struct tracked* entries;
/* The allocated capacity of the entries array */
uintnat alloc_len;
/* The number of active entries. (len <= alloc_len) */
uintnat len;
/* Before this position, the [block] and [user_data] fields point to
the major heap (young <= len). */
uintnat young;
/* There are no pending callbacks before this position (callback <= len). */
uintnat callback;
/* There are no blocks to be deleted before this position */
uintnat delete;
} trackst;
#define MIN_TRACKST_ALLOC_LEN 128
/* Reallocate the [trackst] array if it is either too small or too
large.
Returns 1 if reallocation succeeded --[trackst.alloc_len] is at
least [trackst.len]--, and 0 otherwise. */
static int realloc_trackst(void) {
uintnat new_alloc_len;
struct tracked* new_entries;
if (trackst.len <= trackst.alloc_len &&
(4*trackst.len >= trackst.alloc_len ||
trackst.alloc_len == MIN_TRACKST_ALLOC_LEN))
return 1;
new_alloc_len = trackst.len * 2;
if (new_alloc_len < MIN_TRACKST_ALLOC_LEN)
new_alloc_len = MIN_TRACKST_ALLOC_LEN;
new_entries = caml_stat_resize_noexc(trackst.entries,
new_alloc_len * sizeof(struct tracked));
if (new_entries == NULL) return 0;
trackst.entries = new_entries;
trackst.alloc_len = new_alloc_len;
return 1;
}
static void purge_postponed_queue(void)
static inline uintnat new_tracked(uintnat n_samples, header_t header,
int is_unmarshalled, int is_young,
value block, value user_data)
{
if (postponed_queue != default_postponed_queue) {
caml_stat_free(postponed_queue);
postponed_queue = default_postponed_queue;
postponed_queue_end = postponed_queue + POSTPONED_DEFAULT_QUEUE_SIZE;
struct tracked *t;
trackst.len++;
if (!realloc_trackst()) {
trackst.len--;
return Invalid_index;
}
postponed_hd = postponed_tl = postponed_queue;
t = &trackst.entries[trackst.len - 1];
t->block = block;
t->n_samples = n_samples;
t->header = header;
t->user_data = user_data;
t->idx_ptr = NULL;
t->alloc_young = is_young;
t->unmarshalled = is_unmarshalled;
t->promoted = 0;
t->deallocated = 0;
t->cb_alloc_called = t->cb_promote_called = t->cb_dealloc_called = 0;
t->deleted = 0;
t->callback_running = 0;
return trackst.len - 1;
}
/* This function does not call the GC. This is important since it is
called when allocating a block using [caml_alloc_shr]: The new
block is allocated, but not yet initialized, so that the heap
invariants are broken. */
static void register_postponed_callback(value block, uintnat occurrences,
enum ml_alloc_kind kind,
value* callstack)
static void mark_deleted(uintnat t_idx)
{
struct postponed_block* new_hd;
if (occurrences == 0) return;
if (*callstack == 0) *callstack = capture_callstack_postponed();
if (*callstack == 0) return; /* OOM */
struct tracked* t = &trackst.entries[t_idx];
t->deleted = 1;
t->user_data = Val_unit;
t->block = Val_unit;
if (t_idx < trackst.delete) trackst.delete = t_idx;
CAMLassert(t->idx_ptr == NULL);
}
new_hd = postponed_next(postponed_hd);
if (new_hd == postponed_tl) {
/* Queue is full, reallocate it. (We always leave one free slot in
order to be able to distinguish the 100% full and the empty
states). */
uintnat sz = 2 * (postponed_queue_end - postponed_queue);
struct postponed_block* new_queue =
caml_stat_alloc_noexc(sz * sizeof(struct postponed_block));
if (new_queue == NULL) return;
new_hd = new_queue;
while (postponed_tl != postponed_hd) {
*new_hd = *postponed_tl;
new_hd++;
postponed_tl = postponed_next(postponed_tl);
/* The return value is an exception or [Val_unit] iff [*t_idx] is set to
[Invalid_index]. In this case, the entry is deleted.
Otherwise, the return value is a [Some(...)] block. */
static inline value run_callback_exn(uintnat *t_idx, value cb, value param) {
struct tracked* t = &trackst.entries[*t_idx];
value res;
CAMLassert(!t->callback_running && t->idx_ptr == NULL);
t->callback_running = 1;
t->idx_ptr = t_idx;
res = caml_callback_exn(cb, param);
/* The call above can modify [*t_idx] and thus invalidate [t]. */
if (*t_idx == Invalid_index) {
/* Make sure this entry has not been removed by [caml_memprof_set] */
return Val_unit;
}
t = &trackst.entries[*t_idx];
t->idx_ptr = NULL;
t->callback_running = 0;
if (Is_exception_result(res) || res == Val_unit) {
/* Callback raised an exception or returned None or (), discard
this entry. */
mark_deleted(*t_idx);
*t_idx = Invalid_index;
}
return res;
}
/* Run all the needed callbacks for a given entry.
In case of a thread context switch during a callback, this can be
called in a reetrant way.
If [*t_idx] equals [trackst.callback], then this function
increments [trackst.callback].
The index of the entry may change. It is set to [Invalid_index] if
the entry is discarded.
Returns:
- An exception result if the callback raised an exception
- Val_long(0) == Val_unit == None otherwise
*/
static value handle_entry_callbacks_exn(uintnat* t_idx)
{
value sample_info, res, user_data; /* No need to make these roots */
struct tracked* t = &trackst.entries[*t_idx];
if (*t_idx == trackst.callback) trackst.callback++;
if (t->deleted || t->callback_running) return Val_unit;
if (!t->cb_alloc_called) {
t->cb_alloc_called = 1;
CAMLassert(Is_block(t->block)
|| t->block == Placeholder_value
|| t->deallocated);
sample_info = caml_alloc_small(5, 0);
Field(sample_info, 0) = Val_long(t->n_samples);
Field(sample_info, 1) = Val_long(Wosize_hd(t->header));
Field(sample_info, 2) = Val_long(Tag_hd(t->header));
Field(sample_info, 3) = Val_long(t->unmarshalled);
Field(sample_info, 4) = t->user_data;
t->user_data = Val_unit;
res = run_callback_exn(t_idx,
t->alloc_young ? callback_alloc_minor : callback_alloc_major,
sample_info);
if (*t_idx == Invalid_index)
return res;
CAMLassert(!Is_exception_result(res) && Is_block(res) && Tag_val(res) == 0
&& Wosize_val(res) == 1);
t = &trackst.entries[*t_idx];
t->user_data = Field(res, 0);
if (Is_block(t->user_data) && Is_young(t->user_data) &&
*t_idx < trackst.young)
trackst.young = *t_idx;
}
if (t->promoted && !t->cb_promote_called) {
t->cb_promote_called = 1;
user_data = t->user_data;
t->user_data = Val_unit;
res = run_callback_exn(t_idx, callback_promote, user_data);
if (*t_idx == Invalid_index)
return res;
CAMLassert(!Is_exception_result(res) && Is_block(res) && Tag_val(res) == 0
&& Wosize_val(res) == 1);
t = &trackst.entries[*t_idx];
t->user_data = Field(res, 0);
if (Is_block(t->user_data) && Is_young(t->user_data) &&
*t_idx < trackst.young)
trackst.young = *t_idx;
}
if (t->deallocated && !t->cb_dealloc_called) {
value cb = (t->promoted || !t->alloc_young) ?
callback_dealloc_major : callback_dealloc_minor;
t->cb_dealloc_called = 1;
user_data = t->user_data;
t->user_data = Val_unit;
res = run_callback_exn(t_idx, cb, user_data);
/* [t] is invalid, but we do no longer use it. */
CAMLassert(*t_idx == Invalid_index);
CAMLassert(Is_exception_result(res) || res == Val_unit);
return res;
}
return Val_unit;
}
/* Remove any deleted entries, updating callback and young */
static void flush_deleted(void)
{
uintnat i = trackst.delete, j = i;
while (i < trackst.len) {
if (!trackst.entries[i].deleted) {
if (trackst.entries[i].idx_ptr != NULL)
*trackst.entries[i].idx_ptr = j;
trackst.entries[j] = trackst.entries[i];
j++;
}
if (postponed_queue != default_postponed_queue)
caml_stat_free(postponed_queue);
postponed_tl = postponed_queue = new_queue;
postponed_hd = new_hd;
postponed_queue_end = postponed_queue + sz;
new_hd++;
i++;
if (trackst.young == i) trackst.young = j;
if (trackst.callback == i) trackst.callback = j;
}
postponed_hd->block = block;
postponed_hd->callstack = *callstack;
postponed_hd->occurrences = occurrences;
postponed_hd->kind = kind;
postponed_hd = new_hd;
if (!caml_memprof_suspended) caml_set_action_pending();
trackst.delete = trackst.len = j;
CAMLassert(trackst.callback <= trackst.len);
CAMLassert(trackst.young <= trackst.len);
realloc_trackst();
}
void caml_memprof_check_action_pending(void) {
if (!caml_memprof_suspended && trackst.callback < trackst.len)
caml_set_action_pending();
}
/* In case of a thread context switch during a callback, this can be
called in a reetrant way. */
value caml_memprof_handle_postponed_exn(void)
{
CAMLparam0();
CAMLlocal1(block);
value ephe;
if (caml_memprof_suspended)
CAMLreturn(Val_unit);
while (postponed_tl != postponed_hd) {
struct postponed_block pb = *postponed_tl;
block = pb.block; /* pb.block is not a root! */
postponed_tl = postponed_next(postponed_tl);
if (postponed_tl == postponed_hd) purge_postponed_queue();
/* If using threads, this call can trigger reentrant calls to
[caml_memprof_handle_postponed] even though we set
[caml_memprof_suspended]. */
ephe = do_callback_exn(Tag_val(block), Wosize_val(block),
pb.occurrences, pb.callstack, pb.kind);
if (Is_exception_result(ephe)) CAMLreturn(ephe);
if (Is_block(ephe)) caml_ephemeron_set_key(Field(ephe, 0), 0, block);
value res = Val_unit;
if (caml_memprof_suspended) return res;
caml_memprof_suspended = 1;
while (trackst.callback < trackst.len) {
uintnat i = trackst.callback;
res = handle_entry_callbacks_exn(&i);
if (Is_exception_result(res)) break;
}
CAMLreturn(Val_unit);
caml_memprof_suspended = 0;
caml_memprof_check_action_pending(); /* Needed in case of an exception */
flush_deleted();
return res;
}
/* We don't expect these roots to live long. No need to have a special
case for young roots. */
void caml_memprof_scan_roots(scanning_action f) {
struct postponed_block* p;
for(p = postponed_tl; p != postponed_hd; p = postponed_next(p)) {
f(p->block, &p->block);
f(p->callstack, &p->callstack);
void caml_memprof_oldify_young_roots(void)
{
uintnat i;
/* This loop should always have a small number of iteration (when
compared to the size of the minor heap), because the young
pointer should always be close to the end of the array. Indeed,
it is only moved back when returning from a callback triggered by
allocation or promotion, which can only happen for blocks
allocated recently, which are close to the end of the trackst
array. */
for (i = trackst.young; i < trackst.len; i++)
caml_oldify_one(trackst.entries[i].user_data,
&trackst.entries[i].user_data);
}
void caml_memprof_minor_update(void)
{
uintnat i;
/* See comment in [caml_memprof_oldify_young_roots] for the number
of iterations of this loop. */
for (i = trackst.young; i < trackst.len; i++) {
struct tracked *t = &trackst.entries[i];
CAMLassert(Is_block(t->block) || t->deleted || t->deallocated ||
t->block == Placeholder_value);
if (Is_block(t->block) && Is_young(t->block)) {
if (Hd_val(t->block) == 0) {
/* Block has been promoted */
t->block = Field(t->block, 0);
t->promoted = 1;
} else {
/* Block is dead */
t->block = Val_unit;
t->deallocated = 1;
}
}
}
if (trackst.callback > trackst.young) {
trackst.callback = trackst.young;
caml_memprof_check_action_pending();
}
trackst.young = trackst.len;
}
void caml_memprof_do_roots(scanning_action f)
{
uintnat i;
for (i = 0; i < trackst.len; i++)
f(trackst.entries[i].user_data, &trackst.entries[i].user_data);
}
void caml_memprof_update_clean_phase(void)
{
uintnat i;
for (i = 0; i < trackst.len; i++) {
struct tracked *t = &trackst.entries[i];
if (Is_block(t->block) && !Is_young(t->block)) {
CAMLassert(Is_in_heap(t->block));
CAMLassert(!t->alloc_young || t->promoted);
if (Is_white_val(t->block)) {
t->block = Val_unit;
t->deallocated = 1;
}
}
}
trackst.callback = 0;
caml_memprof_check_action_pending();
}
void caml_memprof_invert_tracked(void)
{
uintnat i;
for (i = 0; i < trackst.len; i++)
caml_invert_root(trackst.entries[i].block, &trackst.entries[i].block);
}
/**** Sampling procedures ****/
void caml_memprof_track_alloc_shr(value block)
{
uintnat n_samples;
value callstack = 0;
CAMLassert(Is_in_heap(block));
/* This test also makes sure memprof is initialized. */
if (lambda == 0 || caml_memprof_suspended) return;
register_postponed_callback(
block, mt_generate_binom(Whsize_val(block)), Major, &callstack);
n_samples = mt_generate_binom(Whsize_val(block));
if (n_samples == 0) return;
callstack = capture_callstack_postponed();
if (callstack == 0) return;
new_tracked(n_samples, Hd_val(block), 0, 0, block, callstack);
caml_memprof_check_action_pending();
}
/* Shifts the next sample in the minor heap by [n] words. Essentially,
@ -397,7 +569,7 @@ void caml_memprof_renew_minor_sample(void)
caml_memprof_young_trigger = Caml_state->young_alloc_start;
else {
uintnat geom = mt_generate_geom();
if(Caml_state->young_ptr - Caml_state->young_alloc_start < geom)
if (Caml_state->young_ptr - Caml_state->young_alloc_start < geom)
/* No trigger in the current minor heap. */
caml_memprof_young_trigger = Caml_state->young_alloc_start;
caml_memprof_young_trigger = Caml_state->young_ptr - (geom - 1);
@ -411,14 +583,13 @@ void caml_memprof_renew_minor_sample(void)
from natively compiled OCaml code). */
void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml)
{
CAMLparam0();
CAMLlocal2(ephe, callstack);
uintnat whsize = Whsize_wosize(wosize);
uintnat occurrences;
uintnat whsize = Whsize_wosize(wosize), n_samples;
uintnat t_idx;
value callstack, res;
if (caml_memprof_suspended) {
caml_memprof_renew_minor_sample();
CAMLreturn0;
return;
}
/* If [lambda == 0], then [caml_memprof_young_trigger] should be
@ -427,16 +598,19 @@ void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml)
caml_memprof_young_trigger], which is contradictory. */
CAMLassert(lambda > 0);
occurrences =
mt_generate_binom(caml_memprof_young_trigger - 1
- Caml_state->young_ptr) + 1;
n_samples = 1 +
mt_generate_binom(caml_memprof_young_trigger - 1 - Caml_state->young_ptr);
if (!from_caml) {
value callstack = 0;
register_postponed_callback(Val_hp(Caml_state->young_ptr), occurrences,
Minor, &callstack);
caml_memprof_renew_minor_sample();
CAMLreturn0;
callstack = capture_callstack_postponed();
if (callstack == 0) return;
new_tracked(n_samples, Make_header(wosize, tag, Caml_white),
0, 1, Val_hp(Caml_state->young_ptr), callstack);
caml_memprof_check_action_pending();
return;
}
/* We need to call the callback for this sampled block. Since the
@ -451,21 +625,42 @@ void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml)
Caml_state->young_ptr += whsize;
caml_memprof_renew_minor_sample();
/* Empty the queue to make sure callbacks are called in the right
order. */
caml_raise_if_exception(caml_memprof_handle_postponed_exn());
caml_memprof_suspended = 1;
callstack = capture_callstack();
ephe = caml_raise_if_exception(do_callback_exn(tag, wosize, occurrences,
callstack, Minor));
t_idx = new_tracked(n_samples, Make_header(wosize, tag, Caml_white),
0, 1, Placeholder_value, callstack);
if (t_idx == Invalid_index)
res = Val_unit;
else
res = handle_entry_callbacks_exn(&t_idx);
caml_memprof_suspended = 0;
caml_memprof_check_action_pending();
/* We need to call [caml_memprof_check_action_pending] since we
reset [caml_memprof_suspended] to 0 (a GC collection may have
triggered some new callback).
We need to make sure that the action pending flag is not set
systematically, which is to be expected, since [new_tracked]
created a new block without updating
[trackst.callback]. Fortunately, [handle_entry_callback_exn]
increments [trackst.callback] if it is equal to [t_idx]. */
/* We can now restore the minor heap in the state needed by
[Alloc_small_aux]. */
if (Caml_state->young_ptr - whsize < Caml_state->young_trigger) {
CAML_INSTR_INT ("force_minor/memprof@", 1);
CAML_INSTR_INT("force_minor/memprof@", 1);
caml_gc_dispatch();
}
/* This condition happens either in the case of an exception or if
the callback returned [None]. If these cases happen frequently,
then we need to call [flush_deleted] somewhere to prevent a
leak. */
if (t_idx == Invalid_index)
flush_deleted();
caml_raise_if_exception(res);
/* Re-allocate the block in the minor heap. We should not call the
GC after this. */
Caml_state->young_ptr -= whsize;
@ -473,55 +668,149 @@ void caml_memprof_track_young(tag_t tag, uintnat wosize, int from_caml)
/* Make sure this block is not going to be sampled again. */
shift_sample(whsize);
/* Write the ephemeron if not [None]. */
if (Is_block(ephe)) {
/* Subtlety: we are actually writing the ephemeron with an invalid
(uninitialized) block. This is correct for two reasons:
- The logic of [caml_ephemeron_set_key] never inspects the content of
the block. In only checks that the block is young.
- The allocation and initialization happens right after returning
from [caml_memprof_track_young]. */
caml_ephemeron_set_key(Field(ephe, 0), 0, Val_hp(Caml_state->young_ptr));
if (t_idx != Invalid_index) {
/* If the execution of the callback has succeeded, then we start the
tracking of this block..
Subtlety: we are actually writing [t->block] with an invalid
(uninitialized) block. This is correct because the allocation
and initialization happens right after returning from
[caml_memprof_track_young]. */
trackst.entries[t_idx].block = Val_hp(Caml_state->young_ptr);
CAMLassert(trackst.entries[t_idx].cb_alloc_called);
if (t_idx < trackst.young) trackst.young = t_idx;
}
/* /!\ Since the heap is in an invalid state before initialization,
very little heap operations are allowed until then. */
CAMLreturn0;
return;
}
void caml_memprof_track_interned(header_t* block, header_t* blockend) {
header_t *p;
value callstack = 0;
int is_young = Is_young(Val_hp(block));
if(lambda == 0 || caml_memprof_suspended)
if (lambda == 0 || caml_memprof_suspended)
return;
/* We have to select the sampled blocks before sampling them,
because sampling may trigger GC, and then blocks can escape from
[block, blockend[. So we use the postponing machinery for
selecting blocks. [intern.c] will call [check_urgent_gc] which
will call [caml_memprof_handle_postponed] in turn. */
p = block;
while(1) {
while (1) {
uintnat next_sample = mt_generate_geom();
header_t *next_sample_p, *next_p;
if(next_sample > blockend - p)
if (next_sample > blockend - p)
break;
/* [next_sample_p] is the block *following* the next sampled
block! */
next_sample_p = p + next_sample;
while(1) {
while (1) {
next_p = p + Whsize_hp(p);
if(next_p >= next_sample_p) break;
if (next_p >= next_sample_p) break;
p = next_p;
}
register_postponed_callback(
Val_hp(p), mt_generate_binom(next_p - next_sample_p) + 1,
Unmarshalled, &callstack);
if (callstack == 0) callstack = capture_callstack_postponed();
if (callstack == 0) break; /* OOM */
new_tracked(mt_generate_binom(next_p - next_sample_p) + 1,
Hd_hp(p), 1, is_young, Val_hp(p), callstack);
p = next_p;
}
caml_memprof_check_action_pending();
}
/**** Interface with the OCaml code. ****/
static void caml_memprof_init(void) {
uintnat i;
init = 1;
mt_index = MT_STATE_SIZE;
mt_state[0] = 42;
for (i = 1; i < MT_STATE_SIZE; i++)
mt_state[i] = 0x6c078965 * (mt_state[i-1] ^ (mt_state[i-1] >> 30)) + i;
callback_alloc_minor = Val_unit;
callback_alloc_major = Val_unit;
callback_promote = Val_unit;
callback_dealloc_minor = Val_unit;
callback_dealloc_major = Val_unit;
caml_register_generational_global_root(&callback_alloc_minor);
caml_register_generational_global_root(&callback_alloc_major);
caml_register_generational_global_root(&callback_promote);
caml_register_generational_global_root(&callback_dealloc_minor);
caml_register_generational_global_root(&callback_dealloc_major);
}
void caml_memprof_shutdown(void) {
init = 0;
lambda = 0.;
caml_memprof_suspended = 0;
trackst.len = 0;
trackst.callback = trackst.young = trackst.delete = 0;
caml_stat_free(trackst.entries);
trackst.entries = NULL;
trackst.alloc_len = 0;
}
CAMLprim value caml_memprof_set(value lv, value szv,
value cb_alloc_minor, value cb_alloc_major,
value cb_promote,
value cb_dealloc_minor, value cb_dealloc_major)
{
CAMLparam5(lv, szv, cb_alloc_minor, cb_alloc_major, cb_promote);
CAMLxparam2(cb_dealloc_minor, cb_dealloc_major);
double l = Double_val(lv);
intnat sz = Long_val(szv);
uintnat i;
if (sz < 0 || !(l >= 0.) || l > 1.) /* Checks that [l] is not NAN. */
caml_invalid_argument("caml_memprof_set");
if (!init) caml_memprof_init();
/* This call to [caml_memprof_set] will discard all the previously
tracked blocks. We try one last time to call the postponed
callbacks. */
caml_raise_if_exception(caml_memprof_handle_postponed_exn());
/* Discard the tracked blocks. */
for (i = 0; i < trackst.len; i++)
if (trackst.entries[i].idx_ptr != NULL)
*trackst.entries[i].idx_ptr = Invalid_index;
trackst.len = 0;
trackst.callback = trackst.young = trackst.delete = 0;
caml_stat_free(trackst.entries);
trackst.entries = NULL;
trackst.alloc_len = 0;
lambda = l;
if (l > 0) {
one_log1m_lambda = l == 1 ? 0 : 1/caml_log1p(-l);
next_mt_generate_geom = mt_generate_geom();
}
caml_memprof_renew_minor_sample();
callstack_size = sz;
caml_modify_generational_global_root(&callback_alloc_minor, cb_alloc_minor);
caml_modify_generational_global_root(&callback_alloc_major, cb_alloc_major);
caml_modify_generational_global_root(&callback_promote, cb_promote);
caml_modify_generational_global_root(&callback_dealloc_minor,
cb_dealloc_minor);
caml_modify_generational_global_root(&callback_dealloc_major,
cb_dealloc_major);
CAMLreturn(Val_unit);
}
CAMLprim value caml_memprof_set_byt(value* argv, int argn)
{
CAMLassert(argn == 7);
return caml_memprof_set(argv[0], argv[1], argv[2], argv[3],
argv[4], argv[5], argv[6]);
}

2
runtime/minor_gc.c
View File

@ -392,6 +392,8 @@ void caml_empty_minor_heap (void)
}
/* Update the OCaml finalise_last values */
caml_final_update_minor_roots();
/* Trigger memprofs callbacks for blocks in the minor heap. */
caml_memprof_minor_update();
/* Run custom block finalisation of dead minor values */
for (elt = Caml_state->custom_table->base;
elt < Caml_state->custom_table->ptr; elt++){

4
runtime/roots_byt.c
View File

@ -58,7 +58,7 @@ void caml_oldify_local_roots (void)
/* Finalised values */
caml_final_oldify_young_roots ();
/* Memprof */
caml_memprof_scan_roots (&caml_oldify_one);
caml_memprof_oldify_young_roots ();
/* Hook */
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one);
}
@ -96,7 +96,7 @@ void caml_do_roots (scanning_action f, int do_globals)
caml_final_do_roots (f);
CAML_INSTR_TIME (tmr, "major_roots/finalised");
/* Memprof */
caml_memprof_scan_roots (f);
caml_memprof_do_roots (f);
CAML_INSTR_TIME (tmr, "major_roots/memprof");
/* Hook */
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);

4
runtime/roots_nat.c
View File

@ -334,7 +334,7 @@ void caml_oldify_local_roots (void)
/* Finalised values */
caml_final_oldify_young_roots ();
/* Memprof */
caml_memprof_scan_roots (&caml_oldify_one);
caml_memprof_oldify_young_roots ();
/* Hook */
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(&caml_oldify_one);
}
@ -432,7 +432,7 @@ void caml_do_roots (scanning_action f, int do_globals)
caml_final_do_roots (f);
CAML_INSTR_TIME (tmr, "major_roots/finalised");
/* Memprof */
caml_memprof_scan_roots (f);
caml_memprof_do_roots (f);
CAML_INSTR_TIME (tmr, "major_roots/memprof");
/* Hook */
if (caml_scan_roots_hook != NULL) (*caml_scan_roots_hook)(f);

2
runtime/startup_aux.c
View File

@ -28,6 +28,7 @@
#endif
#include "caml/osdeps.h"
#include "caml/startup_aux.h"
#include "caml/memprof.h"
#ifdef _WIN32
@ -171,6 +172,7 @@ CAMLexport void caml_shutdown(void)
call_registered_value("Pervasives.do_at_exit");
call_registered_value("Thread.at_shutdown");
caml_finalise_heap();
caml_memprof_shutdown();
caml_free_locale();
#ifndef NATIVE_CODE
caml_free_shared_libs();

8
stdlib/.depend
View File

@ -277,21 +277,15 @@ stdlib__gc.cmo : \
stdlib__string.cmi \
stdlib__printf.cmi \
stdlib__printexc.cmi \
stdlib__obj.cmi \
stdlib__ephemeron.cmi \
stdlib__gc.cmi
stdlib__gc.cmx : \
stdlib__sys.cmx \
stdlib__string.cmx \
stdlib__printf.cmx \
stdlib__printexc.cmx \
stdlib__obj.cmx \
stdlib__ephemeron.cmx \
stdlib__gc.cmi
stdlib__gc.cmi : \
stdlib__printexc.cmi \
stdlib__obj.cmi \
stdlib__ephemeron.cmi
stdlib__printexc.cmi
stdlib__genlex.cmo : \
stdlib__string.cmi \
stdlib__stream.cmi \

63
stdlib/gc.ml
View File

@ -121,31 +121,48 @@ let delete_alarm a = a := false
module Memprof =
struct
type alloc_kind =
| Minor
| Major
| Unmarshalled
type allocation =
{ n_samples : int;
size : int;
tag : int;
unmarshalled : bool;
callstack : Printexc.raw_backtrace }
type sample_info = {
n_samples: int; kind: alloc_kind; tag: int;
size: int; callstack: Printexc.raw_backtrace;
}
external set_ctrl :
float -> int ->
(allocation -> 'minor option) ->
(allocation -> 'major option) ->
('minor -> 'major option) ->
('minor -> unit) ->
('major -> unit) ->
unit
= "caml_memprof_set_byt" "caml_memprof_set"
type 'a callback = sample_info -> (Obj.t, 'a) Ephemeron.K1.t option
let start
~sampling_rate
?(callstack_size = max_int)
?(minor_alloc_callback = fun _ -> None)
?(major_alloc_callback = fun _ -> None)
?(promote_callback = fun _ -> None)
?(minor_dealloc_callback = fun _ -> ())
?(major_dealloc_callback = fun _ -> ()) () =
set_ctrl sampling_rate callstack_size minor_alloc_callback
major_alloc_callback promote_callback minor_dealloc_callback
major_dealloc_callback
type 'a ctrl = {
sampling_rate : float;
callstack_size : int;
callback : 'a callback
}
let stop =
(* We make sure this function does not allocate by preallocating
the parameters of [set_ctrl]. *)
let sampling_rate = 0. in
let callstack_size = 0 in
let minor_alloc_callback _ = None in
let major_alloc_callback _ = None in
let promote_callback _ = None in
let minor_dealloc_callback _ = () in
let major_dealloc_callback _ = () in
let stopped_ctrl = {
sampling_rate = 0.; callstack_size = 0;
callback = fun _ -> assert false
}
external set_ctrl : 'a ctrl -> unit = "caml_memprof_set"
let start = set_ctrl
let stop () = set_ctrl stopped_ctrl
fun () ->
set_ctrl sampling_rate callstack_size minor_alloc_callback
major_alloc_callback promote_callback minor_dealloc_callback
major_dealloc_callback
end

135
stdlib/gc.mli
View File

@ -420,84 +420,93 @@ val create_alarm : (unit -> unit) -> alarm
val delete_alarm : alarm -> unit
(** [delete_alarm a] will stop the calls to the function associated
to [a]. Calling [delete_alarm a] again has no effect. *)
to [a]. Calling [delete_alarm a] again has no effect. *)
(** [Memprof] is a sampling engine for allocated memory words. Every
allocated word has a probability of being sampled equal to a
configurable sampling rate. Since blocks are composed of several
words, a block can potentially be sampled several times. When a
block is sampled (i.e., it contains at least one sample word), a
user-defined callback is called.
configurable sampling rate. Once a block is sampled, it becomes
tracked. A tracked block triggers a user-defined callback as soon
as it is allocated, promoted or deallocated.
Since blocks are composed of several words, a block can potentially
be sampled several times. If a block is sampled several times, then
each of the callback is called once for each event of this block:
the multiplicity is given in the [n_samples] field of the
[allocation] structure.
This engine makes it possible to implement a low-overhead memory
profiler as an OCaml library. *)
profiler as an OCaml library.
Note: this API is EXPERIMENTAL. It may change without prior
notice. *)
module Memprof :
sig
type alloc_kind =
| Minor
| Major
| Unmarshalled
(** Allocation kinds
- [Minor] : the allocation took place in the minor heap.
- [Major] : the allocation took place in the major heap.
- [Unmarshalled] : the allocation happened while unmarshalling. *)
type allocation = private
{ n_samples : int;
(** The number of samples in this block (>= 1). *)
type sample_info = {
n_samples: int;
(** The number of samples in this block. Always >= 1, it is
sampled according to a binomial distribution whose
parameters are the size of the block (including the header)
and the sampling rate. Hence, it is in average equal to the
size of the block multiplied by the sampling rate. *)
kind: alloc_kind;
(** The kind of the allocation. *)
tag: int;
(** The tag of the allocated block. *)
size: int;
(** The size of the allocated block, in words (excluding the
header). *)
callstack: Printexc.raw_backtrace;
size : int;
(** The size of the block, in words, excluding the header. *)
tag : int;
(** The tag of the block. *)
unmarshalled : bool;
(** Whether the block comes from unmarshalling. *)
callstack : Printexc.raw_backtrace
(** The callstack for the allocation. *)
}
(** The meta data passed at each callback. *)
}
(** The type of metadata associated with allocations. This is the
type of records passed to the callback triggered by the
sampling of an allocation. *)
type 'a callback = sample_info -> (Obj.t, 'a) Ephemeron.K1.t option
(** [callback] is the type of callbacks launched by the sampling
engine. A callback returns an option over an ephemeron whose
key is set to the allocated block for further tracking. After
the callback returns, the key of the ephemeron should not be
read, since this would change its reachability properties.
val start :
sampling_rate:float ->
?callstack_size:int ->
?minor_alloc_callback:(allocation -> 'minor option) ->
?major_alloc_callback:(allocation -> 'major option) ->
?promote_callback:('minor -> 'major option) ->
?minor_dealloc_callback:('minor -> unit) ->
?major_dealloc_callback:('major -> unit) ->
unit -> unit
(** Start the sampling with the given parameters. If another
sampling is already running, it is stopped and all the
previously tracked blocks are discarded.
The sampling is temporarily disabled when calling the callback
for the current thread. So it does not need to be reentrant if
the program is single-threaded. However, if threads are used, it is
possible that a context switch occurs during a callback, in
which case reentrancy has to be taken into account.
The parameter [sampling_rate] is the sampling rate in samples
per word (including headers). Usually, with cheap callbacks, a
rate of 1e-4 has no visible effect on performance, and 1e-3
causes the program to run a few percent slower
The parameter [callstack_size] is the length of the callstack
recorded at every sample. Its default is [max_int].
The parameters *[_callback] are functions called when an event
occurs on a sampled block. If such a callback returns [None],
then the tracking of this particular block is cancelled. If
they return [Some v], then the value [v] will be passed to the
next callback for this block. Default callbacks simply return
[None] or [()].
The sampling is temporarily disabled when calling a callback
for the current thread. So they do not need to be reentrant if
the program is single-threaded. However, if threads are used,
it is possible that a context switch occurs during a callback,
in this case the callback functions must be reentrant.
Note that the callback can be postponed slightly after the
actual allocation. Therefore, the context of the callback may
be slightly different than expected.
actual event. The callstack passed to the callback is always
accurate, but the program state may have evolved.
In addition, note that calling [start] or [stop] in a callback
can lead to losses of samples. *)
Calling [Thread.exit] in a callback is currently unsafe and
can result in undefined behavior.
type 'a ctrl = {
sampling_rate : float;
(** The sampling rate in samples per word (including headers).
Usually, with cheap callbacks, a rate of 0.001 has no
visible effect on performance, and 0.01 causes the program
to run a few percent slower. *)
callstack_size : int;
(** The length of the callstack recorded at every sample. *)
callback : 'a callback
(** The callback to be called at every sample. *)
}
(** Control data for the sampling engine. *)
val start : 'a ctrl -> unit
(** Start the sampling with the given parameters. If another
sampling is already running, it is stopped. *)
Calling [start] or [stop] in a callback can lead to callbacks
not being called even though some events happened. *)
val stop : unit -> unit
(** Stop the sampling. *)
(** Stop the sampling. This function does not allocate memory,
but tries to run the postponed callbacks for already allocated
memory blocks (of course, these callbacks may allocate). *)
end

140
testsuite/tests/statmemprof/arrays_in_major.ml
View File

@ -17,52 +17,84 @@ let[@inline never] allocate_arrays lo hi cnt keep =
let check_nosample () =
Printf.printf "check_nosample\n%!";
start {
sampling_rate = 0.;
callstack_size = 10;
callback = fun _ ->
Printf.printf "Callback called with sampling_rate = 0\n";
assert(false)
};
let cb _ =
Printf.printf "Callback called with sampling_rate = 0\n";
assert(false)
in
start ~callstack_size:10 ~minor_alloc_callback:cb ~major_alloc_callback:cb
~sampling_rate:0. ();
allocate_arrays 300 3000 1 false
let () = check_nosample ()
let check_ephe_full_major () =
Printf.printf "check_ephe_full_major\n%!";
let ephes = ref [] in
start {
sampling_rate = 0.01;
callstack_size = 10;
callback = fun _ ->
let res = Ephemeron.K1.create () in
ephes := res :: !ephes;
Some res
};
let check_counts_full_major force_promote =
Printf.printf "check_counts_full_major\n%!";
let nalloc_minor = ref 0 in
let nalloc_major = ref 0 in
let enable = ref true in
let npromote = ref 0 in
let ndealloc_minor = ref 0 in
let ndealloc_major = ref 0 in
start ~callstack_size:10
~minor_alloc_callback:(fun _ ->
if !enable then begin
incr nalloc_minor;
Some ()
end else
None)
~major_alloc_callback:(fun _ ->
if !enable then begin
incr nalloc_major;
Some ()
end else
None)
~promote_callback:(fun _ ->
incr npromote;
Some ())
~minor_dealloc_callback:(fun _ -> incr ndealloc_minor)
~major_dealloc_callback:(fun _ -> incr ndealloc_major)
~sampling_rate:0.01 ();
allocate_arrays 300 3000 1 true;
stop ();
List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes;
Gc.full_major ();
List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes;
root := [];
Gc.full_major ();
List.iter (fun e -> assert (not (Ephemeron.K1.check_key e))) !ephes
enable := false;
assert (!ndealloc_minor = 0 && !ndealloc_major = 0);
if force_promote then begin
Gc.full_major ();
assert (!ndealloc_minor = 0 && !ndealloc_major = 0 &&
!npromote = !nalloc_minor);
root := [];
Gc.full_major ();
assert (!ndealloc_minor = 0 &&
!ndealloc_major = !nalloc_minor + !nalloc_major);
end else begin
root := [];
Gc.minor ();
Gc.full_major ();
Gc.full_major ();
assert (!nalloc_minor = !ndealloc_minor + !npromote &&
!ndealloc_major = !npromote + !nalloc_major)
end;
stop ()
let () = check_ephe_full_major ()
let () =
check_counts_full_major false;
check_counts_full_major true
let check_no_nested () =
Printf.printf "check_no_nested\n%!";
let in_callback = ref false in
start {
sampling_rate = 1.;
callstack_size = 10;
callback = fun _ ->
assert (not !in_callback);
in_callback := true;
allocate_arrays 300 300 100 false;
in_callback := false;
None
};
let cb _ =
assert (not !in_callback);
in_callback := true;
allocate_arrays 300 300 100 false;
in_callback := false;
()
in
let cb' _ = cb (); Some () in
start ~callstack_size:10
~minor_alloc_callback:cb' ~major_alloc_callback:cb'
~promote_callback:cb' ~minor_dealloc_callback:cb
~major_dealloc_callback:cb
~sampling_rate:1. ();
allocate_arrays 300 300 100 false;
stop ()
@ -71,19 +103,16 @@ let () = check_no_nested ()
let check_distrib lo hi cnt rate =
Printf.printf "check_distrib %d %d %d %f\n%!" lo hi cnt rate;
let smp = ref 0 in
start {
sampling_rate = rate;
callstack_size = 10;
callback = fun info ->
(* We also allocate the list constructor in the minor heap. *)
if info.kind = Major then begin
assert (info.tag = 0);
assert (info.size >= lo && info.size <= hi);
assert (info.n_samples > 0);
smp := !smp + info.n_samples
end;
None
};
start ~callstack_size:10
~major_alloc_callback:(fun info ->
assert (info.tag = 0);
assert (info.size >= lo && info.size <= hi);
assert (info.n_samples > 0);
assert (not info.unmarshalled);
smp := !smp + info.n_samples;
None
)
~sampling_rate:rate ();
allocate_arrays lo hi cnt false;
stop ();
@ -113,13 +142,12 @@ let () =
let[@inline never] check_callstack () =
Printf.printf "check_callstack\n%!";
let callstack = ref None in
start {
sampling_rate = 1.;
callstack_size = 10;
callback = fun info ->
if info.kind = Major then callstack := Some info.callstack;
None
};
start ~callstack_size:10
~major_alloc_callback:(fun info ->
callstack := Some info.callstack;
None
)
~sampling_rate:1. ();
allocate_arrays 300 300 100 false;
stop ();
match !callstack with

7
testsuite/tests/statmemprof/arrays_in_major.reference
View File

@ -1,5 +1,6 @@
check_nosample
check_ephe_full_major
check_counts_full_major
check_counts_full_major
check_no_nested
check_distrib 300 3000 3 0.000010
check_distrib 300 3000 1 0.000100
@ -9,6 +10,6 @@ check_distrib 300 300 100000 0.100000
check_distrib 300000 300000 30 0.100000
check_callstack
Raised by primitive operation at file "arrays_in_major.ml", line 13, characters 14-28
Called from file "arrays_in_major.ml", line 123, characters 2-35
Called from file "arrays_in_major.ml", line 129, characters 9-27
Called from file "arrays_in_major.ml", line 151, characters 2-35
Called from file "arrays_in_major.ml", line 157, characters 9-27
OK !

159
testsuite/tests/statmemprof/arrays_in_minor.ml
View File

@ -22,54 +22,86 @@ let[@inline never] allocate_arrays lo hi cnt keep =
let check_nosample () =
Printf.printf "check_nosample\n%!";
start {
sampling_rate = 0.;
callstack_size = 10;
callback = fun _ ->
Printf.printf "Callback called with sampling_rate = 0\n";
assert(false)
};
let cb _ =
Printf.printf "Callback called with sampling_rate = 0\n";
assert(false)
in
start ~callstack_size:10 ~minor_alloc_callback:cb ~major_alloc_callback:cb
~sampling_rate:0. ();
allocate_arrays 1 250 100 false
let () = check_nosample ()
let check_ephe_full_major () =
Printf.printf "check_ephe_full_major\n%!";
let ephes = ref [] in
start {
sampling_rate = 0.01;
callstack_size = 10;
callback = fun s ->
assert (s.tag = 0 || s.tag = 1);
let res = Ephemeron.K1.create () in
ephes := res :: !ephes;
Some res
};
let check_counts_full_major force_promote =
Printf.printf "check_counts_full_major\n%!";
let nalloc_minor = ref 0 in
let enable = ref true in
let promotes_allowed = ref true in
let npromote = ref 0 in
let ndealloc_minor = ref 0 in
let ndealloc_major = ref 0 in
start ~callstack_size:10
~minor_alloc_callback:(fun info ->
if !enable then begin
assert (info.tag = 0 || info.tag = 1);
incr nalloc_minor; if !nalloc_minor mod 100 = 0 then Gc.minor ();
Some (ref 42)
end else begin
allocate_arrays 1 250 1 true;
None
end)
~major_alloc_callback:(fun _ -> assert false)
~promote_callback:(fun k ->
assert (!k = 42 && !promotes_allowed);
incr npromote; if !npromote mod 1097 = 0 then Gc.minor ();
Some (ref 17))
~minor_dealloc_callback:(fun k -> assert (!k = 42); incr ndealloc_minor)
~major_dealloc_callback:(fun r -> assert (!r = 17); incr ndealloc_major)
~sampling_rate:0.01 ();
allocate_arrays 1 250 100 true;
stop ();
List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes;
Gc.full_major ();
List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes;
root := Nil;
Gc.full_major ();
List.iter (fun e -> assert (not (Ephemeron.K1.check_key e))) !ephes
enable := false;
assert (!ndealloc_minor = 0 && !ndealloc_major = 0);
if force_promote then begin
Gc.full_major ();
promotes_allowed := false;
allocate_arrays 1 250 10 true;
Gc.full_major ();
assert (!ndealloc_minor = 0 && !ndealloc_major = 0 &&
!npromote = !nalloc_minor);
root := Nil;
Gc.full_major ();
assert (!ndealloc_minor = 0 && !ndealloc_major = !nalloc_minor);
end else begin
root := Nil;
Gc.minor ();
Gc.full_major ();
Gc.full_major ();
assert (!nalloc_minor = !ndealloc_minor + !npromote &&
!ndealloc_major = !npromote)
end;
stop ()
let () = check_ephe_full_major ()
let () =
check_counts_full_major false;
check_counts_full_major true
let check_no_nested () =
Printf.printf "check_no_nested\n%!";
let in_callback = ref false in
start {
sampling_rate = 1.;
callstack_size = 10;
callback = fun _ ->
assert (not !in_callback);
in_callback := true;
allocate_arrays 1 100 10 false;
ignore (Array.to_list (Array.make 1000 0));
in_callback := false;
None
};
let cb _ =
assert (not !in_callback);
in_callback := true;
allocate_arrays 1 100 10 false;
ignore (Array.to_list (Array.make 1000 0));
in_callback := false;
()
in
let cb' _ = cb (); Some () in
start ~callstack_size:10
~minor_alloc_callback:cb' ~major_alloc_callback:cb'
~promote_callback:cb' ~minor_dealloc_callback:cb
~major_dealloc_callback:cb
~sampling_rate:1. ();
allocate_arrays 1 250 5 false;
stop ()
@ -78,19 +110,19 @@ let () = check_no_nested ()
let check_distrib lo hi cnt rate =
Printf.printf "check_distrib %d %d %d %f\n%!" lo hi cnt rate;
let smp = ref 0 in
start {
sampling_rate = rate;
callstack_size = 10;
callback = fun info ->
assert (info.kind = Minor);
(* Exclude noise such as spurious closures and the root list. *)
if info.tag = 0 then begin
assert (info.size >= lo && info.size <= hi);
assert (info.n_samples > 0);
smp := !smp + info.n_samples
end;
None
};
start ~callstack_size:10
~major_alloc_callback:(fun _ -> assert false)
~minor_alloc_callback:(fun info ->
(* Exclude noise such as spurious closures and the root list. *)
if info.tag = 0 then begin
assert (info.size >= lo && info.size <= hi);
assert (info.n_samples > 0);
assert (not info.unmarshalled);
smp := !smp + info.n_samples
end;
None
)
~sampling_rate:rate ();
allocate_arrays lo hi cnt false;
stop ();
@ -117,28 +149,15 @@ let () =
check_distrib 1 1 10000000 0.01;
check_distrib 250 250 100000 0.1
(* FIXME : in bytecode mode, the function [caml_get_current_callstack_impl],
which is supposed to capture the current call stack, does not have access
to the current value of [pc]. Therefore, depending on how the C call is
performed, we may miss the first call stack slot in the captured backtraces.
This is the reason why the reference file is different in native and
bytecode modes.
Note that [Printexc.get_callstack] does not suffer from this problem, because
this function is actually an automatically generated stub which performs th
C call. This is because [Printexc.get_callstack] is not declared as external
in the mli file. *)
let[@inline never] check_callstack () =
Printf.printf "check_callstack\n%!";
let callstack = ref None in
start {
sampling_rate = 1.;
callstack_size = 10;
callback = fun info ->
if info.tag = 0 then callstack := Some info.callstack;
None
};
start ~callstack_size:10
~minor_alloc_callback:(fun info ->
if info.tag = 0 then callstack := Some info.callstack;
None
)
~sampling_rate:1. ();
allocate_arrays 250 250 100 false;
stop ();
match !callstack with

7
testsuite/tests/statmemprof/arrays_in_minor.reference
View File

@ -1,5 +1,6 @@
check_nosample
check_ephe_full_major
check_counts_full_major
check_counts_full_major
check_no_nested
check_distrib 1 250 1000 0.000010
check_distrib 1 250 1000 0.000100
@ -9,6 +10,6 @@ check_distrib 1 1 10000000 0.010000
check_distrib 250 250 100000 0.100000
check_callstack
Raised by primitive operation at file "arrays_in_minor.ml", line 18, characters 20-34
Called from file "arrays_in_minor.ml", line 142, characters 2-35
Called from file "arrays_in_minor.ml", line 148, characters 9-27
Called from file "arrays_in_minor.ml", line 161, characters 2-35
Called from file "arrays_in_minor.ml", line 167, characters 9-27
OK !

72
testsuite/tests/statmemprof/blocking_in_callback.ml Normal file
View File

@ -0,0 +1,72 @@
(* TEST
* hassysthreads
include systhreads
** bytecode
** native
*)
let cnt = ref 0
let alloc_num = ref 0
let alloc_tot = 100000
let (rd1, wr1) = Unix.pipe ()
let (rd2, wr2) = Unix.pipe ()
let main_thread = Thread.self ()
let cb_main = ref 0 and cb_other = ref 0
let stopped = ref false
let minor_alloc_callback _ =
if !stopped then
None
else begin
let do_stop = !cb_main + !cb_other >= alloc_tot in
if do_stop then stopped := true;
let t = Thread.self () in
if t == main_thread then begin
incr cb_main;
assert (Unix.write wr2 (Bytes.make 1 'a') 0 1 = 1);
if not do_stop then
assert (Unix.read rd1 (Bytes.make 1 'a') 0 1 = 1)
end else begin
incr cb_other;
assert (Unix.write wr1 (Bytes.make 1 'a') 0 1 = 1);
if not do_stop then
assert (Unix.read rd2 (Bytes.make 1 'a') 0 1 = 1)
end;
Some ()
end
let mut = Mutex.create ()
let () = Mutex.lock mut
let rec go () =
Mutex.lock mut;
Mutex.unlock mut;
if !alloc_num < alloc_tot then begin
alloc_num := !alloc_num + 1;
Sys.opaque_identity (Bytes.make (Random.int 300) 'a') |> ignore;
go ()
end else begin
cnt := !cnt + 1;
if !cnt < 2 then begin
Gc.minor (); (* check for callbacks *)
Thread.yield ();
go ()
end else begin
Gc.minor () (* check for callbacks *)
end
end
let () =
let t = Thread.create go () in
Gc.Memprof.start
~callstack_size:10
~minor_alloc_callback
~major_alloc_callback:(fun _ -> None)
~sampling_rate:1. ();
Mutex.unlock mut;
go ();
Thread.join t;
Gc.Memprof.stop ();
assert (abs (!cb_main - !cb_other) <= 1);
assert (!cb_main + !cb_other >= alloc_tot)

9
testsuite/tests/statmemprof/exception_callback.ml
View File

@ -11,10 +11,9 @@ open Gc.Memprof
let _ = Printexc.record_backtrace false
let _ =
start {
sampling_rate = 1.;
callstack_size = 10;
callback = fun _ -> assert false
};
start ~callstack_size:10
~minor_alloc_callback:(fun _ -> assert false)
~major_alloc_callback:(fun _ -> assert false)
~sampling_rate:1. ();
ignore (Sys.opaque_identity (Array.make 200 0));
stop ()

2
testsuite/tests/statmemprof/exception_callback.reference
View File

@ -1 +1 @@
Fatal error: exception File "exception_callback.ml", line 17, characters 24-30: Assertion failed
Fatal error: exception File "exception_callback.ml", line 15, characters 40-46: Assertion failed

7
testsuite/tests/statmemprof/intern.byte.reference
View File

@ -1,5 +1,6 @@
check_nosample
check_ephe_full_major
check_counts_full_major
check_counts_full_major
check_no_nested
check_distrib 2 3000 3 0.000010
check_distrib 2 3000 1 0.000100
@ -9,6 +10,6 @@ check_distrib 300000 300000 20 0.100000
check_callstack
Raised by primitive operation at unknown location
Called from file "intern.ml", line 32, characters 14-35
Called from file "intern.ml", line 160, characters 2-25
Called from file "intern.ml", line 166, characters 9-27
Called from file "intern.ml", line 185, characters 2-25
Called from file "intern.ml", line 191, characters 9-27
OK !

165
testsuite/tests/statmemprof/intern.ml
View File

@ -37,54 +37,86 @@ let[@inline never] do_intern lo hi cnt keep =
let check_nosample () =
Printf.printf "check_nosample\n%!";
precompute_marshalled_data 2 3000;
start {
sampling_rate = 0.;
callstack_size = 10;
callback = fun _ ->
Printf.printf "Callback called with sampling_rate = 0\n";
assert(false)
};
let cb _ =
Printf.printf "Callback called with sampling_rate = 0\n";
assert(false)
in
start ~callstack_size:10 ~minor_alloc_callback:cb ~major_alloc_callback:cb
~sampling_rate:0. ();
do_intern 2 3000 1 false
let () = check_nosample ()
let check_ephe_full_major () =
Printf.printf "check_ephe_full_major\n%!";
let check_counts_full_major force_promote =
Printf.printf "check_counts_full_major\n%!";
precompute_marshalled_data 2 3000;
let ephes = ref [] in
start {
sampling_rate = 0.01;
callstack_size = 10;
callback = fun _ ->
let res = Ephemeron.K1.create () in
ephes := res :: !ephes;
Some res
};
let nalloc_minor = ref 0 in
let nalloc_major = ref 0 in
let enable = ref true in
let npromote = ref 0 in
let ndealloc_minor = ref 0 in
let ndealloc_major = ref 0 in
start ~callstack_size:10
~minor_alloc_callback:(fun _ ->
if !enable then begin
incr nalloc_minor;
Some ()
end else
None)
~major_alloc_callback:(fun _ ->
if !enable then begin
incr nalloc_major;
Some ()
end else
None)
~promote_callback:(fun _ ->
incr npromote;
Some ())
~minor_dealloc_callback:(fun _ -> incr ndealloc_minor)
~major_dealloc_callback:(fun _ -> incr ndealloc_major)
~sampling_rate:0.01 ();
do_intern 2 3000 1 true;
stop ();
List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes;
Gc.full_major ();
List.iter (fun e -> assert (Ephemeron.K1.check_key e)) !ephes;
root := [];
Gc.full_major ();
List.iter (fun e -> assert (not (Ephemeron.K1.check_key e))) !ephes
enable := false;
assert (!ndealloc_minor = 0 && !ndealloc_major = 0);
if force_promote then begin
Gc.full_major ();
assert (!ndealloc_minor = 0 && !ndealloc_major = 0 &&
!npromote = !nalloc_minor);
root := [];
Gc.full_major ();
assert (!ndealloc_minor = 0 &&
!ndealloc_major = !nalloc_minor + !nalloc_major);
end else begin
root := [];
Gc.minor ();
Gc.full_major ();
Gc.full_major ();
assert (!nalloc_minor = !ndealloc_minor + !npromote &&
!ndealloc_major = !npromote + !nalloc_major)
end;
stop ()
let () = check_ephe_full_major ()
let () =
check_counts_full_major false;
check_counts_full_major true
let check_no_nested () =
Printf.printf "check_no_nested\n%!";
precompute_marshalled_data 2 300;
let in_callback = ref false in
start {
sampling_rate = 1.;
callstack_size = 10;
callback = fun _ ->
assert (not !in_callback);
in_callback := true;
do_intern 100 200 1 false;
in_callback := false;
None
};
let cb _ =
assert (not !in_callback);
in_callback := true;
do_intern 100 200 1 false;
in_callback := false;
()
in
let cb' _ = cb (); Some () in
start ~callstack_size:10
~minor_alloc_callback:cb' ~major_alloc_callback:cb'
~promote_callback:cb' ~minor_dealloc_callback:cb
~major_dealloc_callback:cb
~sampling_rate:1. ();
do_intern 100 200 1 false;
stop ()
@ -94,21 +126,21 @@ let check_distrib lo hi cnt rate =
Printf.printf "check_distrib %d %d %d %f\n%!" lo hi cnt rate;
precompute_marshalled_data lo hi;
let smp = ref 0 in
start {
sampling_rate = rate;
callstack_size = 10;
callback = fun info ->
(* We also allocate the list constructor in the minor heap. *)
if info.kind = Unmarshalled then begin
begin match info.tag, info.size with
| 1, 1 | 2, 2 | 3, 1 -> ()
| _ -> assert false
end;
assert (info.n_samples > 0);
smp := !smp + info.n_samples
end;
None
};
let cb info =
(* We also allocate the list constructor in the minor heap,
so we filter that out. *)
if info.unmarshalled then begin
begin match info.tag, info.size with
| 1, 1 | 2, 2 | 3, 1 -> ()
| _ -> assert false
end;
assert (info.n_samples > 0);
smp := !smp + info.n_samples
end;
None
in
start ~callstack_size:10 ~major_alloc_callback:cb ~minor_alloc_callback:cb
~sampling_rate:rate ();
do_intern lo hi cnt false;
stop ();
@ -134,30 +166,23 @@ let () =
check_distrib 2 2000 1 0.9;
check_distrib 300000 300000 20 0.1
(* FIXME : in bytecode mode, the function [caml_get_current_callstack_impl],
which is supposed to capture the current call stack, does not have access
to the current value of [pc]. Therefore, depending on how the C call is
performed, we may miss the first call stack slot in the captured backtraces.
This is the reason why the reference file is different in native and
bytecode modes.
Note that [Printexc.get_callstack] does not suffer from this problem, because
this function is actually an automatically generated stub which performs th
C call. This is because [Printexc.get_callstack] is not declared as external
in the mli file. *)
(* FIXME : in bytecode mode, C calls may or may not be associated with
debug information. In particular, C calls at tail positions do not
have debug information, and the [from_bytes_unsafe] external C
function is called at tail positionin [marshal.ml]. This is the
reason why the reference file is different in native and bytecode
modes. *)
let[@inline never] check_callstack () =
Printf.printf "check_callstack\n%!";
precompute_marshalled_data 2 300;
let callstack = ref None in
start {
sampling_rate = 1.;
callstack_size = 10;
callback = fun info ->
if info.kind = Unmarshalled then callstack := Some info.callstack;
None
};
do_intern 2 300 1 false;
start ~callstack_size:10
~minor_alloc_callback:(fun info ->
if info.unmarshalled then callstack := Some info.callstack;
None)
~sampling_rate:1. ();
do_intern 2 250 1 false;
stop ();
match !callstack with
| None -> assert false

7
testsuite/tests/statmemprof/intern.opt.reference
View File

@ -1,5 +1,6 @@
check_nosample
check_ephe_full_major
check_counts_full_major
check_counts_full_major
check_no_nested
check_distrib 2 3000 3 0.000010
check_distrib 2 3000 1 0.000100
@ -9,6 +10,6 @@ check_distrib 300000 300000 20 0.100000
check_callstack
Raised by primitive operation at file "marshal.ml", line 61, characters 9-35
Called from file "intern.ml", line 32, characters 14-35
Called from file "intern.ml", line 160, characters 2-25
Called from file "intern.ml", line 166, characters 9-27
Called from file "intern.ml", line 185, characters 2-25
Called from file "intern.ml", line 191, characters 9-27
OK !

36
testsuite/tests/statmemprof/lists_in_minor.ml
View File

@ -17,18 +17,17 @@ let[@inline never] allocate_lists len cnt =
let check_distrib len cnt rate =
Printf.printf "check_distrib %d %d %f\n%!" len cnt rate;
let smp = ref 0 in
start {
sampling_rate = rate;
callstack_size = 10;
callback = fun info ->
assert (info.kind = Minor);
if info.tag = 0 then begin (* Exclude noise such as spurious closures. *)
assert (info.size = 2);
assert (info.n_samples > 0);
smp := !smp + info.n_samples
end;
None
};
start ~callstack_size:10
~major_alloc_callback:(fun _ -> assert false)
~minor_alloc_callback:(fun info ->
if info.tag = 0 then begin (* Exclude noise such as spurious closures. *)
assert (info.size = 2);
assert (info.n_samples > 0);
assert (not info.unmarshalled);
smp := !smp + info.n_samples;
end;
None)
~sampling_rate:rate ();
allocate_lists len cnt;
stop ();
@ -59,13 +58,12 @@ let () =
let[@inline never] check_callstack () =
Printf.printf "check_callstack\n%!";
let callstack = ref None in
start {
sampling_rate = 1.;
callstack_size = 10;
callback = fun info ->
if info.tag = 0 then callstack := Some info.callstack;
None
};
start ~callstack_size:10
~minor_alloc_callback:(fun info ->
if info.tag = 0 then callstack := Some info.callstack;
None
)
~sampling_rate:1. ();
allocate_lists 1000000 1;
stop ();
match !callstack with

4
testsuite/tests/statmemprof/lists_in_minor.reference
View File

@ -7,6 +7,6 @@ check_distrib 100000 10 0.100000
check_distrib 100000 10 0.900000
check_callstack
Raised by primitive operation at file "lists_in_minor.ml", line 14, characters 11-33
Called from file "lists_in_minor.ml", line 69, characters 2-26
Called from file "lists_in_minor.ml", line 76, characters 2-20
Called from file "lists_in_minor.ml", line 67, characters 2-26
Called from file "lists_in_minor.ml", line 74, characters 2-20
OK !

37
testsuite/tests/statmemprof/minor_no_postpone.ml Normal file
View File

@ -0,0 +1,37 @@
(* TEST
modules = "minor_no_postpone_stub.c"
* bytecode
*)
open Gc.Memprof
let () =
let callback_ok = ref true in
let callback_done = ref false in
start ~callstack_size:0
~minor_alloc_callback:(fun _ ->
assert !callback_ok;
callback_done := true;
None)
~sampling_rate:1. ();
ignore (Sys.opaque_identity (ref 0));
assert(!callback_done);
callback_ok := false;
stop ()
external alloc_stub : unit -> unit ref = "alloc_stub"
let () =
let callback_ok = ref false in
let callback_done = ref false in
start ~callstack_size:0
~minor_alloc_callback:(fun _ ->
assert !callback_ok;
callback_done := true;
None)
~sampling_rate:1. ();
ignore (Sys.opaque_identity (alloc_stub ()));
assert(not !callback_done);
callback_ok := true;
stop ();
assert(!callback_done)

5
testsuite/tests/statmemprof/minor_no_postpone_stub.c Normal file
View File

@ -0,0 +1,5 @@
#include "caml/alloc.h"
value alloc_stub(value v) {
return caml_alloc(1, 0);
}