From 12becf931a5a5a6fd85cfcfdc0543df43821cedc Mon Sep 17 00:00:00 2001 From: Mark Shinwell Date: Tue, 21 Nov 2023 10:22:12 +0000 Subject: [PATCH] Continuation of PR2027 (tests passing for runtime 4 and 5) (#2057) * Dummy C stubs * Run max_arity_locals test only when stack allocation is enabled * Fix and promote typing-local/ tests for stack allocation being disabled * Predicate some tests on having stack allocation * Forward port all SIMD runtime changes from d3c14133b919058f3d499a43a046562cc24ecdcc * Fix globrootsprim.c test * Fix asmgen tests * Add runtime4 predicate to ocamltest and use it in runtime-naked-pointers/ tests * Add runtime_dir ocamltest variable + use it to fix output-complete-obj/ tests * git mv debugger debugger4 * Import debugger/ from upstream 5 * Debugger build system * Apply JS-specific modifications from debugger4/ -> debugger/ * Fix pr9971 test * Fix tests/regression/pr9326 * Fix tests/gc-roots * Fix tests/asmcomp/polling.c * Fixing of backtrace tests * Skip instrumented-runtime tests on 5.x (these tests are not present in upstream 5) * Fix Ctype.unify call in debugger/loadprinter.ml * Fixes for systhreads/ build and importing of build attributes from systhreads4/ * Add Condition, Mutex and Semaphore to the stdlib * Fix dynlink (including for move of Mutex to the stdlib) * Fix get_header.ml test * Add runtime5 predicate in ocamltest and use it to fix backtrace_c_exn.ml * Fix wrong position of modules line in ocaml/testsuite/tests/typing-local/regions.ml test header * Fix bug in caml_gc_counters in the 5 runtime * Remove ocaml/otherlibs/systhreads4/st_pthreads.h, merge error * Promote tests * Move caml_stat_free call in ocaml/runtime4/dynlink_nat.c * port #797 (long frames in frametable) (#2048) * Fix upstream bug with dynlink check/registration ordering, and revert lib-dynlink-private testcase * Fix caml_natdynlink_run_toplevel to actually call the registration function * Add GC test for ocamlnat * Address code review comments * Regenerate stdlib/.depend * Fix upstream build * Fix three runtime4/ occurrences * Fix for upstream systhreads4 build * Don't skip statmemprof tests on runtime4/ * Fix upstream build for debugger4/ * Use runtime_dir not RUNTIME_DIR in the testsuite scriptsd * Re-enabling (for runtime4) and fixing statmemprof tests * Fix _runtest debugger installation paths * Port bc9a60dd1eb8cb5a1f7d352ccf149459c7810cdb to runtime/ (fix for caml_natdynlink_run_toplevel) * Address comments --------- Co-authored-by: Zesen Qian Co-authored-by: Stephen Dolan --- ocaml/Makefile | 10 +- ocaml/Makefile.common-jst | 12 +- ocaml/bytecomp/dll.ml | 16 +- ocaml/debugger/.depend | 10 +- ocaml/debugger/debugcom.ml | 58 - ocaml/debugger/debugcom.mli | 4 - ocaml/debugger/eval.ml | 1 - ocaml/debugger/frames.ml | 8 - ocaml/debugger/time_travel.ml | 22 - ocaml/debugger4/.depend | 644 +++++++++ ocaml/debugger4/Makefile | 92 ++ ocaml/debugger4/breakpoints.ml | 209 +++ ocaml/debugger4/breakpoints.mli | 60 + ocaml/debugger4/checkpoints.ml | 90 ++ ocaml/debugger4/checkpoints.mli | 60 + ocaml/debugger4/command_line.ml | 1243 +++++++++++++++++ ocaml/debugger4/command_line.mli | 23 + ocaml/debugger4/debugcom.ml | 452 ++++++ ocaml/debugger4/debugcom.mli | 139 ++ ocaml/debugger4/debugger_config.ml | 90 ++ ocaml/debugger4/debugger_config.mli | 41 + ocaml/debugger4/debugger_lexer.mli | 22 + ocaml/debugger4/debugger_lexer.mll | 104 ++ ocaml/debugger4/debugger_parser.mly | 261 ++++ ocaml/debugger4/dune | 34 + ocaml/debugger4/eval.ml | 225 +++ ocaml/debugger4/eval.mli | 41 + ocaml/debugger4/events.ml | 52 + ocaml/debugger4/events.mli | 35 + ocaml/debugger4/exec.ml | 54 + .../mutex.ml => debugger4/exec.mli} | 14 +- ocaml/debugger4/frames.ml | 138 ++ ocaml/debugger4/frames.mli | 55 + ocaml/debugger4/history.ml | 44 + ocaml/debugger4/history.mli | 21 + ocaml/debugger4/input_handling.ml | 108 ++ ocaml/debugger4/input_handling.mli | 61 + ocaml/debugger4/int64ops.ml | 27 + ocaml/debugger4/int64ops.mli | 27 + ocaml/debugger4/loadprinter.ml | 159 +++ ocaml/debugger4/loadprinter.mli | 35 + ocaml/debugger4/main.ml | 241 ++++ ocaml/debugger4/ocamldebug_entry.ml | 2 + ocaml/debugger4/parameters.ml | 44 + ocaml/debugger4/parameters.mli | 34 + ocaml/debugger4/parser_aux.mli | 30 + ocaml/debugger4/pos.ml | 26 + ocaml/debugger4/pos.mli | 16 + ocaml/debugger4/primitives.ml | 126 ++ ocaml/debugger4/primitives.mli | 67 + ocaml/debugger4/printval.ml | 108 ++ ocaml/debugger4/printval.mli | 34 + ocaml/debugger4/program_loading.ml | 188 +++ ocaml/debugger4/program_loading.mli | 35 + ocaml/debugger4/program_management.ml | 163 +++ ocaml/debugger4/program_management.mli | 28 + ocaml/debugger4/question.ml | 48 + ocaml/debugger4/question.mli | 17 + ocaml/debugger4/show_information.ml | 121 ++ ocaml/debugger4/show_information.mli | 27 + ocaml/debugger4/show_source.ml | 94 ++ ocaml/debugger4/show_source.mli | 25 + ocaml/debugger4/source.ml | 191 +++ ocaml/debugger4/source.mli | 62 + ocaml/debugger4/symbols.ml | 259 ++++ ocaml/debugger4/symbols.mli | 71 + ocaml/debugger4/time_travel.ml | 705 ++++++++++ ocaml/debugger4/time_travel.mli | 38 + ocaml/debugger4/trap_barrier.ml | 42 + ocaml/debugger4/trap_barrier.mli | 28 + ocaml/debugger4/unix_tools.ml | 144 ++ ocaml/debugger4/unix_tools.mli | 35 + ocaml/ocamltest/ocaml_actions.ml | 19 +- ocaml/ocamltest/ocaml_files.ml | 8 +- ocaml/ocamltest/ocaml_modifiers.ml | 4 +- ocaml/ocamltest/ocaml_variables.ml | 4 + ocaml/ocamltest/ocaml_variables.mli | 2 + ocaml/otherlibs/dynlink/byte/dynlink.ml | 99 +- ocaml/otherlibs/dynlink/dynlink_common.ml | 40 +- .../dynlink/dynlink_platform_intf.ml | 15 +- ocaml/otherlibs/dynlink/native/dynlink.ml | 52 +- ocaml/otherlibs/systhreads/byte/dune | 21 + ocaml/otherlibs/systhreads/dune | 16 +- ocaml/otherlibs/systhreads/native/dune | 22 + ocaml/otherlibs/systhreads/thread.ml | 4 + ocaml/otherlibs/systhreads4/Makefile | 4 +- ocaml/otherlibs/systhreads4/condition.mli | 53 - ocaml/otherlibs/systhreads4/dune | 12 - ocaml/otherlibs/systhreads4/st_pthreads.h | 387 ----- ocaml/otherlibs/systhreads4/st_stubs.c | 30 + ocaml/runtime/amd64.S | 64 +- ocaml/runtime/amd64nt.asm | 68 +- ocaml/runtime/array.c | 18 +- ocaml/runtime/backtrace_nat.c | 2 +- ocaml/runtime/caml/frame_descriptors.h | 58 +- ocaml/runtime/caml/stack.h | 5 +- ocaml/runtime/dynlink_nat.c | 8 +- ocaml/runtime/fiber.c | 33 +- ocaml/runtime/frame_descriptors.c | 2 +- ocaml/runtime/gc_ctrl.c | 4 +- ocaml/runtime/globroots.c | 22 +- ocaml/runtime/memory.c | 19 + ocaml/runtime/signals_nat.c | 2 +- ocaml/runtime4/caml/domain.h | 10 + ocaml/runtime4/domain.c | 76 + ocaml/runtime4/dune | 2 +- ocaml/runtime4/dynlink_nat.c | 90 +- ocaml/runtime4/gen_primitives.sh | 2 +- ocaml/stdlib/.depend | 37 +- ocaml/stdlib/StdlibModules | 3 + .../systhreads4 => stdlib}/condition.ml | 10 +- ocaml/stdlib/condition.mli | 178 +++ ocaml/stdlib/dune | 18 + ocaml/stdlib/mutex.ml | 34 + .../systhreads4 => stdlib}/mutex.mli | 13 + .../systhreads4 => stdlib}/semaphore.ml | 2 + .../systhreads4 => stdlib}/semaphore.mli | 2 + ocaml/stdlib/stdlib.ml | 9 - ocaml/stdlib/stdlib.mli | 9 - ocaml/testsuite/tests/asmcomp/polling.c | 7 +- .../tests/backtrace/backtrace2.reference | 14 +- .../backtrace/backtrace_c_exn.byte4.reference | 2 + .../tests/backtrace/backtrace_c_exn.ml | 16 +- ...ference => backtrace_c_exn.opt4.reference} | 4 +- .../tests/backtrace/lazy.flambda.reference | 12 +- .../testsuite/tests/backtrace/lazy.reference | 12 +- ocaml/testsuite/tests/backtrace/lazy.run | 3 + .../testsuite/tests/backtrace/names.reference | 4 +- ocaml/testsuite/tests/backtrace/names.run | 3 + .../tests/backtrace/sanitize-backtrace.sh | 6 +- .../tests/basic/patmatch_for_multiple.ml | 314 ++--- ocaml/testsuite/tests/gc-roots/globroots.ml | 13 - .../testsuite/tests/gc-roots/globrootsprim.c | 18 +- .../tests/instrumented-runtime/main.ml | 5 +- .../tests/lib-dynlink-csharp/main.ml | 4 +- .../lib-obj/get_header.byte.local.reference | 3 + ocaml/testsuite/tests/lib-obj/get_header.ml | 14 +- .../lib-obj/get_header.opt.local.reference | 3 + .../tests/lib-obj/get_header.opt.reference | 2 +- ocaml/testsuite/tests/lib-threads/pr9971.ml | 10 +- .../lib-unix/unix-execvpe/has-execvpe.sh | 2 +- .../tests/output-complete-obj/github9344.ml | 2 +- .../tests/output-complete-obj/test.ml | 4 +- .../tests/output-complete-obj/test2.ml | 2 +- .../ppx-empty-cases/test.compilers.reference | 44 +- .../tests/regression/pr9326/gc_set.ml | 14 +- .../tests/runtime-naked-pointers/np1.ml | 5 +- .../tests/runtime-naked-pointers/np2.ml | 5 +- .../tests/runtime-naked-pointers/np3.ml | 7 +- .../tests/runtime-naked-pointers/np4.ml | 7 +- .../tests/runtime-naked-pointers/runtest.sh | 2 +- ocaml/testsuite/tests/shapes/comp_units.ml | 2 +- ocaml/testsuite/tests/shapes/functors.ml | 18 +- ocaml/testsuite/tests/shapes/open_arg.ml | 2 +- ocaml/testsuite/tests/shapes/recmodules.ml | 10 +- ocaml/testsuite/tests/shapes/rotor_example.ml | 2 +- .../tests/statmemprof/alloc_counts.ml | 3 +- .../tests/statmemprof/arrays_in_major.ml | 3 +- .../statmemprof/arrays_in_major.reference | 11 + .../tests/statmemprof/arrays_in_minor.ml | 3 +- .../statmemprof/arrays_in_minor.reference | 11 + .../tests/statmemprof/blocking_in_callback.ml | 7 +- .../callstacks.flat-float-array.reference | 120 +- .../testsuite/tests/statmemprof/callstacks.ml | 14 +- .../statmemprof/comballoc.byte.reference | 78 +- .../testsuite/tests/statmemprof/comballoc.ml | 3 +- .../tests/statmemprof/comballoc.opt.reference | 78 +- ocaml/testsuite/tests/statmemprof/custom.ml | 3 +- .../tests/statmemprof/exception_callback.ml | 3 +- .../statmemprof/exception_callback_minor.ml | 3 +- ocaml/testsuite/tests/statmemprof/intern.ml | 3 +- .../tests/statmemprof/intern.reference | 10 + .../tests/statmemprof/lists_in_minor.ml | 3 +- .../tests/statmemprof/minor_no_postpone.ml | 3 +- .../tests/statmemprof/moved_while_blocking.ml | 9 +- .../statmemprof/thread_exit_in_callback.ml | 10 +- .../tests/syntactic-arity/max_arity_locals.ml | 7 +- .../known-bugs/broken_rec_in_show.ml | 4 +- .../testsuite/tests/tool-toplevel/topeval.ml | 10 + .../translprim/array_spec.heap.flat.reference | 29 +- .../comparison_table.heap.reference | 178 ++- .../tests/typing-local/iarray.byte.reference | 14 + .../tests/typing-local/iarray.heap.reference | 4 +- ocaml/testsuite/tests/typing-local/iarray.ml | 2 +- .../typing-local/loop_regions.heap.reference | 2 + ocaml/testsuite/tests/typing-local/regions.ml | 3 +- .../typing-local/regression_cmm_unboxing.ml | 3 +- testsuite/tests/asmgen/main.c | 4 + 188 files changed, 9316 insertions(+), 1361 deletions(-) create mode 100644 ocaml/debugger4/.depend create mode 100644 ocaml/debugger4/Makefile create mode 100644 ocaml/debugger4/breakpoints.ml create mode 100644 ocaml/debugger4/breakpoints.mli create mode 100644 ocaml/debugger4/checkpoints.ml create mode 100644 ocaml/debugger4/checkpoints.mli create mode 100644 ocaml/debugger4/command_line.ml create mode 100644 ocaml/debugger4/command_line.mli create mode 100644 ocaml/debugger4/debugcom.ml create mode 100644 ocaml/debugger4/debugcom.mli create mode 100644 ocaml/debugger4/debugger_config.ml create mode 100644 ocaml/debugger4/debugger_config.mli create mode 100644 ocaml/debugger4/debugger_lexer.mli create mode 100644 ocaml/debugger4/debugger_lexer.mll create mode 100644 ocaml/debugger4/debugger_parser.mly create mode 100644 ocaml/debugger4/dune create mode 100644 ocaml/debugger4/eval.ml create mode 100644 ocaml/debugger4/eval.mli create mode 100644 ocaml/debugger4/events.ml create mode 100644 ocaml/debugger4/events.mli create mode 100644 ocaml/debugger4/exec.ml rename ocaml/{otherlibs/systhreads4/mutex.ml => debugger4/exec.mli} (74%) create mode 100644 ocaml/debugger4/frames.ml create mode 100644 ocaml/debugger4/frames.mli create mode 100644 ocaml/debugger4/history.ml create mode 100644 ocaml/debugger4/history.mli create mode 100644 ocaml/debugger4/input_handling.ml create mode 100644 ocaml/debugger4/input_handling.mli create mode 100644 ocaml/debugger4/int64ops.ml create mode 100644 ocaml/debugger4/int64ops.mli create mode 100644 ocaml/debugger4/loadprinter.ml create mode 100644 ocaml/debugger4/loadprinter.mli create mode 100644 ocaml/debugger4/main.ml create mode 100644 ocaml/debugger4/ocamldebug_entry.ml create mode 100644 ocaml/debugger4/parameters.ml create mode 100644 ocaml/debugger4/parameters.mli create mode 100644 ocaml/debugger4/parser_aux.mli create mode 100644 ocaml/debugger4/pos.ml create mode 100644 ocaml/debugger4/pos.mli create mode 100644 ocaml/debugger4/primitives.ml create mode 100644 ocaml/debugger4/primitives.mli create mode 100644 ocaml/debugger4/printval.ml create mode 100644 ocaml/debugger4/printval.mli create mode 100644 ocaml/debugger4/program_loading.ml create mode 100644 ocaml/debugger4/program_loading.mli create mode 100644 ocaml/debugger4/program_management.ml create mode 100644 ocaml/debugger4/program_management.mli create mode 100644 ocaml/debugger4/question.ml create mode 100644 ocaml/debugger4/question.mli create mode 100644 ocaml/debugger4/show_information.ml create mode 100644 ocaml/debugger4/show_information.mli create mode 100644 ocaml/debugger4/show_source.ml create mode 100644 ocaml/debugger4/show_source.mli create mode 100644 ocaml/debugger4/source.ml create mode 100644 ocaml/debugger4/source.mli create mode 100644 ocaml/debugger4/symbols.ml create mode 100644 ocaml/debugger4/symbols.mli create mode 100644 ocaml/debugger4/time_travel.ml create mode 100644 ocaml/debugger4/time_travel.mli create mode 100644 ocaml/debugger4/trap_barrier.ml create mode 100644 ocaml/debugger4/trap_barrier.mli create mode 100644 ocaml/debugger4/unix_tools.ml create mode 100644 ocaml/debugger4/unix_tools.mli create mode 100644 ocaml/otherlibs/systhreads/byte/dune create mode 100644 ocaml/otherlibs/systhreads/native/dune delete mode 100644 ocaml/otherlibs/systhreads4/condition.mli delete mode 100644 ocaml/otherlibs/systhreads4/st_pthreads.h rename ocaml/{otherlibs/systhreads4 => stdlib}/condition.ml (81%) create mode 100644 ocaml/stdlib/condition.mli create mode 100644 ocaml/stdlib/mutex.ml rename ocaml/{otherlibs/systhreads4 => stdlib}/mutex.mli (83%) rename ocaml/{otherlibs/systhreads4 => stdlib}/semaphore.ml (99%) rename ocaml/{otherlibs/systhreads4 => stdlib}/semaphore.mli (99%) create mode 100644 ocaml/testsuite/tests/backtrace/backtrace_c_exn.byte4.reference rename ocaml/testsuite/tests/backtrace/{backtrace_c_exn.opt.reference => backtrace_c_exn.opt4.reference} (85%) create mode 100755 ocaml/testsuite/tests/backtrace/lazy.run create mode 100755 ocaml/testsuite/tests/backtrace/names.run create mode 100644 ocaml/testsuite/tests/lib-obj/get_header.byte.local.reference create mode 100644 ocaml/testsuite/tests/lib-obj/get_header.opt.local.reference create mode 100644 ocaml/testsuite/tests/statmemprof/arrays_in_major.reference create mode 100644 ocaml/testsuite/tests/statmemprof/arrays_in_minor.reference create mode 100644 ocaml/testsuite/tests/statmemprof/intern.reference create mode 100644 ocaml/testsuite/tests/typing-local/iarray.byte.reference diff --git a/ocaml/Makefile b/ocaml/Makefile index 70b7e5ea8e7..bdb2ce41b4f 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1158,7 +1158,7 @@ clean:: subdirs = \ stdlib $(addprefix otherlibs/, \ $(filter-out runtime_events, $(ALL_OTHERLIBS))) \ - debugger ocamldoc ocamltest + debugger$(RUNTIME_SUFFIX) ocamldoc ocamltest .PHONY: alldepend alldepend: depend @@ -1352,10 +1352,10 @@ clean:: .PHONY: ocamldebugger ocamldebugger: ocamlc ocamlyacc ocamllex otherlibraries - $(MAKE) -C debugger all + $(MAKE) -C debugger$(RUNTIME_SUFFIX) all partialclean:: - $(MAKE) -C debugger clean + $(MAKE) -C debugger$(RUNTIME_SUFFIX) clean # Check that the native-code compiler is supported .PHONY: checknative @@ -1667,7 +1667,7 @@ depend: beforedepend .PHONY: distclean distclean: clean - $(MAKE) -C debugger distclean + $(MAKE) -C debugger$(RUNTIME_SUFFIX) distclean $(MAKE) -C manual distclean $(MAKE) -C ocamldoc distclean $(MAKE) -C ocamltest distclean @@ -1797,7 +1797,7 @@ ifeq "$(WITH_OCAMLDOC)-$(STDLIB_MANPAGES)" "ocamldoc-true" $(MAKE) -C api_docgen install endif if test -n "$(WITH_DEBUGGER)"; then \ - $(MAKE) -C debugger install; \ + $(MAKE) -C debugger$(RUNTIME_SUFFIX) install; \ fi ifeq "$(BOOTSTRAPPING_FLEXDLL)" "true" ifeq "$(TOOLCHAIN)" "msvc" diff --git a/ocaml/Makefile.common-jst b/ocaml/Makefile.common-jst index 7660136a16a..ac204ebd7cd 100644 --- a/ocaml/Makefile.common-jst +++ b/ocaml/Makefile.common-jst @@ -122,9 +122,9 @@ $(ocamldir)/otherlibs/dune: $(ocamldir)/dune.runtime_selection: if [ "$(RUNTIME_DIR)" = "runtime4" ]; then \ - echo "(dirs (:standard \ runtime))" > $@; \ + echo "(dirs (:standard \ runtime debugger))" > $@; \ else \ - echo "(dirs (:standard \ runtime4))" > $@; \ + echo "(dirs (:standard \ runtime4 debugger4))" > $@; \ fi _build/_bootinstall: Makefile.config $(dune_config_targets) @@ -276,10 +276,10 @@ install_for_test: _install mkdir -p _runtest/lib/ocaml/stublibs/ cp $(main_prefix)/lib/ocaml/stublibs/*.so _runtest/lib/ocaml/stublibs # ocamldebug - mkdir _runtest/debugger - ln -s ../ocamldebug _runtest/debugger - cp $(main_build)/$(ocamldir)/debugger/.ocamldebug.objs/byte/*.cm* \ - _runtest/debugger + mkdir _runtest/debugger$(RUNTIME_SUFFIX) + ln -s ../ocamldebug _runtest/debugger$(RUNTIME_SUFFIX) + cp $(main_build)/$(ocamldir)/debugger$(RUNTIME_SUFFIX)/.ocamldebug.objs/byte/*.cm* \ + _runtest/debugger$(RUNTIME_SUFFIX) # The ast_invariants test needs VERSION to be present. In fact ideally # we should have all the source files in _runtest too for this test, # but for the moment we accept it being a weaker check. We're not diff --git a/ocaml/bytecomp/dll.ml b/ocaml/bytecomp/dll.ml index 019805d2f97..f95728edbaf 100644 --- a/ocaml/bytecomp/dll.ml +++ b/ocaml/bytecomp/dll.ml @@ -19,11 +19,13 @@ type dll_handle type dll_address type dll_mode = For_checking | For_execution -(* BACKPORT BEGIN -external dll_open: string -> dll_handle = "caml_dynlink_open_lib" -*) -external dll_open: dll_mode -> string -> dll_handle = "caml_dynlink_open_lib" -(* BACKPORT END *) +external dll_open5: string -> dll_handle = "caml_dynlink_open_lib" + +external dll_open4: dll_mode -> string -> dll_handle = "caml_dynlink_open_lib" + +let dll_open mode path = + if Config.runtime5 then dll_open5 path else dll_open4 mode path + external dll_close: dll_handle -> unit = "caml_dynlink_close_lib" external dll_sym: dll_handle -> string -> dll_address = "caml_dynlink_lookup_symbol" @@ -85,11 +87,7 @@ let open_dll mode name = failwith (fullname ^ ": " ^ Binutils.error_to_string err) end | (None | Some (Checking _) as current), For_execution -> -(* BACKPORT BEGIN - begin match dll_open fullname with -*) begin match dll_open For_execution fullname with -(* BACKPORT END *) | dll -> let opened = match current with | None -> List.remove_assoc fullname !opened_dlls diff --git a/ocaml/debugger/.depend b/ocaml/debugger/.depend index 4bba9203d7b..72397544b68 100644 --- a/ocaml/debugger/.depend +++ b/ocaml/debugger/.depend @@ -182,7 +182,6 @@ eval.cmo : \ ../typing/env.cmi \ debugcom.cmi \ ../typing/ctype.cmi \ - ../utils/compilation_unit.cmi \ ../typing/btype.cmi \ eval.cmi eval.cmx : \ @@ -203,7 +202,6 @@ eval.cmx : \ ../typing/env.cmx \ debugcom.cmx \ ../typing/ctype.cmx \ - ../utils/compilation_unit.cmx \ ../typing/btype.cmx \ eval.cmi eval.cmi : \ @@ -286,12 +284,10 @@ loadprinter.cmo : \ ../utils/misc.cmi \ ../parsing/longident.cmi \ ../utils/load_path.cmi \ - ../typing/jkind.cmi \ ../typing/ident.cmi \ ../typing/env.cmi \ ../otherlibs/dynlink/dynlink.cmi \ ../typing/ctype.cmi \ - ../utils/compilation_unit.cmi \ loadprinter.cmi loadprinter.cmx : \ ../typing/types.cmx \ @@ -303,12 +299,10 @@ loadprinter.cmx : \ ../utils/misc.cmx \ ../parsing/longident.cmx \ ../utils/load_path.cmx \ - ../typing/jkind.cmx \ ../typing/ident.cmx \ ../typing/env.cmx \ - ../otherlibs/dynlink/dynlink.cmx \ + ../otherlibs/dynlink/dynlink.cmi \ ../typing/ctype.cmx \ - ../utils/compilation_unit.cmx \ loadprinter.cmi loadprinter.cmi : \ ../parsing/longident.cmi \ @@ -407,7 +401,6 @@ printval.cmo : \ ../toplevel/genprintval.cmi \ ../typing/env.cmi \ debugcom.cmi \ - ../utils/compilation_unit.cmi \ printval.cmi printval.cmx : \ ../typing/types.cmx \ @@ -419,7 +412,6 @@ printval.cmx : \ ../toplevel/genprintval.cmx \ ../typing/env.cmx \ debugcom.cmx \ - ../utils/compilation_unit.cmx \ printval.cmi printval.cmi : \ ../typing/types.cmi \ diff --git a/ocaml/debugger/debugcom.ml b/ocaml/debugger/debugcom.ml index e852b3bb97c..5705cd73dbb 100644 --- a/ocaml/debugger/debugcom.ml +++ b/ocaml/debugger/debugcom.ml @@ -52,7 +52,6 @@ type pc = module Sp = struct (* Position in the debuggee's stack. *) -(* BACKPORT BEGIN type t = { block : int; offset : int; @@ -66,13 +65,6 @@ module Sp = struct match Stdlib.compare sp1.block sp2.block with | 0 -> Stdlib.compare sp1.offset sp2.offset | x -> x -*) - type t = int - - let null = 0 - let base _ _ = assert false - let compare = Int.compare -(* BACKPORT END *) end @@ -80,11 +72,7 @@ end Numbering starts at 1 and the runtime registers 2 fragments before the main program: one for uncaught exceptions and one for callbacks. *) -(* BACKPOR BEGIN let main_frag = 3 -*) -let main_frag = 0 -(* BACKPORT END *) let set_event {frag; pos} = output_char !conn.io_out 'e'; @@ -149,21 +137,13 @@ let do_go_smallint n = | c -> Misc.fatal_error (Printf.sprintf "Debugcom.do_go %c" c) in let event_counter = input_binary_int !conn.io_in in -(* BACKPORT BEGIN let block = input_binary_int !conn.io_in in let offset = input_binary_int !conn.io_in in -*) - let rep_stack_pointer = input_binary_int !conn.io_in in -(* BACKPORT END *) let frag = input_binary_int !conn.io_in in let pos = input_binary_int !conn.io_in in { rep_type = summary; rep_event_count = Int64.of_int event_counter; -(* BACKPORT BEGIN rep_stack_pointer = Sp.{block; offset}; -*) - rep_stack_pointer; -(* BACKPORT END *) rep_program_pointer = {frag; pos} }) let rec do_go n = @@ -212,19 +192,11 @@ let wait_child chan = let initial_frame () = output_char !conn.io_out '0'; flush !conn.io_out; -(* BACKPORT BEGIN let block = input_binary_int !conn.io_in in let offset = input_binary_int !conn.io_in in -*) - let stack_pos = input_binary_int !conn.io_in in -(* BACKPORT END *) let frag = input_binary_int !conn.io_in in let pos = input_binary_int !conn.io_in in -(* BACKPORT BEGIN (Sp.{block; offset}, {frag; pos}) -*) - (stack_pos, {frag; pos}) -(* BACKPOR END *) let set_initial_frame () = ignore(initial_frame ()) @@ -237,14 +209,9 @@ let up_frame stacksize = output_char !conn.io_out 'U'; output_binary_int !conn.io_out stacksize; flush !conn.io_out; -(* BACKPORT BEGIN let block = input_binary_int !conn.io_in in let offset = input_binary_int !conn.io_in in -*) - let stack_pos = input_binary_int !conn.io_in in -(* BACKPORT END *) let frag, pos = -(* BACKPORT BEGIN if block = -1 then begin assert (offset = -1); @@ -254,56 +221,31 @@ let up_frame stacksize = let pos = input_binary_int !conn.io_in in frag, pos end -*) - if stack_pos = -1 - then 0, 0 - else let frag = input_binary_int !conn.io_in in - let pos = input_binary_int !conn.io_in in - frag, pos -(* BACKPORT END *) in -(* BACKPORT BEGIN (Sp.{block; offset}, { frag; pos }) -*) - (stack_pos, { frag; pos }) -(* BACKPORT END *) (* Get and set the current frame position *) let get_frame () = output_char !conn.io_out 'f'; flush !conn.io_out; - let stack_pos = input_binary_int !conn.io_in in -(* let block = input_binary_int !conn.io_in in let offset = input_binary_int !conn.io_in in -*) let frag = input_binary_int !conn.io_in in let pos = input_binary_int !conn.io_in in -(* (Sp.{block; offset}, {frag; pos}) -*) - (stack_pos, {frag; pos}) let set_frame stack_pos = output_char !conn.io_out 'S'; -(* BACKPORT BEGIN output_binary_int !conn.io_out stack_pos.Sp.block; output_binary_int !conn.io_out stack_pos.Sp.offset -*) - output_binary_int !conn.io_out stack_pos -(* BACKPORT END *) (* Set the trap barrier to given stack position. *) let set_trap_barrier pos = output_char !conn.io_out 'b'; -(* BACKPORT BEGIN output_binary_int !conn.io_out pos.Sp.block; output_binary_int !conn.io_out pos.Sp.offset -*) - output_binary_int !conn.io_out pos -(* BACKPORT END *) (* Handling of remote values *) diff --git a/ocaml/debugger/debugcom.mli b/ocaml/debugger/debugcom.mli index e9d19edae1f..4e022dbf101 100644 --- a/ocaml/debugger/debugcom.mli +++ b/ocaml/debugger/debugcom.mli @@ -17,11 +17,7 @@ (* Low-level communication with the debuggee *) module Sp : sig -(* BACKPORT BEGIN type t -*) - type t = int -(* BACKPORT END *) val null : t val base : t -> int -> t val compare : t -> t -> int diff --git a/ocaml/debugger/eval.ml b/ocaml/debugger/eval.ml index 02a506acf89..4656e47bc8b 100644 --- a/ocaml/debugger/eval.ml +++ b/ocaml/debugger/eval.ml @@ -39,7 +39,6 @@ exception Error of error let abstract_type = Btype.newgenty (Tconstr (Pident (Ident.create_local ""), [], ref Mnil)) - let get_global_or_predef id = try Debugcom.Remote_value.global (Symtable.get_global_position id) diff --git a/ocaml/debugger/frames.ml b/ocaml/debugger/frames.ml index 364fa4ca71d..d590367d6d6 100644 --- a/ocaml/debugger/frames.ml +++ b/ocaml/debugger/frames.ml @@ -53,11 +53,7 @@ let selected_event_is_before () = let rec move_up frame_count event = if frame_count <= 0 then event else begin let (sp, pc) = up_frame event.ev_ev.ev_stacksize in -(* BACKPORT BEGIN if sp = Sp.null then raise Not_found; -*) - if sp < Sp.null then raise Not_found; -(* BACKPORT END *) move_up (frame_count - 1) (any_event_at_pc pc) end @@ -117,11 +113,7 @@ let do_backtrace action = begin try while action (Some !event) do let (sp, pc) = up_frame !event.ev_ev.ev_stacksize in -(* BACKPORT BEGIN if sp = Sp.null then raise Exit; -*) - if sp < Sp.null then raise Exit; -(* BACKPORT END *) event := any_event_at_pc pc done with Exit -> () diff --git a/ocaml/debugger/time_travel.ml b/ocaml/debugger/time_travel.ml index 7a2665d3051..b05d05767b7 100644 --- a/ocaml/debugger/time_travel.ml +++ b/ocaml/debugger/time_travel.ml @@ -555,11 +555,7 @@ let finish () = | Some {ev_ev={ev_stacksize}} -> set_initial_frame(); let (frame, pc) = up_frame ev_stacksize in -(* BACKPORT BEGIN if frame = Sp.null then begin -*) - if frame < Sp.null then begin -(* BACKPORT END *) prerr_endline "`finish' not meaningful in outermost frame."; raise Toplevel end; @@ -602,14 +598,9 @@ let next_1 () = | Some {ev_ev={ev_stacksize=ev_stacksize2}} -> let (frame2, _pc2) = initial_frame() in (* Call `finish' if we've entered a function. *) -(* BACKPORT BEGIN if frame1 <> Sp.null && frame2 <> Sp.null && Sp.(compare (base frame2 ev_stacksize2) (base frame1 ev_stacksize1)) > 0 -*) - if frame1 >= 0 && frame2 >= 0 && - frame2 - ev_stacksize2 > frame1 - ev_stacksize1 -(* BACKPORT END *) then finish() end @@ -632,11 +623,7 @@ let start () = | Some {ev_ev={ev_stacksize}} -> let (frame, _) = initial_frame() in let (frame', pc) = up_frame ev_stacksize in -(* BACKPORT BEGIN if frame' = Sp.null then begin -*) - if frame' < Sp.null then begin -(* BACKPORT END *) prerr_endline "`start not meaningful in outermost frame."; raise Toplevel end; @@ -658,11 +645,7 @@ let start () = step _minus1; (not !interrupted) && -(* BACKPORT BEGIN Sp.(compare (base frame' nargs) (base frame ev_stacksize)) > 0 -*) - (frame' - nargs > frame - ev_stacksize) -(* BACKPORT END *) | _ -> false do @@ -684,14 +667,9 @@ let previous_1 () = | Some {ev_ev={ev_stacksize=ev_stacksize2}} -> let (frame2, _pc2) = initial_frame() in (* Call `start' if we've entered a function. *) -(* BACKPORT BEGIN if frame1 <> Sp.null && frame2 <> Sp.null && Sp.(compare (base frame2 ev_stacksize2) (base frame1 ev_stacksize1)) > 0 -*) - if frame1 >= 0 && frame2 >= 0 && - frame2 - ev_stacksize2 > frame1 - ev_stacksize1 -(* BACKPORT END *) then start() end diff --git a/ocaml/debugger4/.depend b/ocaml/debugger4/.depend new file mode 100644 index 00000000000..4bba9203d7b --- /dev/null +++ b/ocaml/debugger4/.depend @@ -0,0 +1,644 @@ +breakpoints.cmo : \ + symbols.cmi \ + pos.cmi \ + parameters.cmi \ + ../utils/misc.cmi \ + ../bytecomp/instruct.cmi \ + exec.cmi \ + events.cmi \ + debugger_config.cmi \ + debugcom.cmi \ + checkpoints.cmi \ + breakpoints.cmi +breakpoints.cmx : \ + symbols.cmx \ + pos.cmx \ + parameters.cmx \ + ../utils/misc.cmx \ + ../bytecomp/instruct.cmx \ + exec.cmx \ + events.cmx \ + debugger_config.cmx \ + debugcom.cmx \ + checkpoints.cmx \ + breakpoints.cmi +breakpoints.cmi : \ + events.cmi \ + debugcom.cmi +checkpoints.cmo : \ + primitives.cmi \ + int64ops.cmi \ + debugcom.cmi \ + checkpoints.cmi +checkpoints.cmx : \ + primitives.cmx \ + int64ops.cmx \ + debugcom.cmx \ + checkpoints.cmi +checkpoints.cmi : \ + primitives.cmi \ + debugcom.cmi +command_line.cmo : \ + unix_tools.cmi \ + ../otherlibs/unix/unix.cmi \ + ../typing/types.cmi \ + time_travel.cmi \ + symbols.cmi \ + source.cmi \ + show_source.cmi \ + show_information.cmi \ + question.cmi \ + program_management.cmi \ + program_loading.cmi \ + printval.cmi \ + primitives.cmi \ + pos.cmi \ + parser_aux.cmi \ + parameters.cmi \ + ../parsing/longident.cmi \ + ../parsing/location.cmi \ + loadprinter.cmi \ + ../utils/load_path.cmi \ + int64ops.cmi \ + ../bytecomp/instruct.cmi \ + input_handling.cmi \ + history.cmi \ + frames.cmi \ + events.cmi \ + eval.cmi \ + ../typing/envaux.cmi \ + ../typing/env.cmi \ + debugger_parser.cmi \ + debugger_lexer.cmi \ + debugger_config.cmi \ + debugcom.cmi \ + ../driver/compmisc.cmi \ + checkpoints.cmi \ + breakpoints.cmi \ + command_line.cmi +command_line.cmx : \ + unix_tools.cmx \ + ../otherlibs/unix/unix.cmx \ + ../typing/types.cmx \ + time_travel.cmx \ + symbols.cmx \ + source.cmx \ + show_source.cmx \ + show_information.cmx \ + question.cmx \ + program_management.cmx \ + program_loading.cmx \ + printval.cmx \ + primitives.cmx \ + pos.cmx \ + parser_aux.cmi \ + parameters.cmx \ + ../parsing/longident.cmx \ + ../parsing/location.cmx \ + loadprinter.cmx \ + ../utils/load_path.cmx \ + int64ops.cmx \ + ../bytecomp/instruct.cmx \ + input_handling.cmx \ + history.cmx \ + frames.cmx \ + events.cmx \ + eval.cmx \ + ../typing/envaux.cmx \ + ../typing/env.cmx \ + debugger_parser.cmx \ + debugger_lexer.cmx \ + debugger_config.cmx \ + debugcom.cmx \ + ../driver/compmisc.cmx \ + checkpoints.cmx \ + breakpoints.cmx \ + command_line.cmi +command_line.cmi : +debugcom.cmo : \ + primitives.cmi \ + ../utils/misc.cmi \ + int64ops.cmi \ + ../bytecomp/instruct.cmi \ + input_handling.cmi \ + debugcom.cmi +debugcom.cmx : \ + primitives.cmx \ + ../utils/misc.cmx \ + int64ops.cmx \ + ../bytecomp/instruct.cmx \ + input_handling.cmx \ + debugcom.cmi +debugcom.cmi : \ + primitives.cmi \ + ../bytecomp/instruct.cmi +debugger_config.cmo : \ + int64ops.cmi \ + debugger_config.cmi +debugger_config.cmx : \ + int64ops.cmx \ + debugger_config.cmi +debugger_config.cmi : +debugger_lexer.cmo : \ + debugger_parser.cmi \ + debugger_lexer.cmi +debugger_lexer.cmx : \ + debugger_parser.cmx \ + debugger_lexer.cmi +debugger_lexer.cmi : \ + debugger_parser.cmi +debugger_parser.cmo : \ + parser_aux.cmi \ + ../parsing/longident.cmi \ + int64ops.cmi \ + input_handling.cmi \ + debugcom.cmi \ + debugger_parser.cmi +debugger_parser.cmx : \ + parser_aux.cmi \ + ../parsing/longident.cmx \ + int64ops.cmx \ + input_handling.cmx \ + debugcom.cmx \ + debugger_parser.cmi +debugger_parser.cmi : \ + parser_aux.cmi \ + ../parsing/longident.cmi +eval.cmo : \ + ../typing/types.cmi \ + ../bytecomp/symtable.cmi \ + ../typing/subst.cmi \ + printval.cmi \ + ../typing/printtyp.cmi \ + ../typing/predef.cmi \ + ../typing/path.cmi \ + parser_aux.cmi \ + ../utils/misc.cmi \ + ../parsing/longident.cmi \ + ../bytecomp/instruct.cmi \ + ../typing/ident.cmi \ + frames.cmi \ + events.cmi \ + ../typing/env.cmi \ + debugcom.cmi \ + ../typing/ctype.cmi \ + ../utils/compilation_unit.cmi \ + ../typing/btype.cmi \ + eval.cmi +eval.cmx : \ + ../typing/types.cmx \ + ../bytecomp/symtable.cmx \ + ../typing/subst.cmx \ + printval.cmx \ + ../typing/printtyp.cmx \ + ../typing/predef.cmx \ + ../typing/path.cmx \ + parser_aux.cmi \ + ../utils/misc.cmx \ + ../parsing/longident.cmx \ + ../bytecomp/instruct.cmx \ + ../typing/ident.cmx \ + frames.cmx \ + events.cmx \ + ../typing/env.cmx \ + debugcom.cmx \ + ../typing/ctype.cmx \ + ../utils/compilation_unit.cmx \ + ../typing/btype.cmx \ + eval.cmi +eval.cmi : \ + ../typing/types.cmi \ + ../typing/path.cmi \ + parser_aux.cmi \ + ../parsing/longident.cmi \ + ../typing/ident.cmi \ + events.cmi \ + ../typing/env.cmi \ + debugcom.cmi +events.cmo : \ + ../parsing/location.cmi \ + ../bytecomp/instruct.cmi \ + events.cmi +events.cmx : \ + ../parsing/location.cmx \ + ../bytecomp/instruct.cmx \ + events.cmi +events.cmi : \ + ../bytecomp/instruct.cmi +exec.cmo : \ + exec.cmi +exec.cmx : \ + exec.cmi +exec.cmi : +frames.cmo : \ + symbols.cmi \ + ../utils/misc.cmi \ + ../bytecomp/instruct.cmi \ + events.cmi \ + debugcom.cmi \ + frames.cmi +frames.cmx : \ + symbols.cmx \ + ../utils/misc.cmx \ + ../bytecomp/instruct.cmx \ + events.cmx \ + debugcom.cmx \ + frames.cmi +frames.cmi : \ + events.cmi +history.cmo : \ + primitives.cmi \ + int64ops.cmi \ + debugger_config.cmi \ + checkpoints.cmi \ + history.cmi +history.cmx : \ + primitives.cmx \ + int64ops.cmx \ + debugger_config.cmx \ + checkpoints.cmx \ + history.cmi +history.cmi : +input_handling.cmo : \ + ../otherlibs/unix/unix.cmi \ + primitives.cmi \ + parameters.cmi \ + input_handling.cmi +input_handling.cmx : \ + ../otherlibs/unix/unix.cmx \ + primitives.cmx \ + parameters.cmx \ + input_handling.cmi +input_handling.cmi : \ + primitives.cmi +int64ops.cmo : \ + int64ops.cmi +int64ops.cmx : \ + int64ops.cmi +int64ops.cmi : +loadprinter.cmo : \ + ../typing/types.cmi \ + ../toplevel/topprinters.cmi \ + ../bytecomp/symtable.cmi \ + printval.cmi \ + ../typing/printtyp.cmi \ + ../typing/path.cmi \ + ../utils/misc.cmi \ + ../parsing/longident.cmi \ + ../utils/load_path.cmi \ + ../typing/jkind.cmi \ + ../typing/ident.cmi \ + ../typing/env.cmi \ + ../otherlibs/dynlink/dynlink.cmi \ + ../typing/ctype.cmi \ + ../utils/compilation_unit.cmi \ + loadprinter.cmi +loadprinter.cmx : \ + ../typing/types.cmx \ + ../toplevel/topprinters.cmx \ + ../bytecomp/symtable.cmx \ + printval.cmx \ + ../typing/printtyp.cmx \ + ../typing/path.cmx \ + ../utils/misc.cmx \ + ../parsing/longident.cmx \ + ../utils/load_path.cmx \ + ../typing/jkind.cmx \ + ../typing/ident.cmx \ + ../typing/env.cmx \ + ../otherlibs/dynlink/dynlink.cmx \ + ../typing/ctype.cmx \ + ../utils/compilation_unit.cmx \ + loadprinter.cmi +loadprinter.cmi : \ + ../parsing/longident.cmi \ + ../otherlibs/dynlink/dynlink.cmi +main.cmo : \ + unix_tools.cmi \ + ../otherlibs/unix/unix.cmi \ + time_travel.cmi \ + show_information.cmi \ + question.cmi \ + program_management.cmi \ + primitives.cmi \ + ../typing/persistent_env.cmi \ + parameters.cmi \ + ../utils/misc.cmi \ + ../utils/load_path.cmi \ + input_handling.cmi \ + frames.cmi \ + exec.cmi \ + debugger_config.cmi \ + ../utils/config.cmi \ + ../driver/compmisc.cmi \ + command_line.cmi \ + ../file_formats/cmi_format.cmi \ + ../utils/clflags.cmi \ + checkpoints.cmi +main.cmx : \ + unix_tools.cmx \ + ../otherlibs/unix/unix.cmx \ + time_travel.cmx \ + show_information.cmx \ + question.cmx \ + program_management.cmx \ + primitives.cmx \ + ../typing/persistent_env.cmx \ + parameters.cmx \ + ../utils/misc.cmx \ + ../utils/load_path.cmx \ + input_handling.cmx \ + frames.cmx \ + exec.cmx \ + debugger_config.cmx \ + ../utils/config.cmx \ + ../driver/compmisc.cmx \ + command_line.cmx \ + ../file_formats/cmi_format.cmx \ + ../utils/clflags.cmx \ + checkpoints.cmx +ocamldebug_entry.cmo : \ + ../otherlibs/unix/unix.cmi +ocamldebug_entry.cmx : \ + ../otherlibs/unix/unix.cmx +parameters.cmo : \ + ../utils/load_path.cmi \ + ../typing/envaux.cmi \ + debugger_config.cmi \ + ../utils/config.cmi \ + parameters.cmi +parameters.cmx : \ + ../utils/load_path.cmx \ + ../typing/envaux.cmx \ + debugger_config.cmx \ + ../utils/config.cmx \ + parameters.cmi +parameters.cmi : +parser_aux.cmi : \ + ../parsing/longident.cmi \ + debugcom.cmi +pos.cmo : \ + ../parsing/location.cmi \ + ../bytecomp/instruct.cmi \ + events.cmi \ + pos.cmi +pos.cmx : \ + ../parsing/location.cmx \ + ../bytecomp/instruct.cmx \ + events.cmx \ + pos.cmi +pos.cmi : \ + events.cmi +primitives.cmo : \ + ../otherlibs/unix/unix.cmi \ + primitives.cmi +primitives.cmx : \ + ../otherlibs/unix/unix.cmx \ + primitives.cmi +primitives.cmi : \ + ../otherlibs/unix/unix.cmi +printval.cmo : \ + ../typing/types.cmi \ + ../bytecomp/symtable.cmi \ + ../typing/printtyp.cmi \ + parser_aux.cmi \ + ../typing/outcometree.cmi \ + ../typing/oprint.cmi \ + ../toplevel/genprintval.cmi \ + ../typing/env.cmi \ + debugcom.cmi \ + ../utils/compilation_unit.cmi \ + printval.cmi +printval.cmx : \ + ../typing/types.cmx \ + ../bytecomp/symtable.cmx \ + ../typing/printtyp.cmx \ + parser_aux.cmi \ + ../typing/outcometree.cmi \ + ../typing/oprint.cmx \ + ../toplevel/genprintval.cmx \ + ../typing/env.cmx \ + debugcom.cmx \ + ../utils/compilation_unit.cmx \ + printval.cmi +printval.cmi : \ + ../typing/types.cmi \ + ../typing/path.cmi \ + parser_aux.cmi \ + ../typing/env.cmi \ + debugcom.cmi +program_loading.cmo : \ + unix_tools.cmi \ + ../otherlibs/unix/unix.cmi \ + primitives.cmi \ + parameters.cmi \ + input_handling.cmi \ + debugger_config.cmi \ + program_loading.cmi +program_loading.cmx : \ + unix_tools.cmx \ + ../otherlibs/unix/unix.cmx \ + primitives.cmx \ + parameters.cmx \ + input_handling.cmx \ + debugger_config.cmx \ + program_loading.cmi +program_loading.cmi : \ + primitives.cmi +program_management.cmo : \ + unix_tools.cmi \ + ../otherlibs/unix/unix.cmi \ + time_travel.cmi \ + symbols.cmi \ + question.cmi \ + program_loading.cmi \ + primitives.cmi \ + parameters.cmi \ + ../utils/load_path.cmi \ + int64ops.cmi \ + input_handling.cmi \ + history.cmi \ + ../typing/envaux.cmi \ + debugger_config.cmi \ + debugcom.cmi \ + ../driver/compmisc.cmi \ + breakpoints.cmi \ + program_management.cmi +program_management.cmx : \ + unix_tools.cmx \ + ../otherlibs/unix/unix.cmx \ + time_travel.cmx \ + symbols.cmx \ + question.cmx \ + program_loading.cmx \ + primitives.cmx \ + parameters.cmx \ + ../utils/load_path.cmx \ + int64ops.cmx \ + input_handling.cmx \ + history.cmx \ + ../typing/envaux.cmx \ + debugger_config.cmx \ + debugcom.cmx \ + ../driver/compmisc.cmx \ + breakpoints.cmx \ + program_management.cmi +program_management.cmi : +question.cmo : \ + primitives.cmi \ + input_handling.cmi \ + debugger_lexer.cmi \ + question.cmi +question.cmx : \ + primitives.cmx \ + input_handling.cmx \ + debugger_lexer.cmx \ + question.cmi +question.cmi : +show_information.cmo : \ + symbols.cmi \ + source.cmi \ + show_source.cmi \ + printval.cmi \ + parameters.cmi \ + ../utils/misc.cmi \ + ../bytecomp/instruct.cmi \ + frames.cmi \ + events.cmi \ + debugcom.cmi \ + checkpoints.cmi \ + breakpoints.cmi \ + show_information.cmi +show_information.cmx : \ + symbols.cmx \ + source.cmx \ + show_source.cmx \ + printval.cmx \ + parameters.cmx \ + ../utils/misc.cmx \ + ../bytecomp/instruct.cmx \ + frames.cmx \ + events.cmx \ + debugcom.cmx \ + checkpoints.cmx \ + breakpoints.cmx \ + show_information.cmi +show_information.cmi : \ + events.cmi +show_source.cmo : \ + source.cmi \ + primitives.cmi \ + parameters.cmi \ + ../parsing/location.cmi \ + ../bytecomp/instruct.cmi \ + events.cmi \ + debugger_config.cmi \ + show_source.cmi +show_source.cmx : \ + source.cmx \ + primitives.cmx \ + parameters.cmx \ + ../parsing/location.cmx \ + ../bytecomp/instruct.cmx \ + events.cmx \ + debugger_config.cmx \ + show_source.cmi +show_source.cmi : \ + ../bytecomp/instruct.cmi +source.cmo : \ + primitives.cmi \ + ../utils/misc.cmi \ + ../utils/load_path.cmi \ + debugger_config.cmi \ + source.cmi +source.cmx : \ + primitives.cmx \ + ../utils/misc.cmx \ + ../utils/load_path.cmx \ + debugger_config.cmx \ + source.cmi +source.cmi : +symbols.cmo : \ + ../bytecomp/symtable.cmi \ + program_loading.cmi \ + ../utils/misc.cmi \ + ../bytecomp/instruct.cmi \ + events.cmi \ + debugger_config.cmi \ + debugcom.cmi \ + checkpoints.cmi \ + ../bytecomp/bytesections.cmi \ + symbols.cmi +symbols.cmx : \ + ../bytecomp/symtable.cmx \ + program_loading.cmx \ + ../utils/misc.cmx \ + ../bytecomp/instruct.cmx \ + events.cmx \ + debugger_config.cmx \ + debugcom.cmx \ + checkpoints.cmx \ + ../bytecomp/bytesections.cmx \ + symbols.cmi +symbols.cmi : \ + ../bytecomp/instruct.cmi \ + events.cmi \ + debugcom.cmi +time_travel.cmo : \ + trap_barrier.cmi \ + symbols.cmi \ + question.cmi \ + program_loading.cmi \ + primitives.cmi \ + ../utils/misc.cmi \ + int64ops.cmi \ + ../bytecomp/instruct.cmi \ + input_handling.cmi \ + exec.cmi \ + events.cmi \ + debugger_config.cmi \ + debugcom.cmi \ + checkpoints.cmi \ + breakpoints.cmi \ + time_travel.cmi +time_travel.cmx : \ + trap_barrier.cmx \ + symbols.cmx \ + question.cmx \ + program_loading.cmx \ + primitives.cmx \ + ../utils/misc.cmx \ + int64ops.cmx \ + ../bytecomp/instruct.cmx \ + input_handling.cmx \ + exec.cmx \ + events.cmx \ + debugger_config.cmx \ + debugcom.cmx \ + checkpoints.cmx \ + breakpoints.cmx \ + time_travel.cmi +time_travel.cmi : \ + primitives.cmi +trap_barrier.cmo : \ + exec.cmi \ + debugcom.cmi \ + checkpoints.cmi \ + trap_barrier.cmi +trap_barrier.cmx : \ + exec.cmx \ + debugcom.cmx \ + checkpoints.cmx \ + trap_barrier.cmi +trap_barrier.cmi : \ + debugcom.cmi +unix_tools.cmo : \ + ../otherlibs/unix/unix.cmi \ + ../utils/misc.cmi \ + unix_tools.cmi +unix_tools.cmx : \ + ../otherlibs/unix/unix.cmx \ + ../utils/misc.cmx \ + unix_tools.cmi +unix_tools.cmi : \ + ../otherlibs/unix/unix.cmi diff --git a/ocaml/debugger4/Makefile b/ocaml/debugger4/Makefile new file mode 100644 index 00000000000..0b2b877b47e --- /dev/null +++ b/ocaml/debugger4/Makefile @@ -0,0 +1,92 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +ROOTDIR = .. + +include $(ROOTDIR)/Makefile.common +include $(ROOTDIR)/Makefile.best_binaries + +DYNLINKDIR=$(ROOTDIR)/otherlibs/dynlink +UNIXDIR=$(ROOTDIR)/otherlibs/unix + +CAMLC=$(BEST_OCAMLC) $(STDLIBFLAGS) +COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48-70 -warn-error +A \ + -strict-sequence -strict-formats +LINKFLAGS=-linkall -I $(UNIXDIR) -I $(DYNLINKDIR) +OC_OCAMLDEPDIRS = $(DIRECTORIES) + +DIRECTORIES=$(UNIXDIR) $(DYNLINKDIR) $(addprefix $(ROOTDIR)/,\ + utils parsing typing bytecomp toplevel driver file_formats lambda) + +INCLUDES=$(addprefix -I ,$(DIRECTORIES)) + +compiler_modules := $(addprefix $(ROOTDIR)/toplevel/,\ + genprintval topprinters) + +debugger_modules := \ + int64ops primitives unix_tools debugger_config parameters debugger_lexer \ + input_handling question debugcom exec source pos checkpoints events \ + program_loading symbols breakpoints trap_barrier history printval \ + show_source time_travel program_management frames eval \ + show_information loadprinter debugger_parser command_line main + +compiler_objects := $(addsuffix .cmo,$(compiler_modules)) + +debugger_objects := $(addsuffix .cmo,$(debugger_modules)) + +libraries = $(ROOTDIR)/compilerlibs/ocamlcommon.cma \ + $(UNIXDIR)/unix.cma $(DYNLINKDIR)/dynlink.cma + +all: ocamldebug$(EXE) + +ocamldebug.cmo: $(debugger_objects) + $(V_OCAMLC)$(CAMLC) -pack $(COMPFLAGS) -o $@ $^ + +ocamldebug$(EXE): $(libraries) $(compiler_objects) ocamldebug.cmo \ + ocamldebug_entry.cmo + $(V_LINKC)$(CAMLC) $(LINKFLAGS) -o $@ -linkall $^ + +install: + $(INSTALL_PROG) ocamldebug$(EXE) "$(INSTALL_BINDIR)" + +.PHONY: clean +clean:: + rm -f ocamldebug ocamldebug.exe + rm -f *.cmo *.cmi + +.PHONY: distclean +distclean: clean + +ocamldebug_entry.cmo: ocamldebug_entry.ml ocamldebug.cmo + $(V_OCAMLC)$(CAMLC) -c $(COMPFLAGS) $< + +%.cmo: %.ml + $(V_OCAMLC)$(CAMLC) -c $(COMPFLAGS) -for-pack ocamldebug $< + +%.cmi: %.mli + $(V_OCAMLC)$(CAMLC) -c $(COMPFLAGS) -for-pack ocamldebug $< + +depend: beforedepend + $(V_OCAMLDEP)$(OCAMLDEP_CMD) *.mli *.ml > .depend + +clean:: + rm -f debugger_lexer.ml +beforedepend:: debugger_lexer.ml + +clean:: + rm -f $(addprefix debugger_parser.,ml mli output) +beforedepend:: debugger_parser.ml debugger_parser.mli + +include .depend diff --git a/ocaml/debugger4/breakpoints.ml b/ocaml/debugger4/breakpoints.ml new file mode 100644 index 00000000000..60059fcdbd1 --- /dev/null +++ b/ocaml/debugger4/breakpoints.ml @@ -0,0 +1,209 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(******************************* Breakpoints ***************************) + +open Checkpoints +open Debugcom +open Instruct +open Events +open Printf + +(*** Debugging. ***) +let debug_breakpoints = ref false + +(*** Data. ***) + +(* Number of the last added breakpoint. *) +let breakpoint_number = ref 0 + +(* Breakpoint number -> event. *) +type breakpoint_id = int +let breakpoints = ref ([] : (breakpoint_id * code_event) list) + +(* Program counter -> breakpoint count. *) +let positions = ref ([] : (pc * int ref) list) + +(* Versions of the breakpoint list. *) +let current_version = ref 0 +let max_version = ref 0 + +(*** Miscellaneous. ***) + +(* Mark breakpoints as installed in current checkpoint. *) +let copy_breakpoints () = + !current_checkpoint.c_breakpoints <- !positions; + !current_checkpoint.c_breakpoint_version <- !current_version + +(* Announce a new version of the breakpoint list. *) +let new_version () = + incr max_version; + current_version := !max_version + +(*** Information about breakpoints. ***) + +let breakpoints_count () = + List.length !breakpoints + +(* List of breakpoints at `pc'. *) +let rec breakpoints_at_pc pc = + begin match Symbols.event_at_pc pc with + | {ev_frag = frag; ev_ev = {ev_repr = Event_child {contents = pos}}} -> + breakpoints_at_pc {frag; pos} + | _ -> [] + | exception Not_found -> [] + end + @ + List.map fst (List.filter + (function (_, {ev_frag = frag; ev_ev = {ev_pos = pos}}) -> + {frag; pos} = pc) + !breakpoints) + +(* Is there a breakpoint at `pc' ? *) +let breakpoint_at_pc pc = + breakpoints_at_pc pc <> [] + +(*** Set and remove breakpoints ***) + +let print_pc out {frag;pos} = fprintf out "%d:%d" frag pos + +(* Remove all breakpoints. *) +let remove_breakpoints pcs = + if !debug_breakpoints then + printf "Removing breakpoints...\n%!"; + List.iter + (function (pc, _) -> + if !debug_breakpoints then printf "%a\n%!" print_pc pc; + reset_instr pc; + Symbols.set_event_at_pc pc) + pcs + +(* Set all breakpoints. *) +let set_breakpoints pcs = + if !debug_breakpoints then + printf "Setting breakpoints...\n%!"; + List.iter + (function (pc, _) -> + if !debug_breakpoints then printf "%a\n%!" print_pc pc; + set_breakpoint pc) + pcs + +(* Ensure the current version is installed in current checkpoint. *) +let update_breakpoints () = + if !debug_breakpoints then begin + prerr_string "Updating breakpoints... "; + prerr_int !current_checkpoint.c_breakpoint_version; + prerr_string " "; + prerr_int !current_version; + prerr_endline "" + end; + if !current_checkpoint.c_breakpoint_version <> !current_version then + Exec.protect + (function () -> + remove_breakpoints !current_checkpoint.c_breakpoints; + set_breakpoints !positions; + copy_breakpoints ()) + +(* Execute given function with no breakpoint in current checkpoint. *) +(* --- `goto' runs faster this way (does not stop on each breakpoint). *) +let execute_without_breakpoints f = + Misc.protect_refs [Misc.R (Debugger_config.break_on_load, false); + Misc.R (current_version, 0); + Misc.R (positions, []); + Misc.R (breakpoints, []); + Misc.R (breakpoint_number, 0)] + f + +(* Add a position in the position list. *) +(* Change version if necessary. *) +let insert_position pos = + try + incr (List.assoc pos !positions) + with + Not_found -> + positions := (pos, ref 1) :: !positions; + new_version () + +(* Remove a position in the position list. *) +(* Change version if necessary. *) +let remove_position pos = + let count = List.assoc pos !positions in + decr count; + if !count = 0 then begin + positions := List.remove_assoc pos !positions; + new_version () + end + +(* Insert a new breakpoint in lists. *) +let rec new_breakpoint event = + match event with + {ev_frag=frag; ev_ev={ev_repr=Event_child pos}} -> + new_breakpoint (Symbols.any_event_at_pc {frag; pos=(!pos)}) + | {ev_frag=frag; ev_ev={ev_pos=pos}} -> + let pc = {frag; pos} in + Exec.protect + (function () -> + incr breakpoint_number; + insert_position pc; + breakpoints := (!breakpoint_number, event) :: !breakpoints); + if !Parameters.breakpoint then + printf "Breakpoint %d at %a: %s\n%!" !breakpoint_number print_pc pc + (Pos.get_desc event) + +(* Remove a breakpoint from lists. *) +let remove_breakpoint number = + try + let ev = List.assoc number !breakpoints in + let pc = {frag = ev.ev_frag; pos=ev.ev_ev.ev_pos} in + Exec.protect + (function () -> + breakpoints := List.remove_assoc number !breakpoints; + remove_position pc; + if !Parameters.breakpoint then + printf "Removed breakpoint %d at %a: %s\n%!" number print_pc pc + (Pos.get_desc ev)) + with + Not_found -> + prerr_endline ("No breakpoint number " ^ (Int.to_string number) ^ "."); + raise Not_found + +let remove_all_breakpoints () = + List.iter (function (number, _) -> remove_breakpoint number) !breakpoints + +(*** Temporary breakpoints. ***) + +(* Temporary breakpoint position. *) +let temporary_breakpoint_position = ref (None : pc option) + +(* Execute `funct' with a breakpoint added at `pc'. *) +(* --- Used by `finish'. *) +let exec_with_temporary_breakpoint pc funct = + let previous_version = !current_version in + let remove () = + temporary_breakpoint_position := None; + current_version := previous_version; + let count = List.assoc pc !positions in + decr count; + if !count = 0 then begin + positions := List.remove_assoc pc !positions; + reset_instr pc; + Symbols.set_event_at_pc pc + end + + in + Exec.protect (function () -> insert_position pc); + temporary_breakpoint_position := Some pc; + Fun.protect ~finally:(fun () -> Exec.protect remove) funct diff --git a/ocaml/debugger4/breakpoints.mli b/ocaml/debugger4/breakpoints.mli new file mode 100644 index 00000000000..d26d9b241f7 --- /dev/null +++ b/ocaml/debugger4/breakpoints.mli @@ -0,0 +1,60 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(******************************* Breakpoints ***************************) + +(*** Debugging. ***) +val debug_breakpoints : bool ref + +(*** Information about breakpoints. ***) + +val breakpoints_count : unit -> int + +(* Breakpoint number -> code_event. *) +type breakpoint_id = int +val breakpoints : (breakpoint_id * Events.code_event) list ref + +(* Is there a breakpoint at `pc' ? *) +val breakpoint_at_pc : Debugcom.pc -> bool + +(* List of breakpoints at `pc'. *) +val breakpoints_at_pc : Debugcom.pc -> breakpoint_id list + +(*** Set and remove breakpoints ***) + +(* Ensure the current version is installed in current checkpoint. *) +val update_breakpoints : unit -> unit + +(* Execute given function with no breakpoint in current checkpoint. *) +(* --- `goto' run faster so (does not stop on each breakpoint). *) +val execute_without_breakpoints : (unit -> unit) -> unit + +(* Insert a new breakpoint in lists. *) +val new_breakpoint : Events.code_event -> unit + +(* Remove a breakpoint from lists. *) +val remove_breakpoint : breakpoint_id -> unit + +val remove_all_breakpoints : unit -> unit + +(*** Temporary breakpoints. ***) + +(* Temporary breakpoint position. *) +val temporary_breakpoint_position : Debugcom.pc option ref + +(* Execute `funct' with a breakpoint added at `pc'. *) +(* --- Used by `finish'. *) +val exec_with_temporary_breakpoint : Debugcom.pc -> (unit -> unit) -> unit diff --git a/ocaml/debugger4/checkpoints.ml b/ocaml/debugger4/checkpoints.ml new file mode 100644 index 00000000000..5b72d8c6b59 --- /dev/null +++ b/ocaml/debugger4/checkpoints.ml @@ -0,0 +1,90 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(*************************** Checkpoints *******************************) + +open Int64ops +open Debugcom +open Primitives + +(*** A type for checkpoints. ***) + +type checkpoint_state = + C_stopped + | C_running of int64 + +(* `c_valid' is true if and only if the corresponding + * process is connected to the debugger. + * `c_parent' is the checkpoint whose process is parent + * of the checkpoint one (`root' if no parent). + * c_pid = -2 for root pseudo-checkpoint. + * c_pid = 0 for ghost checkpoints. + * c_pid = -1 for kill checkpoints. + *) +type checkpoint = { + mutable c_time : int64; + mutable c_pid : int; + mutable c_fd : io_channel; + mutable c_valid : bool; + mutable c_report : report option; + mutable c_state : checkpoint_state; + mutable c_parent : checkpoint; + mutable c_breakpoint_version : int; + mutable c_breakpoints : (pc * int ref) list; + mutable c_trap_barrier : Sp.t; + mutable c_code_fragments : int list + } + +(*** Pseudo-checkpoint `root'. ***) +(* --- Parents of all checkpoints which have no parent. *) +let rec root = { + c_time = _0; + c_pid = -2; + c_fd = std_io; + c_valid = false; + c_report = None; + c_state = C_stopped; + c_parent = root; + c_breakpoint_version = 0; + c_breakpoints = []; + c_trap_barrier = Sp.null; + c_code_fragments = [main_frag] + } + +(*** Current state ***) +let checkpoints = + ref ([] : checkpoint list) + +let current_checkpoint = + ref root + +let current_time () = + !current_checkpoint.c_time + +let current_report () = + !current_checkpoint.c_report + +let current_pc_sp () = + (* This pattern matching mimics the test used in debugger.c for + deciding whether or not PC/SP should be sent with the report. + See debugger.c, the [if] statement above the [command_loop] + label. *) + match current_report () with + | Some {rep_type = Event | Breakpoint; + rep_program_pointer = pc; rep_stack_pointer = sp } -> Some (pc, sp) + | _ -> None + +let current_pc () = Option.map fst (current_pc_sp ()) diff --git a/ocaml/debugger4/checkpoints.mli b/ocaml/debugger4/checkpoints.mli new file mode 100644 index 00000000000..81b0e055850 --- /dev/null +++ b/ocaml/debugger4/checkpoints.mli @@ -0,0 +1,60 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(***************************** Checkpoints *****************************) + +open Primitives +open Debugcom + +(*** A type for checkpoints. ***) + +type checkpoint_state = + C_stopped + | C_running of int64 + +(* `c_valid' is true if and only if the corresponding + * process is connected to the debugger. + * `c_parent' is the checkpoint whose process is parent + * of the checkpoint one (`root' if no parent). + * c_pid = 2 for root pseudo-checkpoint. + * c_pid = 0 for ghost checkpoints. + * c_pid = -1 for kill checkpoints. + *) +type checkpoint = + {mutable c_time : int64; + mutable c_pid : int; + mutable c_fd : io_channel; + mutable c_valid : bool; + mutable c_report : report option; + mutable c_state : checkpoint_state; + mutable c_parent : checkpoint; + mutable c_breakpoint_version : int; + mutable c_breakpoints : (pc * int ref) list; + mutable c_trap_barrier : Sp.t; + mutable c_code_fragments : int list} + +(*** Pseudo-checkpoint `root'. ***) +(* --- Parents of all checkpoints which have no parent. *) +val root : checkpoint + +(*** Current state ***) +val checkpoints : checkpoint list ref +val current_checkpoint : checkpoint ref + +val current_time : unit -> int64 +val current_report : unit -> report option +val current_pc : unit -> pc option +val current_pc_sp : unit -> (pc * Sp.t) option diff --git a/ocaml/debugger4/command_line.ml b/ocaml/debugger4/command_line.ml new file mode 100644 index 00000000000..43f4a95f402 --- /dev/null +++ b/ocaml/debugger4/command_line.ml @@ -0,0 +1,1243 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(************************ Reading and executing commands ***************) + +open Int64ops +open Format +open Instruct +open Unix +open Debugger_config +open Types +open Primitives +open Unix_tools +open Debugger_parser +open Parser_aux +open Debugger_lexer +open Input_handling +open Question +open Debugcom +open Program_loading +open Program_management +open Lexing +open Parameters +open Show_source +open Show_information +open Time_travel +open Events +open Symbols +open Source +open Breakpoints +open Checkpoints +open Frames +open Printval + +module Lexer = Debugger_lexer + +(** Instructions, variables and infos lists. **) +type dbg_instruction = + { instr_name: string; (* Name of command *) + instr_prio: bool; (* Has priority *) + instr_action: formatter -> lexbuf -> unit; + (* What to do *) + instr_repeat: bool; (* Can be repeated *) + instr_help: string } (* Help message *) + +let instruction_list = ref ([] : dbg_instruction list) + +type dbg_variable = + { var_name: string; (* Name of variable *) + var_action: (lexbuf -> unit) * (formatter -> unit); + (* Reading, writing fns *) + var_help: string } (* Help message *) + +let variable_list = ref ([] : dbg_variable list) + +type dbg_info = + { info_name: string; (* Name of info *) + info_action: lexbuf -> unit; (* What to do *) + info_help: string } (* Help message *) + +let info_list = ref ([] : dbg_info list) + +(** Utilities. **) +let error text = + eprintf "%s@." text; + raise Toplevel + +let check_not_windows feature = + match Sys.os_type with + | "Win32" -> + error ("\'"^feature^"\' feature not supported on Windows") + | _ -> + () + +let eol = + end_of_line Lexer.lexeme + +let matching_elements list name instr = + List.filter (function a -> isprefix instr (name a)) !list + +let all_matching_instructions = + matching_elements instruction_list (fun i -> i.instr_name) + +(* itz 04-21-96 don't do priority completion in emacs mode *) +(* XL 25-02-97 why? I find it very confusing. *) + +let matching_instructions instr = + let all = all_matching_instructions instr in + let prio = List.filter (fun i -> i.instr_prio) all in + if prio = [] then all else prio + +let matching_variables = + matching_elements variable_list (fun v -> v.var_name) + +let matching_infos = + matching_elements info_list (fun i -> i.info_name) + +let find_ident name matcher action alternative ppf lexbuf = + match identifier_or_eol Lexer.lexeme lexbuf with + | None -> alternative ppf + | Some ident -> + match matcher ident with + | [] -> error ("Unknown " ^ name ^ ".") + | [a] -> action a ppf lexbuf + | _ -> error ("Ambiguous " ^ name ^ ".") + +let find_variable action alternative ppf lexbuf = + find_ident "variable name" matching_variables action alternative ppf lexbuf + +let find_info action alternative ppf lexbuf = + find_ident "info command" matching_infos action alternative ppf lexbuf + +let add_breakpoint_at_pc pc = + try + new_breakpoint (any_event_at_pc pc) + with + | Not_found -> + eprintf "Can\'t add breakpoint at pc %i:%i: no event there.@." + pc.frag pc.pos; + raise Toplevel + +let add_breakpoint_after_pc pc = + let rec try_add n = + if n < 3 then begin + try + new_breakpoint (any_event_at_pc {pc with pos = pc.pos + n * 4}) + with + | Not_found -> + try_add (n+1) + end else begin + error + "Can\'t add breakpoint at beginning of function: no event there" + end + in try_add 0 + +let module_of_longident id = + match id with + | Some x -> Some (String.concat "." (Longident.flatten x)) + | None -> None + +let convert_module mdle = + match mdle with + | Some m -> + (* Strip .ml extension if any, and capitalize *) + String.capitalize_ascii(if Filename.check_suffix m ".ml" + then Filename.chop_suffix m ".ml" + else m) + | None -> + try (get_current_event ()).ev_ev.ev_module + with Not_found -> error "Not in a module." + +(** Toplevel. **) +let current_line = ref "" + +let interprete_line ppf line = + current_line := line; + let lexbuf = Lexing.from_string line in + try + match identifier_or_eol Lexer.lexeme lexbuf with + | Some x -> + begin match matching_instructions x with + | [] -> + error "Unknown command." + | [i] -> + i.instr_action ppf lexbuf; + resume_user_input (); + i.instr_repeat + | _ -> + error "Ambiguous command." + end + | None -> + resume_user_input (); + false + with + | Parsing.Parse_error -> + error "Syntax error." + | Lexer.Int_overflow -> + error "Integer overflow" + +let line_loop ppf line_buffer = + resume_user_input (); + let previous_line = ref "" in + try + while true do + if !loaded then + History.add_current_time (); + let new_line = string_trim (line line_buffer) in + let line = + if new_line <> "" then + new_line + else + !previous_line + in + previous_line := ""; + if interprete_line ppf line && !interactif then + previous_line := line + done + with + | Exit -> + () +(* | Sys_error s -> + error ("System error: " ^ s) *) + +(** Instructions. **) +let instr_cd _ppf lexbuf = + let dir = argument_eol argument lexbuf in + if ask_kill_program () then + try + Sys.chdir (expand_path dir) + with + | Sys_error s -> + error s + +let instr_shell _ppf lexbuf = + let cmdarg = argument_list_eol argument lexbuf in + let cmd = String.concat " " cmdarg in + (* perhaps we should use $SHELL -c ? *) + let err = Sys.command cmd in + if (err != 0) then + eprintf "Shell command %S failed with exit code %d\n%!" cmd err + +let instr_env _ppf lexbuf = + let cmdarg = argument_list_eol argument lexbuf in + let cmdarg = string_trim (String.concat " " cmdarg) in + if cmdarg <> "" then + if ask_kill_program () then begin + try + let eqpos = String.index cmdarg '=' in + if eqpos = 0 then raise Not_found; + let name = String.sub cmdarg 0 eqpos in + let value = + String.sub cmdarg (eqpos + 1) (String.length cmdarg - eqpos - 1) + in + Debugger_config.environment := + (name, value) :: List.remove_assoc name !Debugger_config.environment + with Not_found -> + eprintf "Environment variable must be in name=value format\n%!" + end + else + List.iter + (fun (vvar, vval) -> printf "%s=%s\n%!" vvar vval) + (List.rev !Debugger_config.environment) + +let instr_pwd ppf lexbuf = + eol lexbuf; + fprintf ppf "%s@." (Sys.getcwd ()) + +let instr_dir ppf lexbuf = + let new_directory = argument_list_eol argument lexbuf in + if new_directory = [] then begin + if yes_or_no "Reinitialize directory list" then begin + Load_path.init ~auto_include:Compmisc.auto_include + ~visible:!default_load_path ~hidden:[]; + Envaux.reset_cache ~preserve_persistent_env:false; + Hashtbl.clear Debugger_config.load_path_for; + flush_buffer_list () + end + end + else begin + let new_directory' = List.rev new_directory in + match new_directory' with + | mdl :: for_keyw :: tl + when String.lowercase_ascii for_keyw = "for" && List.length tl > 0 -> + List.iter (function x -> add_path_for mdl (expand_path x)) tl + | _ -> + List.iter (function x -> add_path (expand_path x)) new_directory' + end; + let print_dirs ppf l = List.iter (function x -> fprintf ppf "@ %s" x) l in + fprintf ppf "@[<2>Directories: %a@]@." print_dirs + (Load_path.get_path_list ()); + Hashtbl.iter + (fun mdl dirs -> + fprintf ppf "@[<2>Source directories for %s: %a@]@." mdl print_dirs + dirs) + Debugger_config.load_path_for + +let instr_kill _ppf lexbuf = + eol lexbuf; + if not !loaded then error "The program is not being run."; + if (yes_or_no "Kill the program being debugged") then begin + kill_program (); + show_no_point() + end + +let instr_pid ppf lexbuf = + eol lexbuf; + if not !loaded then error "The program is not being run."; + fprintf ppf "@[%d@]@." !current_checkpoint.c_pid + +let instr_run ppf lexbuf = + eol lexbuf; + ensure_loaded (); + reset_named_values (); + run (); + show_current_event ppf + +let instr_reverse ppf lexbuf = + eol lexbuf; + check_not_windows "reverse"; + ensure_loaded (); + reset_named_values(); + back_run (); + show_current_event ppf + +let instr_step ppf lexbuf = + let step_count = + match opt_signed_int64_eol Lexer.lexeme lexbuf with + | None -> _1 + | Some x -> x + in + ensure_loaded (); + reset_named_values(); + step step_count; + show_current_event ppf + +let instr_back ppf lexbuf = + let step_count = + match opt_signed_int64_eol Lexer.lexeme lexbuf with + | None -> _1 + | Some x -> x + in + check_not_windows "backstep"; + ensure_loaded (); + reset_named_values(); + step (_0 -- step_count); + show_current_event ppf + +let instr_finish ppf lexbuf = + eol lexbuf; + ensure_loaded (); + reset_named_values(); + finish (); + show_current_event ppf + +let instr_next ppf lexbuf = + let step_count = + match opt_integer_eol Lexer.lexeme lexbuf with + | None -> 1 + | Some x -> x + in + ensure_loaded (); + reset_named_values(); + next step_count; + show_current_event ppf + +let instr_start ppf lexbuf = + eol lexbuf; + check_not_windows "start"; + ensure_loaded (); + reset_named_values(); + start (); + show_current_event ppf + +let instr_previous ppf lexbuf = + let step_count = + match opt_integer_eol Lexer.lexeme lexbuf with + | None -> 1 + | Some x -> x + in + check_not_windows "previous"; + ensure_loaded (); + reset_named_values(); + previous step_count; + show_current_event ppf + +let instr_goto ppf lexbuf = + let time = int64_eol Lexer.lexeme lexbuf in + ensure_loaded (); + reset_named_values(); + go_to time; + show_current_event ppf + +let instr_quit _ = + raise Exit + +let print_variable_list ppf = + let pr_vars ppf = List.iter (fun v -> fprintf ppf "%s@ " v.var_name) in + fprintf ppf "List of variables: %a@." pr_vars !variable_list + +let print_info_list ppf = + let pr_infos ppf = List.iter (fun i -> fprintf ppf "%s@ " i.info_name) in + fprintf ppf "List of info commands: %a@." pr_infos !info_list + +let instr_complete _ppf lexbuf = + let ppf = Format.err_formatter in + let rec print_list l = + try + eol lexbuf; + List.iter (function i -> fprintf ppf "%s@." i) l + with _ -> + remove_file !user_channel + and match_list lexbuf = + match identifier_or_eol Lexer.lexeme lexbuf with + | None -> + List.map (fun i -> i.instr_name) !instruction_list + | Some x -> + match matching_instructions x with + | [ {instr_name = ("set" | "show" as i_full)} ] -> + if x = i_full then begin + match identifier_or_eol Lexer.lexeme lexbuf with + | Some ident -> + begin match matching_variables ident with + | [v] -> if v.var_name = ident then [] else [v.var_name] + | l -> List.map (fun v -> v.var_name) l + end + | None -> + List.map (fun v -> v.var_name) !variable_list + end + else [i_full] + | [ {instr_name = "info"} ] -> + if x = "info" then begin + match identifier_or_eol Lexer.lexeme lexbuf with + | Some ident -> + begin match matching_infos ident with + | [i] -> if i.info_name = ident then [] else [i.info_name] + | l -> List.map (fun i -> i.info_name) l + end + | None -> + List.map (fun i -> i.info_name) !info_list + end + else ["info"] + | [ {instr_name = "help"} ] -> + if x = "help" then match_list lexbuf else ["help"] + | [ i ] -> + if x = i.instr_name then [] else [i.instr_name] + | l -> + List.map (fun i -> i.instr_name) l + in + print_list(match_list lexbuf) + +let instr_help ppf lexbuf = + let pr_instrs ppf = + List.iter (fun i -> fprintf ppf "%s@ " i.instr_name) in + match identifier_or_eol Lexer.lexeme lexbuf with + | Some x -> + let print_help nm hlp = + eol lexbuf; + fprintf ppf "%s: %s@." nm hlp in + begin match matching_instructions x with + | [] -> + eol lexbuf; + fprintf ppf "No matching command.@." + | [ {instr_name = "set"} ] -> + find_variable + (fun v _ _ -> + print_help ("set " ^ v.var_name) ("set " ^ v.var_help)) + (fun ppf -> + print_help "set" "set debugger variable."; + print_variable_list ppf) + ppf + lexbuf + | [ {instr_name = "show"} ] -> + find_variable + (fun v _ _ -> + print_help ("show " ^ v.var_name) ("show " ^ v.var_help)) + (fun _v -> + print_help "show" "display debugger variable."; + print_variable_list ppf) + ppf + lexbuf + | [ {instr_name = "info"} ] -> + find_info + (fun i _ _ -> print_help ("info " ^ i.info_name) i.info_help) + (fun ppf -> + print_help "info" + "display infos about the program being debugged."; + print_info_list ppf) + ppf + lexbuf + | [i] -> + print_help i.instr_name i.instr_help + | l -> + eol lexbuf; + fprintf ppf "Ambiguous command \"%s\": %a@." x pr_instrs l + end + | None -> + fprintf ppf "List of commands: %a@." pr_instrs !instruction_list + +(* Printing values *) + +let print_expr depth ev env ppf expr = + try + let (v, ty) = Eval.expression ev env expr in + print_named_value depth expr env v ppf ty + with + | Eval.Error msg -> + Eval.report_error ppf msg; + raise Toplevel + +let env_of_event = + function + None -> Env.empty + | Some ev -> + Envaux.env_from_summary ev.ev_ev.ev_typenv ev.ev_ev.ev_typsubst + +let print_command depth ppf lexbuf = + let exprs = expression_list_eol Lexer.lexeme lexbuf in + ensure_loaded (); + let env = + try + env_of_event !selected_event + with + | Envaux.Error msg -> + Envaux.report_error ppf msg; + raise Toplevel + in + List.iter (print_expr depth !selected_event env ppf) exprs + +let instr_print ppf lexbuf = print_command !max_printer_depth ppf lexbuf + +let instr_display ppf lexbuf = print_command 1 ppf lexbuf + +let instr_address ppf lexbuf = + let exprs = expression_list_eol Lexer.lexeme lexbuf in + ensure_loaded (); + let env = + try + env_of_event !selected_event + with + | Envaux.Error msg -> + Envaux.report_error ppf msg; + raise Toplevel + in + let print_addr expr = + let (v, _ty) = + try Eval.expression !selected_event env expr + with Eval.Error msg -> + Eval.report_error ppf msg; + raise Toplevel + in + match Remote_value.pointer v with + | "" -> fprintf ppf "[not a remote value]@." + | s -> fprintf ppf "0x%s@." s + in + List.iter print_addr exprs + +(* Loading of command files *) + +let extract_filename arg = + (* Allow enclosing filename in quotes *) + let l = String.length arg in + let pos1 = if l > 0 && arg.[0] = '\"' then 1 else 0 in + let pos2 = if l > 0 && arg.[l-1] = '\"' then l-1 else l in + String.sub arg pos1 (pos2 - pos1) + +let instr_source ppf lexbuf = + let file = extract_filename(argument_eol argument lexbuf) + and old_state = !interactif + and old_channel = !user_channel in + let io_chan = + try + io_channel_of_descr + (openfile (Load_path.find (expand_path file)) + [O_RDONLY] 0) + with + | Not_found -> error "Source file not found." + | (Unix_error _) as x -> Unix_tools.report_error x; raise Toplevel + in + interactif := false; + user_channel := io_chan; + let loop () = + line_loop ppf (Lexing.from_function read_user_input) + and finally () = + stop_user_input (); + close_io io_chan; + interactif := old_state; + user_channel := old_channel + in + Fun.protect ~finally loop + +let instr_set = + find_variable + (fun {var_action = (funct, _)} _ppf lexbuf -> funct lexbuf) + (function _ppf -> error "Argument required.") + +let instr_show = + find_variable + (fun {var_action = (_, funct)} ppf lexbuf -> eol lexbuf; funct ppf) + (function ppf -> + List.iter + (function {var_name = nm; var_action = (_, funct)} -> + fprintf ppf "%s: " nm; + funct ppf) + !variable_list) + +let instr_info = + find_info + (fun i _ppf lexbuf -> i.info_action lexbuf) + (function _ppf -> + error "\"info\" must be followed by the name of an info command.") + +let instr_break ppf lexbuf = + let argument = break_argument_eol Lexer.lexeme lexbuf in + ensure_loaded (); + match argument with + | BA_none -> (* break *) + (match !selected_event with + | Some ev -> + new_breakpoint ev + | None -> + error "Can\'t add breakpoint at this point.") + | BA_pc {frag; pos} -> (* break PC *) + add_breakpoint_at_pc {frag; pos} + | BA_function expr -> (* break FUNCTION *) + let env = + try + env_of_event !selected_event + with + | Envaux.Error msg -> + Envaux.report_error ppf msg; + raise Toplevel + in + begin try + let (v, ty) = Eval.expression !selected_event env expr in + match get_desc ty with + | Tarrow _ -> + add_breakpoint_after_pc (Remote_value.closure_code v) + | _ -> + eprintf "Not a function.@."; + raise Toplevel + with + | Eval.Error msg -> + Eval.report_error ppf msg; + raise Toplevel + end + | BA_pos1 (mdle, line, column) -> (* break @ [MODULE] LINE [COL] *) + let module_name = convert_module (module_of_longident mdle) in + new_breakpoint + (try + let ev = event_at_pos module_name 0 in + let ev_pos = + {Lexing.dummy_pos with + pos_fname = (Events.get_pos ev.ev_ev).pos_fname} in + let buffer = + try get_buffer ev_pos module_name with + | Not_found -> + eprintf "No source file for %s.@." module_name; + raise Toplevel + in + match column with + | None -> + event_at_pos module_name (fst (pos_of_line buffer line)) + | Some col -> + event_near_pos module_name (point_of_coord buffer line col) + with + | Not_found -> (* event_at_pos / event_near pos *) + eprintf "Can\'t find any event there.@."; + raise Toplevel + | Out_of_range -> (* pos_of_line / point_of_coord *) + eprintf "Position out of range.@."; + raise Toplevel) + | BA_pos2 (mdle, position) -> (* break @ [MODULE] # POSITION *) + try + new_breakpoint + (event_near_pos (convert_module (module_of_longident mdle)) + position) + with + | Not_found -> + eprintf "Can\'t find any event there.@." + +let instr_delete _ppf lexbuf = + match integer_list_eol Lexer.lexeme lexbuf with + | [] -> + if breakpoints_count () <> 0 && yes_or_no "Delete all breakpoints" + then remove_all_breakpoints () + | breakpoints -> + List.iter + (function x -> try remove_breakpoint x with | Not_found -> ()) + breakpoints + +let instr_frame ppf lexbuf = + let frame_number = + match opt_integer_eol Lexer.lexeme lexbuf with + | None -> !current_frame + | Some x -> x + in + ensure_loaded (); + try + select_frame frame_number; + show_current_frame ppf true + with + | Not_found -> + error ("No frame number " ^ Int.to_string frame_number ^ ".") + +let instr_backtrace ppf lexbuf = + let number = + match opt_signed_integer_eol Lexer.lexeme lexbuf with + | None -> 0 + | Some x -> x in + ensure_loaded (); + match current_report() with + | None | Some {rep_type = Exited | Uncaught_exc | Code_loaded _} -> () + | Some _ -> + let frame_counter = ref 0 in + let print_frame first_frame last_frame = function + | None -> + fprintf ppf + "(Encountered a function with no debugging information)@."; + false + | Some event -> + if !frame_counter >= first_frame then + show_one_frame !frame_counter ppf event; + incr frame_counter; + if !frame_counter >= last_frame then begin + fprintf ppf "(More frames follow)@." + end; + !frame_counter < last_frame in + fprintf ppf "Backtrace:@."; + if number = 0 then + do_backtrace (print_frame 0 max_int) + else if number > 0 then + do_backtrace (print_frame 0 number) + else begin + let num_frames = stack_depth() in + if num_frames < 0 then + fprintf ppf + "(Encountered a function with no debugging information)@." + else + do_backtrace (print_frame (num_frames + number) max_int) + end + +let instr_up ppf lexbuf = + let offset = + match opt_signed_integer_eol Lexer.lexeme lexbuf with + | None -> 1 + | Some x -> x + in + ensure_loaded (); + try + select_frame (!current_frame + offset); + show_current_frame ppf true + with + | Not_found -> error "No such frame." + +let instr_down ppf lexbuf = + let offset = + match opt_signed_integer_eol Lexer.lexeme lexbuf with + | None -> 1 + | Some x -> x + in + ensure_loaded (); + try + select_frame (!current_frame - offset); + show_current_frame ppf true + with + | Not_found -> error "No such frame." + +let instr_last ppf lexbuf = + let count = + match opt_signed_int64_eol Lexer.lexeme lexbuf with + | None -> _1 + | Some x -> x + in + check_not_windows "last"; + reset_named_values(); + go_to (History.previous_time count); + show_current_event ppf + +let instr_list _ppf lexbuf = + let (mo, beg, e) = list_arguments_eol Lexer.lexeme lexbuf in + let (curr_mod, line, column) = + try + selected_point () + with + | Not_found -> + ("", -1, -1) + in + let mdle = + match mo with + | None -> curr_mod + | _ -> convert_module (module_of_longident mo) + in + let pos = Lexing.dummy_pos in + let buffer = + try get_buffer pos mdle with + | Not_found -> error ("No source file for " ^ mdle ^ ".") in + let point = + if column <> -1 then + try + (point_of_coord buffer line 1) + column + with Out_of_range -> + -1 + else + -1 in + let beginning = + match beg with + | None when (mo <> None) || (line = -1) -> + 1 + | None -> + begin try + Int.max 1 (line - 10) + with Out_of_range -> + 1 + end + | Some x -> x + in + let en = + match e with + | None -> beginning + 20 + | Some x -> x + in + if mdle = curr_mod then + show_listing pos mdle beginning en point + (current_event_is_before ()) + else + show_listing pos mdle beginning en (-1) true + +(** Variables. **) +let raw_variable kill name = + (function lexbuf -> + let argument = argument_eol argument lexbuf in + if (not kill) || ask_kill_program () then name := argument), + function ppf -> fprintf ppf "%s@." !name + +let raw_line_variable kill name = + (function lexbuf -> + let argument = argument_eol line_argument lexbuf in + if (not kill) || ask_kill_program () then name := argument), + function ppf -> fprintf ppf "%s@." !name + +let integer_variable kill min msg name = + (function lexbuf -> + let argument = integer_eol Lexer.lexeme lexbuf in + if argument < min then print_endline msg + else if (not kill) || ask_kill_program () then name := argument), + function ppf -> fprintf ppf "%i@." !name + +let int64_variable kill min msg name = + (function lexbuf -> + let argument = int64_eol Lexer.lexeme lexbuf in + if argument < min then print_endline msg + else if (not kill) || ask_kill_program () then name := argument), + function ppf -> fprintf ppf "%Li@." !name + +let boolean_variable kill name = + (function lexbuf -> + let argument = + match identifier_eol Lexer.lexeme lexbuf with + | "on" -> true + | "of" | "off" -> false + | _ -> error "Syntax error." + in + if (not kill) || ask_kill_program () then name := argument), + function ppf -> fprintf ppf "%s@." (if !name then "on" else "off") + +let path_variable kill name = + (function lexbuf -> + let argument = argument_eol argument lexbuf in + if (not kill) || ask_kill_program () then + name := make_absolute (expand_path argument)), + function ppf -> fprintf ppf "%s@." !name + +let loading_mode_variable ppf = + (find_ident + "loading mode" + (matching_elements (ref loading_modes) fst) + (fun (_, mode) _ppf lexbuf -> + eol lexbuf; set_launching_function mode) + (function _ppf -> error "Syntax error.") + ppf), + function ppf -> + let rec find = function + | [] -> () + | (name, funct) :: l -> + if funct == !launching_func then fprintf ppf "%s" name else find l + in + find loading_modes; + fprintf ppf "@." + +let follow_fork_variable = + (function lexbuf -> + let mode = + match identifier_eol Lexer.lexeme lexbuf with + | "child" -> Fork_child + | "parent" -> Fork_parent + | _ -> error "Syntax error." + in + fork_mode := mode; + if !loaded then update_follow_fork_mode ()), + function ppf -> + fprintf ppf "%s@." + (match !fork_mode with + Fork_child -> "child" + | Fork_parent -> "parent") + +(** Infos. **) + +let pr_modules ppf mods = + let pr_mods ppf = List.iter (function x -> fprintf ppf "%s@ " x) in + fprintf ppf "Used modules: @.%a@?" pr_mods mods + +let info_modules ppf lexbuf = + eol lexbuf; + ensure_loaded (); + pr_modules ppf !modules +(******** + print_endline "Opened modules: "; + if !opened_modules_names = [] then + print_endline "(no module opened)." + else + (List.iter (function x -> print_string x;print_space) !opened_modules_names; + print_newline ()) +*********) + +let info_checkpoints ppf lexbuf = + eol lexbuf; + if !checkpoints = [] then fprintf ppf "No checkpoint.@." + else + (if !debug_breakpoints then + (prerr_endline " Time Pid Version"; + List.iter + (function + {c_time = time; c_pid = pid; c_breakpoint_version = version} -> + Printf.printf "%19Ld %5d %d\n" time pid version) + !checkpoints) + else + (print_endline " Time Pid"; + List.iter + (function + {c_time = time; c_pid = pid} -> + Printf.printf "%19Ld %5d\n" time pid) + !checkpoints)) + +let info_one_breakpoint ppf (num, ev) = + fprintf ppf "%3d %d:%10d %s@." num ev.ev_frag ev.ev_ev.ev_pos + (Pos.get_desc ev) + +let info_breakpoints ppf lexbuf = + eol lexbuf; + if !breakpoints = [] then fprintf ppf "No breakpoints.@." + else begin + fprintf ppf "Num Address Where@."; + List.iter (info_one_breakpoint ppf) (List.rev !breakpoints); + end + + +let info_events _ppf lexbuf = + ensure_loaded (); + let mdle = + convert_module (module_of_longident (opt_longident_eol Lexer.lexeme lexbuf)) + in + print_endline ("Module: " ^ mdle); + print_endline " Address Characters Kind Repr."; + let frag, events = events_in_module mdle in + List.iter + (function ev -> + let start_char, end_char = + try + let buffer = get_buffer (Events.get_pos ev) ev.ev_module in + (snd (start_and_cnum buffer ev.ev_loc.Location.loc_start)), + (snd (start_and_cnum buffer ev.ev_loc.Location.loc_end)) + with _ -> + ev.ev_loc.Location.loc_start.Lexing.pos_cnum, + ev.ev_loc.Location.loc_end.Lexing.pos_cnum in + Printf.printf + "%d:%10d %6d-%-6d %10s %10s\n" + frag + ev.ev_pos + start_char + end_char + ((match ev.ev_kind with + Event_before -> "before" + | Event_after _ -> "after" + | Event_pseudo -> "pseudo") + ^ + (match ev.ev_info with + Event_function -> "/fun" + | Event_return _ -> "/ret" + | Event_other -> "")) + (match ev.ev_repr with + Event_none -> "" + | Event_parent _ -> "(repr)" + | Event_child repr -> Int.to_string !repr)) + events + +(** User-defined printers **) + +let instr_load_printer ppf lexbuf = + let filename = extract_filename(argument_eol argument lexbuf) in + try + Loadprinter.loadfile ppf filename + with Loadprinter.Error e -> + Loadprinter.report_error ppf e; raise Toplevel + +let instr_install_printer ppf lexbuf = + let lid = longident_eol Lexer.lexeme lexbuf in + try + Loadprinter.install_printer ppf lid + with Loadprinter.Error e -> + Loadprinter.report_error ppf e; raise Toplevel + +let instr_remove_printer ppf lexbuf = + let lid = longident_eol Lexer.lexeme lexbuf in + try + Loadprinter.remove_printer lid + with Loadprinter.Error e -> + Loadprinter.report_error ppf e; raise Toplevel + +(** Initialization. **) +let init ppf = + instruction_list := [ + { instr_name = "cd"; instr_prio = false; + instr_action = instr_cd; instr_repeat = true; instr_help = +"set working directory to DIR for debugger and program being debugged." }; + { instr_name = "complete"; instr_prio = false; + instr_action = instr_complete; instr_repeat = false; instr_help = +"complete word at cursor according to context. Useful for Emacs." }; + { instr_name = "pwd"; instr_prio = false; + instr_action = instr_pwd; instr_repeat = true; instr_help = +"print working directory." }; + { instr_name = "directory"; instr_prio = false; + instr_action = instr_dir; instr_repeat = false; instr_help = +"add directory DIR to beginning of search path for source and\n\ +interface files.\n\ +Forget cached info on source file locations and line positions.\n\ +With no argument, reset the search path." }; + { instr_name = "kill"; instr_prio = false; + instr_action = instr_kill; instr_repeat = true; instr_help = +"kill the program being debugged." }; + { instr_name = "pid"; instr_prio = false; + instr_action = instr_pid; instr_repeat = true; instr_help = +"print the process ID of the current active process." }; + { instr_name = "address"; instr_prio = false; + instr_action = instr_address; instr_repeat = true; instr_help = +"print the raw address of a value." }; + { instr_name = "help"; instr_prio = false; + instr_action = instr_help; instr_repeat = true; instr_help = +"print list of commands." }; + { instr_name = "quit"; instr_prio = false; + instr_action = instr_quit; instr_repeat = false; instr_help = +"exit the debugger." }; + { instr_name = "shell"; instr_prio = false; + instr_action = instr_shell; instr_repeat = true; instr_help = +"Execute a given COMMAND through the system shell." }; + { instr_name = "environment"; instr_prio = false; + instr_action = instr_env; instr_repeat = false; instr_help = +"environment variable to give to program being debugged when it is started." }; + (* Displacements *) + { instr_name = "run"; instr_prio = true; + instr_action = instr_run; instr_repeat = true; instr_help = +"run the program from current position." }; + { instr_name = "reverse"; instr_prio = false; + instr_action = instr_reverse; instr_repeat = true; instr_help = +"run the program backward from current position." }; + { instr_name = "step"; instr_prio = true; + instr_action = instr_step; instr_repeat = true; instr_help = +"step program until it reaches the next event.\n\ +Argument N means do this N times (or till program stops for another reason)." }; + { instr_name = "backstep"; instr_prio = true; + instr_action = instr_back; instr_repeat = true; instr_help = +"step program backward until it reaches the previous event.\n\ +Argument N means do this N times (or till program stops for another reason)." }; + { instr_name = "goto"; instr_prio = false; + instr_action = instr_goto; instr_repeat = true; instr_help = +"go to the given time." }; + { instr_name = "finish"; instr_prio = true; + instr_action = instr_finish; instr_repeat = true; instr_help = +"execute until topmost stack frame returns." }; + { instr_name = "next"; instr_prio = true; + instr_action = instr_next; instr_repeat = true; instr_help = +"step program until it reaches the next event.\n\ +Skip over function calls.\n\ +Argument N means do this N times (or till program stops for another reason)." }; + { instr_name = "start"; instr_prio = false; + instr_action = instr_start; instr_repeat = true; instr_help = +"execute backward until the current function is exited." }; + { instr_name = "previous"; instr_prio = false; + instr_action = instr_previous; instr_repeat = true; instr_help = +"step program until it reaches the previous event.\n\ +Skip over function calls.\n\ +Argument N means do this N times (or till program stops for another reason)." }; + { instr_name = "print"; instr_prio = true; + instr_action = instr_print; instr_repeat = true; instr_help = +"print value of expressions (deep printing)." }; + { instr_name = "display"; instr_prio = true; + instr_action = instr_display; instr_repeat = true; instr_help = +"print value of expressions (shallow printing)." }; + { instr_name = "source"; instr_prio = false; + instr_action = instr_source; instr_repeat = true; instr_help = +"read command from file FILE." }; + (* Breakpoints *) + { instr_name = "break"; instr_prio = false; + instr_action = instr_break; instr_repeat = false; instr_help = +"Set breakpoint.\ +\nSyntax: break\ +\n break function-name\ +\n break @ [module] linenum\ +\n break @ [module] linenum columnnum\ +\n break @ [module] # characternum\ +\n break frag:pc\ +\n break pc" }; + { instr_name = "delete"; instr_prio = false; + instr_action = instr_delete; instr_repeat = false; instr_help = +"delete some breakpoints.\n\ +Arguments are breakpoint numbers with spaces in between.\n\ +To delete all breakpoints, give no argument." }; + { instr_name = "set"; instr_prio = false; + instr_action = instr_set; instr_repeat = false; instr_help = +"--unused--" }; + { instr_name = "show"; instr_prio = false; + instr_action = instr_show; instr_repeat = true; instr_help = +"--unused--" }; + { instr_name = "info"; instr_prio = false; + instr_action = instr_info; instr_repeat = true; instr_help = +"--unused--" }; + (* Frames *) + { instr_name = "frame"; instr_prio = false; + instr_action = instr_frame; instr_repeat = true; instr_help = +"select and print a stack frame.\n\ +With no argument, print the selected stack frame.\n\ +An argument specifies the frame to select." }; + { instr_name = "backtrace"; instr_prio = false; + instr_action = instr_backtrace; instr_repeat = true; instr_help = +"print backtrace of all stack frames, or innermost COUNT frames.\n\ +With a negative argument, print outermost -COUNT frames." }; + { instr_name = "bt"; instr_prio = false; + instr_action = instr_backtrace; instr_repeat = true; instr_help = +"print backtrace of all stack frames, or innermost COUNT frames.\n\ +With a negative argument, print outermost -COUNT frames." }; + { instr_name = "up"; instr_prio = false; + instr_action = instr_up; instr_repeat = true; instr_help = +"select and print stack frame that called this one.\n\ +An argument says how many frames up to go." }; + { instr_name = "down"; instr_prio = false; + instr_action = instr_down; instr_repeat = true; instr_help = +"select and print stack frame called by this one.\n\ +An argument says how many frames down to go." }; + { instr_name = "last"; instr_prio = true; + instr_action = instr_last; instr_repeat = true; instr_help = +"go back to previous time." }; + { instr_name = "list"; instr_prio = false; + instr_action = instr_list; instr_repeat = true; instr_help = +"list the source code." }; + (* User-defined printers *) + { instr_name = "load_printer"; instr_prio = false; + instr_action = instr_load_printer; instr_repeat = false; instr_help = +"load in the debugger a .cmo or .cma file containing printing functions." }; + { instr_name = "install_printer"; instr_prio = false; + instr_action = instr_install_printer; instr_repeat = false; instr_help = +"use the given function for printing values of its input type.\n\ +The code for the function must have previously been loaded in the debugger\n\ +using \"load_printer\"." }; + { instr_name = "remove_printer"; instr_prio = false; + instr_action = instr_remove_printer; instr_repeat = false; instr_help = +"stop using the given function for printing values of its input type." } +]; + variable_list := [ + (* variable name, (writing, reading), help reading, help writing *) + { var_name = "arguments"; + var_action = raw_line_variable true arguments; + var_help = +"arguments to give program being debugged when it is started." }; + { var_name = "program"; + var_action = path_variable true program_name; + var_help = +"name of program to be debugged." }; + { var_name = "loadingmode"; + var_action = loading_mode_variable ppf; + var_help = +"mode of loading.\n\ +It can be either:\n\ + direct: the program is directly called by the debugger.\n\ + runtime: the debugger execute `ocamlrun programname arguments\'.\n\ + manual: the program is not launched by the debugger,\n\ + but manually by the user." }; + { var_name = "processcount"; + var_action = integer_variable false 1 "Must be >= 1." + checkpoint_max_count; + var_help = +"maximum number of process to keep." }; + { var_name = "checkpoints"; + var_action = boolean_variable false make_checkpoints; + var_help = +"whether to make checkpoints or not." }; + { var_name = "bigstep"; + var_action = int64_variable false _1 "Must be >= 1." + checkpoint_big_step; + var_help = +"step between checkpoints during long displacements." }; + { var_name = "smallstep"; + var_action = int64_variable false _1 "Must be >= 1." + checkpoint_small_step; + var_help = +"step between checkpoints during small displacements." }; + { var_name = "socket"; + var_action = raw_variable true socket_name; + var_help = +"name of the socket used by communications debugger-runtime." }; + { var_name = "history"; + var_action = integer_variable false 0 "" history_size; + var_help = +"history size." }; + { var_name = "print_depth"; + var_action = integer_variable false 1 "Must be at least 1" + max_printer_depth; + var_help = +"maximal depth for printing of values." }; + { var_name = "print_length"; + var_action = integer_variable false 1 "Must be at least 1" + max_printer_steps; + var_help = +"maximal number of value nodes printed." }; + { var_name = "follow_fork_mode"; + var_action = follow_fork_variable; + var_help = +"process to follow after forking.\n\ +It can be either :\n\ + child: the newly created process.\n\ + parent: the process that called fork.\n" }; + { var_name = "break_on_load"; + var_action = boolean_variable false break_on_load; + var_help = +"whether to stop after loading new code (e.g. with Dynlink)." }]; + + info_list := + (* info name, function, help *) + [{ info_name = "modules"; + info_action = info_modules ppf; + info_help = "list opened modules." }; + { info_name = "checkpoints"; + info_action = info_checkpoints ppf; + info_help = "list checkpoints." }; + { info_name = "breakpoints"; + info_action = info_breakpoints ppf; + info_help = "list breakpoints." }; + { info_name = "events"; + info_action = info_events ppf; + info_help = "list events in MODULE (default is current module)." }] + +let _ = init std_formatter diff --git a/ocaml/debugger4/command_line.mli b/ocaml/debugger4/command_line.mli new file mode 100644 index 00000000000..adba635627b --- /dev/null +++ b/ocaml/debugger4/command_line.mli @@ -0,0 +1,23 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(************************ Reading and executing commands ***************) + +open Lexing +open Format + +val interprete_line : formatter -> string -> bool +val line_loop : formatter -> lexbuf -> unit diff --git a/ocaml/debugger4/debugcom.ml b/ocaml/debugger4/debugcom.ml new file mode 100644 index 00000000000..e852b3bb97c --- /dev/null +++ b/ocaml/debugger4/debugcom.ml @@ -0,0 +1,452 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Low-level communication with the debuggee *) + +open Int64ops +open Primitives + +(* The current connection with the debuggee *) + +let conn = ref Primitives.std_io + +(* Set which process the debugger follows on fork. *) + +type follow_fork_mode = + Fork_child + | Fork_parent + +let fork_mode = ref Fork_parent + +let update_follow_fork_mode () = + let a = match !fork_mode with Fork_child -> 0 | Fork_parent -> 1 in + output_char !conn.io_out 'K'; + output_binary_int !conn.io_out a + +(* Set the current connection, and update the fork mode in case it has + * changed. *) + +let set_current_connection io_chan = + conn := io_chan; + update_follow_fork_mode () + +(* Modify the program code *) + +type pc = + { frag : int; + pos : int; } + +module Sp = struct + + (* Position in the debuggee's stack. *) +(* BACKPORT BEGIN + type t = { + block : int; + offset : int; + } + + let null = { block = -1; offset = -1} + + let base sp n = {sp with offset = sp.offset - n} + + let compare sp1 sp2 = + match Stdlib.compare sp1.block sp2.block with + | 0 -> Stdlib.compare sp1.offset sp2.offset + | x -> x +*) + type t = int + + let null = 0 + let base _ _ = assert false + let compare = Int.compare +(* BACKPORT END *) + +end + +(* Identifier of the code fragment for the main program. + Numbering starts at 1 and the runtime registers 2 fragments before + the main program: one for uncaught exceptions and one for callbacks. +*) +(* BACKPOR BEGIN +let main_frag = 3 +*) +let main_frag = 0 +(* BACKPORT END *) + +let set_event {frag; pos} = + output_char !conn.io_out 'e'; + output_binary_int !conn.io_out frag; + output_binary_int !conn.io_out pos + +let set_breakpoint {frag; pos} = + output_char !conn.io_out 'B'; + output_binary_int !conn.io_out frag; + output_binary_int !conn.io_out pos + +let reset_instr {frag; pos} = + output_char !conn.io_out 'i'; + output_binary_int !conn.io_out frag; + output_binary_int !conn.io_out pos + +(* Basic commands for flow control *) + +type execution_summary = + Event + | Breakpoint + | Exited + | Trap_barrier + | Uncaught_exc + | Debug_info of Instruct.debug_event list array + | Code_loaded of int + | Code_unloaded of int + +type report = { + rep_type : execution_summary; + rep_event_count : int64; + rep_stack_pointer : Sp.t; + rep_program_pointer : pc +} + +type checkpoint_report = + Checkpoint_done of int + | Checkpoint_failed + +(* Run the debuggee for N events *) + +let do_go_smallint n = + output_char !conn.io_out 'g'; + output_binary_int !conn.io_out n; + flush !conn.io_out; + Input_handling.execute_with_other_controller + Input_handling.exit_main_loop + !conn + (function () -> + Input_handling.main_loop (); + let summary = + match input_char !conn.io_in with + 'e' -> Event + | 'b' -> Breakpoint + | 'x' -> Exited + | 's' -> Trap_barrier + | 'u' -> Uncaught_exc + | 'D' -> Debug_info (input_value !conn.io_in : + Instruct.debug_event list array) + | 'L' -> Code_loaded (input_binary_int !conn.io_in) + | 'U' -> Code_unloaded (input_binary_int !conn.io_in) + | c -> Misc.fatal_error (Printf.sprintf "Debugcom.do_go %c" c) + in + let event_counter = input_binary_int !conn.io_in in +(* BACKPORT BEGIN + let block = input_binary_int !conn.io_in in + let offset = input_binary_int !conn.io_in in +*) + let rep_stack_pointer = input_binary_int !conn.io_in in +(* BACKPORT END *) + let frag = input_binary_int !conn.io_in in + let pos = input_binary_int !conn.io_in in + { rep_type = summary; + rep_event_count = Int64.of_int event_counter; +(* BACKPORT BEGIN + rep_stack_pointer = Sp.{block; offset}; +*) + rep_stack_pointer; +(* BACKPORT END *) + rep_program_pointer = {frag; pos} }) + +let rec do_go n = + assert (n >= _0); + if n > max_small_int then + begin match do_go_smallint max_int with + | { rep_type = Event } -> + do_go (n -- max_small_int) + | report -> + { report with + rep_event_count = report.rep_event_count ++ (n -- max_small_int) } + end + else + do_go_smallint (Int64.to_int n) + +(* Perform a checkpoint *) + +let do_checkpoint () = + match Sys.os_type with + "Win32" -> failwith "do_checkpoint" + | _ -> + output_char !conn.io_out 'c'; + flush !conn.io_out; + let pid = input_binary_int !conn.io_in in + if pid = -1 then Checkpoint_failed else Checkpoint_done pid + +(* Kill the given process. *) +let stop chan = + try + output_char chan.io_out 's'; + flush chan.io_out + with + Sys_error _ | End_of_file -> () + +(* Ask a process to wait for its child which has been killed. *) +(* (so as to eliminate zombies). *) +let wait_child chan = + try + output_char chan.io_out 'w' + with + Sys_error _ | End_of_file -> () + +(* Move to initial frame (that of current function). *) +(* Return stack position and current pc *) + +let initial_frame () = + output_char !conn.io_out '0'; + flush !conn.io_out; +(* BACKPORT BEGIN + let block = input_binary_int !conn.io_in in + let offset = input_binary_int !conn.io_in in +*) + let stack_pos = input_binary_int !conn.io_in in +(* BACKPORT END *) + let frag = input_binary_int !conn.io_in in + let pos = input_binary_int !conn.io_in in +(* BACKPORT BEGIN + (Sp.{block; offset}, {frag; pos}) +*) + (stack_pos, {frag; pos}) +(* BACKPOR END *) + +let set_initial_frame () = + ignore(initial_frame ()) + +(* Move up one frame *) +(* Return stack position and current pc. + If there's no frame above, return (-1, 0). *) + +let up_frame stacksize = + output_char !conn.io_out 'U'; + output_binary_int !conn.io_out stacksize; + flush !conn.io_out; +(* BACKPORT BEGIN + let block = input_binary_int !conn.io_in in + let offset = input_binary_int !conn.io_in in +*) + let stack_pos = input_binary_int !conn.io_in in +(* BACKPORT END *) + let frag, pos = +(* BACKPORT BEGIN + if block = -1 then + begin + assert (offset = -1); + 0, 0 + end else begin + let frag = input_binary_int !conn.io_in in + let pos = input_binary_int !conn.io_in in + frag, pos + end +*) + if stack_pos = -1 + then 0, 0 + else let frag = input_binary_int !conn.io_in in + let pos = input_binary_int !conn.io_in in + frag, pos +(* BACKPORT END *) + in +(* BACKPORT BEGIN + (Sp.{block; offset}, { frag; pos }) +*) + (stack_pos, { frag; pos }) +(* BACKPORT END *) + +(* Get and set the current frame position *) + +let get_frame () = + output_char !conn.io_out 'f'; + flush !conn.io_out; + let stack_pos = input_binary_int !conn.io_in in +(* + let block = input_binary_int !conn.io_in in + let offset = input_binary_int !conn.io_in in +*) + let frag = input_binary_int !conn.io_in in + let pos = input_binary_int !conn.io_in in +(* + (Sp.{block; offset}, {frag; pos}) +*) + (stack_pos, {frag; pos}) + +let set_frame stack_pos = + output_char !conn.io_out 'S'; +(* BACKPORT BEGIN + output_binary_int !conn.io_out stack_pos.Sp.block; + output_binary_int !conn.io_out stack_pos.Sp.offset +*) + output_binary_int !conn.io_out stack_pos +(* BACKPORT END *) + +(* Set the trap barrier to given stack position. *) + +let set_trap_barrier pos = + output_char !conn.io_out 'b'; +(* BACKPORT BEGIN + output_binary_int !conn.io_out pos.Sp.block; + output_binary_int !conn.io_out pos.Sp.offset +*) + output_binary_int !conn.io_out pos +(* BACKPORT END *) + +(* Handling of remote values *) + +let value_size = if 1 lsl 31 = 0 then 4 else 8 + +let input_remote_value ic = + really_input_string ic value_size + +let output_remote_value ic v = + output_substring ic v 0 value_size + +exception Marshalling_error + +module Remote_value = + struct + type t = Remote of string | Local of Obj.t + + let repr x = Local (Obj.repr x) + + let obj = function + | Local obj -> Obj.obj obj + | Remote v -> + output_char !conn.io_out 'M'; + output_remote_value !conn.io_out v; + flush !conn.io_out; + try + input_value !conn.io_in + with End_of_file | Failure _ -> + raise Marshalling_error + + let is_block = function + | Local obj -> Obj.is_block obj + | Remote v -> Obj.is_block (Array.unsafe_get (Obj.magic v : Obj.t array) 0) + + let tag obj = + if not (is_block obj) then Obj.int_tag + else match obj with + | Local obj -> Obj.tag obj + | Remote v -> + output_char !conn.io_out 'H'; + output_remote_value !conn.io_out v; + flush !conn.io_out; + let header = input_binary_int !conn.io_in in + header land 0xFF + + let size = function + | Local obj -> Obj.size obj + | Remote v -> + output_char !conn.io_out 'H'; + output_remote_value !conn.io_out v; + flush !conn.io_out; + let header = input_binary_int !conn.io_in in + if header land 0xFF = Obj.double_array_tag && Sys.word_size = 32 + then header lsr 11 + else header lsr 10 + + let field v n = + match v with + | Local obj -> Local(Obj.field obj n) + | Remote v -> + output_char !conn.io_out 'F'; + output_remote_value !conn.io_out v; + output_binary_int !conn.io_out n; + flush !conn.io_out; + if input_byte !conn.io_in = 0 then + Remote(input_remote_value !conn.io_in) + else begin + let buf = really_input_string !conn.io_in 8 in + let floatbuf = float n (* force allocation of a new float *) in + String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8; + Local(Obj.repr floatbuf) + end + + let double_field v n = + match v with + | Local obj -> Obj.double_field obj n + | Remote v -> + output_char !conn.io_out 'F'; + output_remote_value !conn.io_out v; + output_binary_int !conn.io_out n; + flush !conn.io_out; + if input_byte !conn.io_in = 0 then + raise Marshalling_error + else begin + let buf = really_input_string !conn.io_in 8 in + let floatbuf = float n (* force allocation of a new float *) in + String.unsafe_blit buf 0 (Obj.magic floatbuf) 0 8; + floatbuf + end + + let double_array_tag = Obj.double_array_tag + + let of_int n = + Local(Obj.repr n) + + let local pos = + output_char !conn.io_out 'L'; + output_binary_int !conn.io_out pos; + flush !conn.io_out; + Remote(input_remote_value !conn.io_in) + + let from_environment pos = + output_char !conn.io_out 'E'; + output_binary_int !conn.io_out pos; + flush !conn.io_out; + Remote(input_remote_value !conn.io_in) + + let global pos = + output_char !conn.io_out 'G'; + output_binary_int !conn.io_out pos; + flush !conn.io_out; + Remote(input_remote_value !conn.io_in) + + let accu () = + output_char !conn.io_out 'A'; + flush !conn.io_out; + Remote(input_remote_value !conn.io_in) + + let closure_code = function + | Local _ -> assert false + | Remote v -> + output_char !conn.io_out 'C'; + output_remote_value !conn.io_out v; + flush !conn.io_out; + let frag = input_binary_int !conn.io_in in + let pos = input_binary_int !conn.io_in in + {frag;pos} + + let same rv1 rv2 = + match (rv1, rv2) with + (Local obj1, Local obj2) -> obj1 == obj2 + | (Remote v1, Remote v2) -> v1 = v2 + (* string equality -> equality of remote pointers *) + | (_, _) -> false + + let pointer rv = + match rv with + | Remote v -> + let bytes = ref [] in + String.iter (fun c -> bytes := c :: !bytes) v; + let obytes = if Sys.big_endian then List.rev !bytes else !bytes in + let to_hex c = Printf.sprintf "%02x" (Char.code c) in + String.concat "" (List.map to_hex obytes) + | Local _ -> "" + + end diff --git a/ocaml/debugger4/debugcom.mli b/ocaml/debugger4/debugcom.mli new file mode 100644 index 00000000000..e9d19edae1f --- /dev/null +++ b/ocaml/debugger4/debugcom.mli @@ -0,0 +1,139 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Low-level communication with the debuggee *) + +module Sp : sig +(* BACKPORT BEGIN + type t +*) + type t = int +(* BACKPORT END *) + val null : t + val base : t -> int -> t + val compare : t -> t -> int +end + +type pc = + { frag : int; + pos : int; } + +val main_frag : int + +type execution_summary = + Event + | Breakpoint + | Exited + | Trap_barrier + | Uncaught_exc + | Debug_info of Instruct.debug_event list array + | Code_loaded of int + | Code_unloaded of int + +type report = + { rep_type : execution_summary; + rep_event_count : int64; + rep_stack_pointer : Sp.t; + rep_program_pointer : pc } + +type checkpoint_report = + Checkpoint_done of int + | Checkpoint_failed + +type follow_fork_mode = + Fork_child + | Fork_parent + +(* Set the current connection with the debuggee *) +val set_current_connection : Primitives.io_channel -> unit + +(* Put an event at given pc *) +val set_event : pc -> unit + +(* Put a breakpoint at given pc *) +val set_breakpoint : pc -> unit + +(* Remove breakpoint or event at given pc *) +val reset_instr : pc -> unit + +(* Create a new checkpoint (the current process forks). *) +val do_checkpoint : unit -> checkpoint_report + +(* Step N events. *) +val do_go : int64 -> report + +(* Tell given process to terminate *) +val stop : Primitives.io_channel -> unit + +(* Tell given process to wait for its children *) +val wait_child : Primitives.io_channel -> unit + +(* Move to initial frame (that of current function). *) +(* Return stack position and current pc *) +val initial_frame : unit -> Sp.t * pc +val set_initial_frame : unit -> unit + +(* Get the current frame position *) +(* Return stack position and current pc *) +val get_frame : unit -> Sp.t * pc + +(* Set the current frame *) +val set_frame : Sp.t -> unit + +(* Move up one frame *) +(* Return stack position and current pc. + If there's no frame above, return (null_sp, _). + The argument is the size of the current frame. + *) +val up_frame : int -> Sp.t * pc + +(* Set the trap barrier to given stack position. *) +val set_trap_barrier : Sp.t -> unit + +(* Set whether the debugger follow the child or the parent process on fork *) +val fork_mode : follow_fork_mode ref +val update_follow_fork_mode : unit -> unit + +(* Handling of remote values *) + +exception Marshalling_error + +module Remote_value : + sig + type t + + val repr : 'a -> t + val obj : t -> 'a + val is_block : t -> bool + val tag : t -> int + val size : t -> int + val field : t -> int -> t + val double_field : t -> int -> float + val double_array_tag : int + val same : t -> t -> bool + + val of_int : int -> t + + val local : int -> t + val from_environment : int -> t + val global : int -> t + val accu : unit -> t + val closure_code : t -> pc + + (* Returns a hexadecimal representation of the remote address, + or [""] if the value is local. *) + val pointer : t -> string + end diff --git a/ocaml/debugger4/debugger_config.ml b/ocaml/debugger4/debugger_config.ml new file mode 100644 index 00000000000..9677bb0c514 --- /dev/null +++ b/ocaml/debugger4/debugger_config.ml @@ -0,0 +1,90 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(**************************** Configuration file ***********************) + +open Int64ops + +exception Toplevel + +(*** Miscellaneous parameters. ***) + +(*ISO 6429 color sequences +00 to restore default color +01 for brighter colors +04 for underlined text +05 for flashing text +30 for black foreground +31 for red foreground +32 for green foreground +33 for yellow (or brown) foreground +34 for blue foreground +35 for purple foreground +36 for cyan foreground +37 for white (or gray) foreground +40 for black background +41 for red background +42 for green background +43 for yellow (or brown) background +44 for blue background +45 for purple background +46 for cyan background +47 for white (or gray) background +let debugger_prompt = "\027[1;04m(ocd)\027[0m " +and event_mark_before = "\027[1;31m$\027[0m" +and event_mark_after = "\027[1;34m$\027[0m" +*) +let debugger_prompt = "(ocd) " +let event_mark_before = "<|b|>" +let event_mark_after = "<|a|>" + +(* Name of shell used to launch the debuggee *) +let shell = + match Sys.os_type with + "Win32" -> "cmd" + | _ -> "/bin/sh" + +(* Name of the OCaml runtime. *) +let runtime_program = "ocamlrun" + +(* Time history size (for `last') *) +let history_size = ref 30 + +let load_path_for = Hashtbl.create 7 + +(*** Time travel parameters. ***) + +(* Step between checkpoints for long displacements.*) +let checkpoint_big_step = ref (~~ "10000") + +(* Idem for small ones. *) +let checkpoint_small_step = ref (~~ "1000") + +(* Maximum number of checkpoints. *) +let checkpoint_max_count = ref 15 + +(* Whether to keep checkpoints or not. *) +let make_checkpoints = ref + (match Sys.os_type with + "Win32" -> false + | _ -> true) + +(* Whether to break when new code is loaded. *) +let break_on_load = ref true + +(*** Environment variables for debuggee. ***) + +let environment = ref [] diff --git a/ocaml/debugger4/debugger_config.mli b/ocaml/debugger4/debugger_config.mli new file mode 100644 index 00000000000..9db86e93300 --- /dev/null +++ b/ocaml/debugger4/debugger_config.mli @@ -0,0 +1,41 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(********************** Configuration file *****************************) + +exception Toplevel + +(*** Miscellaneous parameters. ***) + +val debugger_prompt : string +val event_mark_before : string +val event_mark_after : string +val shell : string +val runtime_program : string +val history_size : int ref +val load_path_for : (string, string list) Hashtbl.t + +(*** Time travel parameters. ***) + +val checkpoint_big_step : int64 ref +val checkpoint_small_step : int64 ref +val checkpoint_max_count : int ref +val make_checkpoints : bool ref +val break_on_load : bool ref + +(*** Environment variables for debuggee. ***) + +val environment : (string * string) list ref diff --git a/ocaml/debugger4/debugger_lexer.mli b/ocaml/debugger4/debugger_lexer.mli new file mode 100644 index 00000000000..0c364d687b9 --- /dev/null +++ b/ocaml/debugger4/debugger_lexer.mli @@ -0,0 +1,22 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +exception Int_overflow + +val line: Lexing.lexbuf -> string +val lexeme: Lexing.lexbuf -> Debugger_parser.token +val argument: Lexing.lexbuf -> Debugger_parser.token +val line_argument: Lexing.lexbuf -> Debugger_parser.token diff --git a/ocaml/debugger4/debugger_lexer.mll b/ocaml/debugger4/debugger_lexer.mll new file mode 100644 index 00000000000..a180427225c --- /dev/null +++ b/ocaml/debugger4/debugger_lexer.mll @@ -0,0 +1,104 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +{ + +open Debugger_parser + +exception Int_overflow + +} + +rule line = (* Read a whole line *) + parse + ([ ^ '\n' '\r' ]* as s) ('\n' | '\r' | "\r\n") + { s } + | [ ^ '\n' '\r' ]* + { Lexing.lexeme lexbuf } + | eof + { raise Exit } + +and argument = (* Read a raw argument *) + parse + [ ^ ' ' '\t' ]+ + { ARGUMENT (Lexing.lexeme lexbuf) } + | [' ' '\t']+ + { argument lexbuf } + | eof + { EOL } + | _ + { raise Parsing.Parse_error } + +and line_argument = + parse + _ * + { ARGUMENT (Lexing.lexeme lexbuf) } + | eof + { EOL } + +and lexeme = (* Read a lexeme *) + parse + [' ' '\t'] + + { lexeme lexbuf } + | ['a'-'z' '\223'-'\246' '\248'-'\255' '_'] + (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' + '\'' '0'-'9' ]) * + { LIDENT(Lexing.lexeme lexbuf) } + | ['A'-'Z' '\192'-'\214' '\216'-'\222' ] + (['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' + '\'' '0'-'9' ]) * + { UIDENT(Lexing.lexeme lexbuf) } + | '"' [^ '"']* "\"" + { let s = Lexing.lexeme lexbuf in + LIDENT(String.sub s 1 (String.length s - 2)) } + | ['0'-'9']+ + | '0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']+ + | '0' ['o' 'O'] ['0'-'7']+ + | '0' ['b' 'B'] ['0'-'1']+ + { try INTEGER (Int64.of_string (Lexing.lexeme lexbuf)) + with Failure _ -> raise Int_overflow + } + | '*' + { STAR } + | "-" + { MINUS } + | "." + { DOT } + | "#" + { HASH } + | "@" + { AT } + | "$" + { DOLLAR } + | ":" + { COLON } + | "!" + { BANG } + | "(" + { LPAREN } + | ")" + { RPAREN } + | "[" + { LBRACKET } + | "]" + { RBRACKET } + | ['!' '?' '~' '=' '<' '>' '|' '&' '$' '@' '^' '+' '-' '*' '/' '%'] + ['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] * + { OPERATOR (Lexing.lexeme lexbuf) } + | eof + { EOL } + | _ + { raise Parsing.Parse_error } diff --git a/ocaml/debugger4/debugger_parser.mly b/ocaml/debugger4/debugger_parser.mly new file mode 100644 index 00000000000..973b761983e --- /dev/null +++ b/ocaml/debugger4/debugger_parser.mly @@ -0,0 +1,261 @@ +/**************************************************************************/ +/* */ +/* OCaml */ +/* */ +/* Jerome Vouillon, projet Cristal, INRIA Rocquencourt */ +/* OCaml port by John Malecki and Xavier Leroy */ +/* */ +/* Copyright 1996 Institut National de Recherche en Informatique et */ +/* en Automatique. */ +/* */ +/* All rights reserved. This file is distributed under the terms of */ +/* the GNU Lesser General Public License version 2.1, with the */ +/* special exception on linking described in the file LICENSE. */ +/* */ +/**************************************************************************/ + +%{ + +open Int64ops +open Input_handling +open Longident +open Parser_aux +open Debugcom + +%} + +%token ARGUMENT +%token LIDENT +%token UIDENT +%token OPERATOR +%token INTEGER +%token STAR /* * */ +%token MINUS /* - */ +%token DOT /* . */ +%token COLON /* : */ +%token HASH /* # */ +%token AT /* @ */ +%token DOLLAR /* $ */ +%token BANG /* ! */ +%token LPAREN /* ( */ +%token RPAREN /* ) */ +%token LBRACKET /* [ */ +%token RBRACKET /* ] */ +%token EOL + +%right DOT +%right BANG + +%start argument_list_eol +%type argument_list_eol + +%start argument_eol +%type argument_eol + +%start integer_list_eol +%type integer_list_eol + +%start integer_eol +%type integer_eol + +%start int64_eol +%type int64_eol + +%start integer +%type integer + +%start opt_integer_eol +%type opt_integer_eol + +%start opt_signed_integer_eol +%type opt_signed_integer_eol + +%start opt_signed_int64_eol +%type opt_signed_int64_eol + +%start identifier +%type identifier + +%start identifier_eol +%type identifier_eol + +%start identifier_or_eol +%type identifier_or_eol + +%start opt_identifier +%type opt_identifier + +%start opt_identifier_eol +%type opt_identifier_eol + +%start expression_list_eol +%type expression_list_eol + +%start break_argument_eol +%type break_argument_eol + +%start list_arguments_eol +%type list_arguments_eol + +%start end_of_line +%type end_of_line + +%start longident_eol +%type longident_eol + +%start opt_longident +%type opt_longident + +%start opt_longident_eol +%type opt_longident_eol + +%% + +/* Raw arguments */ + +argument_list_eol : + ARGUMENT argument_list_eol + { $1::$2 } + | end_of_line + { [] }; + +argument_eol : + ARGUMENT end_of_line + { $1 }; + +/* Integer */ + +integer_list_eol : + INTEGER integer_list_eol + { (to_int $1) :: $2 } + | end_of_line + { [] }; + +integer_eol : + INTEGER end_of_line + { to_int $1 }; + +int64_eol : + INTEGER end_of_line + { $1 }; + +integer : + INTEGER + { to_int $1 }; + +opt_integer_eol : + INTEGER end_of_line + { Some (to_int $1) } + | end_of_line + { None }; + +opt_int64_eol : + INTEGER end_of_line + { Some $1 } + | end_of_line + { None }; + +opt_signed_integer_eol : + MINUS integer_eol + { Some (- $2) } + | opt_integer_eol + { $1 }; + +opt_signed_int64_eol : + MINUS int64_eol + { Some (Int64.neg $2) } + | opt_int64_eol + { $1 }; + +/* Identifiers and long identifiers */ + +longident : + LIDENT { Lident $1 } + | module_path DOT LIDENT { Ldot($1, $3) } + | OPERATOR { Lident $1 } + | module_path DOT OPERATOR { Ldot($1, $3) } + | module_path DOT LPAREN OPERATOR RPAREN { Ldot($1, $4) } +; + +module_path : + UIDENT { Lident $1 } + | module_path DOT UIDENT { Ldot($1, $3) } +; + +longident_eol : + longident end_of_line { $1 }; + +opt_longident : + UIDENT { Some (Lident $1) } + | LIDENT { Some (Lident $1) } + | module_path DOT UIDENT { Some (Ldot($1, $3)) } + | { None }; + +opt_longident_eol : + opt_longident end_of_line { $1 }; + +identifier : + LIDENT { $1 } + | UIDENT { $1 }; + +identifier_eol : + identifier end_of_line { $1 }; + +identifier_or_eol : + identifier { Some $1 } + | end_of_line { None }; + +opt_identifier : + identifier { Some $1 } + | { None }; + +opt_identifier_eol : + opt_identifier end_of_line { $1 }; + +/* Expressions */ + +expression: + longident { E_ident $1 } + | STAR { E_result } + | DOLLAR INTEGER { E_name (to_int $2) } + | expression DOT INTEGER { E_item($1, (to_int $3)) } + | expression DOT LBRACKET INTEGER RBRACKET { E_item($1, (to_int $4)) } + | expression DOT LPAREN INTEGER RPAREN { E_item($1, (to_int $4)) } + | expression DOT LIDENT { E_field($1, $3) } + | BANG expression { E_field($2, "contents") } + | LPAREN expression RPAREN { $2 } +; + +/* Lists of expressions */ + +expression_list_eol : + expression expression_list_eol { $1::$2 } + | end_of_line { [] } +; + +/* Arguments for breakpoint */ + +break_argument_eol : + end_of_line { BA_none } + | integer_eol { BA_pc {frag = main_frag; + pos = $1} } + | INTEGER COLON integer_eol { BA_pc {frag = to_int $1; + pos = $3} } + | expression end_of_line { BA_function $1 } + | AT opt_longident INTEGER opt_integer_eol { BA_pos1 ($2, (to_int $3), $4)} + | AT opt_longident HASH integer_eol { BA_pos2 ($2, $4) } +; + +/* Arguments for list */ + +list_arguments_eol : + opt_longident integer opt_integer_eol + { ($1, Some $2, $3) } + | opt_longident_eol + { ($1, None, None) }; + +/* End of line */ + +end_of_line : + EOL { stop_user_input () } +; diff --git a/ocaml/debugger4/dune b/ocaml/debugger4/dune new file mode 100644 index 00000000000..8e0a61738ca --- /dev/null +++ b/ocaml/debugger4/dune @@ -0,0 +1,34 @@ +;************************************************************************** +;* * +;* OCaml * +;* * +;* Thomas Refis, Jane Street Europe * +;* * +;* Copyright 2018 Jane Street Group LLC * +;* * +;* All rights reserved. This file is distributed under the terms of * +;* the GNU Lesser General Public License version 2.1, with the * +;* special exception on linking described in the file LICENSE. * +;* * +;************************************************************************** + +(ocamllex debugger_lexer) +(ocamlyacc debugger_parser) + +(library + (name ocamldebug) + (flags (:standard -principal -w -9)) + (modules (:standard \ ocamldebug_entry)) + (modules_without_implementation parser_aux) + (libraries ocamlcommon ocamltoplevel unix dynlink_internal)) + +(executable + (name ocamldebug_entry) + (modes byte) + (modules ocamldebug_entry) + (libraries unix ocamldebug)) + +(install + (files (ocamldebug_entry.bc as ocamldebug)) + (section bin) + (package ocaml)) diff --git a/ocaml/debugger4/eval.ml b/ocaml/debugger4/eval.ml new file mode 100644 index 00000000000..02a506acf89 --- /dev/null +++ b/ocaml/debugger4/eval.ml @@ -0,0 +1,225 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Misc +open Path +open Instruct +open Types +open Parser_aux +open Events + +type error = + Unbound_identifier of Ident.t + | Not_initialized_yet of Path.t + | Unbound_long_identifier of Longident.t + | Unknown_name of int + | Tuple_index of type_expr * int * int + | Array_index of int * int + | List_index of int * int + | String_index of string * int * int + | Wrong_item_type of type_expr * int + | Wrong_label of type_expr * string + | Not_a_record of type_expr + | No_result + +exception Error of error + +let abstract_type = + Btype.newgenty (Tconstr (Pident (Ident.create_local ""), [], ref Mnil)) + +let get_global_or_predef id = + try + Debugcom.Remote_value.global (Symtable.get_global_position id) + with Symtable.Error _ -> raise(Error(Unbound_identifier id)) + +let rec address path event = function + | Env.Aunit cu -> + get_global_or_predef (cu |> Compilation_unit.to_global_ident_for_bytecode) + | Env.Alocal id -> + if Ident.is_predef id then get_global_or_predef id + else + begin match event with + Some {ev_ev = ev} -> + begin try + let pos = Ident.find_same id ev.ev_compenv.ce_stack in + Debugcom.Remote_value.local (ev.ev_stacksize - pos) + with Not_found -> + try + let pos = Ident.find_same id ev.ev_compenv.ce_heap in + Debugcom.Remote_value.from_environment pos + with Not_found -> + raise(Error(Unbound_identifier id)) + end + | None -> + raise(Error(Unbound_identifier id)) + end + | Env.Adot(root, pos) -> + let v = address path event root in + if not (Debugcom.Remote_value.is_block v) then + raise(Error(Not_initialized_yet path)); + Debugcom.Remote_value.field v pos + +let value_path event env path = + match Env.find_value_address path env with + | addr -> address path event addr + | exception Not_found -> + fatal_error ("Cannot find address for: " ^ (Path.name path)) + +let rec expression event env = function + | E_ident lid -> begin + match Env.find_value_by_name lid env with + | (p, valdesc) -> + let v = + match valdesc.val_kind with + | Val_ivar (_, cl_num) -> + let (p0, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + let v = value_path event env p0 in + let i = value_path event env p in + Debugcom.Remote_value.field v (Debugcom.Remote_value.obj i) + | _ -> + value_path event env p + in + let typ = Ctype.correct_levels valdesc.val_type in + v, typ + | exception Not_found -> + raise(Error(Unbound_long_identifier lid)) + end + | E_result -> + begin match event with + Some {ev_ev = {ev_kind = Event_after ty; ev_typsubst = subst}} + when !Frames.current_frame = 0 -> + (Debugcom.Remote_value.accu(), Subst.type_expr subst ty) + | _ -> + raise(Error(No_result)) + end + | E_name n -> + begin try + Printval.find_named_value n + with Not_found -> + raise(Error(Unknown_name n)) + end + | E_item(arg, n) -> + let (v, ty) = expression event env arg in + begin match get_desc (Ctype.expand_head_opt env ty) with + Ttuple ty_list -> + if n < 1 || n > List.length ty_list + then raise(Error(Tuple_index(ty, List.length ty_list, n))) + (* CR labeled tuples: handle labels in debugger (also see "E_field" + case) *) + else (Debugcom.Remote_value.field v (n-1), + snd (List.nth ty_list (n-1))) + | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_array -> + let size = Debugcom.Remote_value.size v in + if n >= size + then raise(Error(Array_index(size, n))) + else (Debugcom.Remote_value.field v n, ty_arg) + | Tconstr(path, [ty_arg], _) when Path.same path Predef.path_list -> + let rec nth pos v = + if not (Debugcom.Remote_value.is_block v) then + raise(Error(List_index(pos, n))) + else if pos = n then + (Debugcom.Remote_value.field v 0, ty_arg) + else + nth (pos + 1) (Debugcom.Remote_value.field v 1) + in nth 0 v + | Tconstr(path, [], _) when Path.same path Predef.path_string -> + let s = (Debugcom.Remote_value.obj v : string) in + if n >= String.length s + then raise(Error(String_index(s, String.length s, n))) + else (Debugcom.Remote_value.of_int(Char.code s.[n]), + Predef.type_char) + | _ -> + raise(Error(Wrong_item_type(ty, n))) + end + | E_field(arg, lbl) -> + let (v, ty) = expression event env arg in + begin match get_desc (Ctype.expand_head_opt env ty) with + Tconstr(path, _, _) -> + let tydesc = Env.find_type path env in + begin match tydesc.type_kind with + Type_record(lbl_list, _repr) -> + let (pos, ty_res) = + find_label lbl env ty path tydesc 0 lbl_list in + (Debugcom.Remote_value.field v pos, ty_res) + | _ -> raise(Error(Not_a_record ty)) + end + | _ -> raise(Error(Not_a_record ty)) + end + +and find_label lbl env ty path tydesc pos = function + [] -> + raise(Error(Wrong_label(ty, lbl))) + | {ld_id; ld_type} :: rem -> + if Ident.name ld_id = lbl then begin + let ty_res = + Btype.newgenty(Tconstr(path, tydesc.type_params, ref Mnil)) + in + (pos, + try Ctype.apply env [ty_res] ld_type [ty] with Ctype.Cannot_apply -> + abstract_type) + end else + find_label lbl env ty path tydesc (pos + 1) rem + +(* Error report *) + +open Format + +let report_error ppf = function + | Unbound_identifier id -> + fprintf ppf "@[Unbound identifier %s@]@." (Ident.name id) + | Not_initialized_yet path -> + fprintf ppf + "@[The module path %a is not yet initialized.@ \ + Please run program forward@ \ + until its initialization code is executed.@]@." + Printtyp.path path + | Unbound_long_identifier lid -> + fprintf ppf "@[Unbound identifier %a@]@." Printtyp.longident lid + | Unknown_name n -> + fprintf ppf "@[Unknown value name $%i@]@." n + | Tuple_index(ty, len, pos) -> + fprintf ppf + "@[Cannot extract field number %i from a %i-tuple of type@ %a@]@." + pos len Printtyp.type_expr ty + | Array_index(len, pos) -> + fprintf ppf + "@[Cannot extract element number %i from an array of length %i@]@." + pos len + | List_index(len, pos) -> + fprintf ppf + "@[Cannot extract element number %i from a list of length %i@]@." + pos len + | String_index(s, len, pos) -> + fprintf ppf + "@[Cannot extract character number %i@ \ + from the following string of length %i:@ %S@]@." + pos len s + | Wrong_item_type(ty, pos) -> + fprintf ppf + "@[Cannot extract item number %i from a value of type@ %a@]@." + pos Printtyp.type_expr ty + | Wrong_label(ty, lbl) -> + fprintf ppf + "@[The record type@ %a@ has no label named %s@]@." + Printtyp.type_expr ty lbl + | Not_a_record ty -> + fprintf ppf + "@[The type@ %a@ is not a record type@]@." Printtyp.type_expr ty + | No_result -> + fprintf ppf "@[No result available at current program event@]@." diff --git a/ocaml/debugger4/eval.mli b/ocaml/debugger4/eval.mli new file mode 100644 index 00000000000..6aa8cb1ff43 --- /dev/null +++ b/ocaml/debugger4/eval.mli @@ -0,0 +1,41 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types +open Parser_aux +open Format + +val expression : + Events.code_event option -> Env.t -> expression -> + Debugcom.Remote_value.t * type_expr + +type error = + | Unbound_identifier of Ident.t + | Not_initialized_yet of Path.t + | Unbound_long_identifier of Longident.t + | Unknown_name of int + | Tuple_index of type_expr * int * int + | Array_index of int * int + | List_index of int * int + | String_index of string * int * int + | Wrong_item_type of type_expr * int + | Wrong_label of type_expr * string + | Not_a_record of type_expr + | No_result + +exception Error of error + +val report_error: formatter -> error -> unit diff --git a/ocaml/debugger4/events.ml b/ocaml/debugger4/events.ml new file mode 100644 index 00000000000..411ae2e7681 --- /dev/null +++ b/ocaml/debugger4/events.ml @@ -0,0 +1,52 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(********************************* Events ******************************) + +open Instruct + +type code_event = + { ev_frag : int; + ev_ev : Instruct.debug_event } + +let get_pos ev = + match ev.ev_kind with + | Event_before -> ev.ev_loc.Location.loc_start + | Event_after _ -> ev.ev_loc.Location.loc_end + | _ -> ev.ev_loc.Location.loc_start + + +(*** Current events. ***) + +(* Event at current position *) +let current_event = + ref (None : code_event option) + +(* Current position in source. *) +(* Raise `Not_found' if not on an event (beginning or end of program). *) +let get_current_event () = + match !current_event with + | None -> raise Not_found + | Some ev -> ev + +let current_event_is_before () = + match !current_event with + None -> + raise Not_found + | Some {ev_ev = {ev_kind = Event_before}} -> + true + | _ -> + false diff --git a/ocaml/debugger4/events.mli b/ocaml/debugger4/events.mli new file mode 100644 index 00000000000..3d3f190aec3 --- /dev/null +++ b/ocaml/debugger4/events.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Instruct + +(* A debug event associated with a code fragment. *) +type code_event = + { ev_frag : int; + ev_ev : Instruct.debug_event } + +val get_pos : debug_event -> Lexing.position + +(** Current events. **) + +(* The event at current position. *) +val current_event : code_event option ref + +(* Current position in source. *) +(* Raise `Not_found' if not on an event (beginning or end of program). *) +val get_current_event : unit -> code_event + +val current_event_is_before : unit -> bool diff --git a/ocaml/debugger4/exec.ml b/ocaml/debugger4/exec.ml new file mode 100644 index 00000000000..df940165e5d --- /dev/null +++ b/ocaml/debugger4/exec.ml @@ -0,0 +1,54 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Handling of keyboard interrupts *) + +let interrupted = ref false + +let is_protected = ref false + +let break _signum = + if !is_protected + then interrupted := true + else raise Sys.Break + +let _ = + match Sys.os_type with + "Win32" -> () + | _ -> + Sys.set_signal Sys.sigint (Sys.Signal_handle break); + Sys.set_signal Sys.sigpipe (Sys.Signal_handle(fun _ -> raise End_of_file)) + +let protect f = + if !is_protected then + f () + else begin + is_protected := true; + if not !interrupted then + f (); + is_protected := false; + if !interrupted then begin interrupted := false; raise Sys.Break end + end + +let unprotect f = + if not !is_protected then + f () + else begin + is_protected := false; + if !interrupted then begin interrupted := false; raise Sys.Break end; + f (); + is_protected := true + end diff --git a/ocaml/otherlibs/systhreads4/mutex.ml b/ocaml/debugger4/exec.mli similarity index 74% rename from ocaml/otherlibs/systhreads4/mutex.ml rename to ocaml/debugger4/exec.mli index 836109e761b..05e2e5f8d4c 100644 --- a/ocaml/otherlibs/systhreads4/mutex.ml +++ b/ocaml/debugger4/exec.mli @@ -2,9 +2,10 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) (* *) -(* Copyright 1995 Institut National de Recherche en Informatique et *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) @@ -13,8 +14,7 @@ (* *) (**************************************************************************) -type t -external create: unit -> t = "caml_mutex_new" -external lock: t -> unit = "caml_mutex_lock" -external try_lock: t -> bool = "caml_mutex_try_lock" -external unlock: t -> unit = "caml_mutex_unlock" +(* Handling of keyboard interrupts *) + +val protect : (unit -> unit) -> unit +val unprotect : (unit -> unit) -> unit diff --git a/ocaml/debugger4/frames.ml b/ocaml/debugger4/frames.ml new file mode 100644 index 00000000000..364fa4ca71d --- /dev/null +++ b/ocaml/debugger4/frames.ml @@ -0,0 +1,138 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(***************************** Frames **********************************) + +open Instruct +open Debugcom +open Events +open Symbols + +(* Current frame number *) +let current_frame = ref 0 + +(* Event at selected position *) +let selected_event = ref (None : code_event option) + +(* Selected position in source. *) +(* Raise `Not_found' if not on an event. *) +let selected_point () = + match !selected_event with + None -> + raise Not_found + | Some {ev_ev=ev} -> + (ev.ev_module, + (Events.get_pos ev).Lexing.pos_lnum, + (Events.get_pos ev).Lexing.pos_cnum - (Events.get_pos ev).Lexing.pos_bol) + +let selected_event_is_before () = + match !selected_event with + None -> + raise Not_found + | Some {ev_ev={ev_kind = Event_before}} -> + true + | _ -> + false + +(* Move up `frame_count' frames, assuming current frame pointer + corresponds to event `event'. Return event of final frame. *) + +let rec move_up frame_count event = + if frame_count <= 0 then event else begin + let (sp, pc) = up_frame event.ev_ev.ev_stacksize in +(* BACKPORT BEGIN + if sp = Sp.null then raise Not_found; +*) + if sp < Sp.null then raise Not_found; +(* BACKPORT END *) + move_up (frame_count - 1) (any_event_at_pc pc) + end + +(* Select a frame. *) +(* Raise `Not_found' if no such frame. *) +(* --- Assume the current events have already been updated. *) +let select_frame frame_number = + if frame_number < 0 then raise Not_found; + let (initial_sp, _) = get_frame() in + try + match !current_event with + None -> + raise Not_found + | Some curr_event -> + match !selected_event with + Some sel_event when frame_number >= !current_frame -> + selected_event := + Some(move_up (frame_number - !current_frame) sel_event); + current_frame := frame_number + | _ -> + set_initial_frame(); + selected_event := Some(move_up frame_number curr_event); + current_frame := frame_number + with Not_found -> + set_frame initial_sp; + raise Not_found + +(* Select a frame. *) +(* Same as `select_frame' but raise no exception if the frame is not found. *) +(* --- Assume the currents events have already been updated. *) +let try_select_frame frame_number = + try + select_frame frame_number + with + Not_found -> + () + +(* Return to default frame (frame 0). *) +let reset_frame () = + set_initial_frame(); + selected_event := !current_event; + current_frame := 0 + +(* Perform a stack backtrace. + Call the given function with the events for each stack frame, + or None if we've encountered a stack frame with no debugging info + attached. Stop when the function returns false, or frame with no + debugging info reached, or top of stack reached. *) + +let do_backtrace action = + match !current_event with + None -> Misc.fatal_error "Frames.do_backtrace" + | Some ev -> + let (initial_sp, _) = get_frame() in + set_initial_frame(); + let event = ref ev in + begin try + while action (Some !event) do + let (sp, pc) = up_frame !event.ev_ev.ev_stacksize in +(* BACKPORT BEGIN + if sp = Sp.null then raise Exit; +*) + if sp < Sp.null then raise Exit; +(* BACKPORT END *) + event := any_event_at_pc pc + done + with Exit -> () + | Not_found -> ignore (action None) + end; + set_frame initial_sp + +(* Return the number of frames in the stack *) + +let stack_depth () = + let num_frames = ref 0 in + do_backtrace (function Some _ev -> incr num_frames; true + | None -> num_frames := -1; false); + !num_frames diff --git a/ocaml/debugger4/frames.mli b/ocaml/debugger4/frames.mli new file mode 100644 index 00000000000..08fd326cc8d --- /dev/null +++ b/ocaml/debugger4/frames.mli @@ -0,0 +1,55 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(****************************** Frames *********************************) + +open Events + +(* Current frame number *) +val current_frame : int ref + +(* Fragment and event at selected position. *) +val selected_event : code_event option ref + +(* Selected position in source (module, line, column). *) +(* Raise `Not_found' if not on an event. *) +val selected_point : unit -> string * int * int + +val selected_event_is_before : unit -> bool + +(* Select a frame. *) +(* Raise `Not_found' if no such frame. *) +(* --- Assume the currents events have already been updated. *) +val select_frame : int -> unit + +(* Select a frame. *) +(* Same as `select_frame' but raise no exception if the frame is not found. *) +(* --- Assume the currents events have already been updated. *) +val try_select_frame : int -> unit + +(* Return to default frame (frame 0). *) +val reset_frame : unit -> unit + +(* Perform a stack backtrace. + Call the given function with the events for each stack frame, + or None if we've encountered a stack frame with no debugging info + attached. Stop when the function returns false, or frame with no + debugging info reached, or top of stack reached. *) +val do_backtrace : (code_event option -> bool) -> unit + +(* Return the number of frames in the stack, or (-1) if it can't be + determined because some frames have no debugging info. *) +val stack_depth : unit -> int diff --git a/ocaml/debugger4/history.ml b/ocaml/debugger4/history.ml new file mode 100644 index 00000000000..0ece812b3ee --- /dev/null +++ b/ocaml/debugger4/history.ml @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Int64ops +open Checkpoints +open Primitives +open Debugger_config + +let history = ref ([] : int64 list) + +let empty_history () = + history := [] + +let add_current_time () = + let time = current_time () in + if !history = [] then + history := [time] + else if time <> List.hd !history then + history := list_truncate !history_size (time::!history) + +let previous_time_1 () = + match !history with + _::((time::_) as hist) -> + history := hist; time + | _ -> + prerr_endline "No more information."; raise Toplevel + +let rec previous_time n = + if n = _1 + then previous_time_1() + else begin ignore(previous_time_1()); previous_time(pre64 n) end diff --git a/ocaml/debugger4/history.mli b/ocaml/debugger4/history.mli new file mode 100644 index 00000000000..a184e7b99bf --- /dev/null +++ b/ocaml/debugger4/history.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val empty_history : unit -> unit + +val add_current_time : unit -> unit + +val previous_time : int64 -> int64 diff --git a/ocaml/debugger4/input_handling.ml b/ocaml/debugger4/input_handling.ml new file mode 100644 index 00000000000..5b43ba96151 --- /dev/null +++ b/ocaml/debugger4/input_handling.ml @@ -0,0 +1,108 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(**************************** Input control ****************************) + +open Unix +open Primitives + +(*** Actives files. ***) + +(* List of the actives files. *) +let active_files = + ref ([] : (file_descr * ((io_channel -> unit) * io_channel)) list) + +(* Add a file to the list of actives files. *) +let add_file file controller = + active_files := (file.io_fd, (controller, file))::!active_files + +(* Remove a file from the list of actives files. *) +let remove_file file = + active_files := List.remove_assoc file.io_fd !active_files + +(* Change the controller for the given file. *) +let change_controller file controller = + remove_file file; add_file file controller + +(* Return the controller currently attached to the given file. *) +let current_controller file = + fst (List.assoc file.io_fd !active_files) + +(* Execute a function with `controller' attached to `file'. *) +(* ### controller file funct *) +let execute_with_other_controller controller file funct = + let old_controller = current_controller file in + change_controller file controller; + let finally () = change_controller file old_controller in + Fun.protect ~finally funct + +(*** The "Main Loop" ***) + +let continue_main_loop = + ref true + +let exit_main_loop _ = + continue_main_loop := false + +(* Handle active files until `continue_main_loop' is false. *) +let main_loop () = + let finally = + let old_state = !continue_main_loop in + fun () -> continue_main_loop := old_state + in + Fun.protect ~finally @@ fun () -> + continue_main_loop := true; + while !continue_main_loop do + try + let (input, _, _) = + select (List.map fst !active_files) [] [] (-1.) + in + List.iter + (function fd -> + let (funct, iochan) = (List.assoc fd !active_files) in + funct iochan) + input + with + Unix_error (EINTR, _, _) -> () + done + +(*** Managing user inputs ***) + +(* Are we in interactive mode ? *) +let interactif = ref true + +let current_prompt = ref "" + +(* Where the user input come from. *) +let user_channel = ref std_io + +let read_user_input buffer length = + main_loop (); + input !user_channel.io_in buffer 0 length + +(* Stop reading user input. *) +let stop_user_input () = + remove_file !user_channel + +(* Resume reading user input. *) +let resume_user_input () = + if not (List.mem_assoc !user_channel.io_fd !active_files) then begin + if !interactif && !Parameters.prompt then begin + print_string !current_prompt; + flush Stdlib.stdout + end; + add_file !user_channel exit_main_loop + end diff --git a/ocaml/debugger4/input_handling.mli b/ocaml/debugger4/input_handling.mli new file mode 100644 index 00000000000..e333c785d76 --- /dev/null +++ b/ocaml/debugger4/input_handling.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(***************************** Input control ***************************) + +open Primitives + +(*** Actives files. ***) + +(* Add a file to the list of active files. *) +val add_file : io_channel -> (io_channel -> unit) -> unit + +(* Remove a file from the list of actives files. *) +val remove_file : io_channel -> unit + +(* Return the controller currently attached to the given file. *) +val current_controller : io_channel -> (io_channel -> unit) + +(* Execute a function with `controller' attached to `file'. *) +(* ### controller file funct *) +val execute_with_other_controller : + (io_channel -> unit) -> io_channel -> (unit -> 'a) -> 'a + +(*** The "Main Loop" ***) + +(* Call this function for exiting the main loop. *) +val exit_main_loop : 'a -> unit + +(* Handle active files until `continue_main_loop' is false. *) +val main_loop : unit -> unit + +(*** Managing user inputs ***) + +(* Are we in interactive mode ? *) +val interactif : bool ref + +val current_prompt : string ref + +(* Where the user input come from. *) +val user_channel : io_channel ref + +val read_user_input : bytes -> int -> int + +(* Stop reading user input. *) +val stop_user_input : unit -> unit + +(* Resume reading user input. *) +val resume_user_input : unit -> unit diff --git a/ocaml/debugger4/int64ops.ml b/ocaml/debugger4/int64ops.ml new file mode 100644 index 00000000000..64b6e843ee5 --- /dev/null +++ b/ocaml/debugger4/int64ops.ml @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(****************** arithmetic operators for Int64 *********************) + +let ( ++ ) = Int64.add +let ( -- ) = Int64.sub +let suc64 = Int64.succ +let pre64 = Int64.pred +let _0 = Int64.zero +let _1 = Int64.one +let _minus1 = Int64.minus_one +let ( ~~ ) = Int64.of_string +let max_small_int = Int64.of_int max_int +let to_int = Int64.to_int diff --git a/ocaml/debugger4/int64ops.mli b/ocaml/debugger4/int64ops.mli new file mode 100644 index 00000000000..e085a295b97 --- /dev/null +++ b/ocaml/debugger4/int64ops.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(****************** arithmetic operators for Int64 *********************) + +val ( ++ ) : int64 -> int64 -> int64 +val ( -- ) : int64 -> int64 -> int64 +val suc64 : int64 -> int64 +val pre64 : int64 -> int64 +val _0 : int64 +val _1 : int64 +val _minus1 : int64 +val ( ~~ ) : string -> int64 +val max_small_int : int64 +val to_int : int64 -> int diff --git a/ocaml/debugger4/loadprinter.ml b/ocaml/debugger4/loadprinter.ml new file mode 100644 index 00000000000..9768c0d0de3 --- /dev/null +++ b/ocaml/debugger4/loadprinter.ml @@ -0,0 +1,159 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Loading and installation of user-defined printer functions *) + +open Misc +open Types + +(* Error report *) + +type error = + | Load_failure of Dynlink.error + | Unbound_identifier of Longident.t + | Unavailable_module of string * Longident.t + | Wrong_type of Longident.t + | No_active_printer of Longident.t + +exception Error of error + +(* Load a .cmo or .cma file *) + +open Format + +let rec loadfiles ppf name = + try + let filename = Load_path.find name in + Dynlink.allow_unsafe_modules true; + Dynlink.loadfile filename; + let d = Filename.dirname name in + if d <> Filename.current_dir_name then begin + if not (List.mem d (Load_path.get_path_list ())) then + Load_path.add_dir ~hidden:false d; + end; + fprintf ppf "File %s loaded@." + (if d <> Filename.current_dir_name then + filename + else + Filename.basename filename); + true + with + | Dynlink.Error (Dynlink.Unavailable_unit unit) -> + loadfiles ppf (String.uncapitalize_ascii unit ^ ".cmo") + && + loadfiles ppf name + | Not_found -> + fprintf ppf "Cannot find file %s@." name; + false + | Sys_error msg -> + fprintf ppf "%s: %s@." name msg; + false + | Dynlink.Error e -> + raise(Error(Load_failure e)) + +let loadfile ppf name = + ignore(loadfiles ppf name) + +(* Return the value referred to by a path (as in toplevel/topdirs) *) +(* Note: evaluation proceeds in the debugger memory space, not in + the debuggee. *) + +let rec eval_address = function + | Env.Aunit cu -> + let bytecode_or_asm_symbol = + Ident.name (cu |> Compilation_unit.to_global_ident_for_bytecode) + in + begin match Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol with + | None -> + raise (Symtable.Error (Symtable.Undefined_global bytecode_or_asm_symbol)) + | Some obj -> obj + end + | Env.Alocal _ -> assert false + | Env.Adot(addr, pos) -> Obj.field (eval_address addr) pos + +let eval_value_path env path = + match Env.find_value_address path env with + | addr -> eval_address addr + | exception Not_found -> + fatal_error ("Cannot find address for: " ^ (Path.name path)) + +(* Install, remove a printer (as in toplevel/topdirs) *) + +let match_printer_type desc make_printer_type = + Ctype.with_local_level ~post:Ctype.generalize begin fun () -> + let ty_arg = Ctype.newvar Jkind.(value ~why:Debug_printer_argument) in + Ctype.unify (Lazy.force Env.initial) + (make_printer_type ty_arg) + (Ctype.instance desc.val_type); + ty_arg + end + +let find_printer_type lid = + match Env.find_value_by_name lid Env.empty with + | (path, desc) -> begin + match match_printer_type desc Topprinters.printer_type_new with + | ty_arg -> (ty_arg, path, false) + | exception Ctype.Unify _ -> begin + match match_printer_type desc Topprinters.printer_type_old with + | ty_arg -> (ty_arg, path, true) + | exception Ctype.Unify _ -> raise(Error(Wrong_type lid)) + end + end + | exception Not_found -> + raise(Error(Unbound_identifier lid)) + +let install_printer ppf lid = + let (ty_arg, path, is_old_style) = find_printer_type lid in + let v = + try + eval_value_path Env.empty path + with Symtable.Error(Symtable.Undefined_global s) -> + raise(Error(Unavailable_module(s, lid))) in + let print_function = + if is_old_style then + (fun _formatter repr -> Obj.obj v (Obj.obj repr)) + else + (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in + Printval.install_printer path ty_arg ppf print_function + +let remove_printer lid = + let (_ty_arg, path, _is_old_style) = find_printer_type lid in + try + Printval.remove_printer path + with Not_found -> + raise(Error(No_active_printer lid)) + +(* Error report *) + +open Format + +let report_error ppf = function + | Load_failure e -> + fprintf ppf "@[Error during code loading: %s@]@." + (Dynlink.error_message e) + | Unbound_identifier lid -> + fprintf ppf "@[Unbound identifier %a@]@." + Printtyp.longident lid + | Unavailable_module(md, lid) -> + fprintf ppf + "@[The debugger does not contain the code for@ %a.@ \ + Please load an implementation of %s first.@]@." + Printtyp.longident lid md + | Wrong_type lid -> + fprintf ppf "@[%a has the wrong type for a printing function.@]@." + Printtyp.longident lid + | No_active_printer lid -> + fprintf ppf "@[%a is not currently active as a printing function.@]@." + Printtyp.longident lid diff --git a/ocaml/debugger4/loadprinter.mli b/ocaml/debugger4/loadprinter.mli new file mode 100644 index 00000000000..8fc6f7a6da6 --- /dev/null +++ b/ocaml/debugger4/loadprinter.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1997 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Loading and installation of user-defined printer functions *) + +open Format + +val loadfile : formatter -> string -> unit +val install_printer : formatter -> Longident.t -> unit +val remove_printer : Longident.t -> unit + +(* Error report *) + +type error = + | Load_failure of Dynlink.error + | Unbound_identifier of Longident.t + | Unavailable_module of string * Longident.t + | Wrong_type of Longident.t + | No_active_printer of Longident.t + +exception Error of error + +val report_error: formatter -> error -> unit diff --git a/ocaml/debugger4/main.ml b/ocaml/debugger4/main.ml new file mode 100644 index 00000000000..006e8fd5bb7 --- /dev/null +++ b/ocaml/debugger4/main.ml @@ -0,0 +1,241 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Input_handling +open Question +open Command_line +open Debugger_config +open Checkpoints +open Time_travel +open Parameters +open Program_management +open Frames +open Show_information +open Format +open Primitives + +let line_buffer = Lexing.from_function read_user_input + +let loop ppf = line_loop ppf line_buffer; stop_user_input () + +let current_duration = ref (-1L) + +let rec protect ppf restart loop = + try + loop ppf + with + | End_of_file -> + protect ppf restart (function ppf -> + forget_process + !current_checkpoint.c_fd + !current_checkpoint.c_pid; + pp_print_flush ppf (); + stop_user_input (); + restart ppf) + | Toplevel -> + protect ppf restart (function ppf -> + pp_print_flush ppf (); + stop_user_input (); + restart ppf) + | Sys.Break -> + protect ppf restart (function ppf -> + fprintf ppf "Interrupted.@."; + Exec.protect (function () -> + stop_user_input (); + if !loaded then begin + try_select_frame 0; + show_current_event ppf; + end); + restart ppf) + | Current_checkpoint_lost -> + protect ppf restart (function ppf -> + fprintf ppf "Trying to recover...@."; + stop_user_input (); + recover (); + try_select_frame 0; + show_current_event ppf; + restart ppf) + | Current_checkpoint_lost_start_at (time, init_duration) -> + protect ppf restart (function ppf -> + let b = + if !current_duration = -1L then begin + let msg = sprintf "Restart from time %Ld and try to get \ + closer of the problem" time in + stop_user_input (); + if yes_or_no msg then + (current_duration := init_duration; true) + else + false + end + else + true in + if b then + begin + go_to time; + current_duration := Int64.div !current_duration 10L; + if !current_duration > 0L then + while true do + step !current_duration + done + else begin + current_duration := -1L; + stop_user_input (); + show_current_event ppf; + restart ppf; + end + end + else + begin + recover (); + show_current_event ppf; + restart ppf + end) + | x -> + cleanup x kill_program + +let execute_file_if_any () = + let buffer = Buffer.create 128 in + begin + try + let base = ".ocamldebug" in + let file = + if Sys.file_exists base then + base + else + Filename.concat (Sys.getenv "HOME") base in + let ch = open_in file in + fprintf Format.std_formatter "Executing file %s@." file; + while true do + let line = string_trim (input_line ch) in + if line <> "" && line.[0] <> '#' then begin + Buffer.add_string buffer line; + Buffer.add_char buffer '\n' + end + done; + with _ -> () + end; + let len = Buffer.length buffer in + if len > 0 then + let commands = Buffer.sub buffer 0 (pred len) in + line_loop Format.std_formatter (Lexing.from_string commands); + stop_user_input () + +let toplevel_loop () = + interactif := false; + current_prompt := ""; + execute_file_if_any (); + interactif := true; + current_prompt := debugger_prompt; + protect Format.std_formatter loop loop + +(* Parsing of command-line arguments *) + +exception Found_program_name + +let anonymous s = + program_name := Unix_tools.make_absolute s; raise Found_program_name +let add_include d = + default_load_path := + Misc.expand_directory Config.standard_library d :: !default_load_path +let set_socket s = + socket_name := s +let set_checkpoints n = + checkpoint_max_count := n +let set_directory dir = + Sys.chdir dir +let print_version () = + printf "The OCaml debugger, version %s@." Sys.ocaml_version; + exit 0 + +let print_version_num () = + printf "%s@." Sys.ocaml_version; + exit 0 + +let speclist = [ + "-c", Arg.Int set_checkpoints, + " Set max number of checkpoints kept"; + "-cd", Arg.String set_directory, + " Change working directory"; + "-emacs", Arg.Tuple [Arg.Set emacs; Arg.Set machine_readable], + "For running the debugger under emacs; implies -machine-readable"; + "-I", Arg.String add_include, + " Add to the list of include directories"; + "-machine-readable", Arg.Set machine_readable, + "Print information in a format more suitable for machines"; + "-s", Arg.String set_socket, + " Set the name of the communication socket"; + "-version", Arg.Unit print_version, + " Print version and exit"; + "-vnum", Arg.Unit print_version_num, + " Print version number and exit"; + "-no-version", Arg.Clear Parameters.version, + " Do not print version at startup"; + "-no-prompt", Arg.Clear Parameters.prompt, + " Suppress all prompts"; + "-no-time", Arg.Clear Parameters.time, + " Do not print times"; + "-no-breakpoint-message", Arg.Clear Parameters.breakpoint, + " Do not print message at breakpoint setup and removal"; + ] + +let function_placeholder () = + failwith "custom printer tried to invoke a function from the debuggee" + +let report report_error error = + eprintf "Debugger [version %s] environment error:@ @[@;%a@]@.;" + Config.version report_error error + +let main () = + Callback.register "Debugger.function_placeholder" function_placeholder; + try + socket_name := + (match Sys.os_type with + "Win32" -> + (Unix.string_of_inet_addr Unix.inet_addr_loopback)^ + ":"^ + (Int.to_string (10000 + ((Unix.getpid ()) mod 10000))) + | _ -> Filename.concat (Filename.get_temp_dir_name ()) + ("camldebug" ^ (Int.to_string (Unix.getpid ()))) + ); + begin try + Arg.parse speclist anonymous ""; + Arg.usage speclist + "No program name specified\n\ + Usage: ocamldebug [options] [arguments]\n\ + Options are:"; + exit 2 + with Found_program_name -> + for j = !Arg.current + 1 to Array.length Sys.argv - 1 do + arguments := !arguments ^ " " ^ (Filename.quote Sys.argv.(j)) + done + end; + if !Parameters.version + then printf "\tOCaml Debugger version %s@.@." Config.version; + Load_path.init ~auto_include:Compmisc.auto_include + ~visible:!default_load_path ~hidden:[]; + Clflags.recursive_types := true; (* Allow recursive types. *) + toplevel_loop (); (* Toplevel. *) + kill_program (); + exit 0 + with + | Toplevel -> + exit 2 + | Persistent_env.Error e -> + report Persistent_env.report_error e; + exit 2 + | Cmi_format.Error e -> + report Cmi_format.report_error e; + exit 2 diff --git a/ocaml/debugger4/ocamldebug_entry.ml b/ocaml/debugger4/ocamldebug_entry.ml new file mode 100644 index 00000000000..94e41e6f87e --- /dev/null +++ b/ocaml/debugger4/ocamldebug_entry.ml @@ -0,0 +1,2 @@ +let _ = + Unix.handle_unix_error Ocamldebug.Main.main () diff --git a/ocaml/debugger4/parameters.ml b/ocaml/debugger4/parameters.ml new file mode 100644 index 00000000000..42fc89cd68d --- /dev/null +++ b/ocaml/debugger4/parameters.ml @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Miscellaneous parameters *) + +open Debugger_config + +let program_name = ref "" +let socket_name = ref "" +let arguments = ref "" + +let default_load_path = + ref [ Filename.current_dir_name; Config.standard_library ] + +let breakpoint = ref true +let prompt = ref true +let time = ref true +let version = ref true + +let add_path dir = + Load_path.add_dir ~hidden:false dir; + Envaux.reset_cache ~preserve_persistent_env:false + +let add_path_for mdl dir = + let old = try Hashtbl.find load_path_for mdl with Not_found -> [] in + Hashtbl.replace load_path_for mdl (dir :: old) + +(* Used by emacs ? *) +let emacs = ref false + +let machine_readable = ref false diff --git a/ocaml/debugger4/parameters.mli b/ocaml/debugger4/parameters.mli new file mode 100644 index 00000000000..a0b9d084e47 --- /dev/null +++ b/ocaml/debugger4/parameters.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Miscellaneous parameters *) + +val program_name : string ref +val socket_name : string ref +val arguments : string ref +val default_load_path : string list ref +val breakpoint : bool ref +val prompt : bool ref +val time : bool ref +val version : bool ref + +val add_path : string -> unit +val add_path_for : string -> string -> unit + +(* Used by emacs ? *) +val emacs : bool ref + +val machine_readable : bool ref diff --git a/ocaml/debugger4/parser_aux.mli b/ocaml/debugger4/parser_aux.mli new file mode 100644 index 00000000000..36c383e0c2a --- /dev/null +++ b/ocaml/debugger4/parser_aux.mli @@ -0,0 +1,30 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type expression = + E_ident of Longident.t (* x or Mod.x *) + | E_name of int (* $xxx *) + | E_item of expression * int (* x.1 x.[2] x.(3) *) + | E_field of expression * string (* x.lbl !x *) + | E_result + +type break_arg = + BA_none (* break *) + | BA_pc of Debugcom.pc (* break FRAG PC *) + | BA_function of expression (* break FUNCTION *) + | BA_pos1 of Longident.t option * int * int option + (* break @ [MODULE] LINE [POS] *) + | BA_pos2 of Longident.t option * int (* break @ [MODULE] # OFFSET *) diff --git a/ocaml/debugger4/pos.ml b/ocaml/debugger4/pos.ml new file mode 100644 index 00000000000..2b5b0e2e278 --- /dev/null +++ b/ocaml/debugger4/pos.ml @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Instruct +open Lexing +open Location +open Events + +let get_desc ev = + let loc = ev.ev_ev.ev_loc in + Printf.sprintf "file %s, line %d, characters %d-%d" + loc.loc_start.pos_fname loc.loc_start.pos_lnum + (loc.loc_start.pos_cnum - loc.loc_start.pos_bol + 1) + (loc.loc_end.pos_cnum - loc.loc_start.pos_bol + 1) diff --git a/ocaml/debugger4/pos.mli b/ocaml/debugger4/pos.mli new file mode 100644 index 00000000000..55999526aeb --- /dev/null +++ b/ocaml/debugger4/pos.mli @@ -0,0 +1,16 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Damien Doligez, projet Moscova, INRIA Rocquencourt *) +(* *) +(* Copyright 2003 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +val get_desc : Events.code_event -> string diff --git a/ocaml/debugger4/primitives.ml b/ocaml/debugger4/primitives.ml new file mode 100644 index 00000000000..c6bb233813e --- /dev/null +++ b/ocaml/debugger4/primitives.ml @@ -0,0 +1,126 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(*********************** Basic functions and types *********************) + +(*** Miscellaneous ***) +exception Out_of_range + +let cleanup e f = + let bt = Printexc.get_raw_backtrace () in + let () = f () in + Printexc.raise_with_backtrace e bt + +let nothing _ = () + +(*** Operations on lists. ***) + +(* Remove an element from a list *) +let except e l = + let rec except_e = function + [] -> [] + | elem::l -> if e = elem then l else elem::except_e l + in except_e l + +(* Position of an element in a list. Head of list has position 0. *) +let index a l = + let rec index_rec i = function + [] -> raise Not_found + | b::l -> if a = b then i else index_rec (i + 1) l + in index_rec 0 l + +(* Return the `n' first elements of `l' *) +(* ### n l -> l' *) +let rec list_truncate = + fun + p0 p1 -> match (p0,p1) with (0, _) -> [] + | (_, []) -> [] + | (n, (a::l)) -> a::(list_truncate (n - 1) l) + +(* Separate the `n' first elements of `l' and the others *) +(* ### n list -> (first, last) *) +let rec list_truncate2 = + fun + p0 p1 -> match (p0,p1) with (0, l) -> + ([], l) + | (_, []) -> + ([], []) + | (n, (a::l)) -> + let (first, last) = (list_truncate2 (n - 1) l) in + (a::first, last) + +(* Replace x by y in list l *) +(* ### x y l -> l' *) +let list_replace x y = + let rec repl = + function + [] -> [] + | a::l -> + if a == x then y::l + else a::(repl l) + in repl + +(*** Operations on strings. ***) + +(* Remove blanks (spaces and tabs) at beginning and end of a string. *) +let is_space = function + | ' ' | '\t' -> true | _ -> false + +let string_trim s = + let l = String.length s and i = ref 0 in + while + !i < l && is_space (String.get s !i) + do + incr i + done; + let j = ref (l - 1) in + while + !j >= !i && is_space (String.get s !j) + do + decr j + done; + String.sub s !i (!j - !i + 1) + +(* isprefix s1 s2 returns true if s1 is a prefix of s2. *) + +let isprefix s1 s2 = + let l1 = String.length s1 and l2 = String.length s2 in + (l1 = l2 && s1 = s2) || (l1 < l2 && s1 = String.sub s2 0 l1) + + +(*** I/O channels ***) + +type io_channel = { + io_in : in_channel; + io_out : out_channel; + io_fd : Unix.file_descr + } + +let io_channel_of_descr fd = { + io_in = Unix.in_channel_of_descr fd; + io_out = Unix.out_channel_of_descr fd; + io_fd = fd + } + +let close_io io_channel = + close_out_noerr io_channel.io_out; + close_in_noerr io_channel.io_in + +let std_io = { + io_in = stdin; + io_out = stdout; + io_fd = Unix.stdin + } diff --git a/ocaml/debugger4/primitives.mli b/ocaml/debugger4/primitives.mli new file mode 100644 index 00000000000..8b03d8d2da2 --- /dev/null +++ b/ocaml/debugger4/primitives.mli @@ -0,0 +1,67 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(********************* Basic functions and types ***********************) + +(*** Miscellaneous ***) +val nothing : 'a -> unit + +(*** Types and exceptions. ***) +exception Out_of_range + +(* [cleanup e f x] runs evaluates [f x] and reraises [e] with its original + backtrace. If [f x] raises, then [e] is not raised. *) +val cleanup : exn -> (unit -> unit) -> 'a + +(*** Operations on lists. ***) + +(* Remove an element from a list *) +val except : 'a -> 'a list -> 'a list + +(* Position of an element in a list. Head of list has position 0. *) +val index : 'a -> 'a list -> int + +(* Return the `n' first elements of `l'. *) +(* ### n l -> l' *) +val list_truncate : int -> 'a list -> 'a list + +(* Separate the `n' first elements of `l' and the others. *) +(* ### n list -> (first, last) *) +val list_truncate2 : int -> 'a list -> 'a list * 'a list + +(* Replace x by y in list l *) +(* ### x y l -> l' *) +val list_replace : 'a -> 'a -> 'a list -> 'a list + +(*** Operations on strings. ***) + +(* Remove blanks (spaces and tabs) at beginning and end of a string. *) +val string_trim : string -> string + +(* isprefix s1 s2 returns true if s1 is a prefix of s2. *) +val isprefix : string -> string -> bool + +(*** I/O channels ***) + +type io_channel = { + io_in : in_channel; + io_out : out_channel; + io_fd : Unix.file_descr + } + +val io_channel_of_descr : Unix.file_descr -> io_channel +val close_io : io_channel -> unit +val std_io : io_channel diff --git a/ocaml/debugger4/printval.ml b/ocaml/debugger4/printval.ml new file mode 100644 index 00000000000..ef9978471c7 --- /dev/null +++ b/ocaml/debugger4/printval.ml @@ -0,0 +1,108 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* To print values *) + +open Format +open Parser_aux +open Types + +(* To name printed and ellipsed values *) + +let named_values = + (Hashtbl.create 29 : (int, Debugcom.Remote_value.t * type_expr) Hashtbl.t) +let next_name = ref 1 + +let reset_named_values () = + Hashtbl.clear named_values; + next_name := 1 + +let name_value v ty = + let name = !next_name in + incr next_name; + Hashtbl.add named_values name (v, ty); + name + +let find_named_value name = + Hashtbl.find named_values name + +let check_depth depth obj ty = + if depth <= 0 then begin + let n = name_value obj ty in + Some (Outcometree.Oval_stuff ("$" ^ Int.to_string n)) + end else None + +module EvalPath = + struct + type valu = Debugcom.Remote_value.t + exception Error + + let eval_id id = + try + Debugcom.Remote_value.global (Symtable.get_global_position id) + with Symtable.Error _ -> + raise Error + + let rec eval_address = function + | Env.Aunit cu -> eval_id (cu |> Compilation_unit.to_global_ident_for_bytecode) + | Env.Alocal id -> eval_id id + | Env.Adot(root, pos) -> + let v = eval_address root in + if not (Debugcom.Remote_value.is_block v) + then raise Error + else Debugcom.Remote_value.field v pos + let same_value = Debugcom.Remote_value.same + end + +module Printer = Genprintval.Make(Debugcom.Remote_value)(EvalPath) + +let install_printer path ty _ppf fn = + Printer.install_printer path ty + (fun ppf remote_val -> + try + fn ppf (Obj.repr (Debugcom.Remote_value.obj remote_val)) + with + Debugcom.Marshalling_error -> + fprintf ppf "") + +let remove_printer = Printer.remove_printer + +let max_printer_depth = ref 20 +let max_printer_steps = ref 300 + +let print_exception ppf obj = + let t = Printer.outval_of_untyped_exception obj in + !Oprint.out_value ppf t + +let print_value max_depth env obj (ppf : Format.formatter) ty = + let t = + Printer.outval_of_value !max_printer_steps max_depth + check_depth env obj ty in + !Oprint.out_value ppf t + +let print_named_value max_depth exp env obj ppf ty = + let print_value_name ppf = function + | E_ident lid -> + Printtyp.longident ppf lid + | E_name n -> + fprintf ppf "$%i" n + | _ -> + let n = name_value obj ty in + fprintf ppf "$%i" n in + fprintf ppf "@[<2>%a:@ %a@ =@ %a@]@." + print_value_name exp + Printtyp.type_expr ty + (print_value max_depth env obj) ty diff --git a/ocaml/debugger4/printval.mli b/ocaml/debugger4/printval.mli new file mode 100644 index 00000000000..53c0ee4e417 --- /dev/null +++ b/ocaml/debugger4/printval.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format + +val max_printer_depth : int ref +val max_printer_steps : int ref + +val print_exception: formatter -> Debugcom.Remote_value.t -> unit +val print_named_value : + int -> Parser_aux.expression -> Env.t -> + Debugcom.Remote_value.t -> formatter -> Types.type_expr -> + unit + +val reset_named_values : unit -> unit +val find_named_value : int -> Debugcom.Remote_value.t * Types.type_expr + +val install_printer : + Path.t -> Types.type_expr -> formatter -> + (formatter -> Obj.t -> unit) -> unit +val remove_printer : Path.t -> unit diff --git a/ocaml/debugger4/program_loading.ml b/ocaml/debugger4/program_loading.ml new file mode 100644 index 00000000000..cd757dacb80 --- /dev/null +++ b/ocaml/debugger4/program_loading.ml @@ -0,0 +1,188 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Program loading *) + +open Unix +open Debugger_config +open Parameters +open Input_handling + +(*** Debugging. ***) + +let debug_loading = ref false + +(*** Load a program. ***) + +(* Function used for launching the program. *) +let launching_func = ref (function () -> ()) + +let load_program () = + !launching_func (); + main_loop () + +(*** Launching functions. ***) + +(* Returns a command line prefix to set environment for the debuggee *) +let get_unix_environment () = + let f (vname, vvalue) = + Printf.sprintf "%s=%s " vname (Filename.quote vvalue) + in + String.concat "" (List.map f !Debugger_config.environment) + +(* Notes: + 1. This quoting is not the same as [Filename.quote] because the "set" + command is a shell built-in and its quoting rules are different + from regular commands. + 2. Microsoft's documentation omits the double-quote from the list + of characters that need quoting, but that is a mistake (unquoted + quotes are included in the value, but they alter the quoting of + characters between them). + Reference: http://msdn.microsoft.com/en-us/library/bb490954.aspx + *) +let quote_for_windows_shell s = + let b = Buffer.create (20 + String.length s) in + for i = 0 to String.length s - 1 do + begin match s.[i] with + | '<' | '>' | '|' | '&' | '^' | '\"' -> + Buffer.add_char b '^'; + | _ -> () + end; + Buffer.add_char b s.[i]; + done; + Buffer.contents b + +(* Returns a command line prefix to set environment for the debuggee *) +let get_win32_environment () = + (* Note: no space before the & or Windows will add it to the value *) + let f (vname, vvalue) = + Printf.sprintf "set %s=%s&" vname (quote_for_windows_shell vvalue) + in + String.concat "" (List.map f !Debugger_config.environment) + +(* A generic function for launching the program *) +let generic_exec_unix cmdline = function () -> + if !debug_loading then + prerr_endline "Launching program..."; + let child = + try + fork () + with x -> + Unix_tools.report_error x; + raise Toplevel in + match child with + 0 -> + begin try + match fork () with + 0 -> (* Try to detach the process from the controlling terminal, + so that it does not receive SIGINT on ctrl-C. *) + begin try ignore(setsid()) with Invalid_argument _ -> () end; + execv shell [| shell; "-c"; cmdline() |] + | _ -> exit 0 + with x -> + Unix_tools.report_error x; + exit 1 + end + | _ -> + match wait () with + (_, WEXITED 0) -> () + | _ -> raise Toplevel + +let generic_exec_win cmdline = function () -> + if !debug_loading then + prerr_endline "Launching program..."; + try ignore(create_process "cmd.exe" [| "/C"; cmdline() |] stdin stdout stderr) + with x -> + Unix_tools.report_error x; + raise Toplevel + +let generic_exec = + match Sys.os_type with + "Win32" -> generic_exec_win + | _ -> generic_exec_unix + +(* Execute the program by calling the runtime explicitly *) +let exec_with_runtime = + generic_exec + (function () -> + match Sys.os_type with + "Win32" -> + (* This would fail on a file name with spaces + but quoting is even worse because Unix.create_process + thinks each command line parameter is a file. + So no good solution so far *) + Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s& %s %s %s" + (get_win32_environment ()) + !socket_name + runtime_program + !program_name + !arguments + | _ -> + Printf.sprintf "%sCAML_DEBUG_SOCKET=%s %s %s %s" + (get_unix_environment ()) + !socket_name + (Filename.quote runtime_program) + (Filename.quote !program_name) + !arguments) + +(* Execute the program directly *) +let exec_direct = + generic_exec + (function () -> + match Sys.os_type with + "Win32" -> + (* See the comment above *) + Printf.sprintf "%sset CAML_DEBUG_SOCKET=%s& %s %s" + (get_win32_environment ()) + !socket_name + !program_name + !arguments + | _ -> + Printf.sprintf "%sCAML_DEBUG_SOCKET=%s %s %s" + (get_unix_environment ()) + !socket_name + (Filename.quote !program_name) + !arguments) + +(* Ask the user. *) +let exec_manual = + function () -> + print_newline (); + print_string "Waiting for connection..."; + print_string ("(the socket is " ^ !socket_name ^ ")"); + print_newline () + +(*** Selection of the launching function. ***) + +type launching_function = (unit -> unit) + +let loading_modes = + ["direct", exec_direct; + "runtime", exec_with_runtime; + "manual", exec_manual] + +let set_launching_function func = + launching_func := func + +(* Initialization *) + +let _ = + set_launching_function exec_direct + +(*** Connection. ***) + +let connection = ref Primitives.std_io +let connection_opened = ref false diff --git a/ocaml/debugger4/program_loading.mli b/ocaml/debugger4/program_loading.mli new file mode 100644 index 00000000000..cb4c2161589 --- /dev/null +++ b/ocaml/debugger4/program_loading.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(*** Debugging. ***) + +val debug_loading : bool ref + +(*** Load program ***) + +(* Function used for launching the program. *) +val launching_func : (unit -> unit) ref + +val load_program : unit -> unit + +type launching_function = (unit -> unit) + +val loading_modes : (string * launching_function) list +val set_launching_function : launching_function -> unit + +(** Connection **) +val connection : Primitives.io_channel ref +val connection_opened : bool ref diff --git a/ocaml/debugger4/program_management.ml b/ocaml/debugger4/program_management.ml new file mode 100644 index 00000000000..8f6d62bf8e4 --- /dev/null +++ b/ocaml/debugger4/program_management.ml @@ -0,0 +1,163 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Manage the loading of the program *) + +open Int64ops +open Unix +open Unix_tools +open Debugger_config +open Primitives +open Parameters +open Input_handling +open Question +open Program_loading +open Time_travel + +(*** Connection opening and control. ***) + +(* Name of the file if the socket is in the unix domain.*) +let file_name = ref (None : string option) + +(* Default connection handler. *) +let buffer = Bytes.create 1024 +let control_connection pid fd = + if (read fd.io_fd buffer 0 1024) = 0 then + forget_process fd pid + else begin + prerr_string "Garbage data from process "; + prerr_int pid; + prerr_endline "" + end + +(* Accept a connection from another process. *) +let accept_connection continue fd = + let (sock, _) = accept fd.io_fd in + let io_chan = io_channel_of_descr sock in + let pid = input_binary_int io_chan.io_in in + if pid = -1 then begin + let pid' = input_binary_int io_chan.io_in in + new_checkpoint pid' io_chan; + Input_handling.add_file io_chan (control_connection pid'); + continue () + end + else begin + if set_file_descriptor pid io_chan then + Input_handling.add_file io_chan (control_connection pid) + end + +(* Initialize the socket. *) +let open_connection address continue = + try + let (sock_domain, sock_address) = convert_address address in + file_name := + (match sock_address with + ADDR_UNIX file -> + Some file + | _ -> + None); + let sock = socket sock_domain SOCK_STREAM 0 in + (try + bind sock sock_address; + setsockopt sock SO_REUSEADDR true; + listen sock 3; + connection := io_channel_of_descr sock; + Input_handling.add_file !connection (accept_connection continue); + connection_opened := true + with x -> cleanup x @@ fun () -> close sock) + with + Failure _ -> raise Toplevel + | (Unix_error _) as err -> report_error err; raise Toplevel + +(* Close the socket. *) +let close_connection () = + if !connection_opened then begin + connection_opened := false; + Input_handling.remove_file !connection; + close_io !connection; + match !file_name with + Some file -> + unlink file + | None -> + () + end + +(*** Kill program. ***) +let loaded = ref false + +let kill_program () = + Breakpoints.remove_all_breakpoints (); + History.empty_history (); + kill_all_checkpoints (); + loaded := false; + close_connection () + +let ask_kill_program () = + if not !loaded then + true + else + let answer = yes_or_no "A program is being debugged already. Kill it" in + if answer then + kill_program (); + answer + +(*** Program loading and initializations. ***) + +let initialize_loading () = + if !debug_loading then begin + prerr_endline "Loading debugging information..."; + Printf.fprintf Stdlib.stderr "\tProgram: [%s]\n%!" !program_name; + end; + begin try access !program_name [F_OK] + with Unix_error _ -> + prerr_endline "Program not found."; + raise Toplevel; + end; + Symbols.clear_symbols (); + Symbols.read_symbols Debugcom.main_frag !program_name; + let Load_path.{visible; hidden} = Load_path.get_paths () in + let visible = visible @ !Symbols.program_source_dirs in + Load_path.init ~auto_include:Compmisc.auto_include ~visible ~hidden; + Envaux.reset_cache ~preserve_persistent_env:false; + if !debug_loading then + prerr_endline "Opening a socket..."; + open_connection !socket_name + (function () -> + go_to _0; + Symbols.set_all_events Debugcom.main_frag; + exit_main_loop ()) + +(* Ensure the program is already loaded. *) +let ensure_loaded () = + if not !loaded then begin + print_string "Loading program... "; + flush Stdlib.stdout; + if !program_name = "" then begin + prerr_endline "No program specified."; + raise Toplevel + end; + try + initialize_loading(); + !launching_func (); + if !debug_loading then + prerr_endline "Waiting for connection..."; + main_loop (); + loaded := true; + prerr_endline "done." + with + x -> + cleanup x kill_program + end diff --git a/ocaml/debugger4/program_management.mli b/ocaml/debugger4/program_management.mli new file mode 100644 index 00000000000..384067832ef --- /dev/null +++ b/ocaml/debugger4/program_management.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(*** Program loading and initializations. ***) + +val loaded : bool ref +val ensure_loaded : unit -> unit + +(*** Kill program. ***) +val kill_program : unit -> unit + +(* Ask whether to kill the program or not. *) +(* If yes, kill it. *) +(* Return true iff the program has been killed. *) +val ask_kill_program : unit -> bool diff --git a/ocaml/debugger4/question.ml b/ocaml/debugger4/question.ml new file mode 100644 index 00000000000..ed294beacbc --- /dev/null +++ b/ocaml/debugger4/question.ml @@ -0,0 +1,48 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Pouillard, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Input_handling +open Primitives +module Lexer = Debugger_lexer + +(* Ask user a yes or no question. *) +let yes_or_no message = + if !interactif then + let finally = + let old_prompt = !current_prompt in + fun () -> stop_user_input (); current_prompt := old_prompt + in + Fun.protect ~finally @@ fun () -> + current_prompt := message ^ " ? (y or n) "; + let answer = + let rec ask () = + resume_user_input (); + let line = + string_trim (Lexer.line (Lexing.from_function read_user_input)) + in + match (if String.length line > 0 then line.[0] else ' ') with + 'y' -> true + | 'n' -> false + | _ -> + stop_user_input (); + print_string "Please answer y or n."; + print_newline (); + ask () + in + ask () + in + answer + else + false diff --git a/ocaml/debugger4/question.mli b/ocaml/debugger4/question.mli new file mode 100644 index 00000000000..75f22555daf --- /dev/null +++ b/ocaml/debugger4/question.mli @@ -0,0 +1,17 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nicolas Pouillard, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2006 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Ask user a yes or no question. *) +val yes_or_no : string -> bool diff --git a/ocaml/debugger4/show_information.ml b/ocaml/debugger4/show_information.ml new file mode 100644 index 00000000000..27cdf5f6c19 --- /dev/null +++ b/ocaml/debugger4/show_information.ml @@ -0,0 +1,121 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Instruct +open Format +open Debugcom +open Checkpoints +open Events +open Symbols +open Frames +open Source +open Show_source +open Breakpoints +open Parameters + +(* Display information about the current event. *) +let show_current_event ppf = + if !Parameters.time then begin + fprintf ppf "Time: %Li" (current_time ()); + (match current_pc () with + | Some pc -> + fprintf ppf " - pc: %i:%i" pc.frag pc.pos + | _ -> ()); + end; + update_current_event (); + reset_frame (); + match current_report () with + | None -> + if !Parameters.time then fprintf ppf "@."; + fprintf ppf "Beginning of program.@."; + show_no_point () + | Some {rep_type = (Event | Breakpoint); rep_program_pointer = pc} -> + let ev = (get_current_event ()).ev_ev in + if !Parameters.time then fprintf ppf " - module %s@." ev.ev_module; + (match breakpoints_at_pc pc with + | [] -> + () + | [breakpoint] -> + fprintf ppf "Breakpoint: %i@." breakpoint + | breakpoints -> + fprintf ppf "Breakpoints: %a@." + (fun ppf l -> + List.iter + (function x -> fprintf ppf "%i " x) l) + (List.sort compare breakpoints)); + show_point ev true + | Some {rep_type = Exited} -> + if !Parameters.time then fprintf ppf "@."; + fprintf ppf "Program exit.@."; + show_no_point () + | Some {rep_type = Uncaught_exc} -> + if !Parameters.time then fprintf ppf "@."; + fprintf ppf + "Program end.@.\ + @[Uncaught exception:@ %a@]@." + Printval.print_exception (Debugcom.Remote_value.accu ()); + show_no_point () + | Some {rep_type = Code_loaded frag} -> + let mds = String.concat ", " (Symbols.modules_in_code_fragment frag) in + fprintf ppf "@.Module(s) %s loaded.@." mds; + show_no_point () + | Some {rep_type = Trap_barrier} + | Some {rep_type = Debug_info _} + | Some {rep_type = Code_unloaded _} -> + (* Not visible outside *) + (* of module `time_travel'. *) + if !Parameters.time then fprintf ppf "@."; + Misc.fatal_error "Show_information.show_current_event" + +(* Display short information about one frame. *) + +let show_one_frame framenum ppf ev = + let pos = Events.get_pos ev.ev_ev in + let cnum = + try + let buffer = get_buffer pos ev.ev_ev.ev_module in + snd (start_and_cnum buffer pos) + with _ -> pos.Lexing.pos_cnum in + if !machine_readable then + fprintf ppf "#%i Pc: %i:%i %s char %i@." + framenum ev.ev_frag ev.ev_ev.ev_pos ev.ev_ev.ev_module + cnum + else + fprintf ppf "#%i %s %s:%i:%i@." + framenum ev.ev_ev.ev_module + pos.Lexing.pos_fname pos.Lexing.pos_lnum + (pos.Lexing.pos_cnum - pos.Lexing.pos_bol + 1) + +(* Display information about the current frame. *) +(* --- `select frame' must have succeeded before calling this function. *) +let show_current_frame ppf selected = + match !selected_event with + | None -> + fprintf ppf "@.No frame selected.@." + | Some sel_ev -> + show_one_frame !current_frame ppf sel_ev; + begin match breakpoints_at_pc + {frag=sel_ev.ev_frag; pos = sel_ev.ev_ev.ev_pos} with + | [] -> () + | [breakpoint] -> + fprintf ppf "Breakpoint: %i@." breakpoint + | breakpoints -> + fprintf ppf "Breakpoints: %a@." + (fun ppf l -> + List.iter (function x -> fprintf ppf "%i " x) l) + (List.sort compare breakpoints); + end; + show_point sel_ev.ev_ev selected diff --git a/ocaml/debugger4/show_information.mli b/ocaml/debugger4/show_information.mli new file mode 100644 index 00000000000..bc5df9d9e67 --- /dev/null +++ b/ocaml/debugger4/show_information.mli @@ -0,0 +1,27 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Format + +(* Display information about the current event. *) +val show_current_event : formatter -> unit + +(* Display information about the current frame. *) +(* --- `select frame' must have succeeded before calling this function. *) +val show_current_frame : formatter -> bool -> unit + +(* Display short information about one frame. *) +val show_one_frame : int -> formatter -> Events.code_event -> unit diff --git a/ocaml/debugger4/show_source.ml b/ocaml/debugger4/show_source.ml new file mode 100644 index 00000000000..357132da727 --- /dev/null +++ b/ocaml/debugger4/show_source.ml @@ -0,0 +1,94 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Debugger_config +open Instruct +open Parameters +open Primitives +open Printf +open Source + +(* Print a line; return the beginning of the next line *) +let print_line buffer line_number start point before = + let linefeed = next_linefeed buffer start + and content = buffer_content buffer + in + printf "%i " line_number; + let line_end = + if linefeed > 0 && content.[linefeed - 1] = '\r' then + linefeed - 1 + else + linefeed in + if point <= line_end && point >= start then + (print_string (String.sub content start (point - start)); + print_string (if before then event_mark_before else event_mark_after); + print_string (String.sub content point (line_end - point))) + else + print_string (String.sub content start (line_end - start)); + print_newline (); + linefeed + +(* Tell Emacs we are nowhere in the source. *) +let show_no_point () = + if !emacs then printf "\026\026H\n" + +(* Print the line containing the point *) +let show_point ev selected = + let mdle = ev.ev_module in + let before = (ev.ev_kind = Event_before) in + if !emacs && selected then + begin try + let buffer = get_buffer (Events.get_pos ev) mdle in + let source = source_of_module ev.ev_loc.Location.loc_start mdle in + printf "\026\026M%s:%i:%i" source + (snd (start_and_cnum buffer ev.ev_loc.Location.loc_start)) + (snd (start_and_cnum buffer ev.ev_loc.Location.loc_end)); + printf "%s\n" (if before then ":before" else ":after") + with + Out_of_range -> (* point_of_coord *) + prerr_endline "Position out of range." + | Not_found -> (* Events.get_pos || get_buffer *) + prerr_endline ("No source file for " ^ mdle ^ "."); + show_no_point () + end + else + begin try + let pos = Events.get_pos ev in + let buffer = get_buffer pos mdle in + let start, point = start_and_cnum buffer pos in + ignore(print_line buffer pos.Lexing.pos_lnum start point before) + with + Out_of_range -> (* point_of_coord *) + prerr_endline "Position out of range." + | Not_found -> (* Events.get_pos || get_buffer *) + prerr_endline ("No source file for " ^ mdle ^ ".") + end + +(* Display part of the source. *) +let show_listing pos mdle start stop point before = + try + let buffer = get_buffer pos mdle in + let rec aff (line_start, line_number) = + if line_number <= stop then + aff (print_line buffer line_number line_start point before + 1, + line_number + 1) + in + aff (pos_of_line buffer start) + with + Out_of_range -> (* pos_of_line *) + prerr_endline "Position out of range." + | Not_found -> (* get_buffer *) + prerr_endline ("No source file for " ^ mdle ^ ".") diff --git a/ocaml/debugger4/show_source.mli b/ocaml/debugger4/show_source.mli new file mode 100644 index 00000000000..570a6d491cf --- /dev/null +++ b/ocaml/debugger4/show_source.mli @@ -0,0 +1,25 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Print the line containing the point *) +val show_point : Instruct.debug_event -> bool -> unit + +(* Tell Emacs we are nowhere in the source. *) +val show_no_point : unit -> unit + +(* Display part of the source. *) +val show_listing : + Lexing.position -> string -> int -> int -> int -> bool -> unit diff --git a/ocaml/debugger4/source.ml b/ocaml/debugger4/source.ml new file mode 100644 index 00000000000..d2045cf61b6 --- /dev/null +++ b/ocaml/debugger4/source.ml @@ -0,0 +1,191 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(************************ Source management ****************************) + +open Misc +open Primitives + +let source_extensions = [".ml"] + +(*** Conversion function. ***) + +let source_of_module pos mdle = + let pos_fname = pos.Lexing.pos_fname in + if Sys.file_exists pos_fname then pos_fname else + let is_submodule m m' = + let len' = String.length m' in + try + (String.sub m 0 len') = m' && (String.get m len') = '.' + with + Invalid_argument _ -> false in + let path = + Hashtbl.fold + (fun mdl dirs acc -> + if is_submodule mdle mdl then + dirs + else + acc) + Debugger_config.load_path_for + (Load_path.get_path_list ()) in + let fname = pos.Lexing.pos_fname in + if fname = "" then + let innermost_module = + try + let dot_index = String.rindex mdle '.' in + String.sub mdle (succ dot_index) (pred (String.length mdle - dot_index)) + with Not_found -> mdle in + let rec loop = + function + | [] -> raise Not_found + | ext :: exts -> + try find_in_path_uncap path (innermost_module ^ ext) + with Not_found -> loop exts + in loop source_extensions + else if Filename.is_relative fname then + find_in_path_rel path fname + else if Sys.file_exists fname then fname + else raise Not_found + +(*** Buffer cache ***) + +(* Buffer and cache (to associate lines and positions in the buffer). *) +type buffer = string * (int * int) list ref + +let buffer_max_count = ref 10 + +let buffer_list = + ref ([] : (string * buffer) list) + +let flush_buffer_list () = + buffer_list := [] + +let get_buffer pos mdle = + try List.assoc mdle !buffer_list with + Not_found -> + let inchan = open_in_bin (source_of_module pos mdle) in + let content = really_input_string inchan (in_channel_length inchan) in + let buffer = (content, ref []) in + buffer_list := + (list_truncate !buffer_max_count ((mdle, buffer)::!buffer_list)); + buffer + +let buffer_content = + (fst : buffer -> string) + +let buffer_length x = + String.length (buffer_content x) + +(*** Position conversions. ***) + +type position = int * int + +(* Insert a new pair (position, line) in the cache of the given buffer. *) +let insert_pos buffer ((position, line) as pair) = + let rec new_list = + function + [] -> + [(position, line)] + | ((_pos, lin) as a::l) as l' -> + if lin < line then + pair::l' + else if lin = line then + l' + else + a::(new_list l) + in + let buffer_cache = snd buffer in + buffer_cache := new_list !buffer_cache + +(* Position of the next linefeed after `pos'. *) +(* Position just after the buffer end if no linefeed found. *) +(* Raise `Out_of_range' if already there. *) +let next_linefeed (buffer, _) pos = + let len = String.length buffer in + if pos >= len then + raise Out_of_range + else + let rec search p = + if p = len || String.get buffer p = '\n' then + p + else + search (succ p) + in + search pos + +(* Go to next line. *) +let next_line buffer (pos, line) = + (next_linefeed buffer pos + 1, line + 1) + +(* Convert a position in the buffer to a line number. *) +let line_of_pos buffer position = + let rec find = + function + | [] -> + if position < 0 then + raise Out_of_range + else + (0, 1) + | ((pos, _line) as pair)::l -> + if pos > position then + find l + else + pair + and find_line previous = + let (pos, _line) as next = next_line buffer previous in + if pos <= position then + find_line next + else + previous + in + let result = find_line (find !(snd buffer)) in + insert_pos buffer result; + result + +(* Convert a line number to a position. *) +let pos_of_line buffer line = + let rec find = + function + [] -> + if line <= 0 then + raise Out_of_range + else + (0, 1) + | ((_pos, lin) as pair)::l -> + if lin > line then + find l + else + pair + and find_pos previous = + let (_, lin) as next = next_line buffer previous in + if lin <= line then + find_pos next + else + previous + in + let result = find_pos (find !(snd buffer)) in + insert_pos buffer result; + result + +(* Convert a coordinate (line / column) into a position. *) +(* --- The first line and column are line 1 and column 1. *) +let point_of_coord buffer line column = + fst (pos_of_line buffer line) + (pred column) + +let start_and_cnum buffer pos = + let line_number = pos.Lexing.pos_lnum in + let start = point_of_coord buffer line_number 1 in + start, start + (pos.Lexing.pos_cnum - pos.Lexing.pos_bol) diff --git a/ocaml/debugger4/source.mli b/ocaml/debugger4/source.mli new file mode 100644 index 00000000000..119d6704a72 --- /dev/null +++ b/ocaml/debugger4/source.mli @@ -0,0 +1,62 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(************************ Source management ****************************) + +(*** Conversion function. ***) + +val source_of_module: Lexing.position -> string -> string + +(*** buffer cache ***) + +type buffer + +val buffer_max_count : int ref + +val flush_buffer_list : unit -> unit + +val get_buffer : Lexing.position -> string -> buffer + +val buffer_content : buffer -> string +val buffer_length : buffer -> int + +(*** Position conversions. ***) + +(* Pair (position, line) where `position' is the position in character of *) +(* the beginning of the line (first character is 0) and `line' is its *) +(* number (first line number is 1). *) +type position = int * int + +(* Position of the next linefeed after `pos'. *) +(* Position just after the buffer end if no linefeed found. *) +(* Raise `Out_of_range' if already there. *) +val next_linefeed : buffer -> int -> int + +(* Go to next line. *) +val next_line : buffer -> position -> position + +(* Convert a position in the buffer to a line number. *) +val line_of_pos : buffer -> int -> position + +(* Convert a line number to a position. *) +val pos_of_line : buffer -> int -> position + +(* Convert a coordinate (line / column) into a position. *) +(* --- The first line and column are line 1 and column 1. *) +val point_of_coord : buffer -> int -> int -> int + +(* Return the offsets of both line start and cnum for the passed position. *) +val start_and_cnum : buffer -> Lexing.position -> (int * int) diff --git a/ocaml/debugger4/symbols.ml b/ocaml/debugger4/symbols.ml new file mode 100644 index 00000000000..36f8f874eb0 --- /dev/null +++ b/ocaml/debugger4/symbols.ml @@ -0,0 +1,259 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Handling of symbol tables (globals and events) *) + +open Instruct +open Debugger_config (* Toplevel *) +open Program_loading +open Debugcom +open Events +module String = Misc.Stdlib.String + +let modules = + ref ([] : string list) + +let program_source_dirs = + ref ([] : string list) + +let events_by_pc = + (Hashtbl.create 257 : (pc, debug_event) Hashtbl.t) +let events_by_module = + (Hashtbl.create 17 : (string, int * debug_event array) Hashtbl.t) +let all_events_by_module = + (Hashtbl.create 17 : (string, int * debug_event list) Hashtbl.t) + +let partition_modules evl = + let rec partition_modules' ev evl = + match evl with + [] -> [ev],[] + | ev'::evl -> + let evl,evll = partition_modules' ev' evl in + if ev.ev_module = ev'.ev_module then ev::evl,evll else [ev],evl::evll + in + match evl with + [] -> [] + | ev::evl -> let evl,evll = partition_modules' ev evl in evl::evll + +let relocate_event orig ev = + ev.ev_pos <- orig + ev.ev_pos; + match ev.ev_repr with + Event_parent repr -> repr := ev.ev_pos + | _ -> () + +let read_symbols' bytecode_file = + let ic = open_in_bin bytecode_file in + let toc = + try + let toc = Bytesections.read_toc ic in + ignore(Bytesections.seek_section toc ic Bytesections.Name.SYMB); + toc + with Bytesections.Bad_magic_number | Not_found -> + prerr_string bytecode_file; prerr_endline " is not a bytecode file."; + raise Toplevel + in + Symtable.restore_state (input_value ic); + begin try + ignore (Bytesections.seek_section toc ic Bytesections.Name.DBUG) + with Not_found -> + prerr_string bytecode_file; prerr_endline " has no debugging info."; + raise Toplevel + end; + let num_eventlists = input_binary_int ic in + let dirs = ref String.Set.empty in + let eventlists = ref [] in + for _i = 1 to num_eventlists do + let orig = input_binary_int ic in + let evl = (input_value ic : debug_event list) in + (* Relocate events in event list *) + List.iter (relocate_event orig) evl; + let evll = partition_modules evl in + eventlists := evll @ !eventlists; + dirs := + List.fold_left (fun s e -> String.Set.add e s) !dirs (input_value ic) + done; + begin try + ignore (Bytesections.seek_section toc ic Bytesections.Name.CODE) + with Not_found -> + (* The file contains only debugging info, + loading mode is forced to "manual" *) + set_launching_function (List.assoc "manual" loading_modes) + end; + close_in_noerr ic; + !eventlists, !dirs + +let clear_symbols () = + modules := []; + program_source_dirs := []; + Hashtbl.clear events_by_pc; Hashtbl.clear events_by_module; + Hashtbl.clear all_events_by_module + +let add_symbols frag all_events = + List.iter + (fun evl -> + List.iter + (fun ev -> + Hashtbl.add events_by_pc {frag; pos = ev.ev_pos} ev) + evl) + all_events; + + List.iter + (function + [] -> () + | ev :: _ as evl -> + let md = ev.ev_module in + let cmp ev1 ev2 = compare (Events.get_pos ev1).Lexing.pos_cnum + (Events.get_pos ev2).Lexing.pos_cnum + in + let sorted_evl = List.sort cmp evl in + modules := md :: !modules; + Hashtbl.add all_events_by_module md (frag, sorted_evl); + let real_evl = + List.filter + (function + {ev_kind = Event_pseudo} -> false + | _ -> true) + sorted_evl + in + Hashtbl.add events_by_module md (frag, Array.of_list real_evl)) + all_events + +let read_symbols frag bytecode_file = + let all_events, all_dirs = read_symbols' bytecode_file in + program_source_dirs := !program_source_dirs @ (String.Set.elements all_dirs); + add_symbols frag all_events + +let erase_symbols frag = + let pcs = Hashtbl.fold (fun pc _ pcs -> + if pc.frag = frag then pc :: pcs else pcs) + events_by_pc [] + in + List.iter (Hashtbl.remove events_by_pc) pcs; + + let mds = Hashtbl.fold (fun md (frag', _) mds -> + if frag' = frag then md :: mds else mds) + events_by_module [] + in + List.iter (Hashtbl.remove events_by_module) mds; + List.iter (Hashtbl.remove all_events_by_module) mds; + modules := List.filter (fun md -> not (List.mem md mds)) !modules + +let code_fragments () = + let frags = + Hashtbl.fold + (fun _ (frag, _) l -> frag :: l) + all_events_by_module [] + in + List.sort_uniq compare frags + +let modules_in_code_fragment frag' = + Hashtbl.fold (fun md (frag, _) l -> + if frag' = frag then md :: l else l) + all_events_by_module [] + +let any_event_at_pc pc = + { ev_frag = pc.frag; ev_ev = Hashtbl.find events_by_pc pc } + +let event_at_pc pc = + match any_event_at_pc pc with + { ev_ev = { ev_kind = Event_pseudo } } -> raise Not_found + | ev -> ev + +let set_event_at_pc pc = + try ignore(event_at_pc pc); set_event pc + with Not_found -> () + +(* List all events in module *) +let events_in_module mdle = + try + Hashtbl.find all_events_by_module mdle + with Not_found -> + 0, [] + +(* Binary search of event at or just after char *) +let find_event ev char = + let rec bsearch lo hi = + if lo >= hi then begin + if (Events.get_pos ev.(hi)).Lexing.pos_cnum < char + then raise Not_found + else hi + end else begin + let pivot = (lo + hi) / 2 in + let e = ev.(pivot) in + if char <= (Events.get_pos e).Lexing.pos_cnum + then bsearch lo pivot + else bsearch (pivot + 1) hi + end + in + if Array.length ev = 0 then + raise Not_found + else + bsearch 0 (Array.length ev - 1) + +(* Return first event after the given position. *) +(* Raise [Not_found] if module is unknown or no event is found. *) +let event_at_pos md char = + let ev_frag, ev = Hashtbl.find events_by_module md in + { ev_frag; ev_ev = ev.(find_event ev char) } + +(* Return event closest to given position *) +(* Raise [Not_found] if module is unknown or no event is found. *) +let event_near_pos md char = + let ev_frag, ev = Hashtbl.find events_by_module md in + try + let pos = find_event ev char in + (* Desired event is either ev.(pos) or ev.(pos - 1), + whichever is closest *) + if pos > 0 && char - (Events.get_pos ev.(pos - 1)).Lexing.pos_cnum + <= (Events.get_pos ev.(pos)).Lexing.pos_cnum - char + then { ev_frag; ev_ev = ev.(pos - 1) } + else { ev_frag; ev_ev = ev.(pos) } + with Not_found -> + let pos = Array.length ev - 1 in + if pos < 0 then raise Not_found; + { ev_frag; ev_ev = ev.(pos) } + +(* Flip "event" bit on all instructions *) +let set_all_events frag = + Hashtbl.iter + (fun pc ev -> + match ev.ev_kind with + Event_pseudo -> () + | _ when pc.frag = frag -> set_event pc + | _ -> ()) + events_by_pc + +(* Previous `pc'. *) +(* Save time if `update_current_event' is called *) +(* several times at the same point. *) +let old_pc = ref (None : pc option) + +(* Recompute the current event *) +let update_current_event () = + match Checkpoints.current_pc () with + None -> + Events.current_event := None; + old_pc := None + | (Some pc) as opt_pc when opt_pc <> !old_pc -> + Events.current_event := + begin try + Some (event_at_pc pc) + with Not_found -> + None + end; + old_pc := opt_pc + | _ -> + () diff --git a/ocaml/debugger4/symbols.mli b/ocaml/debugger4/symbols.mli new file mode 100644 index 00000000000..30728f5585d --- /dev/null +++ b/ocaml/debugger4/symbols.mli @@ -0,0 +1,71 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Events + +(* Modules used by the program. *) +val modules : string list ref + +(* Absolute directories containing source code on machine where source was + * compiled *) +val program_source_dirs : string list ref + +(* Clear loaded symbols *) +val clear_symbols : unit -> unit + +(* Read debugging info from executable or dynlinkable file + and associate with given code fragment *) +val read_symbols : int -> string -> unit + +(* Add debugging info from memory and associate with given + code fragment *) +val add_symbols : int -> Instruct.debug_event list list -> unit + +(* Erase debugging info associated with given code fragment *) +val erase_symbols : int -> unit + +(* Return the list of all code fragments that have debug info associated *) +val code_fragments : unit -> int list + +(* Flip "event" bit on all instructions in given fragment *) +val set_all_events : int -> unit + +(* Return event at given PC, or raise Not_found *) +(* Can also return pseudo-event at beginning of functions *) +val any_event_at_pc : Debugcom.pc -> code_event + +(* Return event at given PC, or raise Not_found *) +val event_at_pc : Debugcom.pc -> code_event + +(* Set event at given PC *) +val set_event_at_pc : Debugcom.pc -> unit + +(* List the events in `module'. *) +val events_in_module : string -> int * Instruct.debug_event list + +(* List the modules in given code fragment. *) +val modules_in_code_fragment : int -> string list + +(* First event after the given position. *) +(* --- Raise `Not_found' if no such event. *) +val event_at_pos : string -> int -> code_event + +(* Closest event from given position. *) +(* --- Raise `Not_found' if no such event. *) +val event_near_pos : string -> int -> code_event + +(* Recompute the current event *) +val update_current_event : unit -> unit diff --git a/ocaml/debugger4/time_travel.ml b/ocaml/debugger4/time_travel.ml new file mode 100644 index 00000000000..7a2665d3051 --- /dev/null +++ b/ocaml/debugger4/time_travel.ml @@ -0,0 +1,705 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(**************************** Time travel ******************************) + +open Int64ops +open Instruct +open Events +open Debugcom +open Primitives +open Checkpoints +open Breakpoints +open Trap_barrier +open Input_handling +open Debugger_config +open Program_loading +open Question + +exception Current_checkpoint_lost +exception Current_checkpoint_lost_start_at of int64 * int64 + +let remove_1st key list = + let rec remove = + function + [] -> [] + | a::l -> if a == key then l else a::(remove l) + in + remove list + +(*** Debugging. ***) + +let debug_time_travel = ref false + +(*** Internal utilities. ***) + +(* Insert a checkpoint in the checkpoint list. + * Raise `Exit' if there is already a checkpoint at the same time. + *) +let insert_checkpoint ({c_time = time} as checkpoint) = + let rec traverse = + function + [] -> [checkpoint] + | (({c_time = t} as a)::l) as l' -> + if t > time then + a::(traverse l) + else if t = time then + raise Exit + else + checkpoint::l' + in + checkpoints := traverse !checkpoints + +(* Remove a checkpoint from the checkpoint list. + * --- No error if not found. + *) +let remove_checkpoint checkpoint = + checkpoints := remove_1st checkpoint !checkpoints + +(* Wait for the process used by `checkpoint' to connect. + * --- Usually not called (the process is already connected). + *) +let wait_for_connection checkpoint = + try + Exec.unprotect + (function () -> + let old_controller = Input_handling.current_controller !connection in + execute_with_other_controller + (function + fd -> + old_controller fd; + if checkpoint.c_valid = true then + exit_main_loop ()) + !connection + main_loop) + with + Sys.Break -> + checkpoint.c_parent <- root; + remove_checkpoint checkpoint; + checkpoint.c_pid <- -1; + raise Sys.Break + +(* Select a checkpoint as current. *) +let set_current_checkpoint checkpoint = + if !debug_time_travel then + prerr_endline ("Select: " ^ (Int.to_string checkpoint.c_pid)); + if not checkpoint.c_valid then + wait_for_connection checkpoint; + current_checkpoint := checkpoint; + let dead_frags = List.filter (fun frag -> + not (List.mem frag checkpoint.c_code_fragments)) + (Symbols.code_fragments ()) + in + List.iter Symbols.erase_symbols dead_frags; + set_current_connection checkpoint.c_fd + +(* Kill `checkpoint'. *) +let kill_checkpoint checkpoint = + if !debug_time_travel then + prerr_endline ("Kill: " ^ (Int.to_string checkpoint.c_pid)); + if checkpoint.c_pid > 0 then (* Ghosts don't have to be killed ! *) + (if not checkpoint.c_valid then + wait_for_connection checkpoint; + stop checkpoint.c_fd; + if checkpoint.c_parent.c_pid > 0 then + wait_child checkpoint.c_parent.c_fd; + checkpoint.c_parent <- root; + close_io checkpoint.c_fd; + remove_file checkpoint.c_fd; + remove_checkpoint checkpoint); + checkpoint.c_pid <- -1 (* Don't exist anymore *) + +(*** Cleaning the checkpoint list. ***) + +(* Separate checkpoints before (<=) and after (>) `t'. *) +(* ### t checkpoints -> (after, before) *) +let cut t = + let rec cut_t = + function + [] -> ([], []) + | ({c_time = t'} as a::l) as l' -> + if t' <= t then + ([], l') + else + let (b, e) = cut_t l in + (a::b, e) + in + cut_t + +(* Partition the checkpoints list. *) +let cut2 t0 t l = + let rec cut2_t0 t = + function + [] -> [] + | l -> + let (after, before) = cut (t0 -- t -- _1) l in + let l = cut2_t0 (t ++ t) before in + after::l + in + let (after, before) = cut (t0 -- _1) l in + after::(cut2_t0 t before) + +(* Separate first elements and last element of a list of checkpoints. *) +let chk_merge2 cont = + let rec chk_merge2_cont = + function + [] -> cont + | [a] -> + let (accepted, rejected) = cont in + (a::accepted, rejected) + | a::l -> + let (accepted, rejected) = chk_merge2_cont l in + (accepted, a::rejected) + in chk_merge2_cont + +(* Separate the checkpoint list. *) +(* ### list -> accepted * rejected *) +let rec chk_merge = + function + [] -> ([], []) + | l::tail -> + chk_merge2 (chk_merge tail) l + +let new_checkpoint_list checkpoint_count accepted rejected = + if List.length accepted >= checkpoint_count then + let (k, l) = list_truncate2 checkpoint_count accepted in + (k, l @ rejected) + else + let (k, l) = + list_truncate2 (checkpoint_count - List.length accepted) rejected + in + (List.merge (fun t1 t2 -> compare t2.c_time t1.c_time) accepted k, + l) + +(* Clean the checkpoint list. *) +(* Reference time is `time'. *) +let clean_checkpoints time checkpoint_count = + let (after, before) = cut time !checkpoints in + let (accepted, rejected) = + chk_merge (cut2 time !checkpoint_small_step before) + in + let (kept, lost) = + new_checkpoint_list checkpoint_count accepted after + in + List.iter kill_checkpoint (lost @ rejected); + checkpoints := kept + +(*** Internal functions for moving. ***) + +(* Find the first checkpoint before (or at) `time'. + * Ask for reloading the program if necessary. + *) +let find_checkpoint_before time = + let rec find = + function + [] -> + print_string "Can't go that far in the past !"; print_newline (); + if yes_or_no "Reload program" then begin + load_program (); + find !checkpoints + end + else + raise Toplevel + | { c_time = t } as a::l -> + if t > time then + find l + else + a + in find !checkpoints + +(* Make a copy of the current checkpoint and clean the checkpoint list. *) +(* --- The new checkpoint is not put in the list. *) +let duplicate_current_checkpoint () = + let checkpoint = !current_checkpoint in + if not checkpoint.c_valid then + wait_for_connection checkpoint; + let new_checkpoint = (* Ghost *) + {c_time = checkpoint.c_time; + c_pid = 0; + c_fd = checkpoint.c_fd; + c_valid = false; + c_report = checkpoint.c_report; + c_state = C_stopped; + c_parent = checkpoint; + c_breakpoint_version = checkpoint.c_breakpoint_version; + c_breakpoints = checkpoint.c_breakpoints; + c_trap_barrier = checkpoint.c_trap_barrier; + c_code_fragments = checkpoint.c_code_fragments} + in + checkpoints := list_replace checkpoint new_checkpoint !checkpoints; + set_current_checkpoint checkpoint; + clean_checkpoints (checkpoint.c_time ++ _1) (!checkpoint_max_count - 1); + if new_checkpoint.c_pid = 0 then (* The ghost has not been killed *) + (match do_checkpoint () with (* Duplicate checkpoint *) + Checkpoint_done pid -> + (new_checkpoint.c_pid <- pid; + if !debug_time_travel then + prerr_endline ("Waiting for connection: " ^ Int.to_string pid)) + | Checkpoint_failed -> + prerr_endline + "A fork failed. Reducing maximum number of checkpoints."; + checkpoint_max_count := List.length !checkpoints - 1; + remove_checkpoint new_checkpoint) + +(* Was the movement interrupted ? *) +(* --- An exception could have been used instead, *) +(* --- but it is not clear where it should be caught. *) +(* --- For instance, it should not be caught in `step' *) +(* --- (as `step' is used in `next_1'). *) +(* --- On the other side, other modules does not need to know *) +(* --- about this exception. *) +let interrupted = ref false + +(* Information about last breakpoint encountered *) +let last_breakpoint = ref None + +(* Last debug info loaded *) +let last_debug_info = ref None + +let rec do_go_dynlink steps = + match do_go steps with + | { rep_type = Code_loaded frag; rep_event_count = steps } as report -> + begin match !last_debug_info with + | Some di -> + Symbols.add_symbols frag di; + Symbols.set_all_events frag; + last_debug_info := None + | None -> assert false + end; + if !break_on_load then report + else do_go_dynlink steps + | { rep_type = Code_unloaded frag; rep_event_count = steps } -> + Symbols.erase_symbols frag; + do_go_dynlink steps + | { rep_type = Debug_info di; rep_event_count = steps } -> + last_debug_info := Some (Array.to_list di); + do_go_dynlink steps + | report -> report + +(* Ensure we stop on an event. *) +let rec stop_on_event report = + match report with + {rep_type = Breakpoint; rep_program_pointer = pc; + rep_stack_pointer = sp} -> + last_breakpoint := Some (pc, sp); + Symbols.update_current_event (); + begin match !current_event with + None -> find_event () + | Some _ -> () + end + | {rep_type = Trap_barrier} -> + (* No event at current position. *) + find_event () + | _ -> + () + +and find_event () = + if !debug_time_travel then begin + print_string "Searching next event..."; + print_newline () + end; + let report = do_go_dynlink _1 in + !current_checkpoint.c_report <- Some report; + stop_on_event report + +(* Internal function for running debugged program. + * Requires `duration > 0'. + *) +let internal_step duration = + match current_report () with + Some {rep_type = Exited | Uncaught_exc} -> () + | _ -> + Exec.protect + (function () -> + if !make_checkpoints then + duplicate_current_checkpoint () + else + remove_checkpoint !current_checkpoint; + update_breakpoints (); + update_trap_barrier (); + !current_checkpoint.c_state <- C_running duration; + let report = do_go_dynlink duration in + !current_checkpoint.c_report <- Some report; + !current_checkpoint.c_state <- C_stopped; + !current_checkpoint.c_code_fragments <- Symbols.code_fragments (); + if report.rep_type = Event then begin + !current_checkpoint.c_time <- + !current_checkpoint.c_time ++ duration; + interrupted := false; + last_breakpoint := None + end + else begin + !current_checkpoint.c_time <- + !current_checkpoint.c_time ++ duration + -- report.rep_event_count ++ _1; + interrupted := true; + last_breakpoint := None; + stop_on_event report + end; + (try + insert_checkpoint !current_checkpoint + with + Exit -> + kill_checkpoint !current_checkpoint; + set_current_checkpoint + (find_checkpoint_before (current_time ())))); + if !debug_time_travel then begin + print_string "Checkpoints: pid(time)"; print_newline (); + List.iter + (function {c_time = time; c_pid = pid; c_valid = valid} -> + Printf.printf "%d(%Ld)%s " pid time + (if valid then "" else "(invalid)")) + !checkpoints; + print_newline () + end + +(*** Miscellaneous functions (exported). ***) + +(* Create a checkpoint at time 0 (new program). *) +let new_checkpoint pid fd = + let new_checkpoint = + {c_time = _0; + c_pid = pid; + c_fd = fd; + c_valid = true; + c_report = None; + c_state = C_stopped; + c_parent = root; + c_breakpoint_version = 0; + c_breakpoints = []; + c_trap_barrier = Sp.null; + c_code_fragments = [main_frag]} + in + insert_checkpoint new_checkpoint + +(* Set the file descriptor of a checkpoint *) +(* (a new process has connected with the debugger). *) +(* --- Return `true' on success (close the connection otherwise). *) +let set_file_descriptor pid fd = + let rec find = + function + [] -> + prerr_endline "Unexpected connection"; + close_io fd; + false + | ({c_pid = pid'} as checkpoint)::l -> + if pid <> pid' then + find l + else + (checkpoint.c_fd <- fd; + checkpoint.c_valid <- true; + true) + in + if !debug_time_travel then + prerr_endline ("New connection: " ^(Int.to_string pid)); + find (!current_checkpoint::!checkpoints) + +(* Kill all the checkpoints. *) +let kill_all_checkpoints () = + List.iter kill_checkpoint (!current_checkpoint::!checkpoints) + +(* Kill a checkpoint without killing the process. *) +(* (used when connection with the process is lost). *) +(* --- Assume that the checkpoint is valid. *) +let forget_process fd pid = + let checkpoint = + List.find (function c -> c.c_pid = pid) (!current_checkpoint::!checkpoints) + in + if pid > 0 then begin + Printf.eprintf "Lost connection with process %d" pid; + let kont = + if checkpoint == !current_checkpoint then begin + Printf.eprintf " (active process)\n"; + match !current_checkpoint.c_state with + C_stopped -> + Printf.eprintf "at time %Ld" !current_checkpoint.c_time; + fun () -> raise Current_checkpoint_lost + | C_running duration -> + Printf.eprintf "between time %Ld and time %Ld" + !current_checkpoint.c_time + (!current_checkpoint.c_time ++ duration); + fun () -> raise (Current_checkpoint_lost_start_at + (!current_checkpoint.c_time, duration)) + end + else ignore in + Printf.eprintf "\n"; flush stderr; + Input_handling.remove_file fd; + close_io checkpoint.c_fd; + remove_file checkpoint.c_fd; + remove_checkpoint checkpoint; + checkpoint.c_pid <- -1; (* Don't exist anymore *) + if checkpoint.c_parent.c_pid > 0 then + wait_child checkpoint.c_parent.c_fd; + kont () + end + +(* Try to recover when the current checkpoint is lost. *) +let recover () = + set_current_checkpoint + (find_checkpoint_before (current_time ())) + +(*** Simple movements. ***) + +(* Forward stepping. Requires `duration >= 0'. *) +let rec step_forward duration = + if duration > !checkpoint_small_step then begin + let first_step = + if duration > !checkpoint_big_step then + !checkpoint_big_step + else + !checkpoint_small_step + in + internal_step first_step; + if not !interrupted then + step_forward (duration -- first_step) + end + else if duration != _0 then + internal_step duration + +(* Go to time `time' from current checkpoint (internal). *) +let internal_go_to time = + let duration = time -- (current_time ()) in + if duration > _0 then + execute_without_breakpoints (function () -> step_forward duration) + +(* Move to a given time. *) +let go_to time = + let checkpoint = find_checkpoint_before time in + set_current_checkpoint checkpoint; + internal_go_to time + +(* Return the time of the last breakpoint *) +(* between current time and `max_time'. *) +let find_last_breakpoint max_time = + let rec find break = + let time = current_time () in + step_forward (max_time -- time); + match !last_breakpoint, !temporary_breakpoint_position with + (Some _, _) when current_time () < max_time -> + find !last_breakpoint + | (Some (pc, _), Some pc') when pc = pc' -> + (max_time, !last_breakpoint) + | _ -> + (time, break) + in + find + (match current_pc_sp () with + (Some (pc, _)) as state when breakpoint_at_pc pc -> state + | _ -> None) + +(* Run from `time_max' back to `time'. *) +(* --- Assume 0 <= time < time_max *) +let rec back_to time time_max = + let + {c_time = t} = find_checkpoint_before (pre64 time_max) + in + go_to (Int64.max time t); + let (new_time, break) = find_last_breakpoint time_max in + if break <> None || (new_time <= time) then begin + go_to new_time; + interrupted := break <> None; + last_breakpoint := break + end else + back_to time new_time + +(* Backward stepping. *) +(* --- Assume duration > 1 *) +let step_backward duration = + let time = current_time () in + if time > _0 then + back_to (Int64.max _0 (time -- duration)) time + +(* Run the program from current time. *) +(* Stop at the first breakpoint, or at the end of the program. *) +let rec run () = + internal_step !checkpoint_big_step; + if not !interrupted then + run () + +(* Run the program backward from current time. *) +(* Stop at the first breakpoint, or at the beginning of the program. *) +let back_run () = + if current_time () > _0 then + back_to _0 (current_time ()) + +(* Step in any direction. *) +(* Stop at the first breakpoint, or after `duration' steps. *) +let step duration = + if duration >= _0 then + step_forward duration + else + step_backward (_0 -- duration) + +(*** Next, finish. ***) + +(* Finish current function. *) +let finish () = + Symbols.update_current_event (); + match !current_event with + None -> + prerr_endline "`finish' not meaningful in outermost frame."; + raise Toplevel + | Some {ev_ev={ev_stacksize}} -> + set_initial_frame(); + let (frame, pc) = up_frame ev_stacksize in +(* BACKPORT BEGIN + if frame = Sp.null then begin +*) + if frame < Sp.null then begin +(* BACKPORT END *) + prerr_endline "`finish' not meaningful in outermost frame."; + raise Toplevel + end; + begin + try ignore(Symbols.any_event_at_pc pc) + with Not_found -> + prerr_endline "Calling function has no debugging information."; + raise Toplevel + end; + exec_with_trap_barrier + frame + (fun () -> + exec_with_temporary_breakpoint + pc + (fun () -> + while + run (); + match !last_breakpoint with + Some (pc', frame') when pc = pc' -> + interrupted := false; + frame <> frame' + | _ -> + false + do + () + done)) + +let next_1 () = + Symbols.update_current_event (); + match !current_event with + None -> (* Beginning of the program. *) + step _1 + | Some {ev_ev={ev_stacksize=ev_stacksize1}} -> + let (frame1, _pc1) = initial_frame() in + step _1; + if not !interrupted then begin + Symbols.update_current_event (); + match !current_event with + None -> () + | Some {ev_ev={ev_stacksize=ev_stacksize2}} -> + let (frame2, _pc2) = initial_frame() in + (* Call `finish' if we've entered a function. *) +(* BACKPORT BEGIN + if frame1 <> Sp.null && frame2 <> Sp.null && + Sp.(compare (base frame2 ev_stacksize2) + (base frame1 ev_stacksize1)) > 0 +*) + if frame1 >= 0 && frame2 >= 0 && + frame2 - ev_stacksize2 > frame1 - ev_stacksize1 +(* BACKPORT END *) + then finish() + end + +(* Same as `step' (forward) but skip over function calls. *) +let rec next = + function + 0 -> () + | n -> + next_1 (); + if not !interrupted then + next (n - 1) + +(* Run backward until just before current function. *) +let start () = + Symbols.update_current_event (); + match !current_event with + None -> + prerr_endline "`start not meaningful in outermost frame."; + raise Toplevel + | Some {ev_ev={ev_stacksize}} -> + let (frame, _) = initial_frame() in + let (frame', pc) = up_frame ev_stacksize in +(* BACKPORT BEGIN + if frame' = Sp.null then begin +*) + if frame' < Sp.null then begin +(* BACKPORT END *) + prerr_endline "`start not meaningful in outermost frame."; + raise Toplevel + end; + let nargs = + match + try Symbols.any_event_at_pc pc with Not_found -> + prerr_endline "Calling function has no debugging information."; + raise Toplevel + with + {ev_ev = {ev_info = Event_return nargs}} -> nargs + | _ -> Misc.fatal_error "Time_travel.start" + in + let offset = if nargs < 4 then 1 else 2 in + let pc = { pc with pos = pc.pos - 4 * offset } in + while + exec_with_temporary_breakpoint pc back_run; + match !last_breakpoint with + Some (pc', frame') when pc = pc' -> + step _minus1; + (not !interrupted) + && +(* BACKPORT BEGIN + Sp.(compare (base frame' nargs) (base frame ev_stacksize)) > 0 +*) + (frame' - nargs > frame - ev_stacksize) +(* BACKPORT END *) + | _ -> + false + do + () + done + +let previous_1 () = + Symbols.update_current_event (); + match !current_event with + None -> (* End of the program. *) + step _minus1 + | Some {ev_ev={ev_stacksize=ev_stacksize1}} -> + let (frame1, _pc1) = initial_frame() in + step _minus1; + if not !interrupted then begin + Symbols.update_current_event (); + match !current_event with + None -> () + | Some {ev_ev={ev_stacksize=ev_stacksize2}} -> + let (frame2, _pc2) = initial_frame() in + (* Call `start' if we've entered a function. *) +(* BACKPORT BEGIN + if frame1 <> Sp.null && frame2 <> Sp.null && + Sp.(compare (base frame2 ev_stacksize2) + (base frame1 ev_stacksize1)) > 0 +*) + if frame1 >= 0 && frame2 >= 0 && + frame2 - ev_stacksize2 > frame1 - ev_stacksize1 +(* BACKPORT END *) + then start() + end + +(* Same as `step' (backward) but skip over function calls. *) +let rec previous = + function + 0 -> () + | n -> + previous_1 (); + if not !interrupted then + previous (n - 1) diff --git a/ocaml/debugger4/time_travel.mli b/ocaml/debugger4/time_travel.mli new file mode 100644 index 00000000000..e25bad9fcc7 --- /dev/null +++ b/ocaml/debugger4/time_travel.mli @@ -0,0 +1,38 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(**************************** Time travel ******************************) + +open Primitives + +exception Current_checkpoint_lost +exception Current_checkpoint_lost_start_at of int64 * int64 + +val new_checkpoint : int -> io_channel -> unit +val set_file_descriptor : int -> io_channel -> bool +val kill_all_checkpoints : unit -> unit +val forget_process : io_channel -> int -> unit +val recover : unit -> unit + +val go_to : int64 -> unit + +val run : unit -> unit +val back_run : unit -> unit +val step : int64 -> unit +val finish : unit -> unit +val next : int -> unit +val start : unit -> unit +val previous : int -> unit diff --git a/ocaml/debugger4/trap_barrier.ml b/ocaml/debugger4/trap_barrier.ml new file mode 100644 index 00000000000..861b7f24228 --- /dev/null +++ b/ocaml/debugger4/trap_barrier.ml @@ -0,0 +1,42 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(************************** Trap barrier *******************************) + +open Debugcom +open Checkpoints + +let current_trap_barrier = ref Sp.null + +let install_trap_barrier pos = + current_trap_barrier := pos + +let remove_trap_barrier () = + current_trap_barrier := Sp.null + +(* Ensure the trap barrier state is up to date in current checkpoint. *) +let update_trap_barrier () = + if !current_checkpoint.c_trap_barrier <> !current_trap_barrier then + Exec.protect + (function () -> + set_trap_barrier !current_trap_barrier; + !current_checkpoint.c_trap_barrier <- !current_trap_barrier) + +(* Execute `funct' with a trap barrier. *) +(* --- Used by `finish'. *) +let exec_with_trap_barrier trap_barrier funct = + install_trap_barrier trap_barrier; + Fun.protect ~finally:remove_trap_barrier funct diff --git a/ocaml/debugger4/trap_barrier.mli b/ocaml/debugger4/trap_barrier.mli new file mode 100644 index 00000000000..7d26c8627d1 --- /dev/null +++ b/ocaml/debugger4/trap_barrier.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(************************* Trap barrier ********************************) + +val install_trap_barrier : Debugcom.Sp.t -> unit + +val remove_trap_barrier : unit -> unit + +(* Ensure the trap barrier state is up to date in current checkpoint. *) +val update_trap_barrier : unit -> unit + +(* Execute `funct' with a trap barrier. *) +(* --- Used by `finish'. *) +val exec_with_trap_barrier : Debugcom.Sp.t -> (unit -> unit) -> unit diff --git a/ocaml/debugger4/unix_tools.ml b/ocaml/debugger4/unix_tools.ml new file mode 100644 index 00000000000..f61ac913357 --- /dev/null +++ b/ocaml/debugger4/unix_tools.ml @@ -0,0 +1,144 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(****************** Tools for Unix *************************************) + +module Real_stdlib = Stdlib +open Misc +open Unix + +(*** Convert a socket name into a socket address. ***) +let convert_address address = + try + let n = String.index address ':' in + let host = String.sub address 0 n + and port = String.sub address (n + 1) (String.length address - n - 1) + in + (PF_INET, + ADDR_INET + ((try inet_addr_of_string host with Failure _ -> + try (gethostbyname host).h_addr_list.(0) with Not_found -> + prerr_endline ("Unknown host: " ^ host); + failwith "Can't convert address"), + (try int_of_string port with Failure _ -> + prerr_endline "The port number should be an integer"; + failwith "Can't convert address"))) + with Not_found -> + match Sys.os_type with + "Win32" -> failwith "Unix sockets not supported" + | _ -> (PF_UNIX, ADDR_UNIX address) + +(*** Report a unix error. ***) +let report_error = function + | Unix_error (err, fun_name, arg) -> + prerr_string "Unix error: '"; + prerr_string fun_name; + prerr_string "' failed"; + if String.length arg > 0 then + (prerr_string " on '"; + prerr_string arg; + prerr_string "'"); + prerr_string ": "; + prerr_endline (error_message err) + | _ -> fatal_error "report_error: not a Unix error" + +(* Find program `name' in `PATH'. *) +(* Return the full path if found. *) +(* Raise `Not_found' otherwise. *) +let search_in_path name = + Printf.fprintf Real_stdlib.stderr "search_in_path [%s]\n%!" name; + let check name = + try access name [X_OK]; name with Unix_error _ -> raise Not_found + in + if not (Filename.is_implicit name) then + check name + else + let path = Sys.getenv "PATH" in + let length = String.length path in + let rec traverse pointer = + if (pointer >= length) || (path.[pointer] = ':') then + pointer + else + traverse (pointer + 1) + in + let rec find pos = + let pos2 = traverse pos in + let directory = (String.sub path pos (pos2 - pos)) in + let fullname = + if directory = "" then name else directory ^ "/" ^ name + in + try check fullname with + | Not_found -> + if pos2 < length then find (pos2 + 1) + else raise Not_found + in + find 0 + +(* Expand a path. *) +(* ### path -> path' *) +let rec expand_path ch = + let rec subst_variable ch = + try + let pos = String.index ch '$' in + if (pos + 1 < String.length ch) && (ch.[pos + 1] = '$') then + (String.sub ch 0 (pos + 1)) + ^ (subst_variable + (String.sub ch (pos + 2) (String.length ch - pos - 2))) + else + (String.sub ch 0 pos) + ^ (subst2 (String.sub ch (pos + 1) (String.length ch - pos - 1))) + with Not_found -> + ch + and subst2 ch = + let suiv = + let i = ref 0 in + while !i < String.length ch && + (let c = ch.[!i] in (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + || c = '_') + do incr i done; + !i + in (Sys.getenv (String.sub ch 0 suiv)) + ^ (subst_variable (String.sub ch suiv (String.length ch - suiv))) + in + let ch = subst_variable ch in + let concat_root nom ch2 = + try Filename.concat (getpwnam nom).pw_dir ch2 + with Not_found -> + "~" ^ nom + in + if ch.[0] = '~' then + try + match String.index ch '/' with + 1 -> + (let tail = String.sub ch 2 (String.length ch - 2) + in + try Filename.concat (Sys.getenv "HOME") tail + with Not_found -> + concat_root (Sys.getenv "LOGNAME") tail) + | n -> concat_root + (String.sub ch 1 (n - 1)) + (String.sub ch (n + 1) (String.length ch - n - 1)) + with + Not_found -> + expand_path (ch ^ "/") + else ch + +let make_absolute name = + if Filename.is_relative name + then Filename.concat (getcwd ()) name + else name diff --git a/ocaml/debugger4/unix_tools.mli b/ocaml/debugger4/unix_tools.mli new file mode 100644 index 00000000000..db3af072cc6 --- /dev/null +++ b/ocaml/debugger4/unix_tools.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Jerome Vouillon, projet Cristal, INRIA Rocquencourt *) +(* OCaml port by John Malecki and Xavier Leroy *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(**************************** Tools for Unix ***************************) + +open Unix + +(* Convert a socket name into a socket address. *) +val convert_address : string -> socket_domain * sockaddr + +(* Report an unix error. *) +val report_error : exn -> unit + +(* Find program `name' in `PATH'. *) +(* Return the full path if found. *) +(* Raise `Not_found' otherwise. *) +val search_in_path : string -> string + +(* Path expansion. *) +val expand_path : string -> string + +val make_absolute : string -> string diff --git a/ocaml/ocamltest/ocaml_actions.ml b/ocaml/ocamltest/ocaml_actions.ml index 2a1b282d73c..5d17fe977f8 100644 --- a/ocaml/ocamltest/ocaml_actions.ml +++ b/ocaml/ocamltest/ocaml_actions.ml @@ -1144,6 +1144,8 @@ let config_variables _log env = Ocaml_variables.ocamlrunparam, Sys.safe_getenv "OCAMLRUNPARAM"; Ocaml_variables.ocamlsrcdir, Ocaml_directories.srcdir; Ocaml_variables.os_type, Sys.os_type; + Ocaml_variables.runtime_dir, + if Config.runtime5 then "runtime" else "runtime4" ] env let flat_float_array = Actions.make @@ -1290,6 +1292,19 @@ let no_poll_insertion = Actions.make "Poll insertion disabled" "Poll insertion enabled") +let runtime4 = Actions.make + ~name:"runtime4" + ~description:"Passes if the OCaml 4.x runtime is being used" + (Actions_helpers.pass_or_skip (not Config.runtime5) + "4.x runtime being used" + "5.x runtime being used") + +let runtime5 = Actions.make + ~name:"runtime5" + ~description:"Passes if the OCaml 5.x runtime is being used" + (Actions_helpers.pass_or_skip Config.runtime5 + "5.x runtime being used" + "4.x runtime being used") let ocamldoc = Ocaml_tools.ocamldoc let ocamldoc_output_file env prefix = @@ -1500,5 +1515,7 @@ let _ = ocamlmklib; codegen; cc; - ocamlobjinfo + ocamlobjinfo; + runtime4; + runtime5 ] diff --git a/ocaml/ocamltest/ocaml_files.ml b/ocaml/ocamltest/ocaml_files.ml index 7c657c7d6a0..29deca40fe0 100644 --- a/ocaml/ocamltest/ocaml_files.ml +++ b/ocaml/ocamltest/ocaml_files.ml @@ -28,14 +28,15 @@ let runtime_variant() = else if use_runtime="i" then Instrumented else Normal +let runtime_suffix = if Config.runtime5 then "" else "4" + let ocamlrun = let runtime = match runtime_variant () with | Normal -> "ocamlrun" | Debug -> "ocamlrund" | Instrumented -> "ocamlruni" in let ocamlrunfile = Filename.mkexe runtime in - let suffix = if Config.runtime5 then "" else "4" in - Filename.make_path [Ocaml_directories.srcdir; "runtime" ^ suffix; + Filename.make_path [Ocaml_directories.srcdir; "runtime" ^ runtime_suffix; ocamlrunfile] let ocamlc = @@ -79,7 +80,8 @@ let ocamldoc = let ocamldebug = Filename.make_path - [Ocaml_directories.srcdir; "debugger"; Filename.mkexe "ocamldebug"] + [Ocaml_directories.srcdir; "debugger" ^ runtime_suffix; + Filename.mkexe "ocamldebug"] let ocamlobjinfo = Filename.make_path diff --git a/ocaml/ocamltest/ocaml_modifiers.ml b/ocaml/ocamltest/ocaml_modifiers.ml index b3f20b72b8d..fd945edc70e 100644 --- a/ocaml/ocamltest/ocaml_modifiers.ml +++ b/ocaml/ocamltest/ocaml_modifiers.ml @@ -124,7 +124,9 @@ let compilerlibs_archive archive = append Ocaml_variables.libraries [archive] :: List.map add_compiler_subdir compilerlibs_subdirs -let debugger = [add_compiler_subdir "debugger"] +let runtime_suffix = if Config.runtime5 then "" else "4" + +let debugger = [add_compiler_subdir ("debugger" ^ runtime_suffix)] let _ = register_modifiers "principal" principal; diff --git a/ocaml/ocamltest/ocaml_variables.ml b/ocaml/ocamltest/ocaml_variables.ml index 1f98b6326e3..6cb561b8a97 100644 --- a/ocaml/ocamltest/ocaml_variables.ml +++ b/ocaml/ocamltest/ocaml_variables.ml @@ -226,6 +226,9 @@ let ocaml_script_as_argument = let plugins = Variables.make ( "plugins", "plugins for ocamldoc" ) +let runtime_dir = + Variables.make ( "runtime_dir", "leafname of the runtime directory" ) + let shared_library_cflags = Variables.make ("shared_library_cflags", "Flags used to compile C files for inclusion in shared libraries") @@ -296,6 +299,7 @@ let _ = List.iter register_variable ocaml_script_as_argument; os_type; plugins; + runtime_dir; shared_library_cflags; sharedobjext; use_runtime; diff --git a/ocaml/ocamltest/ocaml_variables.mli b/ocaml/ocamltest/ocaml_variables.mli index 8bd31b4fc7e..7cdd19ee5d7 100644 --- a/ocaml/ocamltest/ocaml_variables.mli +++ b/ocaml/ocamltest/ocaml_variables.mli @@ -129,6 +129,8 @@ val ocaml_script_as_argument : Variables.t val plugins : Variables.t +val runtime_dir : Variables.t + val shared_library_cflags : Variables.t val sharedobjext : Variables.t diff --git a/ocaml/otherlibs/dynlink/byte/dynlink.ml b/ocaml/otherlibs/dynlink/byte/dynlink.ml index 699d606dfa8..1fd8438f6d5 100644 --- a/ocaml/otherlibs/dynlink/byte/dynlink.ml +++ b/ocaml/otherlibs/dynlink/byte/dynlink.ml @@ -113,50 +113,65 @@ module Bytecode = struct init !default_crcs - let run_shared_startup _ ~filename:_ ~priv:_ = () + let run_shared_startup _ = () - let run (ic, file_name, file_digest) ~filename:_ ~unit_header ~priv = + let with_lock lock f = + match lock with + | None -> f () + | Some lock -> + Mutex.lock lock; + Fun.protect f + ~finally:(fun () -> Mutex.unlock lock) + + let run lock (ic, file_name, file_digest) ~unit_header ~priv = let open Misc in - let old_state = Symtable.current_state () in - let compunit : Cmo_format.compilation_unit_descr = unit_header in - seek_in ic compunit.cu_pos; - let code_size = compunit.cu_codesize + 8 in - let code = LongString.create code_size in - LongString.input_bytes_into code ic compunit.cu_codesize; - LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); - LongString.blit_string "\000\000\000\001\000\000\000" 0 - code (compunit.cu_codesize + 1) 7; - begin try - Symtable.patch_object code compunit.cu_reloc; - Symtable.check_global_initialized compunit.cu_reloc; - Symtable.update_global_table () - with Symtable.Error error -> - let new_error : DT.linking_error = - match error with - | Symtable.Undefined_global s -> Undefined_global s - | Symtable.Unavailable_primitive s -> Unavailable_primitive s - | Symtable.Uninitialized_global s -> Uninitialized_global s - | Symtable.Wrong_vm _ -> assert false - in - raise (DT.Error (Linking_error (file_name, new_error))) - end; - (* PR#5215: identify this code fragment by - digest of file contents + unit name. - Unit name is needed for .cma files, which produce several code - fragments. *) - let digest = - Digest.string - (file_digest ^ Compilation_unit.full_path_as_string compunit.cu_name) + let clos = with_lock lock (fun () -> + let old_state = Symtable.current_state () in + let compunit : Cmo_format.compilation_unit_descr = unit_header in + seek_in ic compunit.cu_pos; + let code_size = compunit.cu_codesize + 8 in + let code = LongString.create code_size in + LongString.input_bytes_into code ic compunit.cu_codesize; + LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + LongString.blit_string "\000\000\000\001\000\000\000" 0 + code (compunit.cu_codesize + 1) 7; + begin try + Symtable.patch_object code compunit.cu_reloc; + Symtable.check_global_initialized compunit.cu_reloc; + Symtable.update_global_table () + with Symtable.Error error -> + let new_error : DT.linking_error = + match error with + | Symtable.Undefined_global s -> Undefined_global s + | Symtable.Unavailable_primitive s -> Unavailable_primitive s + | Symtable.Uninitialized_global s -> Uninitialized_global s + | Symtable.Wrong_vm _ -> assert false + in + raise (DT.Error (Linking_error (file_name, new_error))) + end; + (* PR#5215: identify this code fragment by + digest of file contents + unit name. + Unit name is needed for .cma files, which produce several code + fragments. *) + let digest = + Digest.string + (file_digest ^ Compilation_unit.full_path_as_string compunit.cu_name) + in + let events = + if compunit.cu_debug = 0 then [| |] + else begin + seek_in ic compunit.cu_debug; + [| input_value ic |] + end in + if priv then Symtable.hide_additions old_state; + let _, clos = Meta.reify_bytecode code events (Some digest) in + clos + ) in - let events = - if compunit.cu_debug = 0 then [| |] - else begin - seek_in ic compunit.cu_debug; - [| input_value ic |] - end in - if priv then Symtable.hide_additions old_state; - let _, clos = Meta.reify_bytecode code events (Some digest) in - try ignore ((clos ()) : Obj.t) + (* We need to release the dynlink lock here to let the module initialization + code dynlinks plugins too. + *) + try ignore ((clos ()) : Obj.t); with exn -> Printexc.raise_with_backtrace (DT.Error (Library's_module_initializers_failed exn)) @@ -196,6 +211,8 @@ module Bytecode = struct close_in ic; raise exc + let register _handle _header ~priv:_ ~filename:_ = () + let unsafe_get_global_value ~bytecode_or_asm_symbol = let id = Ident.create_persistent bytecode_or_asm_symbol in match Symtable.get_global_value id with diff --git a/ocaml/otherlibs/dynlink/dynlink_common.ml b/ocaml/otherlibs/dynlink/dynlink_common.ml index 8555268c1e8..3fb67190f78 100644 --- a/ocaml/otherlibs/dynlink/dynlink_common.ml +++ b/ocaml/otherlibs/dynlink/dynlink_common.ml @@ -79,11 +79,18 @@ module Make (P : Dynlink_platform_intf.S) = struct mutable inited:bool; mutable unsafe_allowed:bool; } - (* val lock: Mutex.t *) + val lock: Mutex.t option val with_lock: (t->'a) -> 'a end = struct - (* let lock = Mutex.create () *) + external runtime5 : unit -> bool = "%runtime5" + + let lock = + (* We cannot call [Mutex.create] on runtime4 without making the dynlink + library depend on the threads library. *) + if runtime5 () then Some (Mutex.create ()) + else None + type t = { mutable state:State.t; mutable inited:bool; @@ -93,16 +100,16 @@ module Make (P : Dynlink_platform_intf.S) = struct state = State.empty; inited = false; unsafe_allowed = false; - } - (* CR ocaml 5 runtime *) - (* let with_lock0 f = - Mutex.lock lock; - Fun.protect f - ~finally:(fun () -> Mutex.unlock lock) *) + let with_lock0 f = + match lock with + | None -> f () + | Some lock -> + Mutex.lock lock; + Fun.protect f + ~finally:(fun () -> Mutex.unlock lock) - let with_lock0 f = f () let with_lock f = with_lock0 (fun () -> f state) end open Global @@ -358,13 +365,24 @@ module Make (P : Dynlink_platform_intf.S) = struct global.state <- check filename units global.state ~unsafe_allowed ~priv; - P.run_shared_startup handle ~filename ~priv; + (* [register] must be called after [check]: + 1. so as not to leave outdated entries in the frame table + list (etc) after a failure of [check]; + 2. so that the duplicate dyn-globals test only triggers in + public-loading mode in the event of a bug in [Dynlink], + matching the 4.x semantics. *) + P.register handle units ~priv ~filename; + (* [run_shared_startup] doesn't take [lock] because a lock isn't + needed for the native implementation (neither for [run]) and + the bytecode implementation, where [run] does need a lock, + has [run_shared_startup] as a no-op. *) + P.run_shared_startup handle; ); List.iter (fun unit_header -> (* Linked modules might call Dynlink themselves, we need to release the lock *) - P.run (* Global.lock *) handle ~filename ~unit_header ~priv; + P.run Global.lock handle ~unit_header ~priv; if not priv then with_lock (fun global -> global.state <- set_loaded filename unit_header global.state ) diff --git a/ocaml/otherlibs/dynlink/dynlink_platform_intf.ml b/ocaml/otherlibs/dynlink/dynlink_platform_intf.ml index 36eb7cba12e..525617034fc 100644 --- a/ocaml/otherlibs/dynlink/dynlink_platform_intf.ml +++ b/ocaml/otherlibs/dynlink/dynlink_platform_intf.ml @@ -60,13 +60,18 @@ module type S = sig -> priv:bool -> handle * (Unit_header.t list) - val run_shared_startup : handle -> filename:string -> priv:bool -> unit + val register + : handle + -> Unit_header.t list + -> priv:bool + -> filename:string + -> unit + + val run_shared_startup : handle -> unit val run - : (* CR ocaml 5 runtime: The first argument upstream is a mutex. *) - (* Mutex.t -> *) - handle - -> filename:string + : Mutex.t option + -> handle -> unit_header:Unit_header.t -> priv:bool -> unit diff --git a/ocaml/otherlibs/dynlink/native/dynlink.ml b/ocaml/otherlibs/dynlink/native/dynlink.ml index 45171b479c5..ff950d26129 100644 --- a/ocaml/otherlibs/dynlink/native/dynlink.ml +++ b/ocaml/otherlibs/dynlink/native/dynlink.ml @@ -16,6 +16,8 @@ (* *) (**************************************************************************) +(* Dynamic loading of .cmx files *) + [@@@ocaml.warning "+a-4-30-40-41-42"] open! Dynlink_compilerlibs @@ -41,6 +43,8 @@ module Native = struct (* mshinwell: We need something better than caml_sys_exit *) external ndl_open : string -> bool -> handle * Cmxs_format.dynheader = "caml_sys_exit" "caml_natdynlink_open" + external ndl_register : handle -> string array -> unit + = "caml_sys_exit" "caml_natdynlink_register" external ndl_run : handle -> string -> unit = "caml_sys_exit" "caml_natdynlink_run" external ndl_getmap : unit -> global_map list @@ -103,13 +107,40 @@ module Native = struct init (ndl_getmap ()) + let run_shared_startup handle = + ndl_run handle "caml_shared_startup" + + let run _lock handle ~unit_header ~priv:_ = + List.iter (fun cu -> + try ndl_run handle cu + with exn -> + Printexc.raise_with_backtrace + (DT.Error (Library's_module_initializers_failed exn)) + (Printexc.get_raw_backtrace ())) + (Unit_header.defined_symbols unit_header) + exception Register_dyn_global_duplicate let () = Callback.register "Register_dyn_global_duplicate" Register_dyn_global_duplicate - let ndl_run handle cu ~filename ~priv = - try ndl_run handle cu + let load ~filename ~priv = + let handle, header = + try ndl_open filename (not priv) + with exn -> raise (DT.Error (Cannot_open_dynamic_library exn)) + in + if header.dynu_magic <> Config.cmxs_magic_number then begin + raise (DT.Error (Not_a_bytecode_file filename)) + end; + handle, header.dynu_units + + let register handle dynu_units ~priv ~filename = + let syms = + "caml_shared_startup" :: + List.concat_map Unit_header.defined_symbols dynu_units + in + try + ndl_register handle (Array.of_list syms) with | Register_dyn_global_duplicate -> if not priv then @@ -125,23 +156,6 @@ module Native = struct (DT.Error (Library's_module_initializers_failed exn)) (Printexc.get_raw_backtrace ()) - let run_shared_startup handle ~filename ~priv = - ndl_run handle "caml_shared_startup" ~filename ~priv - - let run handle ~filename ~unit_header ~priv = - List.iter (fun cu -> ndl_run handle cu ~filename ~priv) - (Unit_header.defined_symbols unit_header) - - let load ~filename ~priv = - let handle, header = - try ndl_open filename (not priv) - with exn -> raise (DT.Error (Cannot_open_dynamic_library exn)) - in - if header.dynu_magic <> Config.cmxs_magic_number then begin - raise (DT.Error (Not_a_bytecode_file filename)) - end; - handle, header.dynu_units - let unsafe_get_global_value ~bytecode_or_asm_symbol = match ndl_loadsym bytecode_or_asm_symbol with | exception _ -> None diff --git a/ocaml/otherlibs/systhreads/byte/dune b/ocaml/otherlibs/systhreads/byte/dune new file mode 100644 index 00000000000..988d5ad881c --- /dev/null +++ b/ocaml/otherlibs/systhreads/byte/dune @@ -0,0 +1,21 @@ +(copy_files# ../*.{c,h,ml,mli}) + +(copy_files# ../../../runtime/sync_posix.h) + +(library + (name threads) + (modes byte) + (wrapped false) + (flags -w +33..39 -warn-error A -g -bin-annot) + (ocamlopt_flags + (:include %{project_root}/ocamlopt_flags.sexp)) + (libraries unix) + (library_flags -linkall) + (c_library_flags -lpthread) + (foreign_stubs + (language c) + (names st_stubs) + (flags + ((:include %{project_root}/oc_cflags.sexp) + (:include %{project_root}/sharedlib_cflags.sexp) + (:include %{project_root}/oc_cppflags.sexp))))) diff --git a/ocaml/otherlibs/systhreads/dune b/ocaml/otherlibs/systhreads/dune index 3738b645d5f..1f3076c11d1 100644 --- a/ocaml/otherlibs/systhreads/dune +++ b/ocaml/otherlibs/systhreads/dune @@ -17,7 +17,21 @@ (install (files + (byte/threads.cma as threads/threads.cma) + (native/threadsnat.cmxa as threads/threads.cmxa) + (native/threadsnat.a as threads/threads.a) + (byte/libthreads_stubs.a as libthreads_stubs.a) + (byte/dllthreads_stubs.so as stublibs/dllthreads_stubs.so) + (native/libthreadsnat_stubs.a as libthreadsnat_stubs.a) + (native/libthreadsnat_stubs.a as libthreadsnat_stubs_native.a) ; for special_dune compat (thread.mli as threads/thread.mli) - (threads.h as caml/threads.h)) + (event.mli as threads/event.mli) + (threads.h as caml/threads.h) + (native/.threadsnat.objs/native/event.cmx as threads/event.cmx) + (native/.threadsnat.objs/native/thread.cmx as threads/thread.cmx) + (byte/.threads.objs/byte/event.cmi as threads/event.cmi) + (byte/.threads.objs/byte/event.cmti as threads/event.cmti) + (byte/.threads.objs/byte/thread.cmi as threads/thread.cmi) + (byte/.threads.objs/byte/thread.cmti as threads/thread.cmti)) (section lib) (package ocaml)) diff --git a/ocaml/otherlibs/systhreads/native/dune b/ocaml/otherlibs/systhreads/native/dune new file mode 100644 index 00000000000..778b937cf61 --- /dev/null +++ b/ocaml/otherlibs/systhreads/native/dune @@ -0,0 +1,22 @@ +(copy_files# ../*.{c,h,ml,mli}) + +(copy_files# ../../../runtime/sync_posix.h) + +(library + (name threadsnat) + (modes native) + (wrapped false) + (flags -w +33..39 -warn-error A -g -bin-annot) + (ocamlopt_flags + (:include %{project_root}/ocamlopt_flags.sexp)) + (libraries unix) + (library_flags -linkall) + (c_library_flags -lpthread) + (foreign_stubs + (language c) + (names st_stubs) + (flags + ((-DNATIVE_CODE) + (:include %{project_root}/oc_cflags.sexp) + (:include %{project_root}/sharedlib_cflags.sexp) + (:include %{project_root}/oc_cppflags.sexp))))) diff --git a/ocaml/otherlibs/systhreads/thread.ml b/ocaml/otherlibs/systhreads/thread.ml index 83cbb80ca83..9939bbd6aca 100644 --- a/ocaml/otherlibs/systhreads/thread.ml +++ b/ocaml/otherlibs/systhreads/thread.ml @@ -1,3 +1,5 @@ +# 1 "thread.ml" + (**************************************************************************) (* *) (* OCaml *) @@ -15,6 +17,8 @@ (* User-level threads *) +[@@@ocaml.flambda_o3] + type t external thread_initialize : unit -> unit = "caml_thread_initialize" diff --git a/ocaml/otherlibs/systhreads4/Makefile b/ocaml/otherlibs/systhreads4/Makefile index 1404646da39..ecabaf6e675 100644 --- a/ocaml/otherlibs/systhreads4/Makefile +++ b/ocaml/otherlibs/systhreads4/Makefile @@ -45,12 +45,12 @@ LIBNAME=threads BYTECODE_C_OBJS=st_stubs.b.$(O) NATIVECODE_C_OBJS=st_stubs.n.$(O) -THREADS_SOURCES = thread.ml mutex.ml condition.ml event.ml semaphore.ml +THREADS_SOURCES = thread.ml event.ml THREADS_BCOBJS = $(THREADS_SOURCES:.ml=.cmo) THREADS_NCOBJS = $(THREADS_SOURCES:.ml=.cmx) -MLIFILES=thread.mli mutex.mli condition.mli event.mli semaphore.mli +MLIFILES=thread.mli event.mli CMIFILES=$(MLIFILES:.mli=.cmi) diff --git a/ocaml/otherlibs/systhreads4/condition.mli b/ocaml/otherlibs/systhreads4/condition.mli deleted file mode 100644 index 36c71fc818b..00000000000 --- a/ocaml/otherlibs/systhreads4/condition.mli +++ /dev/null @@ -1,53 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(** Condition variables to synchronize between threads. - - Condition variables are used when one thread wants to wait until another - thread has finished doing something: the former thread 'waits' on the - condition variable, the latter thread 'signals' the condition when it - is done. Condition variables should always be protected by a mutex. - The typical use is (if [D] is a shared data structure, [m] its mutex, - and [c] is a condition variable): - {[ - Mutex.lock m; - while (* some predicate P over D is not satisfied *) do - Condition.wait c m - done; - (* Modify D *) - if (* the predicate P over D is now satisfied *) then Condition.signal c; - Mutex.unlock m - ]} -*) - -type t -(** The type of condition variables. *) - -val create : unit -> t -(** Return a new condition variable. *) - -val wait : t -> Mutex.t -> unit -(** [wait c m] atomically unlocks the mutex [m] and suspends the - calling process on the condition variable [c]. The process will - restart after the condition variable [c] has been signalled. - The mutex [m] is locked again before [wait] returns. *) - -val signal : t -> unit -(** [signal c] restarts one of the processes waiting on the - condition variable [c]. *) - -val broadcast : t -> unit -(** [broadcast c] restarts all processes waiting on the - condition variable [c]. *) diff --git a/ocaml/otherlibs/systhreads4/dune b/ocaml/otherlibs/systhreads4/dune index 5c9f889f564..faeb6bc72d0 100644 --- a/ocaml/otherlibs/systhreads4/dune +++ b/ocaml/otherlibs/systhreads4/dune @@ -28,27 +28,15 @@ (thread.mli as threads/thread.mli) - (condition.mli as threads/condition.mli) (event.mli as threads/event.mli) - (mutex.mli as threads/mutex.mli) - (semaphore.mli as threads/semaphore.mli) (threads.h as caml/threads.h) - (native/.threadsnat.objs/native/condition.cmx as threads/condition.cmx) (native/.threadsnat.objs/native/event.cmx as threads/event.cmx) - (native/.threadsnat.objs/native/mutex.cmx as threads/mutex.cmx) - (native/.threadsnat.objs/native/semaphore.cmx as threads/semaphore.cmx) (native/.threadsnat.objs/native/thread.cmx as threads/thread.cmx) - (byte/.threads.objs/byte/condition.cmi as threads/condition.cmi) - (byte/.threads.objs/byte/condition.cmti as threads/condition.cmti) (byte/.threads.objs/byte/event.cmi as threads/event.cmi) (byte/.threads.objs/byte/event.cmti as threads/event.cmti) - (byte/.threads.objs/byte/mutex.cmi as threads/mutex.cmi) - (byte/.threads.objs/byte/mutex.cmti as threads/mutex.cmti) - (byte/.threads.objs/byte/semaphore.cmi as threads/semaphore.cmi) - (byte/.threads.objs/byte/semaphore.cmti as threads/semaphore.cmti) (byte/.threads.objs/byte/thread.cmi as threads/thread.cmi) (byte/.threads.objs/byte/thread.cmti as threads/thread.cmti) ) diff --git a/ocaml/otherlibs/systhreads4/st_pthreads.h b/ocaml/otherlibs/systhreads4/st_pthreads.h deleted file mode 100644 index 26e32caba5e..00000000000 --- a/ocaml/otherlibs/systhreads4/st_pthreads.h +++ /dev/null @@ -1,387 +0,0 @@ -/**************************************************************************/ -/* */ -/* OCaml */ -/* */ -/* Xavier Leroy and Damien Doligez, INRIA Rocquencourt */ -/* */ -/* Copyright 2009 Institut National de Recherche en Informatique et */ -/* en Automatique. */ -/* */ -/* All rights reserved. This file is distributed under the terms of */ -/* the GNU Lesser General Public License version 2.1, with the */ -/* special exception on linking described in the file LICENSE. */ -/* */ -/**************************************************************************/ - -/* CR ocaml 5 runtime: When we update the OCaml 5 runtime, we'll need to - update this library as well. The base of - https://github.com/ocaml-flambda/ocaml-jst/pull/222 may be a good starting - point. - */ - -/* POSIX thread implementation of the "st" interface */ - -#include -#include -#include -#include -#include -#include -#include -#include -#include -#ifdef HAS_UNISTD -#include -#endif -#include -#include -#include - -typedef int st_retcode; - -/* Variables used to stop "tick" threads */ -static atomic_uintnat tick_thread_stop[Max_domains]; -#define Tick_thread_stop tick_thread_stop[Caml_state->id] - -/* OS-specific initialization */ - -static int st_initialize(void) -{ - atomic_store_release(&Tick_thread_stop, 0); - return 0; -} - -/* Thread creation. Created in detached mode if [res] is NULL. */ - -typedef pthread_t st_thread_id; - - -static int st_thread_create(st_thread_id * res, - void * (*fn)(void *), void * arg) -{ - pthread_t thr; - pthread_attr_t attr; - int rc; - - pthread_attr_init(&attr); - if (res == NULL) pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED); - rc = pthread_create(&thr, &attr, fn, arg); - if (res != NULL) *res = thr; - return rc; -} - -#define ST_THREAD_FUNCTION void * - -/* Thread termination */ - -static void st_thread_join(st_thread_id thr) -{ - pthread_join(thr, NULL); - /* best effort: ignore errors */ -} - -/* Thread-specific state */ - -typedef pthread_key_t st_tlskey; - -static int st_tls_newkey(st_tlskey * res) -{ - return pthread_key_create(res, NULL); -} - -Caml_inline void * st_tls_get(st_tlskey k) -{ - return pthread_getspecific(k); -} - -Caml_inline void st_tls_set(st_tlskey k, void * v) -{ - pthread_setspecific(k, v); -} - -/* If we're using glibc, use a custom condition variable implementation to - avoid this bug: https://sourceware.org/bugzilla/show_bug.cgi?id=25847 - - For now we only have this on linux because it directly uses the linux futex - syscalls. */ -#if defined(__linux__) && defined(__GNU_LIBRARY__) && defined(__GLIBC__) && defined(__GLIBC_MINOR__) -typedef struct { - volatile unsigned counter; -} custom_condvar; - -static int custom_condvar_init(custom_condvar * cv) -{ - cv->counter = 0; - return 0; -} - -static int custom_condvar_destroy(custom_condvar * cv) -{ - return 0; -} - -static int custom_condvar_wait(custom_condvar * cv, pthread_mutex_t * mutex) -{ - unsigned old_count = cv->counter; - pthread_mutex_unlock(mutex); - syscall(SYS_futex, &cv->counter, FUTEX_WAIT_PRIVATE, old_count, NULL, NULL, 0); - pthread_mutex_lock(mutex); - return 0; -} - -static int custom_condvar_signal(custom_condvar * cv) -{ - __sync_add_and_fetch(&cv->counter, 1); - syscall(SYS_futex, &cv->counter, FUTEX_WAKE_PRIVATE, 1, NULL, NULL, 0); - return 0; -} - -static int custom_condvar_broadcast(custom_condvar * cv) -{ - __sync_add_and_fetch(&cv->counter, 1); - syscall(SYS_futex, &cv->counter, FUTEX_WAKE_PRIVATE, INT_MAX, NULL, NULL, 0); - return 0; -} -#else -typedef pthread_cond_t custom_condvar; - -static int custom_condvar_init(custom_condvar * cv) -{ - return pthread_cond_init(cv, NULL); -} - -static int custom_condvar_destroy(custom_condvar * cv) -{ - return pthread_cond_destroy(cv); -} - -static int custom_condvar_wait(custom_condvar * cv, pthread_mutex_t * mutex) -{ - return pthread_cond_wait(cv, mutex); -} - -static int custom_condvar_signal(custom_condvar * cv) -{ - return pthread_cond_signal(cv); -} - -static int custom_condvar_broadcast(custom_condvar * cv) -{ - return pthread_cond_broadcast(cv); -} -#endif - -/* The master lock. This is a mutex that is held most of the time, - so we implement it in a slightly convoluted way to avoid - all risks of busy-waiting. Also, we count the number of waiting - threads. */ - -typedef struct { - int init; /* have the mutex and the cond been - initialized already? */ - pthread_mutex_t lock; /* to protect contents */ - uintnat busy; /* 0 = free, 1 = taken */ - atomic_uintnat waiters; /* number of threads waiting on master lock */ - custom_condvar is_free; /* signaled when free */ -} st_masterlock; - -static void st_masterlock_init(st_masterlock * m) -{ - if (!m->init) { - // FIXME: check errors - pthread_mutex_init(&m->lock, NULL); - custom_condvar_init(&m->is_free); - m->init = 1; - } - m->busy = 1; - atomic_store_release(&m->waiters, 0); - - return; -}; - -static uintnat st_masterlock_waiters(st_masterlock * m) -{ - return atomic_load_acquire(&m->waiters); -} - -static void st_bt_lock_acquire(st_masterlock *m) { - - /* We do not want to signal the backup thread is it is not "working" - as it may very well not be, because we could have just resumed - execution from another thread right away. */ - if (caml_bt_is_in_blocking_section()) { - caml_bt_enter_ocaml(); - } - - caml_acquire_domain_lock(); - - return; -} - -static void st_bt_lock_release(st_masterlock *m) { - - /* Here we do want to signal the backup thread iff there's - no thread waiting to be scheduled, and the backup thread is currently - idle. */ - if (st_masterlock_waiters(m) == 0 && - caml_bt_is_in_blocking_section() == 0) { - caml_bt_exit_ocaml(); - } - - caml_release_domain_lock(); - - return; -} - -static void st_masterlock_acquire(st_masterlock *m) -{ - pthread_mutex_lock(&m->lock); - while (m->busy) { - atomic_fetch_add(&m->waiters, +1); - custom_condvar_wait(&m->is_free, &m->lock); - atomic_fetch_add(&m->waiters, -1); - } - m->busy = 1; - st_bt_lock_acquire(m); - pthread_mutex_unlock(&m->lock); - - return; -} - -static void st_masterlock_release(st_masterlock * m) -{ - pthread_mutex_lock(&m->lock); - m->busy = 0; - st_bt_lock_release(m); - custom_condvar_signal(&m->is_free); - pthread_mutex_unlock(&m->lock); - - return; -} - -/* Scheduling hints */ - -/* This is mostly equivalent to release(); acquire(), but better. In particular, - release(); acquire(); leaves both us and the waiter we signal() racing to - acquire the lock. Calling yield or sleep helps there but does not solve the - problem. Sleeping ourselves is much more reliable--and since we're handing - off the lock to a waiter we know exists, it's safe, as they'll certainly - re-wake us later. -*/ -Caml_inline void st_thread_yield(st_masterlock * m) -{ - pthread_mutex_lock(&m->lock); - /* We must hold the lock to call this. */ - - /* We already checked this without the lock, but we might have raced--if - there's no waiter, there's nothing to do and no one to wake us if we did - wait, so just keep going. */ - uintnat waiters = st_masterlock_waiters(m); - - if (waiters == 0) { - pthread_mutex_unlock(&m->lock); - return; - } - - m->busy = 0; - atomic_fetch_add(&m->waiters, +1); - custom_condvar_signal(&m->is_free); - /* releasing the domain lock but not triggering bt messaging - messaging the bt should not be required because yield assumes - that a thread will resume execution (be it the yielding thread - or a waiting thread */ - caml_release_domain_lock(); - - do { - /* Note: the POSIX spec prevents the above signal from pairing with this - wait, which is good: we'll reliably continue waiting until the next - yield() or enter_blocking_section() call (or we see a spurious condvar - wakeup, which are rare at best.) */ - custom_condvar_wait(&m->is_free, &m->lock); - } while (m->busy); - - m->busy = 1; - atomic_fetch_add(&m->waiters, -1); - - caml_acquire_domain_lock(); - - pthread_mutex_unlock(&m->lock); - - return; -} - -/* Triggered events */ - -typedef struct st_event_struct { - pthread_mutex_t lock; /* to protect contents */ - int status; /* 0 = not triggered, 1 = triggered */ - custom_condvar triggered; /* signaled when triggered */ -} * st_event; - - -static int st_event_create(st_event * res) -{ - int rc; - st_event e = caml_stat_alloc_noexc(sizeof(struct st_event_struct)); - if (e == NULL) return ENOMEM; - rc = pthread_mutex_init(&e->lock, NULL); - if (rc != 0) { caml_stat_free(e); return rc; } - rc = custom_condvar_init(&e->triggered); - if (rc != 0) - { pthread_mutex_destroy(&e->lock); caml_stat_free(e); return rc; } - e->status = 0; - *res = e; - return 0; -} - -static int st_event_destroy(st_event e) -{ - int rc1, rc2; - rc1 = pthread_mutex_destroy(&e->lock); - rc2 = custom_condvar_destroy(&e->triggered); - caml_stat_free(e); - return rc1 != 0 ? rc1 : rc2; -} - -static int st_event_trigger(st_event e) -{ - int rc; - rc = pthread_mutex_lock(&e->lock); - if (rc != 0) return rc; - e->status = 1; - rc = pthread_mutex_unlock(&e->lock); - if (rc != 0) return rc; - rc = custom_condvar_broadcast(&e->triggered); - return rc; -} - -static int st_event_wait(st_event e) -{ - int rc; - rc = pthread_mutex_lock(&e->lock); - if (rc != 0) return rc; - while(e->status == 0) { - rc = custom_condvar_wait(&e->triggered, &e->lock); - if (rc != 0) return rc; - } - rc = pthread_mutex_unlock(&e->lock); - return rc; -} - -/* The tick thread: interrupt the domain periodically to force preemption */ - -static void * caml_thread_tick(void * arg) -{ - int *domain_id = (int *) arg; - - caml_init_domain_self(*domain_id); - caml_domain_state *domain = Caml_state; - - while(! atomic_load_acquire(&Tick_thread_stop)) { - st_msleep(Thread_timeout); - - atomic_store_release(&domain->requested_external_interrupt, 1); - caml_interrupt_self(); - } - return NULL; -} diff --git a/ocaml/otherlibs/systhreads4/st_stubs.c b/ocaml/otherlibs/systhreads4/st_stubs.c index e71c8ec49df..804366ae1f7 100644 --- a/ocaml/otherlibs/systhreads4/st_stubs.c +++ b/ocaml/otherlibs/systhreads4/st_stubs.c @@ -533,12 +533,42 @@ static void caml_thread_reinitialize(void) } } +/* Installation of hooks for OCaml 5 stdlib compatibility. + See runtime4/domain.{c,h}. + Another approach would have been to use weak symbols, to override + dummy implementations in domain.c, but unfortunately that doesn't work + with the bytecode interpreter. + */ + +value caml_mutex_new(value unit); +value caml_mutex_lock(value wrapper); +value caml_mutex_unlock(value wrapper); +value caml_mutex_try_lock(value wrapper); +value caml_condition_new(value unit); +value caml_condition_wait(value wcond, value wmut); +value caml_condition_signal(value wrapper); +value caml_condition_broadcast(value wrapper); + +static void install_ocaml_5_compatibility_hooks(void) +{ + caml_hook_mutex_new = &caml_mutex_new; + caml_hook_mutex_lock = &caml_mutex_lock; + caml_hook_mutex_try_lock = &caml_mutex_try_lock; + caml_hook_mutex_unlock = &caml_mutex_unlock; + caml_hook_condition_new = &caml_condition_new; + caml_hook_condition_wait = &caml_condition_wait; + caml_hook_condition_signal = &caml_condition_signal; + caml_hook_condition_broadcast = &caml_condition_broadcast; +} + /* Initialize the thread machinery */ CAMLprim value caml_thread_initialize(value unit) /* ML */ { /* Protect against repeated initialization (PR#3532) */ if (curr_thread != NULL) return Val_unit; + /* OCaml 5 compatibility */ + install_ocaml_5_compatibility_hooks(); /* OS-specific initialization */ st_initialize(); /* Initialize and acquire the master lock */ diff --git a/ocaml/runtime/amd64.S b/ocaml/runtime/amd64.S index f98e0432029..0d4259411c1 100644 --- a/ocaml/runtime/amd64.S +++ b/ocaml/runtime/amd64.S @@ -445,22 +445,22 @@ G(caml_system__code_begin): movq %r10, 10*8(%r15); \ /* %r11 is at 11*8(%r15); */ \ movq %rbp, 12*8(%r15); \ - movsd %xmm0, (0+13)*8(%r15); \ - movsd %xmm1, (1+13)*8(%r15); \ - movsd %xmm2, (2+13)*8(%r15); \ - movsd %xmm3, (3+13)*8(%r15); \ - movsd %xmm4, (4+13)*8(%r15); \ - movsd %xmm5, (5+13)*8(%r15); \ - movsd %xmm6, (6+13)*8(%r15); \ - movsd %xmm7, (7+13)*8(%r15); \ - movsd %xmm8, (8+13)*8(%r15); \ - movsd %xmm9, (9+13)*8(%r15); \ - movsd %xmm10, (10+13)*8(%r15); \ - movsd %xmm11, (11+13)*8(%r15); \ - movsd %xmm12, (12+13)*8(%r15); \ - movsd %xmm13, (13+13)*8(%r15); \ - movsd %xmm14, (14+13)*8(%r15); \ - movsd %xmm15, (15+13)*8(%r15) + movupd %xmm0, (0*16 + 13*8)(%r15); \ + movupd %xmm1, (1*16 + 13*8)(%r15); \ + movupd %xmm2, (2*16 + 13*8)(%r15); \ + movupd %xmm3, (3*16 + 13*8)(%r15); \ + movupd %xmm4, (4*16 + 13*8)(%r15); \ + movupd %xmm5, (5*16 + 13*8)(%r15); \ + movupd %xmm6, (6*16 + 13*8)(%r15); \ + movupd %xmm7, (7*16 + 13*8)(%r15); \ + movupd %xmm8, (8*16 + 13*8)(%r15); \ + movupd %xmm9, (9*16 + 13*8)(%r15); \ + movupd %xmm10, (10*16 + 13*8)(%r15); \ + movupd %xmm11, (11*16 + 13*8)(%r15); \ + movupd %xmm12, (12*16 + 13*8)(%r15); \ + movupd %xmm13, (13*16 + 13*8)(%r15); \ + movupd %xmm14, (14*16 + 13*8)(%r15); \ + movupd %xmm15, (15*16 + 13*8)(%r15) /* Undo SAVE_ALL_REGS. Expects gc_regs bucket in %r15 */ #define RESTORE_ALL_REGS \ @@ -482,22 +482,22 @@ G(caml_system__code_begin): movq 10*8(%r15),%r10; \ movq 11*8(%r15),%r11; \ movq 12*8(%r15),%rbp; \ - movsd (0+13)*8(%r15),%xmm0; \ - movsd (1+13)*8(%r15),%xmm1; \ - movsd (2+13)*8(%r15),%xmm2; \ - movsd (3+13)*8(%r15),%xmm3; \ - movsd (4+13)*8(%r15),%xmm4; \ - movsd (5+13)*8(%r15),%xmm5; \ - movsd (6+13)*8(%r15),%xmm6; \ - movsd (7+13)*8(%r15),%xmm7; \ - movsd (8+13)*8(%r15),%xmm8; \ - movsd (9+13)*8(%r15),%xmm9; \ - movsd (10+13)*8(%r15),%xmm10; \ - movsd (11+13)*8(%r15),%xmm11; \ - movsd (12+13)*8(%r15),%xmm12; \ - movsd (13+13)*8(%r15),%xmm13; \ - movsd (14+13)*8(%r15),%xmm14; \ - movsd (15+13)*8(%r15),%xmm15; \ + movupd (0*16 + 13*8)(%r15),%xmm0; \ + movupd (1*16 + 13*8)(%r15),%xmm1; \ + movupd (2*16 + 13*8)(%r15),%xmm2; \ + movupd (3*16 + 13*8)(%r15),%xmm3; \ + movupd (4*16 + 13*8)(%r15),%xmm4; \ + movupd (5*16 + 13*8)(%r15),%xmm5; \ + movupd (6*16 + 13*8)(%r15),%xmm6; \ + movupd (7*16 + 13*8)(%r15),%xmm7; \ + movupd (8*16 + 13*8)(%r15),%xmm8; \ + movupd (9*16 + 13*8)(%r15),%xmm9; \ + movupd (10*16 + 13*8)(%r15),%xmm10; \ + movupd (11*16 + 13*8)(%r15),%xmm11; \ + movupd (12*16 + 13*8)(%r15),%xmm12; \ + movupd (13*16 + 13*8)(%r15),%xmm13; \ + movupd (14*16 + 13*8)(%r15),%xmm14; \ + movupd (15*16 + 13*8)(%r15),%xmm15; \ movq Caml_state(young_ptr), %r15 FUNCTION(G(caml_call_realloc_stack)) diff --git a/ocaml/runtime/amd64nt.asm b/ocaml/runtime/amd64nt.asm index 604c259fc6b..cea209c82dc 100644 --- a/ocaml/runtime/amd64nt.asm +++ b/ocaml/runtime/amd64nt.asm @@ -70,45 +70,45 @@ caml_call_gc: push rax Store_gc_regs rsp ; Save floating-point registers - sub rsp, 16*8 - movsd QWORD PTR [rsp + 0*8], xmm0 - movsd QWORD PTR [rsp + 1*8], xmm1 - movsd QWORD PTR [rsp + 2*8], xmm2 - movsd QWORD PTR [rsp + 3*8], xmm3 - movsd QWORD PTR [rsp + 4*8], xmm4 - movsd QWORD PTR [rsp + 5*8], xmm5 - movsd QWORD PTR [rsp + 6*8], xmm6 - movsd QWORD PTR [rsp + 7*8], xmm7 - movsd QWORD PTR [rsp + 8*8], xmm8 - movsd QWORD PTR [rsp + 9*8], xmm9 - movsd QWORD PTR [rsp + 10*8], xmm10 - movsd QWORD PTR [rsp + 11*8], xmm11 - movsd QWORD PTR [rsp + 12*8], xmm12 - movsd QWORD PTR [rsp + 13*8], xmm13 - movsd QWORD PTR [rsp + 14*8], xmm14 - movsd QWORD PTR [rsp + 15*8], xmm15 + sub rsp, 16*16 + movupd QWORD PTR [rsp + 0*16], xmm0 + movupd QWORD PTR [rsp + 1*16], xmm1 + movupd QWORD PTR [rsp + 2*16], xmm2 + movupd QWORD PTR [rsp + 3*16], xmm3 + movupd QWORD PTR [rsp + 4*16], xmm4 + movupd QWORD PTR [rsp + 5*16], xmm5 + movupd QWORD PTR [rsp + 6*16], xmm6 + movupd QWORD PTR [rsp + 7*16], xmm7 + movupd QWORD PTR [rsp + 8*16], xmm8 + movupd QWORD PTR [rsp + 9*16], xmm9 + movupd QWORD PTR [rsp + 10*16], xmm10 + movupd QWORD PTR [rsp + 11*16], xmm11 + movupd QWORD PTR [rsp + 12*16], xmm12 + movupd QWORD PTR [rsp + 13*16], xmm13 + movupd QWORD PTR [rsp + 14*16], xmm14 + movupd QWORD PTR [rsp + 15*16], xmm15 ; Call the garbage collector sub rsp, 32 ; PR#5008: bottom 32 bytes are reserved for callee call caml_garbage_collection add rsp, 32 ; PR#5008 ; Restore all regs used by the code generator - movsd xmm0, QWORD PTR [rsp + 0*8] - movsd xmm1, QWORD PTR [rsp + 1*8] - movsd xmm2, QWORD PTR [rsp + 2*8] - movsd xmm3, QWORD PTR [rsp + 3*8] - movsd xmm4, QWORD PTR [rsp + 4*8] - movsd xmm5, QWORD PTR [rsp + 5*8] - movsd xmm6, QWORD PTR [rsp + 6*8] - movsd xmm7, QWORD PTR [rsp + 7*8] - movsd xmm8, QWORD PTR [rsp + 8*8] - movsd xmm9, QWORD PTR [rsp + 9*8] - movsd xmm10, QWORD PTR [rsp + 10*8] - movsd xmm11, QWORD PTR [rsp + 11*8] - movsd xmm12, QWORD PTR [rsp + 12*8] - movsd xmm13, QWORD PTR [rsp + 13*8] - movsd xmm14, QWORD PTR [rsp + 14*8] - movsd xmm15, QWORD PTR [rsp + 15*8] - add rsp, 16*8 + movupd xmm0, QWORD PTR [rsp + 0*16] + movupd xmm1, QWORD PTR [rsp + 1*16] + movupd xmm2, QWORD PTR [rsp + 2*16] + movupd xmm3, QWORD PTR [rsp + 3*16] + movupd xmm4, QWORD PTR [rsp + 4*16] + movupd xmm5, QWORD PTR [rsp + 5*16] + movupd xmm6, QWORD PTR [rsp + 6*16] + movupd xmm7, QWORD PTR [rsp + 7*16] + movupd xmm8, QWORD PTR [rsp + 8*16] + movupd xmm9, QWORD PTR [rsp + 9*16] + movupd xmm10, QWORD PTR [rsp + 10*16] + movupd xmm11, QWORD PTR [rsp + 11*16] + movupd xmm12, QWORD PTR [rsp + 12*16] + movupd xmm13, QWORD PTR [rsp + 13*16] + movupd xmm14, QWORD PTR [rsp + 14*16] + movupd xmm15, QWORD PTR [rsp + 15*16] + add rsp, 16*16 pop rax pop rbx pop rdi diff --git a/ocaml/runtime/array.c b/ocaml/runtime/array.c index 7423467070e..ed3b7d5f434 100644 --- a/ocaml/runtime/array.c +++ b/ocaml/runtime/array.c @@ -600,22 +600,32 @@ CAMLprim value caml_array_fill(value array, CAMLprim value caml_array_concat_local(value al) { - caml_failwith("Called caml_array_concat_local in runtime5: not implemented."); + /* CR ocaml 5 runtime: replace with proper locals implementation */ + return caml_array_concat(al); } CAMLprim value caml_array_sub_local(value al, value a, value b) { - caml_failwith("Called caml_array_sub_local in runtime5: not implemented."); + /* CR ocaml 5 runtime: replace with proper locals implementation */ + return caml_array_sub(al, a, b); } CAMLprim value caml_make_local_vect(value i, value a) { - caml_failwith("Called caml_array_make_local_vect in runtime5: not implemented."); + /* CR ocaml 5 runtime: replace with proper locals implementation */ + return caml_make_vect(i, a); } CAMLprim value caml_array_append_local(value a1, value a2) { - caml_failwith("Called caml_array_append_local in runtime5: not implemented."); + /* CR ocaml 5 runtime: replace with proper locals implementation */ + return caml_array_append(a1, a2); +} + +CAMLprim value caml_floatarray_create_local(value len) +{ + /* CR ocaml 5 runtime: replace with proper locals implementation */ + return caml_floatarray_create(len); } CAMLprim value caml_iarray_of_array(value a) diff --git a/ocaml/runtime/backtrace_nat.c b/ocaml/runtime/backtrace_nat.c index e02825cd88a..48b53f72c41 100644 --- a/ocaml/runtime/backtrace_nat.c +++ b/ocaml/runtime/backtrace_nat.c @@ -231,7 +231,7 @@ debuginfo caml_debuginfo_extract(backtrace_slot slot) return NULL; } /* Recover debugging info */ - infoptr = (unsigned char*)&d->live_ofs[d->num_live]; + infoptr = frame_end_of_live_ofs(d); if (frame_has_allocs(d)) { /* skip alloc_lengths */ infoptr += *infoptr + 1; diff --git a/ocaml/runtime/caml/frame_descriptors.h b/ocaml/runtime/caml/frame_descriptors.h index b0d4f65d444..722c63a207e 100644 --- a/ocaml/runtime/caml/frame_descriptors.h +++ b/ocaml/runtime/caml/frame_descriptors.h @@ -58,6 +58,7 @@ #define FRAME_DESCRIPTOR_ALLOC 2 #define FRAME_DESCRIPTOR_FLAGS 3 #define FRAME_RETURN_TO_C 0xFFFF +#define FRAME_LONG_MARKER 0x7FFF typedef struct { int32_t retaddr_rel; /* offset of return address from &retaddr_rel */ @@ -76,20 +77,67 @@ typedef struct { debug_info itself to a debuginfo structure. */ } frame_descr; +typedef struct { + int32_t retaddr_rel; /* offset of return address from &retaddr_rel */ + uint16_t marker; /* FRAME_LONG_MARKER */ + uint16_t _pad; /* Ensure frame_data is 4-byte aligned */ + uint32_t frame_data; /* frame size and various flags */ + uint32_t num_live; + uint32_t live_ofs[1 /* num_live */]; + /* + If frame_has_allocs(), alloc lengths follow: + uint8_t num_allocs; + uint8_t alloc[num_allocs]; + + If frame_has_debug(), debug info follows (32-bit aligned): + uint32_t debug_info[frame_has_allocs() ? num_allocs : 1]; + + Debug info is stored as a relative offset, in bytes, from the + debug_info itself to a debuginfo structure. */ +} frame_descr_long; + Caml_inline bool frame_return_to_C(frame_descr *d) { - return d->frame_data == 0xFFFF; + return d->frame_data == FRAME_RETURN_TO_C; +} + +Caml_inline bool frame_is_long(frame_descr *d) { + CAMLassert(d && !frame_return_to_C(d)); + return (d -> frame_data == FRAME_LONG_MARKER); +} + +Caml_inline frame_descr_long *frame_as_long(frame_descr *d) { + frame_descr_long *dl = (frame_descr_long *) d; + return dl; +} + +Caml_inline uint32_t frame_data(frame_descr *d) { + if (frame_is_long(d)) { + frame_descr_long *dl = frame_as_long(d); + return (dl -> frame_data); + } else { + return (d -> frame_data); + } +} + +Caml_inline unsigned char *frame_end_of_live_ofs(frame_descr *d) { + if (frame_is_long(d)) { + frame_descr_long *dl = frame_as_long(d); + return ((unsigned char *)&dl->live_ofs[dl->num_live]); + } else { + return ((unsigned char *)&d->live_ofs[d->num_live]); + } } -Caml_inline uint16_t frame_size(frame_descr *d) { - return d->frame_data &~ FRAME_DESCRIPTOR_FLAGS; +Caml_inline uint32_t frame_size(frame_descr *d) { + return frame_data(d) &~ FRAME_DESCRIPTOR_FLAGS; } Caml_inline bool frame_has_allocs(frame_descr *d) { - return (d->frame_data & FRAME_DESCRIPTOR_ALLOC) != 0; + return (frame_data(d) & FRAME_DESCRIPTOR_ALLOC) != 0; } Caml_inline bool frame_has_debug(frame_descr *d) { - return (d->frame_data & FRAME_DESCRIPTOR_DEBUG) != 0; + return (frame_data(d) & FRAME_DESCRIPTOR_DEBUG) != 0; } /* Allocation lengths are encoded reduced by one, so values 0-255 mean diff --git a/ocaml/runtime/caml/stack.h b/ocaml/runtime/caml/stack.h index 8cb955916a5..7f52565a276 100644 --- a/ocaml/runtime/caml/stack.h +++ b/ocaml/runtime/caml/stack.h @@ -46,8 +46,8 @@ #ifdef TARGET_amd64 /* Size of the gc_regs structure, in words. See amd64.S and amd64/proc.ml for the indices */ -#define Wosize_gc_regs (13 /* int regs */ + 16 /* float regs */) -/* CR ocaml 5 runtime (mshinwell): does Wosize_gc_regs need updating for SIMD? */ +/* The "*2" is for SIMD */ +#define Wosize_gc_regs (13 /* int regs */ + (16 * 2) /* float regs */) #define Saved_return_address(sp) *((intnat *)((sp) - 8)) #ifdef WITH_FRAME_POINTERS #define Pop_frame_pointer(sp) (sp) += sizeof(value) @@ -59,6 +59,7 @@ #ifdef TARGET_arm64 /* Size of the gc_regs structure, in words. See arm64.S and arm64/proc.ml for the indices */ +/* CR ocaml 5 runtime (mshinwell): this has not been updated for SIMD */ #define Wosize_gc_regs (2 + 24 /* int regs */ + 24 /* float regs */) #define Saved_return_address(sp) *((intnat *)((sp) - 8)) #define Pop_frame_pointer(sp) sp += sizeof(value) diff --git a/ocaml/runtime/dynlink_nat.c b/ocaml/runtime/dynlink_nat.c index 7b5d9461bde..cfd2cb46209 100644 --- a/ocaml/runtime/dynlink_nat.c +++ b/ocaml/runtime/dynlink_nat.c @@ -168,7 +168,7 @@ CAMLprim value caml_natdynlink_run(value handle_v, value symbol) { CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol) { CAMLparam2 (filename, symbol); - CAMLlocal3 (res, v, handle_v); + CAMLlocal4 (res, v, handle_v, symbols); void *handle; char_os *p; @@ -186,10 +186,16 @@ CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol) Store_field(res, 0, v); } else { handle_v = Val_handle(handle); + + symbols = caml_alloc_small(1, 0); + Field(symbols, 0) = symbol; + (void) caml_natdynlink_register(handle_v, symbols); + res = caml_alloc(1,0); v = caml_natdynlink_run(handle_v, symbol); Store_field(res, 0, v); } + CAMLreturn(res); } diff --git a/ocaml/runtime/fiber.c b/ocaml/runtime/fiber.c index d86daf91415..ff4f34eb132 100644 --- a/ocaml/runtime/fiber.c +++ b/ocaml/runtime/fiber.c @@ -230,8 +230,6 @@ Caml_inline void scan_stack_frames( uintnat retaddr; value * regs; frame_descr * d; - int n, ofs; - unsigned short * p; value *root; caml_frame_descrs fds = caml_get_frame_descrs(); @@ -250,14 +248,31 @@ Caml_inline void scan_stack_frames( CAMLassert(d); if (!frame_return_to_C(d)) { /* Scan the roots in this frame */ - for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { - ofs = *p; - if (ofs & 1) { - root = regs + (ofs >> 1); - } else { - root = (value *)(sp + ofs); + if (frame_is_long(d)) { + frame_descr_long *dl = frame_as_long(d); + uint32_t *p; + uint32_t n; + for (p = dl->live_ofs, n = dl->num_live; n > 0; n--, p++) { + uint32_t ofs = *p; + if (ofs & 1) { + root = regs + (ofs >> 1); + } else { + root = (value *)(sp + ofs); + } + f (fdata, *root, root); + } + } else { + uint16_t *p; + uint16_t n; + for (p = d->live_ofs, n = d->num_live; n > 0; n--, p++) { + uint16_t ofs = *p; + if (ofs & 1) { + root = regs + (ofs >> 1); + } else { + root = (value *)(sp + ofs); + } + f (fdata, *root, root); } - f (fdata, *root, root); } /* Move to next frame */ sp += frame_size(d); diff --git a/ocaml/runtime/frame_descriptors.c b/ocaml/runtime/frame_descriptors.c index 315cbbbe2ab..b3f2622801a 100644 --- a/ocaml/runtime/frame_descriptors.c +++ b/ocaml/runtime/frame_descriptors.c @@ -38,7 +38,7 @@ static frame_descr * next_frame_descr(frame_descr * d) { CAMLassert(Retaddr_frame(d) >= 4096); if (!frame_return_to_C(d)) { /* Skip to end of live_ofs */ - p = (unsigned char*)&d->live_ofs[d->num_live]; + p = frame_end_of_live_ofs(d); /* Skip alloc_lengths if present */ if (frame_has_allocs(d)) { num_allocs = *p; diff --git a/ocaml/runtime/gc_ctrl.c b/ocaml/runtime/gc_ctrl.c index 1b43aca8c86..e74e038b0c1 100644 --- a/ocaml/runtime/gc_ctrl.c +++ b/ocaml/runtime/gc_ctrl.c @@ -109,8 +109,8 @@ CAMLprim value caml_gc_counters(value v) /* get a copy of these before allocating anything... */ double minwords = Caml_state->stat_minor_words - + ((double) Wsize_bsize ((uintnat)Caml_state->young_end - - (uintnat) Caml_state->young_ptr)) / sizeof(value); + + (double) Wsize_bsize ((uintnat)Caml_state->young_end - + (uintnat) Caml_state->young_ptr); double prowords = Caml_state->stat_promoted_words; double majwords = Caml_state->stat_major_words + (double) Caml_state->allocated_words; diff --git a/ocaml/runtime/globroots.c b/ocaml/runtime/globroots.c index 17a1eb99b0a..4601e25b690 100644 --- a/ocaml/runtime/globroots.c +++ b/ocaml/runtime/globroots.c @@ -23,6 +23,8 @@ #include "caml/globroots.h" #include "caml/skiplist.h" #include "caml/stack.h" +#include "caml/callback.h" +#include "caml/fail.h" static caml_plat_mutex roots_mutex = CAML_PLAT_MUTEX_INITIALIZER; @@ -179,11 +181,29 @@ static link *cons(void *data, link *tl) { /* protected by roots_mutex */ static link * caml_dyn_globals = NULL; +static void caml_register_dyn_global(void *v) { + link *link = caml_dyn_globals; + while (link) { + if (link->data == v) { + const value *exn = caml_named_value("Register_dyn_global_duplicate"); + if (exn == NULL) { + fprintf(stderr, + "[ocaml] attempt to add duplicate in caml_dyn_globals: %p\n", v); + abort(); + } + caml_plat_unlock(&roots_mutex); + caml_raise(*exn); + } + link = link->next; + } + caml_dyn_globals = cons((void*) v,caml_dyn_globals); +} + void caml_register_dyn_globals(void **globals, int nglobals) { int i; caml_plat_lock(&roots_mutex); for (i = 0; i < nglobals; i++) - caml_dyn_globals = cons(globals[i],caml_dyn_globals); + caml_register_dyn_global(globals[i]); caml_plat_unlock(&roots_mutex); } diff --git a/ocaml/runtime/memory.c b/ocaml/runtime/memory.c index 2d56089ad38..a057ab46d6d 100644 --- a/ocaml/runtime/memory.c +++ b/ocaml/runtime/memory.c @@ -380,6 +380,25 @@ CAMLexport value caml_alloc_shr_noexc(mlsize_t wosize, tag_t tag) { return alloc_shr(wosize, tag, 0, 1); } +CAMLprim value caml_local_stack_offset(value blk) +{ + /* CR ocaml 5 runtime: implement properly for locals */ + return Val_long(0); +} + +CAMLprim value caml_obj_is_stack(value blk) +{ + /* CR ocaml 5 runtime: implement properly for locals */ + return Val_false; +} + +extern value caml_create_bytes(value); +CAMLprim value caml_create_local_bytes(value len) +{ + /* CR ocaml 5 runtime: implement properly for locals */ + return caml_create_bytes(len); +} + /* Global memory pool. The pool is structured as a ring of blocks, where each block's header diff --git a/ocaml/runtime/signals_nat.c b/ocaml/runtime/signals_nat.c index 69e9eb1f4ff..e1601130b46 100644 --- a/ocaml/runtime/signals_nat.c +++ b/ocaml/runtime/signals_nat.c @@ -62,7 +62,7 @@ void caml_garbage_collection(void) { /* Compute the total allocation size at this point, including allocations combined by Comballoc */ - unsigned char* alloc_len = (unsigned char*)(&d->live_ofs[d->num_live]); + unsigned char* alloc_len = frame_end_of_live_ofs(d); int i, nallocs = *alloc_len++; intnat allocsz = 0; diff --git a/ocaml/runtime4/caml/domain.h b/ocaml/runtime4/caml/domain.h index 23833d24f1d..4a44a50dadc 100644 --- a/ocaml/runtime4/caml/domain.h +++ b/ocaml/runtime4/caml/domain.h @@ -27,6 +27,16 @@ extern "C" { void caml_init_domain(void); +/* OCaml 5 stdlib compatibility hooks */ +extern value (*caml_hook_mutex_new)(value unit); +extern value (*caml_hook_mutex_lock)(value wrapper); +extern value (*caml_hook_mutex_unlock)(value wrapper); +extern value (*caml_hook_mutex_try_lock)(value wrapper); +extern value (*caml_hook_condition_new)(value unit); +extern value (*caml_hook_condition_wait)(value wcond, value wmut); +extern value (*caml_hook_condition_signal)(value wrapper); +extern value (*caml_hook_condition_broadcast)(value wrapper); + #endif /* CAML_INTERNALS */ #ifdef __cplusplus diff --git a/ocaml/runtime4/domain.c b/ocaml/runtime4/domain.c index 839c54de25b..767322ff920 100644 --- a/ocaml/runtime4/domain.c +++ b/ocaml/runtime4/domain.c @@ -99,3 +99,79 @@ void caml_init_domain () Caml_state->checking_pointer_pc = NULL; #endif } + +/* OCaml 5 stdlib compatibility hooks */ +value (*caml_hook_mutex_new)(value unit) = NULL; +value (*caml_hook_mutex_lock)(value wrapper) = NULL; +value (*caml_hook_mutex_unlock)(value wrapper) = NULL; +value (*caml_hook_mutex_try_lock)(value wrapper) = NULL; +value (*caml_hook_condition_new)(value unit) = NULL; +value (*caml_hook_condition_wait)(value wcond, value wmut) = NULL; +value (*caml_hook_condition_signal)(value wrapper) = NULL; +value (*caml_hook_condition_broadcast)(value wrapper) = NULL; + +#include "caml/fail.h" + +CAMLprim value caml_ml_mutex_new(value unit) +{ + if (caml_hook_mutex_new == NULL) + caml_failwith("Must initialize systhreads library before using Mutex"); + + return (*caml_hook_mutex_new)(unit); +} + +CAMLprim value caml_ml_mutex_lock(value wrapper) +{ + if (caml_hook_mutex_lock == NULL) + caml_failwith("Must initialize systhreads library before using Mutex"); + + return (*caml_hook_mutex_lock)(wrapper); +} + +CAMLprim value caml_ml_mutex_unlock(value wrapper) +{ + if (caml_hook_mutex_unlock == NULL) + caml_failwith("Must initialize systhreads library before using Mutex"); + + return (*caml_hook_mutex_unlock)(wrapper); +} + +CAMLprim value caml_ml_mutex_try_lock(value wrapper) +{ + if (caml_hook_mutex_try_lock == NULL) + caml_failwith("Must initialize systhreads library before using Mutex"); + + return (*caml_hook_mutex_try_lock)(wrapper); +} + +CAMLprim value caml_ml_condition_new(value unit) +{ + if (caml_hook_condition_new == NULL) + caml_failwith("Must initialize systhreads library before using Condition"); + + return (*caml_hook_condition_new)(unit); +} + +CAMLprim value caml_ml_condition_wait(value wcond, value wmut) +{ + if (caml_hook_condition_wait == NULL) + caml_failwith("Must initialize systhreads library before using Condition"); + + return (*caml_hook_condition_wait)(wcond, wmut); +} + +CAMLprim value caml_ml_condition_signal(value wrapper) +{ + if (caml_hook_condition_signal == NULL) + caml_failwith("Must initialize systhreads library before using Condition"); + + return (*caml_hook_condition_signal)(wrapper); +} + +CAMLprim value caml_ml_condition_broadcast(value wrapper) +{ + if (caml_hook_condition_broadcast == NULL) + caml_failwith("Must initialize systhreads library before using Condition"); + + return (*caml_hook_condition_broadcast)(wrapper); +} diff --git a/ocaml/runtime4/dune b/ocaml/runtime4/dune index 2cf354911e6..5e915e48a92 100644 --- a/ocaml/runtime4/dune +++ b/ocaml/runtime4/dune @@ -23,7 +23,7 @@ callback.c weak.c finalise.c stacks.c dynlink.c backtrace_byt.c backtrace.c afl.c - bigarray.c eventlog.c misc.c) + bigarray.c eventlog.c misc.c domain.c) (action (with-stdout-to %{targets} (run %{dep:gen_primitives.sh})))) (rule diff --git a/ocaml/runtime4/dynlink_nat.c b/ocaml/runtime4/dynlink_nat.c index 88871cfc4f7..0f48734e104 100644 --- a/ocaml/runtime4/dynlink_nat.c +++ b/ocaml/runtime4/dynlink_nat.c @@ -46,7 +46,7 @@ static void *getsym(void *handle, const char *module, const char *name){ char *fullname = caml_stat_strconcat(2, module, name); void *sym; sym = caml_dlsym (handle, fullname); - /* printf("%s => %lx\n", fullname, (uintnat) sym); */ + /* printf("%s => %lx\n", fullname, (uintnat) sym); */ caml_stat_free(fullname); return sym; } @@ -104,30 +104,74 @@ CAMLprim value caml_natdynlink_open(value filename, value global) CAMLreturn(res); } -CAMLprim value caml_natdynlink_run(value handle_v, value symbol) { - CAMLparam2 (handle_v, symbol); - CAMLlocal1 (result); - void *sym,*sym2; +CAMLprim value caml_natdynlink_register(value handle_v, value symbols) { + CAMLparam2 (handle_v, symbols); + int i; + int nsymbols = Wosize_val(symbols); void* handle = Handle_val(handle_v); - const char *unit = String_val(symbol); - void (*entrypoint)(void); - - sym = getsym_exn(handle, unit, "__gc_roots"); + void** table; + + table = caml_stat_alloc(sizeof(void*) * nsymbols); + + for (i = 0; i < nsymbols; i++) { + const char* unit = String_val(Field(symbols, i)); + table[i] = getsym(handle, unit, "__gc_roots"); + if (table[i] == NULL) { + caml_stat_free(table); + caml_invalid_argument_value( + caml_alloc_sprintf("Dynlink: Missing gc_roots for %s", unit)); + } + } + for (int i = 0; i < nsymbols; i++) + caml_register_dyn_global(table[i]); /* [caml_register_dyn_global] can raise, so do it prior to registering frametables etc. */ - caml_register_dyn_global(sym); - sym = getsym_exn(handle, unit, "__frametable"); - caml_register_frametable(sym); + for (i = 0; i < nsymbols; i++) { + const char* unit = String_val(Field(symbols, i)); + table[i] = getsym(handle, unit, "__frametable"); + if (table[i] == NULL) { + caml_stat_free(table); + caml_invalid_argument_value( + caml_alloc_sprintf("Dynlink: Missing frametable for %s", unit)); + } + } + for (int i = 0; i < nsymbols; i++) + caml_register_frametable(table[i]); + + caml_stat_free(table); + + for (i = 0; i < nsymbols; i++) { + void* sym; + void* sym2; + const char* unit = String_val(Field(symbols, i)); + sym = getsym_exn(handle, unit, "__data_begin"); + sym2 = getsym_exn(handle, unit, "__data_end"); + caml_page_table_add(In_static_data, sym, sym2); + } + + for (i = 0; i < nsymbols; i++) { + const char* unit = String_val(Field(symbols, i)); + void* sym = getsym(handle, unit, "__code_begin"); + void* sym2 = getsym(handle, unit, "__code_end"); + /* Do not register empty code fragments */ + if (NULL != sym && NULL != sym2 && sym != sym2) { + caml_register_code_fragment((char *) sym, (char *) sym2, + DIGEST_LATER, NULL); + } + } + + CAMLreturn (Val_unit); +} - sym = getsym_exn(handle, unit, "__data_begin"); - sym2 = getsym_exn(handle, unit, "__data_end"); - caml_page_table_add(In_static_data, sym, sym2); +CAMLprim value caml_natdynlink_run(value handle_v, value symbol) { + CAMLparam2 (handle_v, symbol); + CAMLlocal1 (result); + void* handle = Handle_val(handle_v); + const char *unit; + void (*entrypoint)(void); - sym = getsym_exn(handle, unit, "__code_begin"); - sym2 = getsym_exn(handle, unit, "__code_end"); - caml_register_code_fragment((char *) sym, (char *) sym2, - DIGEST_LATER, NULL); + unit = String_val(symbol); if( caml_natdynlink_hook != NULL ) caml_natdynlink_hook(handle,unit); @@ -141,7 +185,7 @@ CAMLprim value caml_natdynlink_run(value handle_v, value symbol) { CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol) { CAMLparam2 (filename, symbol); - CAMLlocal3 (res, v, handle_v); + CAMLlocal4 (res, v, handle_v, symbols); void *handle; char_os *p; @@ -159,10 +203,16 @@ CAMLprim value caml_natdynlink_run_toplevel(value filename, value symbol) Store_field(res, 0, v); } else { handle_v = Val_handle(handle); + + symbols = caml_alloc_small(1, 0); + Field(symbols, 0) = symbol; + (void) caml_natdynlink_register(handle_v, symbols); + res = caml_alloc(1,0); v = caml_natdynlink_run(handle_v, symbol); Store_field(res, 0, v); } + CAMLreturn(res); } diff --git a/ocaml/runtime4/gen_primitives.sh b/ocaml/runtime4/gen_primitives.sh index 45fc5038ad2..1a1232631ef 100755 --- a/ocaml/runtime4/gen_primitives.sh +++ b/ocaml/runtime4/gen_primitives.sh @@ -25,7 +25,7 @@ export LC_ALL=C alloc array compare extern floats gc_ctrl hash intern interp ints io \ lexing md5 meta memprof obj parsing signals str sys callback weak \ finalise stacks dynlink backtrace_byt backtrace afl \ - bigarray eventlog misc + bigarray eventlog misc domain do sed -n -e 's/^CAMLprim value \([a-z0-9_][a-z0-9_]*\).*/\1/p' "$prim.c" done diff --git a/ocaml/stdlib/.depend b/ocaml/stdlib/.depend index d3aa99ef202..14d31401e79 100644 --- a/ocaml/stdlib/.depend +++ b/ocaml/stdlib/.depend @@ -241,6 +241,14 @@ stdlib__Complex.cmx : complex.ml \ stdlib__Complex.cmi stdlib__Complex.cmi : complex.mli \ stdlib.cmi +stdlib__Condition.cmo : condition.ml \ + stdlib__Mutex.cmi \ + stdlib__Condition.cmi +stdlib__Condition.cmx : condition.ml \ + stdlib__Mutex.cmx \ + stdlib__Condition.cmi +stdlib__Condition.cmi : condition.mli \ + stdlib__Mutex.cmi stdlib__Digest.cmo : digest.ml \ stdlib__String.cmi \ stdlib.cmi \ @@ -259,12 +267,14 @@ stdlib__Domain.cmo : domain.ml \ stdlib__Sys.cmi \ stdlib.cmi \ stdlib__Obj.cmi \ + stdlib__Atomic.cmi \ stdlib__Array.cmi \ stdlib__Domain.cmi stdlib__Domain.cmx : domain.ml \ stdlib__Sys.cmx \ stdlib.cmx \ stdlib__Obj.cmx \ + stdlib__Atomic.cmx \ stdlib__Array.cmx \ stdlib__Domain.cmi stdlib__Domain.cmi : domain.mli @@ -313,8 +323,8 @@ stdlib__Filename.cmo : filename.ml \ stdlib__Random.cmi \ stdlib__Printf.cmi \ stdlib__List.cmi \ - stdlib__Lazy.cmi \ stdlib__Fun.cmi \ + stdlib__Domain.cmi \ stdlib__Buffer.cmi \ stdlib__Filename.cmi stdlib__Filename.cmx : filename.ml \ @@ -324,8 +334,8 @@ stdlib__Filename.cmx : filename.ml \ stdlib__Random.cmx \ stdlib__Printf.cmx \ stdlib__List.cmx \ - stdlib__Lazy.cmx \ stdlib__Fun.cmx \ + stdlib__Domain.cmx \ stdlib__Buffer.cmx \ stdlib__Filename.cmi stdlib__Filename.cmi : filename.mli \ @@ -363,8 +373,8 @@ stdlib__Format.cmo : format.ml \ stdlib__Queue.cmi \ stdlib__List.cmi \ stdlib__Int.cmi \ - stdlib__Fun.cmi \ stdlib__Either.cmi \ + stdlib__Domain.cmi \ camlinternalFormatBasics.cmi \ camlinternalFormat.cmi \ stdlib__Bytes.cmi \ @@ -379,8 +389,8 @@ stdlib__Format.cmx : format.ml \ stdlib__Queue.cmx \ stdlib__List.cmx \ stdlib__Int.cmx \ - stdlib__Fun.cmx \ stdlib__Either.cmx \ + stdlib__Domain.cmx \ camlinternalFormatBasics.cmx \ camlinternalFormat.cmx \ stdlib__Bytes.cmx \ @@ -391,6 +401,7 @@ stdlib__Format.cmi : format.mli \ stdlib.cmi \ stdlib__Seq.cmi \ stdlib__Either.cmi \ + stdlib__Domain.cmi \ stdlib__Buffer.cmi stdlib__Fun.cmo : fun.ml \ stdlib.cmi \ @@ -430,8 +441,8 @@ stdlib__Hashtbl.cmo : hashtbl.ml \ stdlib__Seq.cmi \ stdlib__Random.cmi \ stdlib__Obj.cmi \ - stdlib__Lazy.cmi \ stdlib__Int.cmi \ + stdlib__Domain.cmi \ stdlib__Atomic.cmi \ stdlib__Array.cmi \ stdlib__Hashtbl.cmi @@ -442,8 +453,8 @@ stdlib__Hashtbl.cmx : hashtbl.ml \ stdlib__Seq.cmx \ stdlib__Random.cmx \ stdlib__Obj.cmx \ - stdlib__Lazy.cmx \ stdlib__Int.cmx \ + stdlib__Domain.cmx \ stdlib__Atomic.cmx \ stdlib__Array.cmx \ stdlib__Hashtbl.cmi @@ -616,6 +627,11 @@ stdlib__MoreLabels.cmi : moreLabels.mli \ stdlib__Seq.cmi \ stdlib__Map.cmi \ stdlib__Hashtbl.cmi +stdlib__Mutex.cmo : mutex.ml \ + stdlib__Mutex.cmi +stdlib__Mutex.cmx : mutex.ml \ + stdlib__Mutex.cmi +stdlib__Mutex.cmi : mutex.mli stdlib__Nativeint.cmo : nativeint.ml \ stdlib__Sys.cmi \ stdlib.cmi \ @@ -794,6 +810,15 @@ stdlib__Scanf.cmx : scanf.ml \ stdlib__Scanf.cmi stdlib__Scanf.cmi : scanf.mli \ stdlib.cmi +stdlib__Semaphore.cmo : semaphore.ml \ + stdlib__Mutex.cmi \ + stdlib__Condition.cmi \ + stdlib__Semaphore.cmi +stdlib__Semaphore.cmx : semaphore.ml \ + stdlib__Mutex.cmx \ + stdlib__Condition.cmx \ + stdlib__Semaphore.cmi +stdlib__Semaphore.cmi : semaphore.mli stdlib__Seq.cmo : seq.ml \ stdlib.cmi \ stdlib__Lazy.cmi \ diff --git a/ocaml/stdlib/StdlibModules b/ocaml/stdlib/StdlibModules index 0ce73c14d1e..3942dd39ca2 100644 --- a/ocaml/stdlib/StdlibModules +++ b/ocaml/stdlib/StdlibModules @@ -77,6 +77,9 @@ STDLIB_MODULE_BASENAMES = \ fun \ gc \ digest \ + mutex \ + condition \ + semaphore \ domain \ bigarray \ random \ diff --git a/ocaml/otherlibs/systhreads4/condition.ml b/ocaml/stdlib/condition.ml similarity index 81% rename from ocaml/otherlibs/systhreads4/condition.ml rename to ocaml/stdlib/condition.ml index 9a014528abf..8fc7b580da9 100644 --- a/ocaml/otherlibs/systhreads4/condition.ml +++ b/ocaml/stdlib/condition.ml @@ -13,8 +13,10 @@ (* *) (**************************************************************************) +open! Stdlib + type t -external create: unit -> t = "caml_condition_new" -external wait: t -> Mutex.t -> unit = "caml_condition_wait" -external signal: t -> unit = "caml_condition_signal" -external broadcast: t -> unit = "caml_condition_broadcast" +external create: unit -> t = "caml_ml_condition_new" +external wait: t -> Mutex.t -> unit = "caml_ml_condition_wait" +external signal: t -> unit = "caml_ml_condition_signal" +external broadcast: t -> unit = "caml_ml_condition_broadcast" diff --git a/ocaml/stdlib/condition.mli b/ocaml/stdlib/condition.mli new file mode 100644 index 00000000000..ca97e575655 --- /dev/null +++ b/ocaml/stdlib/condition.mli @@ -0,0 +1,178 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Damien Doligez, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open! Stdlib + +(**Condition variables. + + Condition variables are useful when several threads wish to access a + shared data structure that is protected by a mutex (a mutual exclusion + lock). + + A condition variable is a {i communication channel}. On the receiver + side, one or more threads can indicate that they wish to {i wait} + for a certain property to become true. On the sender side, a thread + can {i signal} that this property has become true, causing one (or + more) waiting threads to be woken up. + + For instance, in the implementation of a queue data structure, if a + thread that wishes to extract an element finds that the queue is + currently empty, then this thread waits for the queue to become + nonempty. A thread that inserts an element into the queue signals + that the queue has become nonempty. A condition variable is used for this + purpose. This communication channel conveys the information that + the property "the queue is nonempty" is true, or more accurately, + may be true. (We explain below why the receiver of a signal cannot + be certain that the property holds.) + + To continue the example of the queue, assuming that the queue has a fixed + maximum capacity, then a thread that wishes to insert an element + may find that the queue is full. Then, this thread must wait for + the queue to become not full, and a thread that extracts an element + of the queue signals that the queue has become not full. Another + condition variable is used for this purpose. + + In short, a condition variable [c] is used to convey the information + that a certain property {i P} about a shared data structure {i D}, + protected by a mutex [m], may be true. + + Condition variables provide an efficient alternative to busy-waiting. + When one wishes to wait for the property {i P} to be true, + instead of writing a busy-waiting loop: + {[ + Mutex.lock m; + while not P do + Mutex.unlock m; Mutex.lock m + done; + ; + Mutex.unlock m + ]} + one uses {!wait} in the body of the loop, as follows: + {[ + Mutex.lock m; + while not P do + Condition.wait c m + done; + ; + Mutex.unlock m + ]} + The busy-waiting loop is inefficient because the waiting thread + consumes processing time and creates contention of the mutex [m]. + Calling {!wait} allows the waiting thread to be suspended, so it + does not consume any computing resources while waiting. + + With a condition variable [c], exactly one mutex [m] is associated. + This association is implicit: the mutex [m] is not explicitly passed + as an argument to {!create}. It is up to the programmer to know, for + each condition variable [c], which is the associated mutex [m]. + + With a mutex [m], several condition variables can be associated. + In the example of the bounded queue, one condition variable is + used to indicate that the queue is nonempty, and another condition + variable is used to indicate that the queue is not full. + + With a condition variable [c], exactly one logical property {i P} + should be associated. Examples of such properties + include "the queue is nonempty" and "the queue is not full". + It is up to the programmer to keep track, for each condition + variable, of the corresponding property {i P}. + A signal is sent on the condition variable [c] + as an indication that the property {i P} is true, or may be true. + On the receiving end, however, a thread that is woken up + cannot assume that {i P} is true; + after a call to {!wait} terminates, + one must explicitly test whether {i P} is true. + There are several reasons why this is so. + One reason is that, + between the moment when the signal is sent + and the moment when a waiting thread receives the signal + and is scheduled, + the property {i P} may be falsified by some other thread + that is able to acquire the mutex [m] and alter the data structure {i D}. + Another reason is that {i spurious wakeups} may occur: + a waiting thread can be woken up even if no signal was sent. + + Here is a complete example, where a mutex protects a sequential + unbounded queue, and where a condition variable is used to signal + that the queue is nonempty. + {[ + type 'a safe_queue = + { queue : 'a Queue.t; mutex : Mutex.t; nonempty : Condition.t } + + let create () = + { queue = Queue.create(); mutex = Mutex.create(); + nonempty = Condition.create() } + + let add v q = + Mutex.lock q.mutex; + let was_empty = Queue.is_empty q.queue in + Queue.add v q.queue; + if was_empty then Condition.broadcast q.nonempty; + Mutex.unlock q.mutex + + let take q = + Mutex.lock q.mutex; + while Queue.is_empty q.queue do Condition.wait q.nonempty q.mutex done; + let v = Queue.take q.queue in (* cannot fail since queue is nonempty *) + Mutex.unlock q.mutex; + v + ]} + Because the call to {!broadcast} takes place inside the critical + section, the following property holds whenever the mutex is unlocked: + {i if the queue is nonempty, then no thread is waiting}, + or, in other words, + {i if some thread is waiting, then the queue must be empty}. + This is a desirable property: if a thread + that attempts to execute a [take] operation + could remain suspended + even though the queue is nonempty, + that would be a problematic situation, + known as a {i deadlock}. *) + +type t +(** The type of condition variables. *) + +val create : unit -> t +(**[create()] creates and returns a new condition variable. + This condition variable should be associated (in the programmer's mind) + with a certain mutex [m] and with a certain property {i P} of the data + structure that is protected by the mutex [m]. *) + +val wait : t -> Mutex.t -> unit +(**The call [wait c m] is permitted only if [m] is the mutex associated + with the condition variable [c], and only if [m] is currently locked. + This call atomically unlocks the mutex [m] and suspends the + current thread on the condition variable [c]. This thread can + later be woken up after the condition variable [c] has been signaled + via {!signal} or {!broadcast}; however, it can also be woken up for + no reason. The mutex [m] is locked again before [wait] returns. One + cannot assume that the property {i P} associated with the condition + variable [c] holds when [wait] returns; one must explicitly test + whether {i P} holds after calling [wait]. *) + +val signal : t -> unit +(**[signal c] wakes up one of the threads waiting on the condition + variable [c], if there is one. If there is none, this call has + no effect. + + It is recommended to call [signal c] inside a critical section, + that is, while the mutex [m] associated with [c] is locked. *) + +val broadcast : t -> unit +(**[broadcast c] wakes up all threads waiting on the condition + variable [c]. If there are none, this call has no effect. + + It is recommended to call [broadcast c] inside a critical section, + that is, while the mutex [m] associated with [c] is locked. *) diff --git a/ocaml/stdlib/dune b/ocaml/stdlib/dune index 0f54479caaf..b3d889baa4b 100644 --- a/ocaml/stdlib/dune +++ b/ocaml/stdlib/dune @@ -108,6 +108,8 @@ char.mli complex.ml complex.mli + condition.ml + condition.mli digest.ml digest.mli domain.ml @@ -156,6 +158,8 @@ marshal.mli moreLabels.ml moreLabels.mli + mutex.ml + mutex.mli nativeint.ml nativeint.mli obj.ml @@ -180,6 +184,8 @@ result.mli scanf.ml scanf.mli + semaphore.ml + semaphore.mli seq.ml seq.mli set.ml @@ -244,6 +250,9 @@ .stdlib.objs/byte/stdlib__Complex.cmi .stdlib.objs/byte/stdlib__Complex.cmt .stdlib.objs/byte/stdlib__Complex.cmti + .stdlib.objs/byte/stdlib__Condition.cmi + .stdlib.objs/byte/stdlib__Condition.cmt + .stdlib.objs/byte/stdlib__Condition.cmti .stdlib.objs/byte/stdlib__Digest.cmi .stdlib.objs/byte/stdlib__Digest.cmt .stdlib.objs/byte/stdlib__Digest.cmti @@ -316,6 +325,9 @@ .stdlib.objs/byte/stdlib__MoreLabels.cmi .stdlib.objs/byte/stdlib__MoreLabels.cmt .stdlib.objs/byte/stdlib__MoreLabels.cmti + .stdlib.objs/byte/stdlib__Mutex.cmi + .stdlib.objs/byte/stdlib__Mutex.cmt + .stdlib.objs/byte/stdlib__Mutex.cmti .stdlib.objs/byte/stdlib__Nativeint.cmi .stdlib.objs/byte/stdlib__Nativeint.cmt .stdlib.objs/byte/stdlib__Nativeint.cmti @@ -352,6 +364,9 @@ .stdlib.objs/byte/stdlib__Scanf.cmi .stdlib.objs/byte/stdlib__Scanf.cmt .stdlib.objs/byte/stdlib__Scanf.cmti + .stdlib.objs/byte/stdlib__Semaphore.cmi + .stdlib.objs/byte/stdlib__Semaphore.cmt + .stdlib.objs/byte/stdlib__Semaphore.cmti .stdlib.objs/byte/stdlib__Seq.cmi .stdlib.objs/byte/stdlib__Seq.cmt .stdlib.objs/byte/stdlib__Seq.cmti @@ -437,6 +452,9 @@ .stdlib.objs/native/stdlib__Result.cmx .stdlib.objs/native/stdlib__Map.cmx .stdlib.objs/native/stdlib__Char.cmx + .stdlib.objs/native/stdlib__Condition.cmx + .stdlib.objs/native/stdlib__Mutex.cmx + .stdlib.objs/native/stdlib__Semaphore.cmx .stdlib.objs/native/stdlib__Printexc.cmx .stdlib.objs/native/stdlib__Lazy.cmx .stdlib.objs/native/stdlib__Parsing.cmx diff --git a/ocaml/stdlib/mutex.ml b/ocaml/stdlib/mutex.ml new file mode 100644 index 00000000000..e081a7e4528 --- /dev/null +++ b/ocaml/stdlib/mutex.ml @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Pascal Cuoq, INRIA Rocquencourt *) +(* *) +(* Copyright 1995 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t +external create: unit -> t = "caml_ml_mutex_new" +external lock: t -> unit = "caml_ml_mutex_lock" +external try_lock: t -> bool = "caml_ml_mutex_try_lock" +external unlock: t -> unit = "caml_ml_mutex_unlock" + +(* private re-export *) +external reraise : exn -> 'a = "%reraise" + +(* cannot inline, otherwise flambda might move code around. *) +let[@inline never] protect m f = + lock m; + match f() with + | x -> + unlock m; x + | exception e -> + (* NOTE: [unlock] does not poll for asynchronous exceptions *) + unlock m; + reraise e diff --git a/ocaml/otherlibs/systhreads4/mutex.mli b/ocaml/stdlib/mutex.mli similarity index 83% rename from ocaml/otherlibs/systhreads4/mutex.mli rename to ocaml/stdlib/mutex.mli index 70a67ce408a..7e838a64b02 100644 --- a/ocaml/otherlibs/systhreads4/mutex.mli +++ b/ocaml/stdlib/mutex.mli @@ -58,3 +58,16 @@ val unlock : t -> unit @before 4.12 {!Sys_error} was not raised when unlocking an unlocked mutex or when unlocking a mutex from a different thread. *) + +val protect : t -> (unit -> 'a) -> 'a +(** [protect mutex f] runs [f()] in a critical section where [mutex] + is locked (using {!lock}); it then takes care of releasing [mutex], + whether [f()] returned a value or raised an exception. + + The unlocking operation is guaranteed to always takes place, + even in the event an asynchronous exception (e.g. {!Sys.Break}) is raised + in some signal handler. + + @since 5.1 *) +(* CR ocaml 5 runtime (mshinwell): looks like [protect] needs to use + Sys.with_async_exns? *) diff --git a/ocaml/otherlibs/systhreads4/semaphore.ml b/ocaml/stdlib/semaphore.ml similarity index 99% rename from ocaml/otherlibs/systhreads4/semaphore.ml rename to ocaml/stdlib/semaphore.ml index e4fa4181a0e..f0ecc032cee 100644 --- a/ocaml/otherlibs/systhreads4/semaphore.ml +++ b/ocaml/stdlib/semaphore.ml @@ -13,6 +13,8 @@ (* *) (**************************************************************************) +open! Stdlib + (** Semaphores *) type sem = { diff --git a/ocaml/otherlibs/systhreads4/semaphore.mli b/ocaml/stdlib/semaphore.mli similarity index 99% rename from ocaml/otherlibs/systhreads4/semaphore.mli rename to ocaml/stdlib/semaphore.mli index 3a62747829b..553e1062e16 100644 --- a/ocaml/otherlibs/systhreads4/semaphore.mli +++ b/ocaml/stdlib/semaphore.mli @@ -13,6 +13,8 @@ (* *) (**************************************************************************) +open! Stdlib + (** Semaphores A semaphore is a thread synchronization device that can be used to diff --git a/ocaml/stdlib/stdlib.ml b/ocaml/stdlib/stdlib.ml index b5cef7b61e7..71bfff3df07 100644 --- a/ocaml/stdlib/stdlib.ml +++ b/ocaml/stdlib/stdlib.ml @@ -612,10 +612,7 @@ module BytesLabels = BytesLabels module Callback = Callback module Char = Char module Complex = Complex -(* CR ocaml 5 runtime: - BACKPORT module Condition = Condition -*) module Digest = Digest module Domain = Domain (* CR ocaml 5 runtime: @@ -641,10 +638,7 @@ module ListLabels = ListLabels module Map = Map module Marshal = Marshal module MoreLabels = MoreLabels -(* CR ocaml 5 runtime: - BACKPORT module Mutex = Mutex -*) module Nativeint = Nativeint module Obj = Obj module Oo = Oo @@ -657,10 +651,7 @@ module Queue = Queue module Random = Random module Result = Result module Scanf = Scanf -(* CR ocaml 5 runtime: - BACKPORT module Semaphore = Semaphore -*) module Seq = Seq module Set = Set module Stack = Stack diff --git a/ocaml/stdlib/stdlib.mli b/ocaml/stdlib/stdlib.mli index 135979099c6..435be8870f1 100644 --- a/ocaml/stdlib/stdlib.mli +++ b/ocaml/stdlib/stdlib.mli @@ -1403,10 +1403,7 @@ module BytesLabels = BytesLabels module Callback = Callback module Char = Char module Complex = Complex -(* CR ocaml 5 runtime: - BACKPORT module Condition = Condition -*) module Digest = Digest module Domain = Domain [@@alert "-unstable"] @@ -1440,10 +1437,7 @@ module ListLabels = ListLabels module Map = Map module Marshal = Marshal module MoreLabels = MoreLabels -(* CR ocaml 5 runtime: - BACKPORT module Mutex = Mutex -*) module Nativeint = Nativeint module Obj = Obj module Oo = Oo @@ -1456,10 +1450,7 @@ module Queue = Queue module Random = Random module Result = Result module Scanf = Scanf -(* CR ocaml 5 runtime: -BACKPORT module Semaphore = Semaphore -*) module Seq = Seq module Set = Set module Stack = Stack diff --git a/ocaml/testsuite/tests/asmcomp/polling.c b/ocaml/testsuite/tests/asmcomp/polling.c index f38b66c1596..a69affc0f45 100644 --- a/ocaml/testsuite/tests/asmcomp/polling.c +++ b/ocaml/testsuite/tests/asmcomp/polling.c @@ -3,7 +3,7 @@ #include #include #include -#if 0 /* BACKPORT */ +#if CAML_RUNTIME_5 #include #include #endif @@ -22,8 +22,9 @@ CAMLprim value request_minor_gc(value v) { } CAMLprim value minor_gcs(value v) { -#if 0 /* BACKPORT */ +#if CAML_RUNTIME_5 return Val_long(atomic_load(&caml_minor_collections_count)); -#endif +#else return Val_long(Caml_state->stat_minor_collections); +#endif } diff --git a/ocaml/testsuite/tests/backtrace/backtrace2.reference b/ocaml/testsuite/tests/backtrace/backtrace2.reference index 30a3be84b66..aece04fdc85 100644 --- a/ocaml/testsuite/tests/backtrace/backtrace2.reference +++ b/ocaml/testsuite/tests/backtrace/backtrace2.reference @@ -66,8 +66,8 @@ Called from Backtrace2.test_lazy.aux in file "backtrace2.ml", line 47, character Called from Backtrace2.test_lazy.aux in file "backtrace2.ml", line 47, characters 43-52 Called from Backtrace2.test_lazy.aux in file "backtrace2.ml", line 47, characters 43-52 Called from Backtrace2.test_lazy.aux in file "backtrace2.ml", line 47, characters 43-52 -Called from CamlinternalLazy.force_lazy_block in file "camlinternalLazy.ml", line 49, characters 17-27 -Re-raised at CamlinternalLazy.force_lazy_block in file "camlinternalLazy.ml", line 56, characters 4-11 +Called from CamlinternalLazy. +Re-raised at CamlinternalLazy. Called from Backtrace2.run in file "backtrace2.ml", line 62, characters 11-23 Uncaught exception Not_found Raised at Backtrace2.test_Not_found.aux in file "backtrace2.ml", line 36, characters 18-33 @@ -89,12 +89,12 @@ Called from Backtrace2.test_lazy.aux in file "backtrace2.ml", line 47, character Called from Backtrace2.test_lazy.aux in file "backtrace2.ml", line 47, characters 43-52 Called from Backtrace2.test_lazy.aux in file "backtrace2.ml", line 47, characters 43-52 Called from Backtrace2.test_lazy.aux in file "backtrace2.ml", line 47, characters 43-52 -Called from CamlinternalLazy.force_lazy_block in file "camlinternalLazy.ml", line 37, characters 17-27 -Re-raised at CamlinternalLazy.force_lazy_block in file "camlinternalLazy.ml", line 42, characters 4-11 +Called from CamlinternalLazy. +Re-raised at CamlinternalLazy. Called from Backtrace2.run in file "backtrace2.ml", line 62, characters 11-23 Re-raised at Stdlib__Hashtbl.find in file "hashtbl.ml", line 542, characters 13-28 Called from Backtrace2.test_lazy.exception_raised_internally in file "backtrace2.ml", line 50, characters 8-41 -Re-raised at CamlinternalLazy.force_lazy_block.(fun) in file "camlinternalLazy.ml", line 54, characters 56-63 -Called from CamlinternalLazy.force_lazy_block in file "camlinternalLazy.ml", line 49, characters 17-27 -Re-raised at CamlinternalLazy.force_lazy_block in file "camlinternalLazy.ml", line 56, characters 4-11 +Re-raised at CamlinternalLazy. +Called from CamlinternalLazy. +Re-raised at CamlinternalLazy. Called from Backtrace2.run in file "backtrace2.ml", line 62, characters 11-23 diff --git a/ocaml/testsuite/tests/backtrace/backtrace_c_exn.byte4.reference b/ocaml/testsuite/tests/backtrace/backtrace_c_exn.byte4.reference new file mode 100644 index 00000000000..a17b0e1b52c --- /dev/null +++ b/ocaml/testsuite/tests/backtrace/backtrace_c_exn.byte4.reference @@ -0,0 +1,2 @@ +Failure("exn") +Raised by primitive operation at Backtrace_c_exn in file "backtrace_c_exn.ml", line 28, characters 4-20 diff --git a/ocaml/testsuite/tests/backtrace/backtrace_c_exn.ml b/ocaml/testsuite/tests/backtrace/backtrace_c_exn.ml index 29af1f43478..b139d56992b 100644 --- a/ocaml/testsuite/tests/backtrace/backtrace_c_exn.ml +++ b/ocaml/testsuite/tests/backtrace/backtrace_c_exn.ml @@ -2,10 +2,18 @@ modules = "backtrace_c_exn_.c" flags = "-g" ocamlrunparam += ",b=1" - * bytecode - reference = "${test_source_directory}/backtrace_c_exn.byte.reference" - * native - reference = "${test_source_directory}/backtrace_c_exn.opt.reference" + * runtime4 + ** bytecode + reference = "${test_source_directory}/backtrace_c_exn.byte4.reference" + ** native + reference = "${test_source_directory}/backtrace_c_exn.opt4.reference" + * runtime5 + reference = "${test_source_directory}/backtrace_c_exn.byte.reference" +*) + +(* CR mshinwell: it isn't clear to me why the 5 reference output here + is not worse. It seems to have lost the stack frames on the C side. + (The reference file does match upstream 5.) *) (* https://github.com/ocaml-multicore/ocaml-multicore/issues/498 *) diff --git a/ocaml/testsuite/tests/backtrace/backtrace_c_exn.opt.reference b/ocaml/testsuite/tests/backtrace/backtrace_c_exn.opt4.reference similarity index 85% rename from ocaml/testsuite/tests/backtrace/backtrace_c_exn.opt.reference rename to ocaml/testsuite/tests/backtrace/backtrace_c_exn.opt4.reference index f4ec6135684..00436033844 100644 --- a/ocaml/testsuite/tests/backtrace/backtrace_c_exn.opt.reference +++ b/ocaml/testsuite/tests/backtrace/backtrace_c_exn.opt4.reference @@ -1,4 +1,4 @@ Failure("exn") Raised at Stdlib.failwith in file "stdlib.ml", line 34, characters 17-33 -Called from Backtrace_c_exn in file "backtrace_c_exn.ml", line 20, characters 4-20 -Called from Backtrace_c_exn in file "backtrace_c_exn.ml", line 20, characters 4-20 +Called from Backtrace_c_exn in file "backtrace_c_exn.ml", line 28, characters 4-20 +Called from Backtrace_c_exn in file "backtrace_c_exn.ml", line 28, characters 4-20 diff --git a/ocaml/testsuite/tests/backtrace/lazy.flambda.reference b/ocaml/testsuite/tests/backtrace/lazy.flambda.reference index 8b8ecc7a994..b245c47a6f4 100644 --- a/ocaml/testsuite/tests/backtrace/lazy.flambda.reference +++ b/ocaml/testsuite/tests/backtrace/lazy.flambda.reference @@ -1,17 +1,17 @@ Uncaught exception Not_found Raised at Lazy.l1 in file "lazy.ml", line 3, characters 28-45 -Called from CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 126, characters 19-29 -Re-raised at CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 131, characters 6-13 +Called from CamlinternalLazy.Lazy. +Re-raised at CamlinternalLazy.Lazy. Called from Lazy.test1 in file "lazy.ml", line 6, characters 11-24 Called from Lazy.run in file "lazy.ml", line 15, characters 4-11 Uncaught exception Not_found Raised at Lazy.l1 in file "lazy.ml", line 3, characters 28-45 -Called from CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 126, characters 19-29 -Re-raised at CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 131, characters 6-13 +Called from CamlinternalLazy.Lazy. +Re-raised at CamlinternalLazy.Lazy. Called from Lazy.test1 in file "lazy.ml", line 6, characters 11-24 Called from Lazy.run in file "lazy.ml", line 15, characters 4-11 Re-raised at Lazy.l2 in file "lazy.ml", line 8, characters 28-45 -Called from CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 126, characters 19-29 -Re-raised at CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 131, characters 6-13 +Called from CamlinternalLazy.Lazy. +Re-raised at CamlinternalLazy.Lazy. Called from Lazy.test2 in file "lazy.ml", line 11, characters 6-15 Called from Lazy.run in file "lazy.ml", line 15, characters 4-11 diff --git a/ocaml/testsuite/tests/backtrace/lazy.reference b/ocaml/testsuite/tests/backtrace/lazy.reference index 8b8ecc7a994..b245c47a6f4 100644 --- a/ocaml/testsuite/tests/backtrace/lazy.reference +++ b/ocaml/testsuite/tests/backtrace/lazy.reference @@ -1,17 +1,17 @@ Uncaught exception Not_found Raised at Lazy.l1 in file "lazy.ml", line 3, characters 28-45 -Called from CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 126, characters 19-29 -Re-raised at CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 131, characters 6-13 +Called from CamlinternalLazy.Lazy. +Re-raised at CamlinternalLazy.Lazy. Called from Lazy.test1 in file "lazy.ml", line 6, characters 11-24 Called from Lazy.run in file "lazy.ml", line 15, characters 4-11 Uncaught exception Not_found Raised at Lazy.l1 in file "lazy.ml", line 3, characters 28-45 -Called from CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 126, characters 19-29 -Re-raised at CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 131, characters 6-13 +Called from CamlinternalLazy.Lazy. +Re-raised at CamlinternalLazy.Lazy. Called from Lazy.test1 in file "lazy.ml", line 6, characters 11-24 Called from Lazy.run in file "lazy.ml", line 15, characters 4-11 Re-raised at Lazy.l2 in file "lazy.ml", line 8, characters 28-45 -Called from CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 126, characters 19-29 -Re-raised at CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 131, characters 6-13 +Called from CamlinternalLazy.Lazy. +Re-raised at CamlinternalLazy.Lazy. Called from Lazy.test2 in file "lazy.ml", line 11, characters 6-15 Called from Lazy.run in file "lazy.ml", line 15, characters 4-11 diff --git a/ocaml/testsuite/tests/backtrace/lazy.run b/ocaml/testsuite/tests/backtrace/lazy.run new file mode 100755 index 00000000000..ecfe43c9739 --- /dev/null +++ b/ocaml/testsuite/tests/backtrace/lazy.run @@ -0,0 +1,3 @@ +#!/bin/sh +(${program} 2>&1 || true) 2>&1 | \ + ${test_source_directory}/sanitize-backtrace.sh > ${output} diff --git a/ocaml/testsuite/tests/backtrace/names.reference b/ocaml/testsuite/tests/backtrace/names.reference index cfb1d0db093..956cadb1977 100644 --- a/ocaml/testsuite/tests/backtrace/names.reference +++ b/ocaml/testsuite/tests/backtrace/names.reference @@ -1,8 +1,8 @@ Raised at Names.bang in file "names.ml", line 9, characters 29-39 Called from Names.nontailcall in file "names.ml", line 106, characters 2-6 Called from Names.lazy_ in file "names.ml", line 101, characters 41-45 -Called from CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 126, characters 19-29 -Re-raised at CamlinternalLazy.Lazy4.force_lazy_block in file "camlinternalLazy.ml", line 131, characters 6-13 +Called from CamlinternalLazy.Lazy. +Re-raised at CamlinternalLazy.Lazy. Called from Names.inline_object.object#othermeth in file "names.ml", line 96, characters 6-10 Called from Names.inline_object.object#meth in file "names.ml", line 94, characters 6-26 Called from Names.klass2#othermeth.(fun) in file "names.ml", line 88, characters 18-22 diff --git a/ocaml/testsuite/tests/backtrace/names.run b/ocaml/testsuite/tests/backtrace/names.run new file mode 100755 index 00000000000..ecfe43c9739 --- /dev/null +++ b/ocaml/testsuite/tests/backtrace/names.run @@ -0,0 +1,3 @@ +#!/bin/sh +(${program} 2>&1 || true) 2>&1 | \ + ${test_source_directory}/sanitize-backtrace.sh > ${output} diff --git a/ocaml/testsuite/tests/backtrace/sanitize-backtrace.sh b/ocaml/testsuite/tests/backtrace/sanitize-backtrace.sh index 0a08a3af365..08545b114d2 100755 --- a/ocaml/testsuite/tests/backtrace/sanitize-backtrace.sh +++ b/ocaml/testsuite/tests/backtrace/sanitize-backtrace.sh @@ -6,4 +6,8 @@ # - remove "by primitive operations" because flambda2 handles # array primitives a bit differently and thus does not emit # this "by primitive operation" for e.g. array accesses -sed -e 's/ (inlined)//' -e 's/ by primitive operation//' +# In addition to the above it now irons out some runtime4/5 differences. +sed -e 's/ (inlined)//' -e 's/ by primitive operation//' \ + -e 's/CamlinternalLazy\.Lazy[45]\./CamlinternalLazy.Lazy./' \ + -e 's/CamlinternalLazy.Lazy.force_lazy_block.*/CamlinternalLazy.Lazy./' \ + -e 's/CamlinternalLazy.Lazy.do_force_block.*/CamlinternalLazy.Lazy./' diff --git a/ocaml/testsuite/tests/basic/patmatch_for_multiple.ml b/ocaml/testsuite/tests/basic/patmatch_for_multiple.ml index ff23b6dde39..711f4eaa6d1 100644 --- a/ocaml/testsuite/tests/basic/patmatch_for_multiple.ml +++ b/ocaml/testsuite/tests/basic/patmatch_for_multiple.ml @@ -26,15 +26,15 @@ match (3, 2, 1) with | _ -> false ;; [%%expect{| -(let (*match*/272 =[int] 3 *match*/273 =[int] 2 *match*/274 =[int] 1) +(let (*match*/275 =[int] 3 *match*/276 =[int] 2 *match*/277 =[int] 1) (catch (catch - (catch (if (!= *match*/273 3) (exit 3) (exit 1)) with (3) - (if (!= *match*/272 1) (exit 2) (exit 1))) + (catch (if (!= *match*/276 3) (exit 3) (exit 1)) with (3) + (if (!= *match*/275 1) (exit 2) (exit 1))) with (2) 0) with (1) 1)) -(let (*match*/272 =[int] 3 *match*/273 =[int] 2 *match*/274 =[int] 1) - (catch (if (!= *match*/273 3) (if (!= *match*/272 1) 0 (exit 1)) (exit 1)) +(let (*match*/275 =[int] 3 *match*/276 =[int] 2 *match*/277 =[int] 1) + (catch (if (!= *match*/276 3) (if (!= *match*/275 1) 0 (exit 1)) (exit 1)) with (1) 1)) - : bool = false |}];; @@ -47,32 +47,32 @@ match (3, 2, 1) with | _ -> false ;; [%%expect{| -(let (*match*/277 =[int] 3 *match*/278 =[int] 2 *match*/279 =[int] 1) +(let (*match*/280 =[int] 3 *match*/281 =[int] 2 *match*/282 =[int] 1) (catch (catch (catch - (if (!= *match*/278 3) (exit 6) + (if (!= *match*/281 3) (exit 6) (let - (x/281 =a[(consts ()) (non_consts ([0: [int], [int], [int]]))] - (makeblock 0 *match*/277 *match*/278 *match*/279)) - (exit 4 x/281))) + (x/284 =a[(consts ()) (non_consts ([0: [int], [int], [int]]))] + (makeblock 0 *match*/280 *match*/281 *match*/282)) + (exit 4 x/284))) with (6) - (if (!= *match*/277 1) (exit 5) + (if (!= *match*/280 1) (exit 5) (let - (x/280 =a[(consts ()) (non_consts ([0: [int], [int], [int]]))] - (makeblock 0 *match*/277 *match*/278 *match*/279)) - (exit 4 x/280)))) + (x/283 =a[(consts ()) (non_consts ([0: [int], [int], [int]]))] + (makeblock 0 *match*/280 *match*/281 *match*/282)) + (exit 4 x/283)))) with (5) 0) - with (4 x/275[(consts ()) (non_consts ([0: [int], [int], [int]]))]) - (seq (ignore x/275) 1))) -(let (*match*/277 =[int] 3 *match*/278 =[int] 2 *match*/279 =[int] 1) + with (4 x/278[(consts ()) (non_consts ([0: [int], [int], [int]]))]) + (seq (ignore x/278) 1))) +(let (*match*/280 =[int] 3 *match*/281 =[int] 2 *match*/282 =[int] 1) (catch - (if (!= *match*/278 3) - (if (!= *match*/277 1) 0 - (exit 4 (makeblock 0 *match*/277 *match*/278 *match*/279))) - (exit 4 (makeblock 0 *match*/277 *match*/278 *match*/279))) - with (4 x/275[(consts ()) (non_consts ([0: [int], [int], [int]]))]) - (seq (ignore x/275) 1))) + (if (!= *match*/281 3) + (if (!= *match*/280 1) 0 + (exit 4 (makeblock 0 *match*/280 *match*/281 *match*/282))) + (exit 4 (makeblock 0 *match*/280 *match*/281 *match*/282))) + with (4 x/278[(consts ()) (non_consts ([0: [int], [int], [int]]))]) + (seq (ignore x/278) 1))) - : bool = false |}];; @@ -82,8 +82,8 @@ let _ = fun a b -> | ((true, _) as _g) | ((false, _) as _g) -> () [%%expect{| -(function {nlocal = 0} a/282[int] b/283 : int 0) -(function {nlocal = 0} a/282[int] b/283 : int 0) +(function {nlocal = 0} a/285[int] b/286 : int 0) +(function {nlocal = 0} a/285[int] b/286 : int 0) - : bool -> 'a -> unit = |}];; @@ -102,15 +102,15 @@ let _ = fun a b -> match a, b with | (false, _) as p -> p (* outside, trivial *) [%%expect {| -(function {nlocal = 0} a/286[int] b/287 +(function {nlocal = 0} a/289[int] b/290 [(consts ()) (non_consts ([0: [int], *]))](let - (p/288 =a[(consts ()) + (p/291 =a[(consts ()) (non_consts ( [0: [int], *]))] - (makeblock 0 a/286 b/287)) - p/288)) -(function {nlocal = 0} a/286[int] b/287 - [(consts ()) (non_consts ([0: [int], *]))](makeblock 0 a/286 b/287)) + (makeblock 0 a/289 b/290)) + p/291)) +(function {nlocal = 0} a/289[int] b/290 + [(consts ()) (non_consts ([0: [int], *]))](makeblock 0 a/289 b/290)) - : bool -> 'a -> bool * 'a = |}] @@ -119,15 +119,15 @@ let _ = fun a b -> match a, b with | ((false, _) as p) -> p (* inside, trivial *) [%%expect{| -(function {nlocal = 0} a/290[int] b/291 +(function {nlocal = 0} a/293[int] b/294 [(consts ()) (non_consts ([0: [int], *]))](let - (p/292 =a[(consts ()) + (p/295 =a[(consts ()) (non_consts ( [0: [int], *]))] - (makeblock 0 a/290 b/291)) - p/292)) -(function {nlocal = 0} a/290[int] b/291 - [(consts ()) (non_consts ([0: [int], *]))](makeblock 0 a/290 b/291)) + (makeblock 0 a/293 b/294)) + p/295)) +(function {nlocal = 0} a/293[int] b/294 + [(consts ()) (non_consts ([0: [int], *]))](makeblock 0 a/293 b/294)) - : bool -> 'a -> bool * 'a = |}];; @@ -136,20 +136,20 @@ let _ = fun a b -> match a, b with | (false as x, _) as p -> x, p (* outside, simple *) [%%expect {| -(function {nlocal = 0} a/296[int] b/297 +(function {nlocal = 0} a/299[int] b/300 [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], *]))]]))] (let - (x/298 =a[int] a/296 - p/299 =a[(consts ()) (non_consts ([0: [int], *]))] - (makeblock 0 a/296 b/297)) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) x/298 - p/299))) -(function {nlocal = 0} a/296[int] b/297 + (x/301 =a[int] a/299 + p/302 =a[(consts ()) (non_consts ([0: [int], *]))] + (makeblock 0 a/299 b/300)) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) x/301 + p/302))) +(function {nlocal = 0} a/299[int] b/300 [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], *]))]]))] - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) a/296 - (makeblock 0 a/296 b/297))) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) a/299 + (makeblock 0 a/299 b/300))) - : bool -> 'a -> bool * (bool * 'a) = |}] @@ -158,20 +158,20 @@ let _ = fun a b -> match a, b with | ((false as x, _) as p) -> x, p (* inside, simple *) [%%expect {| -(function {nlocal = 0} a/302[int] b/303 +(function {nlocal = 0} a/305[int] b/306 [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], *]))]]))] (let - (x/304 =a[int] a/302 - p/305 =a[(consts ()) (non_consts ([0: [int], *]))] - (makeblock 0 a/302 b/303)) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) x/304 - p/305))) -(function {nlocal = 0} a/302[int] b/303 + (x/307 =a[int] a/305 + p/308 =a[(consts ()) (non_consts ([0: [int], *]))] + (makeblock 0 a/305 b/306)) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) x/307 + p/308))) +(function {nlocal = 0} a/305[int] b/306 [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], *]))]]))] - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) a/302 - (makeblock 0 a/302 b/303))) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) a/305 + (makeblock 0 a/305 b/306))) - : bool -> 'a -> bool * (bool * 'a) = |}] @@ -180,30 +180,30 @@ let _ = fun a b -> match a, b with | (false, x) as p -> x, p (* outside, complex *) [%%expect{| -(function {nlocal = 0} a/312[int] b/313[int] +(function {nlocal = 0} a/315[int] b/316[int] [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], [int]]))]]))] - (if a/312 + (if a/315 (let - (x/314 =a[int] a/312 - p/315 =a[(consts ()) (non_consts ([0: [int], [int]]))] - (makeblock 0 a/312 b/313)) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/314 - p/315)) + (x/317 =a[int] a/315 + p/318 =a[(consts ()) (non_consts ([0: [int], [int]]))] + (makeblock 0 a/315 b/316)) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/317 + p/318)) (let - (x/316 =a[(consts ()) (non_consts ([0: ]))] b/313 - p/317 =a[(consts ()) (non_consts ([0: [int], [int]]))] - (makeblock 0 a/312 b/313)) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/316 - p/317)))) -(function {nlocal = 0} a/312[int] b/313[int] + (x/319 =a[(consts ()) (non_consts ([0: ]))] b/316 + p/320 =a[(consts ()) (non_consts ([0: [int], [int]]))] + (makeblock 0 a/315 b/316)) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/319 + p/320)))) +(function {nlocal = 0} a/315[int] b/316[int] [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], [int]]))]]))] - (if a/312 - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) a/312 - (makeblock 0 a/312 b/313)) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) b/313 - (makeblock 0 a/312 b/313)))) + (if a/315 + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) a/315 + (makeblock 0 a/315 b/316)) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) b/316 + (makeblock 0 a/315 b/316)))) - : bool -> bool -> bool * (bool * bool) = |}] @@ -213,33 +213,33 @@ let _ = fun a b -> match a, b with -> x, p (* inside, complex *) [%%expect{| -(function {nlocal = 0} a/318[int] b/319[int] +(function {nlocal = 0} a/321[int] b/322[int] [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], [int]]))]]))] (catch - (if a/318 + (if a/321 (let - (x/326 =a[int] a/318 - p/327 =a[(consts ()) (non_consts ([0: [int], [int]]))] - (makeblock 0 a/318 b/319)) - (exit 10 x/326 p/327)) + (x/329 =a[int] a/321 + p/330 =a[(consts ()) (non_consts ([0: [int], [int]]))] + (makeblock 0 a/321 b/322)) + (exit 10 x/329 p/330)) (let - (x/324 =a[(consts ()) (non_consts ([0: ]))] b/319 - p/325 =a[(consts ()) (non_consts ([0: [int], [int]]))] - (makeblock 0 a/318 b/319)) - (exit 10 x/324 p/325))) - with (10 x/320[int] p/321[(consts ()) (non_consts ([0: [int], [int]]))]) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/320 - p/321))) -(function {nlocal = 0} a/318[int] b/319[int] + (x/327 =a[(consts ()) (non_consts ([0: ]))] b/322 + p/328 =a[(consts ()) (non_consts ([0: [int], [int]]))] + (makeblock 0 a/321 b/322)) + (exit 10 x/327 p/328))) + with (10 x/323[int] p/324[(consts ()) (non_consts ([0: [int], [int]]))]) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/323 + p/324))) +(function {nlocal = 0} a/321[int] b/322[int] [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], [int]]))]]))] (catch - (if a/318 (exit 10 a/318 (makeblock 0 a/318 b/319)) - (exit 10 b/319 (makeblock 0 a/318 b/319))) - with (10 x/320[int] p/321[(consts ()) (non_consts ([0: [int], [int]]))]) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/320 - p/321))) + (if a/321 (exit 10 a/321 (makeblock 0 a/321 b/322)) + (exit 10 b/322 (makeblock 0 a/321 b/322))) + with (10 x/323[int] p/324[(consts ()) (non_consts ([0: [int], [int]]))]) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/323 + p/324))) - : bool -> bool -> bool * (bool * bool) = |}] @@ -252,30 +252,30 @@ let _ = fun a b -> match a, b with | (false as x, _) as p -> x, p (* outside, onecase *) [%%expect {| -(function {nlocal = 0} a/328[int] b/329[int] +(function {nlocal = 0} a/331[int] b/332[int] [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], [int]]))]]))] - (if a/328 + (if a/331 (let - (x/330 =a[int] a/328 - _p/331 =a[(consts ()) (non_consts ([0: [int], [int]]))] - (makeblock 0 a/328 b/329)) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/330 + (x/333 =a[int] a/331 + _p/334 =a[(consts ()) (non_consts ([0: [int], [int]]))] + (makeblock 0 a/331 b/332)) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/333 [0: 1 1])) (let - (x/332 =a[int] a/328 - p/333 =a[(consts ()) (non_consts ([0: [int], [int]]))] - (makeblock 0 a/328 b/329)) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/332 - p/333)))) -(function {nlocal = 0} a/328[int] b/329[int] + (x/335 =a[int] a/331 + p/336 =a[(consts ()) (non_consts ([0: [int], [int]]))] + (makeblock 0 a/331 b/332)) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) x/335 + p/336)))) +(function {nlocal = 0} a/331[int] b/332[int] [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], [int]]))]]))] - (if a/328 - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) a/328 + (if a/331 + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) a/331 [0: 1 1]) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) a/328 - (makeblock 0 a/328 b/329)))) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], [int]]))]) a/331 + (makeblock 0 a/331 b/332)))) - : bool -> bool -> bool * (bool * bool) = |}] @@ -284,20 +284,20 @@ let _ = fun a b -> match a, b with | ((false as x, _) as p) -> x, p (* inside, onecase *) [%%expect{| -(function {nlocal = 0} a/334[int] b/335 +(function {nlocal = 0} a/337[int] b/338 [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], *]))]]))] (let - (x/336 =a[int] a/334 - p/337 =a[(consts ()) (non_consts ([0: [int], *]))] - (makeblock 0 a/334 b/335)) - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) x/336 - p/337))) -(function {nlocal = 0} a/334[int] b/335 + (x/339 =a[int] a/337 + p/340 =a[(consts ()) (non_consts ([0: [int], *]))] + (makeblock 0 a/337 b/338)) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) x/339 + p/340))) +(function {nlocal = 0} a/337[int] b/338 [(consts ()) (non_consts ([0: [int], [(consts ()) (non_consts ([0: [int], *]))]]))] - (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) a/334 - (makeblock 0 a/334 b/335))) + (makeblock 0 (int,[(consts ()) (non_consts ([0: [int], *]))]) a/337 + (makeblock 0 a/337 b/338))) - : bool -> 'a -> bool * (bool * 'a) = |}] @@ -314,23 +314,23 @@ let _ =fun a b -> match a, b with | (_, _) as p -> p (* outside, tuplist *) [%%expect {| -(function {nlocal = 0} a/347[int] - b/348[(consts (0)) +(function {nlocal = 0} a/350[int] + b/351[(consts (0)) (non_consts ([0: [(consts ()) (non_consts ([0: *, *]))]]))] [(consts ()) (non_consts ([0: [int], [(consts (0)) (non_consts ([0: *]))]]))](catch - (if a/347 - (if b/348 + (if a/350 + (if b/351 (let - (p/349 =a + (p/352 =a (field_imm 0 - b/348)) - p/349) + b/351)) + p/352) (exit 12)) (exit 12)) with (12) (let - (p/350 =a + (p/353 =a [(consts ()) (non_consts ( [0: @@ -339,24 +339,24 @@ let _ =fun a b -> match a, b with (non_consts ( [0: *]))]]))] (makeblock 0 - a/347 - b/348)) - p/350))) -(function {nlocal = 0} a/347[int] - b/348[(consts (0)) + a/350 + b/351)) + p/353))) +(function {nlocal = 0} a/350[int] + b/351[(consts (0)) (non_consts ([0: [(consts ()) (non_consts ([0: *, *]))]]))] [(consts ()) (non_consts ([0: [int], [(consts (0)) (non_consts ([0: *]))]]))](catch - (if a/347 - (if b/348 + (if a/350 + (if b/351 (field_imm 0 - b/348) + b/351) (exit 12)) (exit 12)) with (12) (makeblock 0 - a/347 - b/348))) + a/350 + b/351))) - : bool -> bool tuplist -> bool * bool tuplist = |}] @@ -365,25 +365,25 @@ let _ = fun a b -> match a, b with | ((_, _) as p) -> p (* inside, tuplist *) [%%expect{| -(function {nlocal = 0} a/351[int] - b/352[(consts (0)) +(function {nlocal = 0} a/354[int] + b/355[(consts (0)) (non_consts ([0: [(consts ()) (non_consts ([0: *, *]))]]))] [(consts ()) (non_consts ([0: [int], [(consts (0)) (non_consts ([0: *]))]]))](catch (catch - (if a/351 - (if b/352 + (if a/354 + (if b/355 (let - (p/356 =a + (p/359 =a (field_imm 0 - b/352)) + b/355)) (exit 13 - p/356)) + p/359)) (exit 14)) (exit 14)) with (14) (let - (p/355 =a + (p/358 =a [(consts ()) (non_consts ( [0: @@ -392,11 +392,11 @@ let _ = fun a b -> match a, b with (non_consts ( [0: *]))]]))] (makeblock 0 - a/351 - b/352)) + a/354 + b/355)) (exit 13 - p/355))) - with (13 p/353 + p/358))) + with (13 p/356 [(consts ()) (non_consts ( [0: @@ -404,26 +404,26 @@ let _ = fun a b -> match a, b with [(consts (0)) (non_consts ( [0: *]))]]))]) - p/353)) -(function {nlocal = 0} a/351[int] - b/352[(consts (0)) + p/356)) +(function {nlocal = 0} a/354[int] + b/355[(consts (0)) (non_consts ([0: [(consts ()) (non_consts ([0: *, *]))]]))] [(consts ()) (non_consts ([0: [int], [(consts (0)) (non_consts ([0: *]))]]))](catch (catch - (if a/351 - (if b/352 + (if a/354 + (if b/355 (exit 13 (field_imm 0 - b/352)) + b/355)) (exit 14)) (exit 14)) with (14) (exit 13 (makeblock 0 - a/351 - b/352))) - with (13 p/353 + a/354 + b/355))) + with (13 p/356 [(consts ()) (non_consts ( [0: @@ -431,6 +431,6 @@ let _ = fun a b -> match a, b with [(consts (0)) (non_consts ( [0: *]))]]))]) - p/353)) + p/356)) - : bool -> bool tuplist -> bool * bool tuplist = |}] diff --git a/ocaml/testsuite/tests/gc-roots/globroots.ml b/ocaml/testsuite/tests/gc-roots/globroots.ml index 60f93816d6b..56d1586331b 100644 --- a/ocaml/testsuite/tests/gc-roots/globroots.ml +++ b/ocaml/testsuite/tests/gc-roots/globroots.ml @@ -26,27 +26,14 @@ module Generational : GLOBREF = struct external remove: t -> unit = "gb_generational_remove" end -(* BACKPORT BEGIN *) -module Domain = struct - module DLS = struct - let get t = Lazy.force t - end -end -(* BACKPORT END *) - module Test(G: GLOBREF) () = struct let size = 1024 let random_state = - (* BACKPORT BEGIN Domain.DLS.new_key ~split_from_parent:Random.State.split Random.State.make_self_init - *) - lazy (Random.State.make_self_init ()) - (* BACKPORT END *) - let vals = Array.init size Int.to_string diff --git a/ocaml/testsuite/tests/gc-roots/globrootsprim.c b/ocaml/testsuite/tests/gc-roots/globrootsprim.c index 2f9df707bd7..10280a12672 100644 --- a/ocaml/testsuite/tests/gc-roots/globrootsprim.c +++ b/ocaml/testsuite/tests/gc-roots/globrootsprim.c @@ -13,17 +13,15 @@ /* For testing global root registration */ -/* BACKPORT #define CAML_INTERNALS -*/ #include "caml/mlvalues.h" #include "caml/memory.h" #include "caml/alloc.h" #include "caml/gc.h" -/* BACKPORT +#ifdef CAML_RUNTIME_5 #include "caml/shared_heap.h" -*/ +#endif #include "caml/callback.h" struct block { value header; value v; }; @@ -39,11 +37,11 @@ value gb_get(value vblock) value gb_classic_register(value v) { struct block * b = caml_stat_alloc(sizeof(struct block)); - /* BACKPORT BEGIN +#ifdef CAML_RUNTIME_5 b->header = Make_header(1, 0, NOT_MARKABLE); - */ +#else b->header = Make_header(1, 0, Caml_black); - /* BACKPORT END */ +#endif b->v = v; caml_register_global_root(&(b->v)); return Val_block(b); @@ -64,11 +62,11 @@ value gb_classic_remove(value vblock) value gb_generational_register(value v) { struct block * b = caml_stat_alloc(sizeof(struct block)); - /* BACKPORT BEGIN +#ifdef CAML_RUNTIME_5 b->header = Make_header(1, 0, NOT_MARKABLE); - */ +#else b->header = Make_header(1, 0, Caml_black); - /* BACKPORT END */ +#endif b->v = v; caml_register_generational_global_root(&(b->v)); return Val_block(b); diff --git a/ocaml/testsuite/tests/instrumented-runtime/main.ml b/ocaml/testsuite/tests/instrumented-runtime/main.ml index 4b0260df8d5..306523c5b25 100644 --- a/ocaml/testsuite/tests/instrumented-runtime/main.ml +++ b/ocaml/testsuite/tests/instrumented-runtime/main.ml @@ -1,6 +1,7 @@ (* TEST - * instrumented-runtime - ** native + * runtime4 + ** instrumented-runtime + *** native flags = "-runtime-variant=i" *) diff --git a/ocaml/testsuite/tests/lib-dynlink-csharp/main.ml b/ocaml/testsuite/tests/lib-dynlink-csharp/main.ml index 31ff6412f77..12a5050cfc6 100644 --- a/ocaml/testsuite/tests/lib-dynlink-csharp/main.ml +++ b/ocaml/testsuite/tests/lib-dynlink-csharp/main.ml @@ -34,7 +34,7 @@ program = "main_obj.${objext}" all_modules = "dynlink.cma entry.c main.ml" ****** script script = "${mkdll} -maindll -o main.dll main_obj.${objext} entry.${objext} \ - ${ocamlsrcdir}/runtime4/libcamlrun.${libext} ${bytecc_libs}" + ${ocamlsrcdir}/${runtime_dir}/libcamlrun.${libext} ${bytecc_libs}" ******* script script = "${csharp_cmd}" ******** run @@ -70,7 +70,7 @@ program = "main_obj.${objext}" all_modules = "dynlink.cmxa entry.c main.ml" ****** script script = "${mkdll} -maindll -o main.dll main_obj.${objext} entry.${objext} \ - ${ocamlsrcdir}/runtime4/libasmrun.${libext} ${nativecc_libs}" + ${ocamlsrcdir}/${runtime_dir}/libasmrun.${libext} ${nativecc_libs}" ******* script script = "${csharp_cmd}" ******** run diff --git a/ocaml/testsuite/tests/lib-obj/get_header.byte.local.reference b/ocaml/testsuite/tests/lib-obj/get_header.byte.local.reference new file mode 100644 index 00000000000..1627d1560fc --- /dev/null +++ b/ocaml/testsuite/tests/lib-obj/get_header.byte.local.reference @@ -0,0 +1,3 @@ +None false +Some(wosize=1,color=0,tag=252) false +Some(wosize=1,color=0,tag=0) false diff --git a/ocaml/testsuite/tests/lib-obj/get_header.ml b/ocaml/testsuite/tests/lib-obj/get_header.ml index d13c1fafd69..d2e40e9f3d3 100644 --- a/ocaml/testsuite/tests/lib-obj/get_header.ml +++ b/ocaml/testsuite/tests/lib-obj/get_header.ml @@ -1,8 +1,14 @@ (* TEST - * native - reference = "${test_source_directory}/get_header.opt.reference" - * bytecode - reference = "${test_source_directory}/get_header.byte.reference" + * stack-allocation + ** native + reference = "${test_source_directory}/get_header.opt.local.reference" + ** bytecode + reference = "${test_source_directory}/get_header.byte.local.reference" + * no-stack-allocation + ** native + reference = "${test_source_directory}/get_header.opt.reference" + ** bytecode + reference = "${test_source_directory}/get_header.byte.reference" *) external repr : ('a[@local_opt]) -> (Obj.t[@local_opt]) = "%identity" diff --git a/ocaml/testsuite/tests/lib-obj/get_header.opt.local.reference b/ocaml/testsuite/tests/lib-obj/get_header.opt.local.reference new file mode 100644 index 00000000000..4eee2c72cf2 --- /dev/null +++ b/ocaml/testsuite/tests/lib-obj/get_header.opt.local.reference @@ -0,0 +1,3 @@ +None false +Some(wosize=1,color=3,tag=252) false +Some(wosize=1,color=2,tag=0) true diff --git a/ocaml/testsuite/tests/lib-obj/get_header.opt.reference b/ocaml/testsuite/tests/lib-obj/get_header.opt.reference index 4eee2c72cf2..ba64d682deb 100644 --- a/ocaml/testsuite/tests/lib-obj/get_header.opt.reference +++ b/ocaml/testsuite/tests/lib-obj/get_header.opt.reference @@ -1,3 +1,3 @@ None false Some(wosize=1,color=3,tag=252) false -Some(wosize=1,color=2,tag=0) true +Some(wosize=1,color=0,tag=0) false diff --git a/ocaml/testsuite/tests/lib-threads/pr9971.ml b/ocaml/testsuite/tests/lib-threads/pr9971.ml index dc016f3f96a..c20967c7f32 100644 --- a/ocaml/testsuite/tests/lib-threads/pr9971.ml +++ b/ocaml/testsuite/tests/lib-threads/pr9971.ml @@ -1,12 +1,16 @@ (* TEST -* hassysthreads +* runtime4 +** hassysthreads include systhreads -** bytecode -** native +*** bytecode +*** native *) +(* This test was deleted in OCaml 5 upstream + (rev 55da58ca6c9144331c7fa56a5d0083cb97b50925) *) + let t = let t = Thread.create (fun _ -> ())() in Thread.join t diff --git a/ocaml/testsuite/tests/lib-unix/unix-execvpe/has-execvpe.sh b/ocaml/testsuite/tests/lib-unix/unix-execvpe/has-execvpe.sh index 0998faa28cd..7d26050eba1 100755 --- a/ocaml/testsuite/tests/lib-unix/unix-execvpe/has-execvpe.sh +++ b/ocaml/testsuite/tests/lib-unix/unix-execvpe/has-execvpe.sh @@ -5,7 +5,7 @@ # It makes sense to run the tests only if execvpe is nt implemented. # If it is implemented, the test is skipped. -if grep -q "#define HAS_EXECVPE" ${ocamlsrcdir}/runtime4/caml/s.h; then +if grep -q "#define HAS_EXECVPE" ${ocamlsrcdir}/${runtime_dir}/caml/s.h; then exit ${TEST_SKIP}; fi exit ${TEST_PASS} diff --git a/ocaml/testsuite/tests/output-complete-obj/github9344.ml b/ocaml/testsuite/tests/output-complete-obj/github9344.ml index 1dc117c1a49..9944999eab3 100644 --- a/ocaml/testsuite/tests/output-complete-obj/github9344.ml +++ b/ocaml/testsuite/tests/output-complete-obj/github9344.ml @@ -4,7 +4,7 @@ use_runtime = "false" * setup-ocamlc.byte-build-env ** ocamlc.byte -flags = "-w -a -output-complete-exe -ccopt -I${ocamlsrcdir}/runtime4" +flags = "-w -a -output-complete-exe -ccopt -I${ocamlsrcdir}/${runtime_dir}" program = "github9344" *** run program = "sh ${test_source_directory}/github9344.sh" diff --git a/ocaml/testsuite/tests/output-complete-obj/test.ml b/ocaml/testsuite/tests/output-complete-obj/test.ml index e35434673ad..5728491bdc8 100644 --- a/ocaml/testsuite/tests/output-complete-obj/test.ml +++ b/ocaml/testsuite/tests/output-complete-obj/test.ml @@ -7,7 +7,7 @@ readonly_files = "test.ml_stub.c" flags = "-w -a -output-complete-obj" program = "test.ml.bc.${objext}" *** script -script = "${mkexe} -I${ocamlsrcdir}/runtime4 -o test.ml_bc_stub.exe \ +script = "${mkexe} -I${ocamlsrcdir}/${runtime_dir} -o test.ml_bc_stub.exe \ test.ml.bc.${objext} ${nativecc_libs} test.ml_stub.c" output = "${compiler_output}" **** run @@ -19,7 +19,7 @@ stderr = "program-output" flags = "-w -a -output-complete-obj" program = "test.ml.exe.${objext}" *** script -script = "${mkexe} -I${ocamlsrcdir}/runtime4 -o test.ml_stub.exe \ +script = "${mkexe} -I${ocamlsrcdir}/${runtime_dir} -o test.ml_stub.exe \ test.ml.exe.${objext} ${bytecc_libs} test.ml_stub.c" output = "${compiler_output}" **** run diff --git a/ocaml/testsuite/tests/output-complete-obj/test2.ml b/ocaml/testsuite/tests/output-complete-obj/test2.ml index fc0313b226e..48012b89a3f 100644 --- a/ocaml/testsuite/tests/output-complete-obj/test2.ml +++ b/ocaml/testsuite/tests/output-complete-obj/test2.ml @@ -8,7 +8,7 @@ unset FOO include unix ** setup-ocamlc.byte-build-env *** ocamlc.byte -flags = "-w -a -output-complete-exe puts.c -ccopt -I${ocamlsrcdir}/runtime4" +flags = "-w -a -output-complete-exe puts.c -ccopt -I${ocamlsrcdir}/${runtime_dir}" program = "test2" **** run program = "./test2" diff --git a/ocaml/testsuite/tests/ppx-empty-cases/test.compilers.reference b/ocaml/testsuite/tests/ppx-empty-cases/test.compilers.reference index d93ebf73d62..3d8b843ef81 100644 --- a/ocaml/testsuite/tests/ppx-empty-cases/test.compilers.reference +++ b/ocaml/testsuite/tests/ppx-empty-cases/test.compilers.reference @@ -1,40 +1,40 @@ (setglobal Test! (let - (empty_cases_returning_string/266 = - (function {nlocal = 0} param/268 + (empty_cases_returning_string/269 = + (function {nlocal = 0} param/271 (raise (makeblock 0 (getpredef Match_failure/26!!) [0: "test.ml" 28 50]))) - empty_cases_returning_float64/269 = - (function {nlocal = 0} param/271 : unboxed_float + empty_cases_returning_float64/272 = + (function {nlocal = 0} param/274 : unboxed_float (raise (makeblock 0 (getpredef Match_failure/26!!) [0: "test.ml" 29 50]))) - empty_cases_accepting_string/272 = - (function {nlocal = 0} param/274 + empty_cases_accepting_string/275 = + (function {nlocal = 0} param/277 (raise (makeblock 0 (getpredef Match_failure/26!!) [0: "test.ml" 30 50]))) - empty_cases_accepting_float64/275 = - (function {nlocal = 0} param/277[unboxed_float] + empty_cases_accepting_float64/278 = + (function {nlocal = 0} param/280[unboxed_float] (raise (makeblock 0 (getpredef Match_failure/26!!) [0: "test.ml" 31 50]))) - non_empty_cases_returning_string/278 = - (function {nlocal = 0} param/280 + non_empty_cases_returning_string/281 = + (function {nlocal = 0} param/283 (raise (makeblock 0 (getpredef Assert_failure/36!!) [0: "test.ml" 32 68]))) - non_empty_cases_returning_float64/281 = - (function {nlocal = 0} param/283 : unboxed_float + non_empty_cases_returning_float64/284 = + (function {nlocal = 0} param/286 : unboxed_float (raise (makeblock 0 (getpredef Assert_failure/36!!) [0: "test.ml" 33 68]))) - non_empty_cases_accepting_string/284 = - (function {nlocal = 0} param/286 + non_empty_cases_accepting_string/287 = + (function {nlocal = 0} param/289 (raise (makeblock 0 (getpredef Assert_failure/36!!) [0: "test.ml" 34 68]))) - non_empty_cases_accepting_float64/287 = - (function {nlocal = 0} param/289[unboxed_float] + non_empty_cases_accepting_float64/290 = + (function {nlocal = 0} param/292[unboxed_float] (raise (makeblock 0 (getpredef Assert_failure/36!!) [0: "test.ml" 35 68])))) - (makeblock 0 empty_cases_returning_string/266 - empty_cases_returning_float64/269 empty_cases_accepting_string/272 - empty_cases_accepting_float64/275 non_empty_cases_returning_string/278 - non_empty_cases_returning_float64/281 - non_empty_cases_accepting_string/284 - non_empty_cases_accepting_float64/287))) + (makeblock 0 empty_cases_returning_string/269 + empty_cases_returning_float64/272 empty_cases_accepting_string/275 + empty_cases_accepting_float64/278 non_empty_cases_returning_string/281 + non_empty_cases_returning_float64/284 + non_empty_cases_accepting_string/287 + non_empty_cases_accepting_float64/290))) diff --git a/ocaml/testsuite/tests/regression/pr9326/gc_set.ml b/ocaml/testsuite/tests/regression/pr9326/gc_set.ml index 27a7ac127ab..5d4d748776f 100644 --- a/ocaml/testsuite/tests/regression/pr9326/gc_set.ml +++ b/ocaml/testsuite/tests/regression/pr9326/gc_set.ml @@ -1,7 +1,7 @@ (* TEST *) -(* BACKPORT BEGIN +module OCaml_5 = struct open Gc let min_heap_sz = 524288 (* 512k *) @@ -11,7 +11,7 @@ let custom_major_ratio = 40 let custom_minor_ratio = 99 let custom_minor_max_size = 4096 -let _ = +let run () = let g1 = Gc.get() in (* Do not use { g1 with ... }, so that the code will break if more fields are added to the Gc.control record type *) @@ -37,19 +37,20 @@ let _ = assert (g2.custom_major_ratio = custom_major_ratio); assert (g2.custom_minor_ratio = custom_minor_ratio); assert (g2.custom_minor_max_size = custom_minor_max_size) -*) +end (* OCaml 4 and 5's runtime differ in what fields are controllable via [Gc.set], e.g. [stack_limit] can be changed in OCaml 5 native code but not in OCaml 4 native code. *) +module OCaml_4 = struct open Gc let min_heap_sz = 524288 (* 512k *) let maj_heap_inc = 4194304 (* 4M *) -let _ = +let run () = let g1 = Gc.get() in (* Do not use { g1 with ... }, so that the code will break if more fields are added to the Gc.control record type *) @@ -77,4 +78,7 @@ let _ = assert (g2.custom_minor_ratio = g1.custom_minor_ratio); assert (g2.custom_minor_max_size = g1.custom_minor_max_size) -(* BACKPORT END *) +end + +external runtime5 : unit -> bool = "%runtime5" +let () = if runtime5 () then OCaml_5.run () else OCaml_4.run () diff --git a/ocaml/testsuite/tests/runtime-naked-pointers/np1.ml b/ocaml/testsuite/tests/runtime-naked-pointers/np1.ml index be4c677a238..48a8ed84e93 100644 --- a/ocaml/testsuite/tests/runtime-naked-pointers/np1.ml +++ b/ocaml/testsuite/tests/runtime-naked-pointers/np1.ml @@ -1,7 +1,8 @@ (* TEST modules = "cstubs.c np.ml" - * bytecode - * native + * runtime4 + ** bytecode + ** native *) open Np diff --git a/ocaml/testsuite/tests/runtime-naked-pointers/np2.ml b/ocaml/testsuite/tests/runtime-naked-pointers/np2.ml index f24c813c2b6..11b39933b1f 100644 --- a/ocaml/testsuite/tests/runtime-naked-pointers/np2.ml +++ b/ocaml/testsuite/tests/runtime-naked-pointers/np2.ml @@ -1,7 +1,8 @@ (* TEST modules = "cstubs.c np.ml" - * bytecode - * native + * runtime4 + ** bytecode + ** native *) open Np diff --git a/ocaml/testsuite/tests/runtime-naked-pointers/np3.ml b/ocaml/testsuite/tests/runtime-naked-pointers/np3.ml index d207279df16..bf1e8b69ccb 100644 --- a/ocaml/testsuite/tests/runtime-naked-pointers/np3.ml +++ b/ocaml/testsuite/tests/runtime-naked-pointers/np3.ml @@ -1,8 +1,9 @@ (* TEST modules = "cstubs.c np.ml" - * naked_pointers - ** bytecode - ** native + * runtime4 + ** naked_pointers + *** bytecode + *** native *) open Np diff --git a/ocaml/testsuite/tests/runtime-naked-pointers/np4.ml b/ocaml/testsuite/tests/runtime-naked-pointers/np4.ml index 9cd0e238091..3d5ecb596ed 100644 --- a/ocaml/testsuite/tests/runtime-naked-pointers/np4.ml +++ b/ocaml/testsuite/tests/runtime-naked-pointers/np4.ml @@ -1,8 +1,9 @@ (* TEST modules = "cstubs.c np.ml" - * naked_pointers - ** bytecode - ** native + * runtime4 + ** naked_pointers + *** bytecode + *** native *) open Np diff --git a/ocaml/testsuite/tests/runtime-naked-pointers/runtest.sh b/ocaml/testsuite/tests/runtime-naked-pointers/runtest.sh index 5f460f91ebe..531664347bf 100755 --- a/ocaml/testsuite/tests/runtime-naked-pointers/runtest.sh +++ b/ocaml/testsuite/tests/runtime-naked-pointers/runtest.sh @@ -1,6 +1,6 @@ #!/bin/sh -if grep -q "#define NAKED_POINTERS_CHECKER" ${ocamlsrcdir}/runtime4/caml/m.h \ +if grep -q "#define NAKED_POINTERS_CHECKER" ${ocamlsrcdir}/${runtime_dir}/caml/m.h \ && (echo ${program} | grep -q '\.opt') then (${program} > ${output}) 2>&1 | grep -q '^Out-of-heap ' diff --git a/ocaml/testsuite/tests/shapes/comp_units.ml b/ocaml/testsuite/tests/shapes/comp_units.ml index 138207d9ea3..793fd4b96da 100644 --- a/ocaml/testsuite/tests/shapes/comp_units.ml +++ b/ocaml/testsuite/tests/shapes/comp_units.ml @@ -25,7 +25,7 @@ module Mproj = Unit module F (X : sig type t end) = X [%%expect{| { - "F"[module] -> Abs<.4>(X/275, X/275<.3>); + "F"[module] -> Abs<.4>(X/278, X/278<.3>); } module F : functor (X : sig type t end) -> sig type t = X.t end |}] diff --git a/ocaml/testsuite/tests/shapes/functors.ml b/ocaml/testsuite/tests/shapes/functors.ml index 7be1b1eeb2f..2044222a542 100644 --- a/ocaml/testsuite/tests/shapes/functors.ml +++ b/ocaml/testsuite/tests/shapes/functors.ml @@ -17,7 +17,7 @@ module type S = sig type t val x : t end module Falias (X : S) = X [%%expect{| { - "Falias"[module] -> Abs<.4>(X/277, X/277<.3>); + "Falias"[module] -> Abs<.4>(X/280, X/280<.3>); } module Falias : functor (X : S) -> sig type t = X.t val x : t end |}] @@ -29,10 +29,10 @@ end { "Finclude"[module] -> Abs<.6> - (X/281, + (X/284, { - "t"[type] -> X/281<.5> . "t"[type]; - "x"[value] -> X/281<.5> . "x"[value]; + "t"[type] -> X/284<.5> . "t"[type]; + "x"[value] -> X/284<.5> . "x"[value]; }); } module Finclude : functor (X : S) -> sig type t = X.t val x : t end @@ -45,7 +45,7 @@ end [%%expect{| { "Fredef"[module] -> - Abs<.10>(X/288, { + Abs<.10>(X/291, { "t"[type] -> <.8>; "x"[value] -> <.9>; }); @@ -223,8 +223,8 @@ module Big_to_small1 : B2S = functor (X : Big) -> X [%%expect{| { "Big_to_small1"[module] -> - Abs<.40>(X/381, {<.39> - "t"[type] -> X/381<.39> . "t"[type]; + Abs<.40>(X/384, {<.39> + "t"[type] -> X/384<.39> . "t"[type]; }); } module Big_to_small1 : B2S @@ -234,8 +234,8 @@ module Big_to_small2 : B2S = functor (X : Big) -> struct include X end [%%expect{| { "Big_to_small2"[module] -> - Abs<.42>(X/384, { - "t"[type] -> X/384<.41> . "t"[type]; + Abs<.42>(X/387, { + "t"[type] -> X/387<.41> . "t"[type]; }); } module Big_to_small2 : B2S diff --git a/ocaml/testsuite/tests/shapes/open_arg.ml b/ocaml/testsuite/tests/shapes/open_arg.ml index e8020169be0..81b19af3f75 100644 --- a/ocaml/testsuite/tests/shapes/open_arg.ml +++ b/ocaml/testsuite/tests/shapes/open_arg.ml @@ -22,7 +22,7 @@ end = struct end [%%expect{| { - "Make"[module] -> Abs<.3>(I/277, { + "Make"[module] -> Abs<.3>(I/280, { }); } module Make : functor (I : sig end) -> sig end diff --git a/ocaml/testsuite/tests/shapes/recmodules.ml b/ocaml/testsuite/tests/shapes/recmodules.ml index cd00342ab9e..6d9d86fc9a1 100644 --- a/ocaml/testsuite/tests/shapes/recmodules.ml +++ b/ocaml/testsuite/tests/shapes/recmodules.ml @@ -43,8 +43,8 @@ and B : sig end = B [%%expect{| { - "A"[module] -> A/300<.11>; - "B"[module] -> B/301<.12>; + "A"[module] -> A/303<.11>; + "B"[module] -> B/304<.12>; } module rec A : sig type t = Leaf of B.t end and B : sig type t = int end @@ -82,12 +82,12 @@ end = Set.Make(A) "ASet"[module] -> { "compare"[value] -> - CU Stdlib . "Set"[module] . "Make"[module](A/322<.19>) . + CU Stdlib . "Set"[module] . "Make"[module](A/325<.19>) . "compare"[value]; "elt"[type] -> - CU Stdlib . "Set"[module] . "Make"[module](A/322<.19>) . "elt"[type]; + CU Stdlib . "Set"[module] . "Make"[module](A/325<.19>) . "elt"[type]; "t"[type] -> - CU Stdlib . "Set"[module] . "Make"[module](A/322<.19>) . "t"[type]; + CU Stdlib . "Set"[module] . "Make"[module](A/325<.19>) . "t"[type]; }; } module rec A : diff --git a/ocaml/testsuite/tests/shapes/rotor_example.ml b/ocaml/testsuite/tests/shapes/rotor_example.ml index ffa17b8f0d8..182a0a9bc2d 100644 --- a/ocaml/testsuite/tests/shapes/rotor_example.ml +++ b/ocaml/testsuite/tests/shapes/rotor_example.ml @@ -25,7 +25,7 @@ end [%%expect{| { "Pair"[module] -> - Abs<.9>(X/277, Y/278, { + Abs<.9>(X/280, Y/281, { "t"[type] -> <.5>; "to_string"[value] -> <.6>; }); diff --git a/ocaml/testsuite/tests/statmemprof/alloc_counts.ml b/ocaml/testsuite/tests/statmemprof/alloc_counts.ml index de0d1e9e49d..79837d7033d 100644 --- a/ocaml/testsuite/tests/statmemprof/alloc_counts.ml +++ b/ocaml/testsuite/tests/statmemprof/alloc_counts.ml @@ -1,6 +1,5 @@ (* TEST -* skip -reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" +* runtime4 *) module MP = Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/arrays_in_major.ml b/ocaml/testsuite/tests/statmemprof/arrays_in_major.ml index eb627324ba6..2e2a4d65ccf 100644 --- a/ocaml/testsuite/tests/statmemprof/arrays_in_major.ml +++ b/ocaml/testsuite/tests/statmemprof/arrays_in_major.ml @@ -1,7 +1,6 @@ (* TEST flags = "-g" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" + * runtime4 *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/arrays_in_major.reference b/ocaml/testsuite/tests/statmemprof/arrays_in_major.reference new file mode 100644 index 00000000000..1f34ad8ec85 --- /dev/null +++ b/ocaml/testsuite/tests/statmemprof/arrays_in_major.reference @@ -0,0 +1,11 @@ +check_nosample +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 +check_distrib 300 3000 1 0.010000 +check_distrib 300 3000 1 0.900000 +check_distrib 300 300 100000 0.100000 +check_distrib 300000 300000 30 0.100000 +OK ! diff --git a/ocaml/testsuite/tests/statmemprof/arrays_in_minor.ml b/ocaml/testsuite/tests/statmemprof/arrays_in_minor.ml index 99862958361..0a82e3f7e07 100644 --- a/ocaml/testsuite/tests/statmemprof/arrays_in_minor.ml +++ b/ocaml/testsuite/tests/statmemprof/arrays_in_minor.ml @@ -1,7 +1,6 @@ (* TEST flags = "-g" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" + * runtime4 *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/arrays_in_minor.reference b/ocaml/testsuite/tests/statmemprof/arrays_in_minor.reference new file mode 100644 index 00000000000..1dad91939c8 --- /dev/null +++ b/ocaml/testsuite/tests/statmemprof/arrays_in_minor.reference @@ -0,0 +1,11 @@ +check_nosample +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 +check_distrib 1 250 1000 0.010000 +check_distrib 1 250 1000 0.900000 +check_distrib 1 1 10000000 0.010000 +check_distrib 250 250 100000 0.100000 +OK ! diff --git a/ocaml/testsuite/tests/statmemprof/blocking_in_callback.ml b/ocaml/testsuite/tests/statmemprof/blocking_in_callback.ml index e1e40f1fb6a..b0018d4ecae 100644 --- a/ocaml/testsuite/tests/statmemprof/blocking_in_callback.ml +++ b/ocaml/testsuite/tests/statmemprof/blocking_in_callback.ml @@ -1,10 +1,9 @@ (* TEST * hassysthreads include systhreads -* skip -reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" -** bytecode -** native +** runtime4 +*** bytecode +*** native *) let cnt = ref 0 diff --git a/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.reference b/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.reference index 4eebf868f88..687fc7c7a65 100644 --- a/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.reference +++ b/ocaml/testsuite/tests/statmemprof/callstacks.flat-float-array.reference @@ -1,74 +1,74 @@ ----------- -Raised by primitive operation at Callstacks.alloc_list_literal in file "callstacks.ml", line 18, characters 30-53 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_list_literal in file "callstacks.ml", line 20, characters 30-53 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_pair in file "callstacks.ml", line 21, characters 30-76 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_pair in file "callstacks.ml", line 23, characters 30-76 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_record in file "callstacks.ml", line 26, characters 12-66 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_record in file "callstacks.ml", line 28, characters 12-66 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_some in file "callstacks.ml", line 29, characters 30-60 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_some in file "callstacks.ml", line 31, characters 30-60 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_array_literal in file "callstacks.ml", line 32, characters 30-55 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_array_literal in file "callstacks.ml", line 34, characters 30-55 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_float_array_literal in file "callstacks.ml", line 36, characters 12-62 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_float_array_literal in file "callstacks.ml", line 38, characters 12-62 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.do_alloc_unknown_array_literal in file "callstacks.ml", line 39, characters 22-27 -Called from Callstacks.alloc_unknown_array_literal in file "callstacks.ml", line 41, characters 30-65 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.do_alloc_unknown_array_literal in file "callstacks.ml", line 41, characters 22-27 +Called from Callstacks.alloc_unknown_array_literal in file "callstacks.ml", line 43, characters 30-65 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_small_array in file "callstacks.ml", line 44, characters 30-69 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_small_array in file "callstacks.ml", line 46, characters 30-69 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_large_array in file "callstacks.ml", line 47, characters 30-73 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_large_array in file "callstacks.ml", line 49, characters 30-73 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_closure.(fun) in file "callstacks.ml", line 51, characters 30-43 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_closure.(fun) in file "callstacks.ml", line 53, characters 30-43 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.get0 in file "callstacks.ml", line 54, characters 28-33 -Called from Callstacks.getfloatfield in file "callstacks.ml", line 56, characters 30-47 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.get0 in file "callstacks.ml", line 56, characters 28-33 +Called from Callstacks.getfloatfield in file "callstacks.ml", line 58, characters 30-47 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Stdlib__Marshal.from_bytes in file "marshal.ml", line 66, characters 9-35 -Called from Callstacks.alloc_unmarshal in file "callstacks.ml", line 62, characters 12-87 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Stdlib__Marshal.from_bytes in file "marshal.ml", line 70, characters 9-35 +Called from Callstacks.alloc_unmarshal in file "callstacks.ml", line 64, characters 12-87 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.alloc_ref in file "callstacks.ml", line 65, characters 30-59 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.alloc_ref in file "callstacks.ml", line 67, characters 30-59 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 ----------- -Raised by primitive operation at Callstacks.prod_floats in file "callstacks.ml", line 68, characters 37-43 -Called from Callstacks.alloc_boxedfloat in file "callstacks.ml", line 70, characters 30-49 -Called from Callstacks.test in file "callstacks.ml", line 92, characters 2-10 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Callstacks in file "callstacks.ml", line 99, characters 2-27 +Raised by primitive operation at Callstacks.prod_floats in file "callstacks.ml", line 70, characters 37-43 +Called from Callstacks.alloc_boxedfloat in file "callstacks.ml", line 72, characters 30-49 +Called from Callstacks.test in file "callstacks.ml", line 94, characters 2-10 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Callstacks in file "callstacks.ml", line 101, characters 2-27 diff --git a/ocaml/testsuite/tests/statmemprof/callstacks.ml b/ocaml/testsuite/tests/statmemprof/callstacks.ml index e864a50019e..3e63a778565 100644 --- a/ocaml/testsuite/tests/statmemprof/callstacks.ml +++ b/ocaml/testsuite/tests/statmemprof/callstacks.ml @@ -3,17 +3,15 @@ * flat-float-array reference = "${test_source_directory}/callstacks.flat-float-array.reference" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" - ** native - ** bytecode + ** runtime4 + *** native + *** bytecode * no-flat-float-array reference = "${test_source_directory}/callstacks.no-flat-float-array.reference" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" - ** native - ** bytecode + ** runtime4 + *** native + *** bytecode *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/comballoc.byte.reference b/ocaml/testsuite/tests/statmemprof/comballoc.byte.reference index 156768ae61b..2682ecfe055 100644 --- a/ocaml/testsuite/tests/statmemprof/comballoc.byte.reference +++ b/ocaml/testsuite/tests/statmemprof/comballoc.byte.reference @@ -1,49 +1,49 @@ 2: 0.42 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 3: 0.42 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 4: 0.42 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 11, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 14, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 12, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 2: 0.01 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 3: 0.01 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 4: 0.01 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 11, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 14, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 12, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 2: 0.83 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 3: 0.83 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 4: 0.83 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 11, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 14, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml", line 12, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 OK diff --git a/ocaml/testsuite/tests/statmemprof/comballoc.ml b/ocaml/testsuite/tests/statmemprof/comballoc.ml index 60ca4a01233..df17426e0b2 100644 --- a/ocaml/testsuite/tests/statmemprof/comballoc.ml +++ b/ocaml/testsuite/tests/statmemprof/comballoc.ml @@ -1,7 +1,6 @@ (* TEST flags = "-g" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" + * runtime4 ** bytecode reference = "${test_source_directory}/comballoc.byte.reference" ** native diff --git a/ocaml/testsuite/tests/statmemprof/comballoc.opt.reference b/ocaml/testsuite/tests/statmemprof/comballoc.opt.reference index d557a37c0e4..bc7ae01daed 100644 --- a/ocaml/testsuite/tests/statmemprof/comballoc.opt.reference +++ b/ocaml/testsuite/tests/statmemprof/comballoc.opt.reference @@ -1,49 +1,49 @@ 2: 0.42 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 3: 0.42 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 4: 0.42 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 11, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 14, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 12, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 2: 0.01 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 3: 0.01 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 4: 0.01 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 11, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 14, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 12, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 2: 0.83 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 2-19 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 2-19 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 3: 0.83 false -Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 14, characters 6-18 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f in file "comballoc.ml", line 15, characters 6-18 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 4: 0.83 true -Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 11, characters 11-20 -Called from Comballoc.f in file "comballoc.ml", line 14, characters 13-17 -Called from Comballoc.test in file "comballoc.ml", line 39, characters 25-48 -Called from Stdlib__List.iter in file "list.ml", line 114, characters 12-15 -Called from Comballoc in file "comballoc.ml", line 69, characters 2-35 +Raised by primitive operation at Comballoc.f4 in file "comballoc.ml" (inlined), line 12, characters 11-20 +Called from Comballoc.f in file "comballoc.ml", line 15, characters 13-17 +Called from Comballoc.test in file "comballoc.ml", line 40, characters 25-48 +Called from Stdlib__List.iter in file "list.ml", line 116, characters 12-15 +Called from Comballoc in file "comballoc.ml", line 70, characters 2-35 OK diff --git a/ocaml/testsuite/tests/statmemprof/custom.ml b/ocaml/testsuite/tests/statmemprof/custom.ml index 41cf902ec89..38c8fbd5042 100644 --- a/ocaml/testsuite/tests/statmemprof/custom.ml +++ b/ocaml/testsuite/tests/statmemprof/custom.ml @@ -1,6 +1,5 @@ (* TEST -* skip -reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" +* runtime4 *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/exception_callback.ml b/ocaml/testsuite/tests/statmemprof/exception_callback.ml index f9f02f690f7..1447f94f559 100644 --- a/ocaml/testsuite/tests/statmemprof/exception_callback.ml +++ b/ocaml/testsuite/tests/statmemprof/exception_callback.ml @@ -1,7 +1,6 @@ (* TEST exit_status = "2" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" + * runtime4 *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/exception_callback_minor.ml b/ocaml/testsuite/tests/statmemprof/exception_callback_minor.ml index 0bb37782bea..ec55a31be69 100644 --- a/ocaml/testsuite/tests/statmemprof/exception_callback_minor.ml +++ b/ocaml/testsuite/tests/statmemprof/exception_callback_minor.ml @@ -1,7 +1,6 @@ (* TEST exit_status = "2" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" + * runtime4 *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/intern.ml b/ocaml/testsuite/tests/statmemprof/intern.ml index bebcc3c8fff..f720475e32c 100644 --- a/ocaml/testsuite/tests/statmemprof/intern.ml +++ b/ocaml/testsuite/tests/statmemprof/intern.ml @@ -1,7 +1,6 @@ (* TEST flags = "-g" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" + * runtime4 *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/intern.reference b/ocaml/testsuite/tests/statmemprof/intern.reference new file mode 100644 index 00000000000..d83e8d6d50e --- /dev/null +++ b/ocaml/testsuite/tests/statmemprof/intern.reference @@ -0,0 +1,10 @@ +check_nosample +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 +check_distrib 2 2000 1 0.010000 +check_distrib 2 2000 1 0.900000 +check_distrib 300000 300000 20 0.100000 +OK ! diff --git a/ocaml/testsuite/tests/statmemprof/lists_in_minor.ml b/ocaml/testsuite/tests/statmemprof/lists_in_minor.ml index 765d4fb092b..21f926354b8 100644 --- a/ocaml/testsuite/tests/statmemprof/lists_in_minor.ml +++ b/ocaml/testsuite/tests/statmemprof/lists_in_minor.ml @@ -1,7 +1,6 @@ (* TEST flags = "-g" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" + * runtime4 *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/minor_no_postpone.ml b/ocaml/testsuite/tests/statmemprof/minor_no_postpone.ml index 21c8bfb2447..e17efa44f1d 100644 --- a/ocaml/testsuite/tests/statmemprof/minor_no_postpone.ml +++ b/ocaml/testsuite/tests/statmemprof/minor_no_postpone.ml @@ -1,7 +1,6 @@ (* TEST modules = "minor_no_postpone_stub.c" - * skip - reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" + * runtime4 *) open Gc.Memprof diff --git a/ocaml/testsuite/tests/statmemprof/moved_while_blocking.ml b/ocaml/testsuite/tests/statmemprof/moved_while_blocking.ml index bb8dfc9848e..a7c1db41973 100644 --- a/ocaml/testsuite/tests/statmemprof/moved_while_blocking.ml +++ b/ocaml/testsuite/tests/statmemprof/moved_while_blocking.ml @@ -1,10 +1,9 @@ (* TEST -* hassysthreads +* runtime4 +** hassysthreads include systhreads -* skip -reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" -** bytecode -** native +*** bytecode +*** native *) let t2_begin = Atomic.make false diff --git a/ocaml/testsuite/tests/statmemprof/thread_exit_in_callback.ml b/ocaml/testsuite/tests/statmemprof/thread_exit_in_callback.ml index 28e2aabb8b9..4e3c32aa652 100644 --- a/ocaml/testsuite/tests/statmemprof/thread_exit_in_callback.ml +++ b/ocaml/testsuite/tests/statmemprof/thread_exit_in_callback.ml @@ -1,12 +1,14 @@ (* TEST * hassysthreads include systhreads -* skip -reason = "port stat-mem-prof : https://github.com/ocaml/ocaml/pull/8634" -** bytecode -** native +** runtime4 +*** bytecode +*** native *) +(* CR ocaml 5 runtime: Once statmemprof is ported, remove "runtime4" stanzas + for the tests/statmemprof/ tests. *) + let _ = let main_thread = Thread.id (Thread.self ()) in Gc.Memprof.(start ~callstack_size:10 ~sampling_rate:1. diff --git a/ocaml/testsuite/tests/syntactic-arity/max_arity_locals.ml b/ocaml/testsuite/tests/syntactic-arity/max_arity_locals.ml index 048e9294a0a..fafd6023804 100644 --- a/ocaml/testsuite/tests/syntactic-arity/max_arity_locals.ml +++ b/ocaml/testsuite/tests/syntactic-arity/max_arity_locals.ml @@ -3,9 +3,10 @@ flags = "-dlambda -dno-unique-ids -w +unused-value-declaration" * flambda -** setup-ocamlopt.byte-build-env -*** ocamlopt.byte -**** check-ocamlopt.byte-output +** stack-allocation +*** setup-ocamlopt.byte-build-env +**** ocamlopt.byte +***** check-ocamlopt.byte-output *) (* This test prints the translation of functions whose arity exceeds diff --git a/ocaml/testsuite/tests/tool-toplevel/known-bugs/broken_rec_in_show.ml b/ocaml/testsuite/tests/tool-toplevel/known-bugs/broken_rec_in_show.ml index 688ac53844f..de8262bc0f8 100644 --- a/ocaml/testsuite/tests/tool-toplevel/known-bugs/broken_rec_in_show.ml +++ b/ocaml/testsuite/tests/tool-toplevel/known-bugs/broken_rec_in_show.ml @@ -54,8 +54,8 @@ type t = X of u | Y of [ f | `B ] and u = Y of t;; [%%expect{| type t type f = [ `A of t ] -type t = X of u | Y of [ `A of t/1 | `B ] -and u = Y of t/2 +type t = X of u | Y of [ `A of t/2 | `B ] +and u = Y of t |}];; #show t;; diff --git a/ocaml/testsuite/tests/tool-toplevel/topeval.ml b/ocaml/testsuite/tests/tool-toplevel/topeval.ml index 802f04b5afc..da5143ff8a0 100644 --- a/ocaml/testsuite/tests/tool-toplevel/topeval.ml +++ b/ocaml/testsuite/tests/tool-toplevel/topeval.ml @@ -45,3 +45,13 @@ let List.(String.(_)) = 'd' let List.(_) : float = 42.0 ;; + +(* Check that frametables are correctly loaded by triggering GC *) +let () = + Gc.minor (); + let r = List.init 1000 Sys.opaque_identity in + Gc.minor (); + let _ = Sys.opaque_identity (List.init 1000 (fun _ -> "!")) in + List.iteri (fun i j -> assert (i = j)) r; + () +;; diff --git a/ocaml/testsuite/tests/translprim/array_spec.heap.flat.reference b/ocaml/testsuite/tests/translprim/array_spec.heap.flat.reference index 287506151b0..0117619c81b 100644 --- a/ocaml/testsuite/tests/translprim/array_spec.heap.flat.reference +++ b/ocaml/testsuite/tests/translprim/array_spec.heap.flat.reference @@ -23,63 +23,74 @@ (let (eta_gen_len = (function {nlocal = 0} prim[genarray] stub - (array.length[gen] prim)) + ignore assert all zero_alloc : int (array.length[gen] prim)) eta_gen_safe_get = (function {nlocal = 0} prim[genarray] prim[int] stub - (array.get[gen] prim prim)) + ignore assert all zero_alloc (array.get[gen] prim prim)) eta_gen_unsafe_get = (function {nlocal = 0} prim[genarray] prim[int] stub - (array.unsafe_get[gen] prim prim)) + ignore assert all zero_alloc (array.unsafe_get[gen] prim prim)) eta_gen_safe_set = (function {nlocal = 0} prim[genarray] prim[int] prim stub + ignore assert all zero_alloc : int (array.set[gen] prim prim prim)) eta_gen_unsafe_set = (function {nlocal = 0} prim[genarray] prim[int] prim stub + ignore assert all zero_alloc : int (array.unsafe_set[gen] prim prim prim)) eta_int_len = (function {nlocal = 0} prim[intarray] stub - (array.length[int] prim)) + ignore assert all zero_alloc : int (array.length[int] prim)) eta_int_safe_get = (function {nlocal = 0} prim[intarray] prim[int] stub - (array.get[int] prim prim)) + ignore assert all zero_alloc : int (array.get[int] prim prim)) eta_int_unsafe_get = (function {nlocal = 0} prim[intarray] prim[int] stub + ignore assert all zero_alloc : int (array.unsafe_get[int] prim prim)) eta_int_safe_set = (function {nlocal = 0} prim[intarray] prim[int] prim[int] stub + ignore assert all zero_alloc : int (array.set[int] prim prim prim)) eta_int_unsafe_set = (function {nlocal = 0} prim[intarray] prim[int] prim[int] stub + ignore assert all zero_alloc : int (array.unsafe_set[int] prim prim prim)) eta_float_len = (function {nlocal = 0} prim[floatarray] stub - (array.length[float] prim)) + ignore assert all zero_alloc : int (array.length[float] prim)) eta_float_safe_get = (function {nlocal = 0} prim[floatarray] prim[int] stub + ignore assert all zero_alloc : float (array.get[float] prim prim)) eta_float_unsafe_get = (function {nlocal = 0} prim[floatarray] prim[int] stub + ignore assert all zero_alloc : float (array.unsafe_get[float] prim prim)) eta_float_safe_set = (function {nlocal = 0} prim[floatarray] prim[int] prim[float] stub + ignore assert all zero_alloc : int (array.set[float] prim prim prim)) eta_float_unsafe_set = (function {nlocal = 0} prim[floatarray] prim[int] prim[float] stub + ignore assert all zero_alloc : int (array.unsafe_set[float] prim prim prim)) eta_addr_len = (function {nlocal = 0} prim[addrarray] stub - (array.length[addr] prim)) + ignore assert all zero_alloc : int (array.length[addr] prim)) eta_addr_safe_get = (function {nlocal = 0} prim[addrarray] prim[int] stub - (array.get[addr] prim prim)) + ignore assert all zero_alloc (array.get[addr] prim prim)) eta_addr_unsafe_get = (function {nlocal = 0} prim[addrarray] prim[int] stub - (array.unsafe_get[addr] prim prim)) + ignore assert all zero_alloc (array.unsafe_get[addr] prim prim)) eta_addr_safe_set = (function {nlocal = 0} prim[addrarray] prim[int] prim stub + ignore assert all zero_alloc : int (array.set[addr] prim prim prim)) eta_addr_unsafe_set = (function {nlocal = 0} prim[addrarray] prim[int] prim stub + ignore assert all zero_alloc : int (array.unsafe_set[addr] prim prim prim))) (makeblock 0 int_a float_a addr_a eta_gen_len eta_gen_safe_get eta_gen_unsafe_get eta_gen_safe_set eta_gen_unsafe_set eta_int_len diff --git a/ocaml/testsuite/tests/translprim/comparison_table.heap.reference b/ocaml/testsuite/tests/translprim/comparison_table.heap.reference index e8b3f67924a..29c1b3a8cb3 100644 --- a/ocaml/testsuite/tests/translprim/comparison_table.heap.reference +++ b/ocaml/testsuite/tests/translprim/comparison_table.heap.reference @@ -96,161 +96,195 @@ (function {nlocal = 0} x[nativeint] y[nativeint] : int (Nativeint.>= x y)) eta_gen_cmp = - (function {nlocal = 0} prim prim stub (caml_compare prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_compare prim prim)) eta_int_cmp = (function {nlocal = 0} prim[int] prim[int] stub - (compare_ints prim prim)) + ignore assert all zero_alloc : int (compare_ints prim prim)) eta_bool_cmp = (function {nlocal = 0} prim[int] prim[int] stub - (compare_ints prim prim)) + ignore assert all zero_alloc : int (compare_ints prim prim)) eta_intlike_cmp = (function {nlocal = 0} prim[int] prim[int] stub - (compare_ints prim prim)) + ignore assert all zero_alloc : int (compare_ints prim prim)) eta_float_cmp = (function {nlocal = 0} prim[float] prim[float] stub - (compare_floats prim prim)) + ignore assert all zero_alloc : int (compare_floats prim prim)) eta_string_cmp = - (function {nlocal = 0} prim prim stub (caml_string_compare prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_string_compare prim prim)) eta_int32_cmp = (function {nlocal = 0} prim[int32] prim[int32] stub - (compare_bints int32 prim prim)) + ignore assert all zero_alloc : int (compare_bints int32 prim prim)) eta_int64_cmp = (function {nlocal = 0} prim[int64] prim[int64] stub - (compare_bints int64 prim prim)) + ignore assert all zero_alloc : int (compare_bints int64 prim prim)) eta_nativeint_cmp = (function {nlocal = 0} prim[nativeint] prim[nativeint] stub + ignore assert all zero_alloc : int (compare_bints nativeint prim prim)) eta_gen_eq = - (function {nlocal = 0} prim prim stub (caml_equal prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_equal prim prim)) eta_int_eq = - (function {nlocal = 0} prim[int] prim[int] stub (== prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (== prim prim)) eta_bool_eq = - (function {nlocal = 0} prim[int] prim[int] stub (== prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (== prim prim)) eta_intlike_eq = - (function {nlocal = 0} prim[int] prim[int] stub (== prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (== prim prim)) eta_float_eq = - (function {nlocal = 0} prim[float] prim[float] stub (==. prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (==. prim prim)) eta_string_eq = - (function {nlocal = 0} prim prim stub (caml_string_equal prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_string_equal prim prim)) eta_int32_eq = (function {nlocal = 0} prim[int32] prim[int32] stub - (Int32.== prim prim)) + ignore assert all zero_alloc : int (Int32.== prim prim)) eta_int64_eq = (function {nlocal = 0} prim[int64] prim[int64] stub - (Int64.== prim prim)) + ignore assert all zero_alloc : int (Int64.== prim prim)) eta_nativeint_eq = (function {nlocal = 0} prim[nativeint] prim[nativeint] stub - (Nativeint.== prim prim)) + ignore assert all zero_alloc : int (Nativeint.== prim prim)) eta_gen_ne = - (function {nlocal = 0} prim prim stub (caml_notequal prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_notequal prim prim)) eta_int_ne = - (function {nlocal = 0} prim[int] prim[int] stub (!= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (!= prim prim)) eta_bool_ne = - (function {nlocal = 0} prim[int] prim[int] stub (!= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (!= prim prim)) eta_intlike_ne = - (function {nlocal = 0} prim[int] prim[int] stub (!= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (!= prim prim)) eta_float_ne = - (function {nlocal = 0} prim[float] prim[float] stub (!=. prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (!=. prim prim)) eta_string_ne = - (function {nlocal = 0} prim prim stub - (caml_string_notequal prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_string_notequal prim prim)) eta_int32_ne = (function {nlocal = 0} prim[int32] prim[int32] stub - (Int32.!= prim prim)) + ignore assert all zero_alloc : int (Int32.!= prim prim)) eta_int64_ne = (function {nlocal = 0} prim[int64] prim[int64] stub - (Int64.!= prim prim)) + ignore assert all zero_alloc : int (Int64.!= prim prim)) eta_nativeint_ne = (function {nlocal = 0} prim[nativeint] prim[nativeint] stub - (Nativeint.!= prim prim)) + ignore assert all zero_alloc : int (Nativeint.!= prim prim)) eta_gen_lt = - (function {nlocal = 0} prim prim stub (caml_lessthan prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_lessthan prim prim)) eta_int_lt = - (function {nlocal = 0} prim[int] prim[int] stub (< prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (< prim prim)) eta_bool_lt = - (function {nlocal = 0} prim[int] prim[int] stub (< prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (< prim prim)) eta_intlike_lt = - (function {nlocal = 0} prim[int] prim[int] stub (< prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (< prim prim)) eta_float_lt = - (function {nlocal = 0} prim[float] prim[float] stub (<. prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (<. prim prim)) eta_string_lt = - (function {nlocal = 0} prim prim stub - (caml_string_lessthan prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_string_lessthan prim prim)) eta_int32_lt = (function {nlocal = 0} prim[int32] prim[int32] stub - (Int32.< prim prim)) + ignore assert all zero_alloc : int (Int32.< prim prim)) eta_int64_lt = (function {nlocal = 0} prim[int64] prim[int64] stub - (Int64.< prim prim)) + ignore assert all zero_alloc : int (Int64.< prim prim)) eta_nativeint_lt = (function {nlocal = 0} prim[nativeint] prim[nativeint] stub - (Nativeint.< prim prim)) + ignore assert all zero_alloc : int (Nativeint.< prim prim)) eta_gen_gt = - (function {nlocal = 0} prim prim stub (caml_greaterthan prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_greaterthan prim prim)) eta_int_gt = - (function {nlocal = 0} prim[int] prim[int] stub (> prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (> prim prim)) eta_bool_gt = - (function {nlocal = 0} prim[int] prim[int] stub (> prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (> prim prim)) eta_intlike_gt = - (function {nlocal = 0} prim[int] prim[int] stub (> prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (> prim prim)) eta_float_gt = - (function {nlocal = 0} prim[float] prim[float] stub (>. prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (>. prim prim)) eta_string_gt = - (function {nlocal = 0} prim prim stub - (caml_string_greaterthan prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_string_greaterthan prim prim)) eta_int32_gt = (function {nlocal = 0} prim[int32] prim[int32] stub - (Int32.> prim prim)) + ignore assert all zero_alloc : int (Int32.> prim prim)) eta_int64_gt = (function {nlocal = 0} prim[int64] prim[int64] stub - (Int64.> prim prim)) + ignore assert all zero_alloc : int (Int64.> prim prim)) eta_nativeint_gt = (function {nlocal = 0} prim[nativeint] prim[nativeint] stub - (Nativeint.> prim prim)) + ignore assert all zero_alloc : int (Nativeint.> prim prim)) eta_gen_le = - (function {nlocal = 0} prim prim stub (caml_lessequal prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_lessequal prim prim)) eta_int_le = - (function {nlocal = 0} prim[int] prim[int] stub (<= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (<= prim prim)) eta_bool_le = - (function {nlocal = 0} prim[int] prim[int] stub (<= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (<= prim prim)) eta_intlike_le = - (function {nlocal = 0} prim[int] prim[int] stub (<= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (<= prim prim)) eta_float_le = - (function {nlocal = 0} prim[float] prim[float] stub (<=. prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (<=. prim prim)) eta_string_le = - (function {nlocal = 0} prim prim stub - (caml_string_lessequal prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_string_lessequal prim prim)) eta_int32_le = (function {nlocal = 0} prim[int32] prim[int32] stub - (Int32.<= prim prim)) + ignore assert all zero_alloc : int (Int32.<= prim prim)) eta_int64_le = (function {nlocal = 0} prim[int64] prim[int64] stub - (Int64.<= prim prim)) + ignore assert all zero_alloc : int (Int64.<= prim prim)) eta_nativeint_le = (function {nlocal = 0} prim[nativeint] prim[nativeint] stub - (Nativeint.<= prim prim)) + ignore assert all zero_alloc : int (Nativeint.<= prim prim)) eta_gen_ge = - (function {nlocal = 0} prim prim stub (caml_greaterequal prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_greaterequal prim prim)) eta_int_ge = - (function {nlocal = 0} prim[int] prim[int] stub (>= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (>= prim prim)) eta_bool_ge = - (function {nlocal = 0} prim[int] prim[int] stub (>= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (>= prim prim)) eta_intlike_ge = - (function {nlocal = 0} prim[int] prim[int] stub (>= prim prim)) + (function {nlocal = 0} prim[int] prim[int] stub + ignore assert all zero_alloc : int (>= prim prim)) eta_float_ge = - (function {nlocal = 0} prim[float] prim[float] stub (>=. prim prim)) + (function {nlocal = 0} prim[float] prim[float] stub + ignore assert all zero_alloc : int (>=. prim prim)) eta_string_ge = - (function {nlocal = 0} prim prim stub - (caml_string_greaterequal prim prim)) + (function {nlocal = 0} prim prim stub ignore assert all zero_alloc + : int (caml_string_greaterequal prim prim)) eta_int32_ge = (function {nlocal = 0} prim[int32] prim[int32] stub - (Int32.>= prim prim)) + ignore assert all zero_alloc : int (Int32.>= prim prim)) eta_int64_ge = (function {nlocal = 0} prim[int64] prim[int64] stub - (Int64.>= prim prim)) + ignore assert all zero_alloc : int (Int64.>= prim prim)) eta_nativeint_ge = (function {nlocal = 0} prim[nativeint] prim[nativeint] stub - (Nativeint.>= prim prim)) + ignore assert all zero_alloc : int (Nativeint.>= prim prim)) int_vec =[(consts (0)) (non_consts ([0: *, [(consts (0)) (non_consts ([0: *, *]))]]))] [0: [0: 1 1] [0: [0: 1 2] [0: [0: 2 1] 0]]] @@ -294,9 +328,9 @@ (non_consts ( [0: *, *]))] (apply f - (field 0 + (field_imm 0 param) - (field 1 + (field_imm 1 param))) map = (function @@ -315,7 +349,7 @@ (non_consts ( [0: *, *]))]]))] (apply - (field 18 + (field_imm 19 (global Stdlib__List!)) (apply uncurry @@ -496,7 +530,7 @@ (uncurry = (function {nlocal = 0} f param[(consts ()) (non_consts ([0: *, *]))] - (apply f (field 0 param) (field 1 param))) + (apply f (field_imm 0 param) (field_imm 1 param))) map = (function {nlocal = 0} f l[(consts (0)) @@ -505,7 +539,7 @@ [(consts (0)) (non_consts ([0: *, [(consts (0)) (non_consts ([0: *, *]))]]))] - (apply (field 18 (global Stdlib__List!)) + (apply (field_imm 19 (global Stdlib__List!)) (apply uncurry f) l))) (makeblock 0 ([(consts ()) (non_consts ([0: diff --git a/ocaml/testsuite/tests/typing-local/iarray.byte.reference b/ocaml/testsuite/tests/typing-local/iarray.byte.reference new file mode 100644 index 00000000000..4987b8e6a3e --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/iarray.byte.reference @@ -0,0 +1,14 @@ + init_local: Allocation + append_local: Allocation + concat_local: Allocation + sub_local: Allocation + to_list_local: Allocation + of_list_local: Allocation + map_local: Allocation + mapi_local: Allocation + fold_left_local: Allocation + fold_left_map_local: Allocation + fold_right_local: Allocation + map2_local: Allocation + split_local: Allocation + combine_local: Allocation diff --git a/ocaml/testsuite/tests/typing-local/iarray.heap.reference b/ocaml/testsuite/tests/typing-local/iarray.heap.reference index 4987b8e6a3e..4932e36ec70 100644 --- a/ocaml/testsuite/tests/typing-local/iarray.heap.reference +++ b/ocaml/testsuite/tests/typing-local/iarray.heap.reference @@ -1,9 +1,9 @@ init_local: Allocation append_local: Allocation concat_local: Allocation - sub_local: Allocation + sub_local: No Allocation to_list_local: Allocation - of_list_local: Allocation + of_list_local: No Allocation map_local: Allocation mapi_local: Allocation fold_left_local: Allocation diff --git a/ocaml/testsuite/tests/typing-local/iarray.ml b/ocaml/testsuite/tests/typing-local/iarray.ml index ee4e14fffa4..c1bb5c02198 100644 --- a/ocaml/testsuite/tests/typing-local/iarray.ml +++ b/ocaml/testsuite/tests/typing-local/iarray.ml @@ -1,6 +1,6 @@ (* TEST * bytecode - reference = "${test_source_directory}/iarray.heap.reference" + reference = "${test_source_directory}/iarray.byte.reference" * stack-allocation ** native reference = "${test_source_directory}/iarray.stack.reference" diff --git a/ocaml/testsuite/tests/typing-local/loop_regions.heap.reference b/ocaml/testsuite/tests/typing-local/loop_regions.heap.reference index 7769c32e8b9..50aac3b7f2e 100644 --- a/ocaml/testsuite/tests/typing-local/loop_regions.heap.reference +++ b/ocaml/testsuite/tests/typing-local/loop_regions.heap.reference @@ -4,3 +4,5 @@ nonlocal while body: [0; 0; 0] local while cond: [0; 0; 0] nonlocal while cond: [0; 0; 0] + local func: [0; 0; 0] + nonlocal func: [0; 0; 0] diff --git a/ocaml/testsuite/tests/typing-local/regions.ml b/ocaml/testsuite/tests/typing-local/regions.ml index d5eabc7c7cd..3b9c4167f84 100644 --- a/ocaml/testsuite/tests/typing-local/regions.ml +++ b/ocaml/testsuite/tests/typing-local/regions.ml @@ -1,7 +1,8 @@ (* TEST modules = "cstubs.c" + * stack-allocation include ocamlcommon - * native *) + ** native *) external local_stack_offset : unit -> int = "caml_local_stack_offset" external opaque_identity : ('a[@local_opt]) -> ('a[@local_opt]) = "%opaque" diff --git a/ocaml/testsuite/tests/typing-local/regression_cmm_unboxing.ml b/ocaml/testsuite/tests/typing-local/regression_cmm_unboxing.ml index 63d1d15eb8a..89b060aab32 100644 --- a/ocaml/testsuite/tests/typing-local/regression_cmm_unboxing.ml +++ b/ocaml/testsuite/tests/typing-local/regression_cmm_unboxing.ml @@ -1,5 +1,6 @@ (* TEST - * native + * stack-allocation + ** native *) (* Regression test for a bad interaction between Cmm unboxing diff --git a/testsuite/tests/asmgen/main.c b/testsuite/tests/asmgen/main.c index 165b8a53c24..94b158fd076 100644 --- a/testsuite/tests/asmgen/main.c +++ b/testsuite/tests/asmgen/main.c @@ -24,6 +24,10 @@ void caml_call_gc(void) { } +void caml_call_realloc_stack(void) +{ + +}; #endif void caml_ml_array_bound_error(void)