Created
April 29, 2022 15:52
-
-
Save renatoalencar/bb225c4fe7dc35c73d7ded5639f8ce88 to your computer and use it in GitHub Desktop.
Exploring OCaml values internals
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| #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; | |
| } |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment