[sledge][llvm] Fix unsafe uses of Store_field

Summary:
Using `Store_field` to initialize fields of blocks allocated with
`caml_alloc_small` is unsafe. The fields of blocks allocated by
`caml_alloc_small` are not initialized, and `Store_field` calls the
OCaml GC write barrier. If the uninitialized value of a field happens
to point into the OCaml heap, then it will e.g. be added to a conflict
set or followed and have what the GC thinks are color bits
changed. This leads to crashes or memory corruption.

This diff fixes a few (I think all) instances of this problem. Some of
these are creating option values. OCaml 4.12 has a dedicated
`caml_alloc_some` function for this, so this diff adds a compatible
function with a version check to avoid conflict. With that, macros for
accessing option values are also added.

Upstream Differential Revision: https://reviews.llvm.org/D99471

Reviewed By: ngorogiannis

Differential Revision: D27564868

fbshipit-source-id: 1dfdd0530

sledge/vendor/llvm-dune/llvm-project/llvm/bindings/ocaml/analysis/CMakeLists.txt

@@ -2,4 +2,5 @@ add_ocaml_library(llvm_analysis
   OCAML    llvm_analysis
   OCAMLDEP llvm
   C        analysis_ocaml
+  CFLAGS   "-I${CMAKE_CURRENT_SOURCE_DIR}/../llvm"
   LLVM     Analysis)

sledge/vendor/llvm-dune/llvm-project/llvm/bindings/ocaml/analysis/analysis_ocaml.c

@@ -20,6 +20,7 @@
 #include "caml/alloc.h"
 #include "caml/mlvalues.h"
 #include "caml/memory.h"
