Exploring OCaml values internals

lib.c

#include <stdio.h>
#include <ctype.h>
#include "caml/mlvalues.h"

char* tag_repr(int tag) {
  switch (tag) {
    case Custom_tag:
      return "Custom_tag";
    case Double_array_tag:
      return "Double_array_tag";
    case Double_tag:
      return "Double_tag";
    case String_tag:
      return "String_tag";
    case No_scan_tag:
      return "No_scan_tag or Abstract_tag";
    case Forward_tag:
      return "Forward_tag";
    case Infix_tag:
      return "Infix_tag";
    case Object_tag:
      return "Object_tag";
    case Closure_tag:
      return "Closure_tag";
    case Lazy_tag:
      return "Lazy_tag";
    /*case Cont_tag:
      return "Cont_tag";
    case Forcing_tag:
      return "Forcing_tag";*/
    case 0:
      return "variant, record, tuple or array";
    default:
      return "probably a variant";
  }
}

void dump_printable_chars(char* addr, int idx) {
  for (int j = 16 - (idx % 16); j < 16; j++) {
    printf("   ");
  }

  if ((idx % 16) >= 8) {
    printf(" ");
  }

  printf(" | ");

  for (int j = idx - 16; j < idx; j++) {
    putc(isprint(addr[j]) ? addr[j] : '.', stdout);
  }
}

void hexdump(char* addr, intnat wosize) {
  int wordsize = sizeof(intnat);
  int i;

  for (i = 0; i < (wordsize * wosize); i++) {
      if (i % 16 == 8) {
        putc(' ', stdout);
      }

      if (i % 16 == 0) {
          if (i > 0) {
            dump_printable_chars(addr, i);
          }

          printf("\n%p |", &addr[i]);
      }

      printf(" %02x", addr[i] & 0xff);
  }

  dump_printable_chars(addr, i);
  printf("\n\n");
}

void inspect_caml_value(value a);

void inspect_contents(intnat tag, value a, intnat size) {
  switch (tag) {
    case String_tag:
      printf("String contents: \"%s\"\n", (char *) a);
      break;
    case Double_tag:
      printf("Double contents: %f\n", *((double *) a));
      break;
    case Double_array_tag:
      printf("Double array contents: [ ");
      float* vector = (float *) a;
      for (int i = 0; i < size; i++) {
        printf("%f, ", vector[i]);
      }
      printf("]\n");
      break;
    case Custom_tag:
      printf("Custom config pointer %p\n", (void *) *((void **) a));
      break;
    case No_scan_tag:
    default:  
      printf("No scan tag contents\n");
      if (tag > 243) {
        printf("Ignored...\n");
        break;
      }

      intnat* contents = (intnat *) a;
      for (int i = 0; i < size; i++) {
        printf("Field %d\n", i);
        inspect_caml_value(contents[i]);
      }
  }
}

void inspect_caml_value(value a) {
  printf("%p\n", (void *) a);

  if ((a & 1) != 0) {
    printf("Long: %ld\n\n", a >> 1);
    return;
  }

  printf("Block\n");

  intnat header = *(((intnat *) a) - 1);
  intnat tag = header & 0xff;
  intnat color = (header & 0x300) >> 8;
  intnat wosize = header >> 10;

  printf("Tag: %ld (%s), Color: %ld, Wo size: %ld\n", tag, tag_repr(tag), color, wosize);
  hexdump((char *) a, wosize);

  intnat* contents = (intnat *) a;
  inspect_contents(tag, a, wosize);
}

CAMLprim value inspect_caml_value_stub(value a) {
  inspect_caml_value(a);
  return Val_unit;
}