l4/pkg/ocaml/contrib/byterun/backtrace.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                           Objective Caml                            */
   4 /*                                                                     */
   5 /*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
   6 /*                                                                     */
   7 /*  Copyright 2000 Institut National de Recherche en Informatique et   */
   8 /*  en Automatique.  All rights reserved.  This file is distributed    */
   9 /*  under the terms of the GNU Library General Public License, with    */
  10 /*  the special exception on linking described in file ../LICENSE.     */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id: backtrace.c 9300 2009-06-18 11:17:16Z xclerc $ */
  15
  16 /* Stack backtrace for uncaught exceptions */
  17
  18 #include <stdio.h>
  19 #include <stdlib.h>
  20 #include <fcntl.h>
  21 #include "config.h"
  22 #ifdef HAS_UNISTD
  23 #include <unistd.h>
  24 #endif
  25 #include "mlvalues.h"
  26 #include "alloc.h"
  27 #include "io.h"
  28 #include "instruct.h"
  29 #include "intext.h"
  30 #include "exec.h"
  31 #include "fix_code.h"
  32 #include "memory.h"
  33 #include "startup.h"
  34 #include "stacks.h"
  35 #include "sys.h"
  36 #include "backtrace.h"
  37
  38 CAMLexport int caml_backtrace_active = 0;
  39 CAMLexport int caml_backtrace_pos = 0;
  40 CAMLexport code_t * caml_backtrace_buffer = NULL;
  41 CAMLexport value caml_backtrace_last_exn = Val_unit;
  42 CAMLexport char * caml_cds_file = NULL;
  43 #define BACKTRACE_BUFFER_SIZE 1024
  44
  45 /* Location of fields in the Instruct.debug_event record */
  46 enum { EV_POS = 0,
  47        EV_MODULE = 1,
  48        EV_LOC = 2,
  49        EV_KIND = 3 };
  50
  51 /* Location of fields in the Location.t record. */
  52 enum { LOC_START = 0,
  53        LOC_END = 1,
  54        LOC_GHOST = 2 };
  55
  56 /* Location of fields in the Lexing.position record. */
  57 enum {
  58   POS_FNAME = 0,
  59   POS_LNUM = 1,
  60   POS_BOL = 2,
  61   POS_CNUM = 3
  62 };
  63
  64 /* Start or stop the backtrace machinery */
  65
  66 CAMLprim value caml_record_backtrace(value vflag)
  67 {
  68   int flag = Int_val(vflag);
  69
  70   if (flag != caml_backtrace_active) {
  71     caml_backtrace_active = flag;
  72     caml_backtrace_pos = 0;
  73     if (flag) {
  74       caml_register_global_root(&caml_backtrace_last_exn);
  75     } else {
  76       caml_remove_global_root(&caml_backtrace_last_exn);
  77     }
  78     /* Note: lazy initialization of caml_backtrace_buffer in
  79        caml_stash_backtrace to simplify the interface with the thread
  80        libraries */
  81   }
  82   return Val_unit;
  83 }
  84
  85 /* Return the status of the backtrace machinery */
  86
  87 CAMLprim value caml_backtrace_status(value vunit)
  88 {
  89   return Val_bool(caml_backtrace_active);
  90 }
  91
  92 /* Store the return addresses contained in the given stack fragment
  93    into the backtrace array */
  94
  95 void caml_stash_backtrace(value exn, code_t pc, value * sp)
  96 {
  97   code_t end_code = (code_t) ((char *) caml_start_code + caml_code_size);
  98   if (pc != NULL) pc = pc - 1;
  99   if (exn != caml_backtrace_last_exn) {
 100     caml_backtrace_pos = 0;
 101     caml_backtrace_last_exn = exn;
 102   }
 103   if (caml_backtrace_buffer == NULL) {
 104     caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
 105     if (caml_backtrace_buffer == NULL) return;
 106   }
 107   if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
 108   if (pc >= caml_start_code && pc < end_code){
 109     caml_backtrace_buffer[caml_backtrace_pos++] = pc;
 110   }
 111   for (/*nothing*/; sp < caml_trapsp; sp++) {
 112     code_t p = (code_t) *sp;
 113     if (p >= caml_start_code && p < end_code) {
 114       if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) break;
 115       caml_backtrace_buffer[caml_backtrace_pos++] = p;
 116     }
 117   }
 118 }
 119
 120 /* Read the debugging info contained in the current bytecode executable.
 121    Return a Caml array of Caml lists of debug_event records in "events",
 122    or Val_false on failure. */
 123
 124 #ifndef O_BINARY
 125 #define O_BINARY 0
 126 #endif
 127
 128 static value read_debug_info(void)
 129 {
 130   CAMLparam0();
 131   CAMLlocal1(events);
 132   char * exec_name;
 133   int fd;
 134   struct exec_trailer trail;
 135   struct channel * chan;
 136   uint32 num_events, orig, i;
 137   value evl, l;
 138
 139   if (caml_cds_file != NULL) {
 140     exec_name = caml_cds_file;
 141   } else {
 142     exec_name = caml_exe_name;
 143   }
 144   fd = caml_attempt_open(&exec_name, &trail, 1);
 145   if (fd < 0) CAMLreturn(Val_false);
 146   caml_read_section_descriptors(fd, &trail);
 147   if (caml_seek_optional_section(fd, &trail, "DBUG") == -1) {
 148     close(fd);
 149     CAMLreturn(Val_false);
 150   }
 151   chan = caml_open_descriptor_in(fd);
 152   num_events = caml_getword(chan);
 153   events = caml_alloc(num_events, 0);
 154   for (i = 0; i < num_events; i++) {
 155     orig = caml_getword(chan);
 156     evl = caml_input_val(chan);
 157     /* Relocate events in event list */
 158     for (l = evl; l != Val_int(0); l = Field(l, 1)) {
 159       value ev = Field(l, 0);
 160       Field(ev, EV_POS) = Val_long(Long_val(Field(ev, EV_POS)) + orig);
 161     }
 162     /* Record event list */
 163     Store_field(events, i, evl);
 164   }
 165   caml_close_channel(chan);
 166   CAMLreturn(events);
 167 }
 168
 169 /* Search the event for the given PC.  Return Val_false if not found. */
 170
 171 static value event_for_location(value events, code_t pc)
 172 {
 173   mlsize_t i;
 174   value pos, l, ev, ev_pos, best_ev;
 175
 176   best_ev = 0;
 177   Assert(pc >= caml_start_code && pc < caml_start_code + caml_code_size);
 178   pos = Val_long((char *) pc - (char *) caml_start_code);
 179   for (i = 0; i < Wosize_val(events); i++) {
 180     for (l = Field(events, i); l != Val_int(0); l = Field(l, 1)) {
 181       ev = Field(l, 0);
 182       ev_pos = Field(ev, EV_POS);
 183       if (ev_pos == pos) return ev;
 184       /* ocamlc sometimes moves an event past a following PUSH instruction;
 185          allow mismatch by 1 instruction. */
 186       if (ev_pos == pos + 8) best_ev = ev;
 187     }
 188   }
 189   if (best_ev != 0) return best_ev;
 190   return Val_false;
 191 }
 192
 193 /* Extract location information for the given PC */
 194
 195 struct loc_info {
 196   int loc_valid;
 197   int loc_is_raise;
 198   char * loc_filename;
 199   int loc_lnum;
 200   int loc_startchr;
 201   int loc_endchr;
 202 };
 203
 204 static void extract_location_info(value events, code_t pc,
 205                                   /*out*/ struct loc_info * li)
 206 {
 207   value ev, ev_start;
 208
 209   ev = event_for_location(events, pc);
 210   li->loc_is_raise = caml_is_instruction(*pc, RAISE);
 211   if (ev == Val_false) {
 212     li->loc_valid = 0;
 213     return;
 214   }
 215   li->loc_valid = 1;
 216   ev_start = Field (Field (ev, EV_LOC), LOC_START);
 217   li->loc_filename = String_val (Field (ev_start, POS_FNAME));
 218   li->loc_lnum = Int_val (Field (ev_start, POS_LNUM));
 219   li->loc_startchr =
 220     Int_val (Field (ev_start, POS_CNUM))
 221     - Int_val (Field (ev_start, POS_BOL));
 222   li->loc_endchr =
 223     Int_val (Field (Field (Field (ev, EV_LOC), LOC_END), POS_CNUM))
 224     - Int_val (Field (ev_start, POS_BOL));
 225 }
 226
 227 /* Print location information */
 228
 229 static void print_location(struct loc_info * li, int index)
 230 {
 231   char * info;
 232
 233   /* Ignore compiler-inserted raise */
 234   if (!li->loc_valid && li->loc_is_raise) return;
 235
 236   if (li->loc_is_raise) {
 237     /* Initial raise if index == 0, re-raise otherwise */
 238     if (index == 0)
 239       info = "Raised at";
 240     else
 241       info = "Re-raised at";
 242   } else {
 243     if (index == 0)
 244       info = "Raised by primitive operation at";
 245     else
 246       info = "Called from";
 247   }
 248   if (! li->loc_valid) {
 249     fprintf(stderr, "%s unknown location\n", info);
 250   } else {
 251     fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n",
 252              info, li->loc_filename, li->loc_lnum,
 253              li->loc_startchr, li->loc_endchr);
 254   }
 255 }
 256
 257 /* Print a backtrace */
 258
 259 CAMLexport void caml_print_exception_backtrace(void)
 260 {
 261   value events;
 262   int i;
 263   struct loc_info li;
 264
 265   events = read_debug_info();
 266   if (events == Val_false) {
 267     fprintf(stderr,
 268             "(Program not linked with -g, cannot print stack backtrace)\n");
 269     return;
 270   }
 271   for (i = 0; i < caml_backtrace_pos; i++) {
 272     extract_location_info(events, caml_backtrace_buffer[i], &li);
 273     print_location(&li, i);
 274   }
 275 }
 276
 277 /* Convert the backtrace to a data structure usable from Caml */
 278
 279 CAMLprim value caml_get_exception_backtrace(value unit)
 280 {
 281   CAMLparam0();
 282   CAMLlocal5(events, res, arr, p, fname);
 283   int i;
 284   struct loc_info li;
 285
 286   events = read_debug_info();
 287   if (events == Val_false) {
 288     res = Val_int(0);           /* None */
 289   } else {
 290     arr = caml_alloc(caml_backtrace_pos, 0);
 291     for (i = 0; i < caml_backtrace_pos; i++) {
 292       extract_location_info(events, caml_backtrace_buffer[i], &li);
 293       if (li.loc_valid) {
 294         fname = caml_copy_string(li.loc_filename);
 295         p = caml_alloc_small(5, 0);
 296         Field(p, 0) = Val_bool(li.loc_is_raise);
 297         Field(p, 1) = fname;
 298         Field(p, 2) = Val_int(li.loc_lnum);
 299         Field(p, 3) = Val_int(li.loc_startchr);
 300         Field(p, 4) = Val_int(li.loc_endchr);
 301       } else {
 302         p = caml_alloc_small(1, 1);
 303         Field(p, 0) = Val_bool(li.loc_is_raise);
 304       }
 305       caml_modify(&Field(arr, i), p);
 306     }
 307     res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
 308   }
 309   CAMLreturn(res);
 310 }
 311