+#include "llvm_ocaml.h"
 
 /* Llvm.llmodule -> string option */
 CAMLprim value llvm_verify_module(LLVMModuleRef M) {
@@ -30,11 +31,10 @@ CAMLprim value llvm_verify_module(LLVMModuleRef M) {
   int Result = LLVMVerifyModule(M, LLVMReturnStatusAction, &Message);
 
   if (0 == Result) {
-    Option = Val_int(0);
+    Option = Val_none;
   } else {
-    Option = alloc(1, 0);
     String = copy_string(Message);
-    Store_field(Option, 0, String);
+    Option = caml_alloc_some(String);
   }
 
   LLVMDisposeMessage(Message);

sledge/vendor/llvm-dune/llvm-project/llvm/bindings/ocaml/llvm/llvm_ocaml.c

@@ -25,9 +25,17 @@
 #include "caml/memory.h"
 #include "caml/fail.h"
 #include "caml/callback.h"
-
 #include "llvm_ocaml.h"
 
+#if OCAML_VERSION < 41200
+value caml_alloc_some(value v) {
+  CAMLparam1(v);
+  value Some = caml_alloc_small(1, 0);
+  Field(Some, 0) = v;
+  CAMLreturn(Some);
+}
+#endif
+
 value llvm_string_of_message(char* Message) {
   value String = caml_copy_string(Message);
   LLVMDisposeMessage(Message);
@@ -36,13 +44,9 @@ value llvm_string_of_message(char* Message) {
 }
 
 CAMLprim value ptr_to_option(void *Ptr) {
-  CAMLparam0();
-  CAMLlocal1(Option);
   if (!Ptr)
-    CAMLreturn(Val_int(0));
+    return Val_none;
-  Option = caml_alloc_small(1, 0);
+  return caml_alloc_some((value)Ptr);
-  Store_field(Option, 0, (value)Ptr);
-  CAMLreturn(Option);
 }
 
 CAMLprim value cstr_to_string(const char *Str, mlsize_t Len) {
@@ -59,14 +63,12 @@ CAMLprim value cstr_to_string(const char *Str, mlsize_t Len) {
 
 CAMLprim value cstr_to_string_option(const char *CStr, mlsize_t Len) {
   CAMLparam0();
-  CAMLlocal2(Option, String);
+  CAMLlocal1(String);
   if (!CStr)
-    CAMLreturn(Val_int(0));
+    CAMLreturn(Val_none);
   String = caml_alloc_string(Len);
   memcpy((char *)String_val(String), CStr, Len);
-  Option = caml_alloc_small(1, 0);
+  return caml_alloc_some(String);
-  Store_field(Option, 0, (value)String);
-  CAMLreturn(Option);
 }
 
 void llvm_raise(value Prototype, char *Message) {
@@ -712,7 +714,7 @@ CAMLprim value llvm_classify_value(LLVMValueRef Val) {
   }
   if (LLVMIsAInstruction(Val)) {
     result = caml_alloc_small(1, 0);
-    Store_field(result, 0, Val_int(LLVMGetInstructionOpcode(Val)));
+    Field(result, 0) = Val_int(LLVMGetInstructionOpcode(Val));
     CAMLreturn(result);
   }
   if (LLVMIsAGlobalValue(Val)) {

sledge/vendor/llvm-dune/llvm-project/llvm/bindings/ocaml/llvm/llvm_ocaml.h

@@ -20,6 +20,17 @@
 
 #include "caml/alloc.h"
 #include "caml/custom.h"
+#include "caml/version.h"
+
+#if OCAML_VERSION < 41200
+/* operations on OCaml option values, defined by OCaml 4.12 */
+#define Val_none Val_int(0)
+#define Some_val(v) Field(v, 0)
+#define Tag_some 0
+#define Is_none(v) ((v) == Val_none)
+#define Is_some(v) Is_block(v)
+value caml_alloc_some(value);
+#endif
 
 /* Convert a C pointer to an OCaml option */
 CAMLprim value ptr_to_option(void *Ptr);

sledge/vendor/llvm-dune/llvm-project/llvm/bindings/ocaml/target/CMakeLists.txt

@@ -2,4 +2,5 @@ add_ocaml_library(llvm_target
   OCAML    llvm_target
   OCAMLDEP llvm
   C        target_ocaml
+  CFLAGS   "-I${CMAKE_CURRENT_SOURCE_DIR}/../llvm"
   LLVM     Target)

sledge/vendor/llvm-dune/llvm-project/llvm/bindings/ocaml/target/target_ocaml.c

@@ -23,6 +23,7 @@
 #include "caml/memory.h"
 #include "caml/custom.h"
 #include "caml/callback.h"
+#include "llvm_ocaml.h"
 
 void llvm_raise(value Prototype, char *Message);
 value llvm_string_of_message(char* Message);
@@ -144,16 +145,6 @@ CAMLprim value llvm_datalayout_offset_of_element(LLVMTypeRef Ty, value Index,
 
 /*===---- Target ----------------------------------------------------------===*/
 
-static value llvm_target_option(LLVMTargetRef Target) {
-  if(Target != NULL) {
-    value Result = caml_alloc_small(1, 0);
-    Store_field(Result, 0, (value) Target);
-    return Result;
-  }
-
-  return Val_int(0);
-}
-
 /* unit -> string */
 CAMLprim value llvm_target_default_triple(value Unit) {
   char *TripleCStr = LLVMGetDefaultTargetTriple();
@@ -165,17 +156,17 @@ CAMLprim value llvm_target_default_triple(value Unit) {
 
 /* unit -> Target.t option */
 CAMLprim value llvm_target_first(value Unit) {
-  return llvm_target_option(LLVMGetFirstTarget());
+  return ptr_to_option(LLVMGetFirstTarget());
 }
 
 /* Target.t -> Target.t option */
 CAMLprim value llvm_target_succ(LLVMTargetRef Target) {
-  return llvm_target_option(LLVMGetNextTarget(Target));
+  return ptr_to_option(LLVMGetNextTarget(Target));
 }
 
 /* string -> Target.t option */
 CAMLprim value llvm_target_by_name(value Name) {
-  return llvm_target_option(LLVMGetTargetFromName(String_val(Name)));
+  return ptr_to_option(LLVMGetTargetFromName(String_val(Name)));
 }
 
 /* string -> Target.t */