ocaml/asmrun/backtrace.c

/***********************************************************************/
/*                                                                     */
/*                                OCaml                                */
/*                                                                     */
/*            Xavier Leroy, 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 Library General Public License, with    */
/*  the special exception on linking described in file ../LICENSE.     */
/*                                                                     */
/***********************************************************************/

/* Stack backtrace for uncaught exceptions */

#include <stdio.h>
#include "alloc.h"
#include "backtrace.h"
#include "memory.h"
#include "misc.h"
#include "mlvalues.h"
#include "stack.h"

int caml_backtrace_active = 0;
int caml_backtrace_pos = 0;
code_t * caml_backtrace_buffer = NULL;
value caml_backtrace_last_exn = Val_unit;
#define BACKTRACE_BUFFER_SIZE 1024

/* Start or stop the backtrace machinery */

CAMLprim value caml_record_backtrace(value vflag)
{
  int flag = Int_val(vflag);

  if (flag != caml_backtrace_active) {
    caml_backtrace_active = flag;
    caml_backtrace_pos = 0;
    if (flag) {
      caml_register_global_root(&caml_backtrace_last_exn);
    } else {
      caml_remove_global_root(&caml_backtrace_last_exn);
    }
  }
  return Val_unit;
}

/* Return the status of the backtrace machinery */

CAMLprim value caml_backtrace_status(value vunit)
{
  return Val_bool(caml_backtrace_active);
}

/* Store the return addresses contained in the given stack fragment
   into the backtrace array */

void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
{
  frame_descr * d;
  uintnat h;

  if (exn != caml_backtrace_last_exn) {
    caml_backtrace_pos = 0;
    caml_backtrace_last_exn = exn;
  }
  if (caml_backtrace_buffer == NULL) {
    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
    if (caml_backtrace_buffer == NULL) return;
  }
  if (caml_frame_descriptors == NULL) caml_init_frame_descriptors();

  while (1) {
    /* Find the descriptor corresponding to the return address */
    h = Hash_retaddr(pc);
    while(1) {
      d = caml_frame_descriptors[h];
      if (d == 0) return; /* can happen if some code not compiled with -g */
      if (d->retaddr == pc) break;
      h = (h+1) & caml_frame_descriptors_mask;
    }
    /* Skip to next frame */
    if (d->frame_size != 0xFFFF) {
      /* Regular frame, store its descriptor in the backtrace buffer */
      if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
      caml_backtrace_buffer[caml_backtrace_pos++] = (code_t) d;
#ifndef Stack_grows_upwards
      sp += (d->frame_size & 0xFFFC);
#else
      sp -= (d->frame_size & 0xFFFC);
#endif
      pc = Saved_return_address(sp);
#ifdef Mask_already_scanned
      pc = Mask_already_scanned(pc);
#endif
    } else {
      /* Special frame marking the top of a stack chunk for an ML callback.
         Skip C portion of stack and continue with next ML stack chunk. */
      struct caml_context * next_context = Callback_link(sp);
      sp = next_context->bottom_of_stack;
      pc = next_context->last_retaddr;
      /* A null sp means no more ML stack chunks; stop here. */
      if (sp == NULL) return;
    }
    /* Stop when we reach the current exception handler */
#ifndef Stack_grows_upwards
    if (sp > trapsp) return;
#else
    if (sp < trapsp) return;
#endif
  }
}

/* Extract location information for the given frame descriptor */

struct loc_info {
  int loc_valid;
  int loc_is_raise;
  char * loc_filename;
  int loc_lnum;
  int loc_startchr;
  int loc_endchr;
};

static void extract_location_info(frame_descr * d,
                                  /*out*/ struct loc_info * li)
{
  uintnat infoptr;
  uint32 info1, info2;

  /* If no debugging information available, print nothing.
     When everything is compiled with -g, this corresponds to
     compiler-inserted re-raise operations. */
  if ((d->frame_size & 1) == 0) {
    li->loc_valid = 0;
    li->loc_is_raise = 1;
    return;
  }
  /* Recover debugging info */
  infoptr = ((uintnat) d +
             sizeof(char *) + sizeof(short) + sizeof(short) +
             sizeof(short) * d->num_live + sizeof(frame_descr *) - 1)
            & -sizeof(frame_descr *);
  info1 = ((uint32 *)infoptr)[0];
  info2 = ((uint32 *)infoptr)[1];
  /* Format of the two info words:
       llllllllllllllllllll aaaaaaaa bbbbbbbbbb nnnnnnnnnnnnnnnnnnnnnnnn kk
                          44       36         26                       2  0
                       (32+12)    (32+4)
     k ( 2 bits): 0 if it's a call, 1 if it's a raise
     n (24 bits): offset (in 4-byte words) of file name relative to infoptr
     l (20 bits): line number
     a ( 8 bits): beginning of character range
     b (10 bits): end of character range */
  li->loc_valid = 1;
  li->loc_is_raise = (info1 & 3) != 0;
  li->loc_filename = (char *) infoptr + (info1 & 0x3FFFFFC);
  li->loc_lnum = info2 >> 12;
  li->loc_startchr = (info2 >> 4) & 0xFF;
  li->loc_endchr = ((info2 & 0xF) << 6) | (info1 >> 26);
}

static void print_location(struct loc_info * li, int index)
{
  char * info;

  /* Ignore compiler-inserted raise */
  if (!li->loc_valid) return;

  if (index == 0)
    info = "Raised at";
  else if (li->loc_is_raise)
    info = "Re-raised at";
  else
    info = "Called from";
  fprintf (stderr, "%s file \"%s\", line %d, characters %d-%d\n",
           info, li->loc_filename, li->loc_lnum,
           li->loc_startchr, li->loc_endchr);
}

/* Print a backtrace */

void caml_print_exception_backtrace(void)
{
  int i;
  struct loc_info li;

  for (i = 0; i < caml_backtrace_pos; i++) {
    extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li);
    print_location(&li, i);
  }
}

/* Convert the backtrace to a data structure usable from OCaml */

CAMLprim value caml_get_exception_backtrace(value unit)
{
  CAMLparam0();
  CAMLlocal4(res, arr, p, fname);
  int i;
  struct loc_info li;

  arr = caml_alloc(caml_backtrace_pos, 0);
  for (i = 0; i < caml_backtrace_pos; i++) {
    extract_location_info((frame_descr *) (caml_backtrace_buffer[i]), &li);
    if (li.loc_valid) {
      fname = caml_copy_string(li.loc_filename);
      p = caml_alloc_small(5, 0);
      Field(p, 0) = Val_bool(li.loc_is_raise);
      Field(p, 1) = fname;
      Field(p, 2) = Val_int(li.loc_lnum);
      Field(p, 3) = Val_int(li.loc_startchr);
      Field(p, 4) = Val_int(li.loc_endchr);
    } else {
      p = caml_alloc_small(1, 1);
      Field(p, 0) = Val_bool(li.loc_is_raise);
    }
    caml_modify(&Field(arr, i), p);
  }
  res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
  CAMLreturn(res);
}