1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* Xavier Leroy, projet Cristal, INRIA Rocquencourt */
6 /* */
7 /* Copyright 1996 Institut National de Recherche en Informatique et */
8 /* en Automatique. */
9 /* */
10 /* All rights reserved. This file is distributed under the terms of */
11 /* the GNU Lesser General Public License version 2.1, with the */
12 /* special exception on linking described in the file LICENSE. */
13 /* */
14 /**************************************************************************/
15
16 #define CAML_INTERNALS
17
18 /* Print an uncaught exception and abort */
19
20 #include <stdio.h>
21 #include <stdlib.h>
22 #include <string.h>
23 #include "caml/backtrace.h"
24 #include "caml/callback.h"
25 #include "caml/debugger.h"
26 #include "caml/fail.h"
27 #include "caml/misc.h"
28 #include "caml/mlvalues.h"
29 #include "caml/printexc.h"
30 #include "caml/memory.h"
31 #include "caml/memprof.h"
32
33 struct stringbuf {
34 char * ptr;
35 char * end;
36 char data[256];
37 };
38
39 static void add_char(struct stringbuf *buf, char c)
40 {
41 if (buf->ptr < buf->end) *(buf->ptr++) = c;
42 }
43
44 static void add_string(struct stringbuf *buf, const char *s)
45 {
46 size_t len = strlen(s);
47 if (buf->ptr + len > buf->end) len = buf->end - buf->ptr;
48 if (len > 0) memmove(buf->ptr, s, len);
49 buf->ptr += len;
50 }
51
52 CAMLexport char * caml_format_exception(value exn)
53 {
54 mlsize_t start, i;
55 value bucket, v;
56 struct stringbuf buf;
57 char intbuf[64];
58 char * res;
59
60 buf.ptr = buf.data;
61 buf.end = buf.data + sizeof(buf.data) - 1;
62 if (Tag_val(exn) == 0) {
63 add_string(&buf, String_val(Field(Field(exn, 0), 0)));
64 /* Check for exceptions in the style of Match_failure and Assert_failure */
65 if (Wosize_val(exn) == 2 &&
66 Is_block(Field(exn, 1)) &&
67 Tag_val(Field(exn, 1)) == 0 &&
68 caml_is_special_exception(Field(exn, 0))) {
69 bucket = Field(exn, 1);
70 start = 0;
71 } else {
72 bucket = exn;
73 start = 1;
74 }
75 add_char(&buf, '(');
76 for (i = start; i < Wosize_val(bucket); i++) {
77 if (i > start) add_string(&buf, ", ");
78 v = Field(bucket, i);
79 if (Is_long(v)) {
80 snprintf(intbuf, sizeof(intbuf),
81 "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
82 add_string(&buf, intbuf);
83 } else if (Tag_val(v) == String_tag) {
84 add_char(&buf, '"');
85 add_string(&buf, String_val(v));
86 add_char(&buf, '"');
87 } else {
88 add_char(&buf, '_');
89 }
90 }
91 add_char(&buf, ')');
92 } else
93 add_string(&buf, String_val(Field(exn, 0)));
94
95 *buf.ptr = 0; /* Terminate string */
96 i = buf.ptr - buf.data + 1;
97 res = caml_stat_alloc_noexc(i);
98 if (res == NULL) return NULL;
99 memmove(res, buf.data, i);
100 return res;
101 }
102
103
104 #ifdef NATIVE_CODE
105 # define DEBUGGER_IN_USE 0
106 #else
107 # define DEBUGGER_IN_USE caml_debugger_in_use
108 #endif
109
110 /* Default C implementation in case the OCaml one is not registered. */
111 static void default_fatal_uncaught_exception(value exn)
112 {
113 char * msg;
114 const value * at_exit;
115 int saved_backtrace_active, saved_backtrace_pos;
116
117 /* Build a string representation of the exception */
118 msg = caml_format_exception(exn);
119 /* Perform "at_exit" processing, ignoring all exceptions that may
120 be triggered by this */
121 saved_backtrace_active = Caml_state->backtrace_active;
122 saved_backtrace_pos = Caml_state->backtrace_pos;
123 Caml_state->backtrace_active = 0;
124 at_exit = caml_named_value("Pervasives.do_at_exit");
125 if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit);
126 Caml_state->backtrace_active = saved_backtrace_active;
127 Caml_state->backtrace_pos = saved_backtrace_pos;
128 /* Display the uncaught exception */
129 fprintf(stderr, "Fatal error: exception %s\n", msg);
130 caml_stat_free(msg);
131 /* Display the backtrace if available */
132 if (Caml_state->backtrace_active && !DEBUGGER_IN_USE)
133 caml_print_exception_backtrace();
134 }
135
136 int caml_abort_on_uncaught_exn = 0; /* see afl.c */
137
138 void caml_fatal_uncaught_exception(value exn)
139 {
140 const value *handle_uncaught_exception;
141
142 handle_uncaught_exception =
143 caml_named_value("Printexc.handle_uncaught_exception");
144
145 /* If the callback allocates, memprof could be called. In this case,
146 memprof's callback could raise an exception while
147 [handle_uncaught_exception] is running, so that the printing of
148 the exception fails. */
149 caml_memprof_suspended = 1;
150
151 if (handle_uncaught_exception != NULL)
152 /* [Printexc.handle_uncaught_exception] does not raise exception. */
153 caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE));
154 else
155 default_fatal_uncaught_exception(exn);
156 /* Terminate the process */
157 if (caml_abort_on_uncaught_exn) {
158 abort();
159 } else {
160 exit(2);
161 }
162 }
163