2016-02-18 07:11:59 -08:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* OCaml *)
|
|
|
|
(* *)
|
|
|
|
(* Xavier Leroy, projet Cristal, 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. *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
1995-08-09 08:06:35 -07:00
|
|
|
|
2016-04-28 07:00:18 -07:00
|
|
|
open Printf
|
1997-06-06 07:54:09 -07:00
|
|
|
|
2018-11-08 07:08:17 -08:00
|
|
|
type t = exn = ..
|
|
|
|
|
2020-04-08 16:34:11 -07:00
|
|
|
let printers = Atomic.make []
|
2010-01-20 08:26:46 -08:00
|
|
|
|
2016-04-28 07:00:18 -07:00
|
|
|
let locfmt = format_of_string "File \"%s\", line %d, characters %d-%d: %s"
|
1997-05-13 11:27:27 -07:00
|
|
|
|
1997-06-12 08:29:01 -07:00
|
|
|
let field x i =
|
|
|
|
let f = Obj.field x i in
|
|
|
|
if not (Obj.is_block f) then
|
|
|
|
sprintf "%d" (Obj.magic f : int) (* can also be a char *)
|
1998-10-01 05:34:32 -07:00
|
|
|
else if Obj.tag f = Obj.string_tag then
|
2002-06-27 02:27:14 -07:00
|
|
|
sprintf "%S" (Obj.magic f : string)
|
1998-10-01 05:34:32 -07:00
|
|
|
else if Obj.tag f = Obj.double_tag then
|
1997-06-12 08:29:01 -07:00
|
|
|
string_of_float (Obj.magic f : float)
|
|
|
|
else
|
|
|
|
"_"
|
2016-04-28 07:00:18 -07:00
|
|
|
|
1997-06-12 08:29:01 -07:00
|
|
|
let rec other_fields x i =
|
|
|
|
if i >= Obj.size x then ""
|
|
|
|
else sprintf ", %s%s" (field x i) (other_fields x (i+1))
|
2016-04-28 07:00:18 -07:00
|
|
|
|
1997-06-12 08:29:01 -07:00
|
|
|
let fields x =
|
|
|
|
match Obj.size x with
|
|
|
|
| 0 -> ""
|
|
|
|
| 1 -> ""
|
|
|
|
| 2 -> sprintf "(%s)" (field x 1)
|
2016-03-09 14:20:22 -08:00
|
|
|
| _ -> sprintf "(%s%s)" (field x 1) (other_fields x 2)
|
1997-06-12 08:29:01 -07:00
|
|
|
|
2019-04-14 06:38:27 -07:00
|
|
|
let use_printers x =
|
2010-04-19 05:25:46 -07:00
|
|
|
let rec conv = function
|
|
|
|
| hd :: tl ->
|
2019-04-14 06:38:27 -07:00
|
|
|
(match hd x with
|
|
|
|
| None | exception _ -> conv tl
|
|
|
|
| Some s -> Some s)
|
|
|
|
| [] -> None in
|
2020-04-08 16:34:11 -07:00
|
|
|
conv (Atomic.get printers)
|
1995-05-04 03:15:53 -07:00
|
|
|
|
2019-04-14 06:38:27 -07:00
|
|
|
let to_string_default = function
|
|
|
|
| Out_of_memory -> "Out of memory"
|
|
|
|
| Stack_overflow -> "Stack overflow"
|
|
|
|
| Match_failure(file, line, char) ->
|
|
|
|
sprintf locfmt file line char (char+5) "Pattern matching failed"
|
|
|
|
| Assert_failure(file, line, char) ->
|
|
|
|
sprintf locfmt file line char (char+6) "Assertion failed"
|
|
|
|
| Undefined_recursive_module(file, line, char) ->
|
|
|
|
sprintf locfmt file line char (char+6) "Undefined recursive module"
|
|
|
|
| x ->
|
|
|
|
let x = Obj.repr x in
|
|
|
|
if Obj.tag x <> 0 then
|
|
|
|
(Obj.magic (Obj.field x 0) : string)
|
|
|
|
else
|
|
|
|
let constructor =
|
|
|
|
(Obj.magic (Obj.field (Obj.field x 0) 0) : string) in
|
|
|
|
constructor ^ (fields x)
|
|
|
|
|
|
|
|
let to_string e =
|
|
|
|
match use_printers e with
|
|
|
|
| Some s -> s
|
|
|
|
| None -> to_string_default e
|
|
|
|
|
1995-05-04 03:15:53 -07:00
|
|
|
let print fct arg =
|
|
|
|
try
|
|
|
|
fct arg
|
|
|
|
with x ->
|
1997-06-12 08:29:01 -07:00
|
|
|
eprintf "Uncaught exception: %s\n" (to_string x);
|
1995-11-15 01:33:15 -08:00
|
|
|
flush stderr;
|
1995-05-04 03:15:53 -07:00
|
|
|
raise x
|
|
|
|
|
|
|
|
let catch fct arg =
|
|
|
|
try
|
|
|
|
fct arg
|
|
|
|
with x ->
|
|
|
|
flush stdout;
|
1997-06-12 08:29:01 -07:00
|
|
|
eprintf "Uncaught exception: %s\n" (to_string x);
|
1995-05-04 03:15:53 -07:00
|
|
|
exit 2
|
2008-03-14 06:47:24 -07:00
|
|
|
|
Printexc: OCaml-friendly access to individual backtrace slots
(Patch by Jacques-Henri Jourdan)
There are several changes:
- `raw_backtrace` is no longer an abstract type, but rather an
`raw_backtrace_slot array`, where `raw_backtrace_slot` is a new
abstract type. `raw_backtrace_slot` elements are hashable and
comparable. At runtime, values of this type contain either
a bytecode pointer or a frame_descr pointer. In order to prevent the
GC from walking through this pointer, the low-order bit is set to
1 when stored in the array.
- The old `loc_info` type is know public, renamed into `backtrace_slot`:
type backtrace_slot =
| Known_location of bool (* is_raise *)
* string (* filename *)
* int (* line number *)
* int (* start char *)
* int (* end char *)
| Unknown_location of bool (*is_raise*)
- new primitive :
val convert_raw_backtrace_slot: raw_backtrace_slot -> backtrace_slot
Rather than returning an option, it raises Failure when it is not
possible to get the debugging information. It seems more idiomatic,
especially because the exceptional case cannot appear only for a part
of the executable.
- the caml_convert_raw_backtrace primitive is removed; it is more
difficult to implement in the C side because of the new exception
interface described above.
- In the bytecode runtime, the events are no longer deserialized once
for each conversion, but once and for all at the first conversion,
and stored in a global array (*outside* the OCaml heap), sorted by
program counter value. I believe this information should not take
much memory in practice (it uses the same order of magnitude memory
as the bytecode executable). It also makes location lookup much more
efficient, as a dichomoty is used instead of linear search as
previously.
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14776 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
2014-05-10 12:19:47 -07:00
|
|
|
type raw_backtrace_slot
|
2020-07-13 03:13:12 -07:00
|
|
|
type raw_backtrace_entry = private int
|
|
|
|
type raw_backtrace = raw_backtrace_entry array
|
|
|
|
|
|
|
|
let raw_backtrace_entries bt = bt
|
2013-03-11 12:04:12 -07:00
|
|
|
|
|
|
|
external get_raw_backtrace:
|
|
|
|
unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
|
|
|
|
|
2016-12-05 07:56:56 -08:00
|
|
|
external raise_with_backtrace: exn -> raw_backtrace -> 'a
|
|
|
|
= "%raise_with_backtrace"
|
|
|
|
|
Printexc: OCaml-friendly access to individual backtrace slots
(Patch by Jacques-Henri Jourdan)
There are several changes:
- `raw_backtrace` is no longer an abstract type, but rather an
`raw_backtrace_slot array`, where `raw_backtrace_slot` is a new
abstract type. `raw_backtrace_slot` elements are hashable and
comparable. At runtime, values of this type contain either
a bytecode pointer or a frame_descr pointer. In order to prevent the
GC from walking through this pointer, the low-order bit is set to
1 when stored in the array.
- The old `loc_info` type is know public, renamed into `backtrace_slot`:
type backtrace_slot =
| Known_location of bool (* is_raise *)
* string (* filename *)
* int (* line number *)
* int (* start char *)
* int (* end char *)
| Unknown_location of bool (*is_raise*)
- new primitive :
val convert_raw_backtrace_slot: raw_backtrace_slot -> backtrace_slot
Rather than returning an option, it raises Failure when it is not
possible to get the debugging information. It seems more idiomatic,
especially because the exceptional case cannot appear only for a part
of the executable.
- the caml_convert_raw_backtrace primitive is removed; it is more
difficult to implement in the C side because of the new exception
interface described above.
- In the bytecode runtime, the events are no longer deserialized once
for each conversion, but once and for all at the first conversion,
and stored in a global array (*outside* the OCaml heap), sorted by
program counter value. I believe this information should not take
much memory in practice (it uses the same order of magnitude memory
as the bytecode executable). It also makes location lookup much more
efficient, as a dichomoty is used instead of linear search as
previously.
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14776 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
2014-05-10 12:19:47 -07:00
|
|
|
type backtrace_slot =
|
2016-05-25 06:00:37 -07:00
|
|
|
| Known_location of {
|
|
|
|
is_raise : bool;
|
|
|
|
filename : string;
|
|
|
|
line_number : int;
|
|
|
|
start_char : int;
|
|
|
|
end_char : int;
|
|
|
|
is_inline : bool;
|
2019-11-20 07:48:10 -08:00
|
|
|
defname : string;
|
2016-05-25 06:00:37 -07:00
|
|
|
}
|
|
|
|
| Unknown_location of {
|
|
|
|
is_raise : bool
|
|
|
|
}
|
2008-03-14 06:47:24 -07:00
|
|
|
|
2012-05-29 05:37:01 -07:00
|
|
|
(* to avoid warning *)
|
2016-05-25 06:00:37 -07:00
|
|
|
let _ = [Known_location { is_raise = false; filename = "";
|
|
|
|
line_number = 0; start_char = 0; end_char = 0;
|
2019-11-20 07:48:10 -08:00
|
|
|
is_inline = false; defname = "" };
|
2016-05-25 06:00:37 -07:00
|
|
|
Unknown_location { is_raise = false }]
|
2012-05-29 04:47:28 -07:00
|
|
|
|
Printexc: OCaml-friendly access to individual backtrace slots
(Patch by Jacques-Henri Jourdan)
There are several changes:
- `raw_backtrace` is no longer an abstract type, but rather an
`raw_backtrace_slot array`, where `raw_backtrace_slot` is a new
abstract type. `raw_backtrace_slot` elements are hashable and
comparable. At runtime, values of this type contain either
a bytecode pointer or a frame_descr pointer. In order to prevent the
GC from walking through this pointer, the low-order bit is set to
1 when stored in the array.
- The old `loc_info` type is know public, renamed into `backtrace_slot`:
type backtrace_slot =
| Known_location of bool (* is_raise *)
* string (* filename *)
* int (* line number *)
* int (* start char *)
* int (* end char *)
| Unknown_location of bool (*is_raise*)
- new primitive :
val convert_raw_backtrace_slot: raw_backtrace_slot -> backtrace_slot
Rather than returning an option, it raises Failure when it is not
possible to get the debugging information. It seems more idiomatic,
especially because the exceptional case cannot appear only for a part
of the executable.
- the caml_convert_raw_backtrace primitive is removed; it is more
difficult to implement in the C side because of the new exception
interface described above.
- In the bytecode runtime, the events are no longer deserialized once
for each conversion, but once and for all at the first conversion,
and stored in a global array (*outside* the OCaml heap), sorted by
program counter value. I believe this information should not take
much memory in practice (it uses the same order of magnitude memory
as the bytecode executable). It also makes location lookup much more
efficient, as a dichomoty is used instead of linear search as
previously.
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14776 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
2014-05-10 12:19:47 -07:00
|
|
|
external convert_raw_backtrace_slot:
|
|
|
|
raw_backtrace_slot -> backtrace_slot = "caml_convert_raw_backtrace_slot"
|
2013-03-11 12:04:12 -07:00
|
|
|
|
2016-05-25 06:00:37 -07:00
|
|
|
external convert_raw_backtrace:
|
|
|
|
raw_backtrace -> backtrace_slot array = "caml_convert_raw_backtrace"
|
|
|
|
|
|
|
|
let convert_raw_backtrace bt =
|
|
|
|
try Some (convert_raw_backtrace bt)
|
Printexc: OCaml-friendly access to individual backtrace slots
(Patch by Jacques-Henri Jourdan)
There are several changes:
- `raw_backtrace` is no longer an abstract type, but rather an
`raw_backtrace_slot array`, where `raw_backtrace_slot` is a new
abstract type. `raw_backtrace_slot` elements are hashable and
comparable. At runtime, values of this type contain either
a bytecode pointer or a frame_descr pointer. In order to prevent the
GC from walking through this pointer, the low-order bit is set to
1 when stored in the array.
- The old `loc_info` type is know public, renamed into `backtrace_slot`:
type backtrace_slot =
| Known_location of bool (* is_raise *)
* string (* filename *)
* int (* line number *)
* int (* start char *)
* int (* end char *)
| Unknown_location of bool (*is_raise*)
- new primitive :
val convert_raw_backtrace_slot: raw_backtrace_slot -> backtrace_slot
Rather than returning an option, it raises Failure when it is not
possible to get the debugging information. It seems more idiomatic,
especially because the exceptional case cannot appear only for a part
of the executable.
- the caml_convert_raw_backtrace primitive is removed; it is more
difficult to implement in the C side because of the new exception
interface described above.
- In the bytecode runtime, the events are no longer deserialized once
for each conversion, but once and for all at the first conversion,
and stored in a global array (*outside* the OCaml heap), sorted by
program counter value. I believe this information should not take
much memory in practice (it uses the same order of magnitude memory
as the bytecode executable). It also makes location lookup much more
efficient, as a dichomoty is used instead of linear search as
previously.
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14776 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
2014-05-10 12:19:47 -07:00
|
|
|
with Failure _ -> None
|
2008-03-14 06:47:24 -07:00
|
|
|
|
2014-05-10 12:20:00 -07:00
|
|
|
let format_backtrace_slot pos slot =
|
|
|
|
let info is_raise =
|
2008-03-14 06:47:24 -07:00
|
|
|
if is_raise then
|
|
|
|
if pos = 0 then "Raised at" else "Re-raised at"
|
|
|
|
else
|
|
|
|
if pos = 0 then "Raised by primitive operation at" else "Called from"
|
|
|
|
in
|
2014-05-10 12:20:00 -07:00
|
|
|
match slot with
|
2016-05-25 06:00:37 -07:00
|
|
|
| Unknown_location l ->
|
|
|
|
if l.is_raise then
|
|
|
|
(* compiler-inserted re-raise, skipped *) None
|
|
|
|
else
|
|
|
|
Some (sprintf "%s unknown location" (info false))
|
|
|
|
| Known_location l ->
|
2019-11-20 07:48:10 -08:00
|
|
|
Some (sprintf "%s %s in file \"%s\"%s, line %d, characters %d-%d"
|
|
|
|
(info l.is_raise) l.defname l.filename
|
2016-05-25 06:00:37 -07:00
|
|
|
(if l.is_inline then " (inlined)" else "")
|
|
|
|
l.line_number l.start_char l.end_char)
|
2008-03-14 06:47:24 -07:00
|
|
|
|
2013-03-11 12:04:12 -07:00
|
|
|
let print_exception_backtrace outchan backtrace =
|
|
|
|
match backtrace with
|
2008-03-14 06:47:24 -07:00
|
|
|
| None ->
|
|
|
|
fprintf outchan
|
|
|
|
"(Program not linked with -g, cannot print stack backtrace)\n"
|
|
|
|
| Some a ->
|
|
|
|
for i = 0 to Array.length a - 1 do
|
2014-05-10 12:20:00 -07:00
|
|
|
match format_backtrace_slot i a.(i) with
|
|
|
|
| None -> ()
|
|
|
|
| Some str -> fprintf outchan "%s\n" str
|
2008-03-14 06:47:24 -07:00
|
|
|
done
|
|
|
|
|
2013-03-11 12:04:12 -07:00
|
|
|
let print_raw_backtrace outchan raw_backtrace =
|
|
|
|
print_exception_backtrace outchan (convert_raw_backtrace raw_backtrace)
|
|
|
|
|
|
|
|
(* confusingly named: prints the global current backtrace *)
|
|
|
|
let print_backtrace outchan =
|
|
|
|
print_raw_backtrace outchan (get_raw_backtrace ())
|
|
|
|
|
|
|
|
let backtrace_to_string backtrace =
|
|
|
|
match backtrace with
|
2008-03-14 06:47:24 -07:00
|
|
|
| None ->
|
|
|
|
"(Program not linked with -g, cannot print stack backtrace)\n"
|
|
|
|
| Some a ->
|
|
|
|
let b = Buffer.create 1024 in
|
|
|
|
for i = 0 to Array.length a - 1 do
|
2014-05-10 12:20:00 -07:00
|
|
|
match format_backtrace_slot i a.(i) with
|
|
|
|
| None -> ()
|
|
|
|
| Some str -> bprintf b "%s\n" str
|
2008-03-14 06:47:24 -07:00
|
|
|
done;
|
|
|
|
Buffer.contents b
|
|
|
|
|
2013-03-11 12:04:12 -07:00
|
|
|
let raw_backtrace_to_string raw_backtrace =
|
|
|
|
backtrace_to_string (convert_raw_backtrace raw_backtrace)
|
|
|
|
|
2014-05-10 12:20:00 -07:00
|
|
|
let backtrace_slot_is_raise = function
|
2016-05-25 06:00:37 -07:00
|
|
|
| Known_location l -> l.is_raise
|
|
|
|
| Unknown_location l -> l.is_raise
|
|
|
|
|
|
|
|
let backtrace_slot_is_inline = function
|
|
|
|
| Known_location l -> l.is_inline
|
|
|
|
| Unknown_location _ -> false
|
2014-05-10 12:20:00 -07:00
|
|
|
|
|
|
|
type location = {
|
|
|
|
filename : string;
|
|
|
|
line_number : int;
|
|
|
|
start_char : int;
|
|
|
|
end_char : int;
|
|
|
|
}
|
|
|
|
|
|
|
|
let backtrace_slot_location = function
|
|
|
|
| Unknown_location _ -> None
|
2016-05-25 06:00:37 -07:00
|
|
|
| Known_location l ->
|
2014-05-10 12:20:00 -07:00
|
|
|
Some {
|
2016-05-25 06:00:37 -07:00
|
|
|
filename = l.filename;
|
|
|
|
line_number = l.line_number;
|
|
|
|
start_char = l.start_char;
|
|
|
|
end_char = l.end_char;
|
2014-05-10 12:20:00 -07:00
|
|
|
}
|
|
|
|
|
2019-11-20 07:48:10 -08:00
|
|
|
let backtrace_slot_defname = function
|
|
|
|
| Unknown_location _
|
|
|
|
| Known_location { defname = "" } -> None
|
|
|
|
| Known_location l -> Some l.defname
|
|
|
|
|
2014-05-10 12:20:00 -07:00
|
|
|
let backtrace_slots raw_backtrace =
|
|
|
|
(* The documentation of this function guarantees that Some is
|
|
|
|
returned only if a part of the trace is usable. This gives us
|
|
|
|
a bit more work than just convert_raw_backtrace, but it makes the
|
|
|
|
API more user-friendly -- otherwise most users would have to
|
|
|
|
reimplement the "Program not linked with -g, sorry" logic
|
|
|
|
themselves. *)
|
|
|
|
match convert_raw_backtrace raw_backtrace with
|
|
|
|
| None -> None
|
|
|
|
| Some backtrace ->
|
|
|
|
let usable_slot = function
|
|
|
|
| Unknown_location _ -> false
|
|
|
|
| Known_location _ -> true in
|
|
|
|
let rec exists_usable = function
|
|
|
|
| (-1) -> false
|
|
|
|
| i -> usable_slot backtrace.(i) || exists_usable (i - 1) in
|
|
|
|
if exists_usable (Array.length backtrace - 1)
|
|
|
|
then Some backtrace
|
|
|
|
else None
|
|
|
|
|
2020-07-13 03:13:12 -07:00
|
|
|
let backtrace_slots_of_raw_entry entry =
|
|
|
|
backtrace_slots [| entry |]
|
|
|
|
|
2014-05-10 12:20:00 -07:00
|
|
|
module Slot = struct
|
|
|
|
type t = backtrace_slot
|
|
|
|
let format = format_backtrace_slot
|
|
|
|
let is_raise = backtrace_slot_is_raise
|
2016-05-25 06:00:37 -07:00
|
|
|
let is_inline = backtrace_slot_is_inline
|
2014-05-10 12:20:00 -07:00
|
|
|
let location = backtrace_slot_location
|
2019-11-20 07:48:10 -08:00
|
|
|
let name = backtrace_slot_defname
|
2014-05-10 12:20:00 -07:00
|
|
|
end
|
|
|
|
|
2020-07-13 03:13:12 -07:00
|
|
|
let raw_backtrace_length bt = Array.length bt
|
2016-05-25 06:00:37 -07:00
|
|
|
|
|
|
|
external get_raw_backtrace_slot :
|
|
|
|
raw_backtrace -> int -> raw_backtrace_slot = "caml_raw_backtrace_slot"
|
|
|
|
|
|
|
|
external get_raw_backtrace_next_slot :
|
2016-08-01 07:06:59 -07:00
|
|
|
raw_backtrace_slot -> raw_backtrace_slot option
|
|
|
|
= "caml_raw_backtrace_next_slot"
|
2014-05-10 12:20:00 -07:00
|
|
|
|
2013-03-11 12:04:12 -07:00
|
|
|
(* confusingly named:
|
|
|
|
returns the *string* corresponding to the global current backtrace *)
|
2016-12-05 07:56:56 -08:00
|
|
|
let get_backtrace () = raw_backtrace_to_string (get_raw_backtrace ())
|
2013-03-11 12:04:12 -07:00
|
|
|
|
2008-03-14 06:47:24 -07:00
|
|
|
external record_backtrace: bool -> unit = "caml_record_backtrace"
|
|
|
|
external backtrace_status: unit -> bool = "caml_backtrace_status"
|
|
|
|
|
2020-04-08 16:34:11 -07:00
|
|
|
let rec register_printer fn =
|
|
|
|
let old_printers = Atomic.get printers in
|
|
|
|
let new_printers = fn :: old_printers in
|
|
|
|
let success = Atomic.compare_and_set printers old_printers new_printers in
|
|
|
|
if not success then register_printer fn
|
2013-07-11 05:37:10 -07:00
|
|
|
|
|
|
|
external get_callstack: int -> raw_backtrace = "caml_get_current_callstack"
|
2013-10-23 07:35:43 -07:00
|
|
|
|
|
|
|
let exn_slot x =
|
|
|
|
let x = Obj.repr x in
|
2013-11-06 02:57:20 -08:00
|
|
|
if Obj.tag x = 0 then Obj.field x 0 else x
|
2013-10-23 07:35:43 -07:00
|
|
|
|
|
|
|
let exn_slot_id x =
|
|
|
|
let slot = exn_slot x in
|
|
|
|
(Obj.obj (Obj.field slot 1) : int)
|
|
|
|
|
|
|
|
let exn_slot_name x =
|
|
|
|
let slot = exn_slot x in
|
|
|
|
(Obj.obj (Obj.field slot 0) : string)
|
2014-04-18 08:36:08 -07:00
|
|
|
|
2018-12-10 23:54:49 -08:00
|
|
|
external get_debug_info_status : unit -> int = "caml_ml_debug_info_status"
|
|
|
|
|
|
|
|
(* Descriptions for errors in startup.h. See also backtrace.c *)
|
|
|
|
let errors = [| "";
|
|
|
|
(* FILE_NOT_FOUND *)
|
|
|
|
"(Cannot print locations:\n \
|
|
|
|
bytecode executable program file not found)";
|
|
|
|
(* BAD_BYTECODE *)
|
|
|
|
"(Cannot print locations:\n \
|
|
|
|
bytecode executable program file appears to be corrupt)";
|
|
|
|
(* WRONG_MAGIC *)
|
|
|
|
"(Cannot print locations:\n \
|
|
|
|
bytecode executable program file has wrong magic number)";
|
|
|
|
(* NO_FDS *)
|
|
|
|
"(Cannot print locations:\n \
|
|
|
|
bytecode executable program file cannot be opened;\n \
|
2018-12-11 01:17:04 -08:00
|
|
|
-- too many open files. Try running with OCAMLRUNPARAM=b=2)"
|
2018-12-10 23:54:49 -08:00
|
|
|
|]
|
|
|
|
|
2020-01-25 09:53:49 -08:00
|
|
|
let default_uncaught_exception_handler exn raw_backtrace =
|
|
|
|
eprintf "Fatal error: exception %s\n" (to_string exn);
|
|
|
|
print_raw_backtrace stderr raw_backtrace;
|
2018-12-10 23:54:49 -08:00
|
|
|
let status = get_debug_info_status () in
|
|
|
|
if status < 0 then
|
|
|
|
prerr_endline errors.(abs status);
|
2020-01-25 09:53:49 -08:00
|
|
|
flush stderr
|
2014-04-18 08:36:08 -07:00
|
|
|
|
2020-01-25 09:53:49 -08:00
|
|
|
let uncaught_exception_handler = ref default_uncaught_exception_handler
|
2014-04-18 08:36:08 -07:00
|
|
|
|
2020-01-25 09:53:49 -08:00
|
|
|
let set_uncaught_exception_handler fn = uncaught_exception_handler := fn
|
2014-04-18 08:36:08 -07:00
|
|
|
|
2020-07-13 03:13:12 -07:00
|
|
|
let empty_backtrace : raw_backtrace = [| |]
|
2014-04-18 08:36:08 -07:00
|
|
|
|
|
|
|
let try_get_raw_backtrace () =
|
|
|
|
try
|
|
|
|
get_raw_backtrace ()
|
|
|
|
with _ (* Out_of_memory? *) ->
|
|
|
|
empty_backtrace
|
|
|
|
|
|
|
|
let handle_uncaught_exception' exn debugger_in_use =
|
|
|
|
try
|
|
|
|
(* Get the backtrace now, in case one of the [at_exit] function
|
|
|
|
destroys it. *)
|
|
|
|
let raw_backtrace =
|
2018-06-20 08:43:29 -07:00
|
|
|
if debugger_in_use (* Same test as in [runtime/printexc.c] *) then
|
2014-04-18 08:36:08 -07:00
|
|
|
empty_backtrace
|
|
|
|
else
|
|
|
|
try_get_raw_backtrace ()
|
|
|
|
in
|
2018-08-27 04:42:14 -07:00
|
|
|
(try Stdlib.do_at_exit () with _ -> ());
|
2020-01-25 09:53:49 -08:00
|
|
|
try
|
|
|
|
!uncaught_exception_handler exn raw_backtrace
|
|
|
|
with exn' ->
|
|
|
|
let raw_backtrace' = try_get_raw_backtrace () in
|
|
|
|
eprintf "Fatal error: exception %s\n" (to_string exn);
|
|
|
|
print_raw_backtrace stderr raw_backtrace;
|
|
|
|
eprintf "Fatal error in uncaught exception handler: exception %s\n"
|
|
|
|
(to_string exn');
|
|
|
|
print_raw_backtrace stderr raw_backtrace';
|
|
|
|
flush stderr
|
2014-04-18 08:36:08 -07:00
|
|
|
with
|
|
|
|
| Out_of_memory ->
|
|
|
|
prerr_endline
|
|
|
|
"Fatal error: out of memory in uncaught exception handler"
|
|
|
|
|
|
|
|
(* This function is called by [caml_fatal_uncaught_exception] in
|
2018-06-20 08:43:29 -07:00
|
|
|
[runtime/printexc.c] which expects no exception is raised. *)
|
2014-04-18 08:36:08 -07:00
|
|
|
let handle_uncaught_exception exn debugger_in_use =
|
|
|
|
try
|
|
|
|
handle_uncaught_exception' exn debugger_in_use
|
|
|
|
with _ ->
|
|
|
|
(* There is not much we can do at this point *)
|
|
|
|
()
|
|
|
|
|
|
|
|
external register_named_value : string -> 'a -> unit
|
|
|
|
= "caml_register_named_value"
|
|
|
|
|
|
|
|
let () =
|
|
|
|
register_named_value "Printexc.handle_uncaught_exception"
|
|
|
|
handle_uncaught_exception
|