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 
31 struct stringbuf {
32   char * ptr;
33   char * end;
34   char data[256];
35 };
36 
add_char(struct stringbuf * buf,char c)37 static void add_char(struct stringbuf *buf, char c)
38 {
39   if (buf->ptr < buf->end) *(buf->ptr++) = c;
40 }
41 
add_string(struct stringbuf * buf,char * s)42 static void add_string(struct stringbuf *buf, char *s)
43 {
44   int len = strlen(s);
45   if (buf->ptr + len > buf->end) len = buf->end - buf->ptr;
46   if (len > 0) memmove(buf->ptr, s, len);
47   buf->ptr += len;
48 }
49 
caml_format_exception(value exn)50 CAMLexport char * caml_format_exception(value exn)
51 {
52   mlsize_t start, i;
53   value bucket, v;
54   struct stringbuf buf;
55   char intbuf[64];
56   char * res;
57 
58   buf.ptr = buf.data;
59   buf.end = buf.data + sizeof(buf.data) - 1;
60   if (Tag_val(exn) == 0) {
61     add_string(&buf, String_val(Field(Field(exn, 0), 0)));
62     /* Check for exceptions in the style of Match_failure and Assert_failure */
63     if (Wosize_val(exn) == 2 &&
64         Is_block(Field(exn, 1)) &&
65         Tag_val(Field(exn, 1)) == 0 &&
66         caml_is_special_exception(Field(exn, 0))) {
67       bucket = Field(exn, 1);
68       start = 0;
69     } else {
70       bucket = exn;
71       start = 1;
72     }
73     add_char(&buf, '(');
74     for (i = start; i < Wosize_val(bucket); i++) {
75       if (i > start) add_string(&buf, ", ");
76       v = Field(bucket, i);
77       if (Is_long(v)) {
78         snprintf(intbuf, sizeof(intbuf),
79                  "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
80         add_string(&buf, intbuf);
81       } else if (Tag_val(v) == String_tag) {
82         add_char(&buf, '"');
83         add_string(&buf, String_val(v));
84         add_char(&buf, '"');
85       } else {
86         add_char(&buf, '_');
87       }
88     }
89     add_char(&buf, ')');
90   } else
91     add_string(&buf, String_val(Field(exn, 0)));
92 
93   *buf.ptr = 0;              /* Terminate string */
94   i = buf.ptr - buf.data + 1;
95   res = malloc(i);
96   if (res == NULL) return NULL;
97   memmove(res, buf.data, i);
98   return res;
99 }
100 
101 
102 #ifdef NATIVE_CODE
103 #  define DEBUGGER_IN_USE 0
104 #else
105 #  define DEBUGGER_IN_USE caml_debugger_in_use
106 #endif
107 
108 /* Default C implementation in case the OCaml one is not registered. */
default_fatal_uncaught_exception(value exn)109 static void default_fatal_uncaught_exception(value exn)
110 {
111   char * msg;
112   value * at_exit;
113   int saved_backtrace_active, saved_backtrace_pos;
114 
115   /* Build a string representation of the exception */
116   msg = caml_format_exception(exn);
117   /* Perform "at_exit" processing, ignoring all exceptions that may
118      be triggered by this */
119   saved_backtrace_active = caml_backtrace_active;
120   saved_backtrace_pos = caml_backtrace_pos;
121   caml_backtrace_active = 0;
122   at_exit = caml_named_value("Pervasives.do_at_exit");
123   if (at_exit != NULL) caml_callback_exn(*at_exit, Val_unit);
124   caml_backtrace_active = saved_backtrace_active;
125   caml_backtrace_pos = saved_backtrace_pos;
126   /* Display the uncaught exception */
127   fprintf(stderr, "Fatal error: exception %s\n", msg);
128   free(msg);
129   /* Display the backtrace if available */
130   if (caml_backtrace_active && !DEBUGGER_IN_USE)
131     caml_print_exception_backtrace();
132 }
133 
134 int caml_abort_on_uncaught_exn = 0; /* see afl.c */
135 
caml_fatal_uncaught_exception(value exn)136 void caml_fatal_uncaught_exception(value exn)
137 {
138   value *handle_uncaught_exception;
139 
140   handle_uncaught_exception =
141     caml_named_value("Printexc.handle_uncaught_exception");
142   if (handle_uncaught_exception != NULL)
143     /* [Printexc.handle_uncaught_exception] does not raise exception. */
144     caml_callback2(*handle_uncaught_exception, exn, Val_bool(DEBUGGER_IN_USE));
145   else
146     default_fatal_uncaught_exception(exn);
147   /* Terminate the process */
148   if (caml_abort_on_uncaught_exn) {
149     abort();
150   } else {
151     CAML_SYS_EXIT(2);
152     exit(2); /* Second exit needed for the Noreturn flag */
153   }
154 }
155