Please use GitHub pull requests for new patches. Avoid migrating existing patches. Phabricator shutdown timeline

Differential D136400 Diff 498897 llvm/bindings/ocaml/llvm/llvm_ocaml.c

Changeset View

Standalone View

llvm/bindings/ocaml/llvm/llvm_ocaml.c

/*===-- llvm_ocaml.c - LLVM OCaml Glue --------------------------*- C++ -*-===*\ /*===-- llvm_ocaml.c - LLVM OCaml Glue --------------------------*- C++ -*-===*\

|* *| |* *|

|* Part of the LLVM Project, under the Apache License v2.0 with LLVM *| |* Part of the LLVM Project, under the Apache License v2.0 with LLVM *|

|* Exceptions. *| |* Exceptions. *|

|* See https://llvm.org/LICENSE.txt for license information. *| |* See https://llvm.org/LICENSE.txt for license information. *|

|* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception *| |* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception *|

|* *| |* *|

|*===----------------------------------------------------------------------===*| |*===----------------------------------------------------------------------===*|

|* *| |* *|

|* This file glues LLVM's OCaml interface to its C interface. These functions *| |* This file glues LLVM's OCaml interface to its C interface. These functions *|

|* are by and large transparent wrappers to the corresponding C functions. *| |* are by and large transparent wrappers to the corresponding C functions. *|

|* *| |* *|

|* Note that these functions intentionally take liberties with the CAMLparamX *| |* Note that these functions intentionally take liberties with the CAMLparamX *|

|* macros, since most of the parameters are not GC heap objects. *| |* macros, since most of the parameters are not GC heap objects. *|

|* *| |* *|

jberdineUnsubmitted

Not Done

A high-level question about this diff is whether you really want to change the bindings in this way. The current situation is that they intentionally take a low-level view of the FFI and have been written with that in mind and reviewed from that perspective. There is probably more chance of introducing bugs by changing this than by just adding the encoding of naked pointers and retaining the use of the low-level FFI. My personal preference would be to keep the existing low level FFI. But if such a change from the low-level to the high-level FFI is done, it should be done as a separate diff that does only that.

jberdine: A high-level question about this diff is whether you really want to change the bindings in this…

alanAuthorUnsubmitted

Done

I thought about this a long time, even before you left this comment. The OCaml manual instructs you to use the CAMLparam, CAMLlocal, and CAMLreturn macros for all FFI functions (https://v2.ocaml.org/manual/intfc.html#ss:c-simple-gc-harmony). It does not give any nuances, like "You don't need to register unboxed integers with CAMLparam" or "You don't need to use the macros if you never call the OCaml runtime." When I first wrote this patch, I just added all the macros to be extra safe.

I've been going through the code locally now and removing the macros, and so far the tests still pass, but there are several spots where I was unsure if removing the macro would be unsafe. (Example: Where one of the arguments is a pointer into the OCaml-managed heap, such as an OCaml string or an Abstract_tagged LLVM value for purposes of custom finalizer, and the function calls the OCaml runtime by allocating something.) I don't want a heisenbug where the code usually passes the tests, but mysteriously segfaults in some user's program if the GC kicks in at the wrong time and deallocates memory that shouldn't, because the binding code plays fast and loose with the macros.

Then, we have the issue with the diagnostic handler, meaning that the OCaml runtime could kick in at many points that may not be obvious, but the diagnostic handler could violate so many assumptions about C and C++ resource cleanup, as we've discussed, that I don't know if it should factor in to the decision whether to use the macros.

When I was thinking about whether to use the macros or drop them, my view was mainly about efficiency versus readability, where I viewed the macros as sacrificing slight efficiency (because the code spends instructions registering values with the GC, when this may not be necessary) for readability (because the code follows the rules of the OCaml FFI manual to the letter). I do not share your view that using the macros would *introduce* bugs or make the code harder to review; I always thought the macros make the code safer and easier to review. It's better to just use the macro than to think, "Do we need to use a macro here? Does the GC need to know about this value before we call caml_alloc_whatever?"

alan: I thought about this a long time, even before you left this comment. The OCaml manual instructs…

jberdineUnsubmitted

Not Done

My main point is not so much about whether or not to most desirable final situation involves abiding by the simplified FFI rules, but that the changes to do so are large and orthogonal to the goal of changing the bindings to avoid naked pointers. Changing to the simplified FFI rules is a judgement call that has pros and cons, while eliminating naked pointers is a hard requirement going forward. That is why I think the two things should be done as two separate diffs.

As for potentially introducing bugs, maybe I'm just paranoid, but large changes are hard to review and not as precise when bisecting issues that are discovered later. More specifically, adding CAMLlocal and associated macros publish more locations as GC roots, and the associated changes involve more allocations. Going all the way to strictly following the simplified rules should be fine, but if there are any oversights and we only get part of the way there, it seems entirely possible to introduce bugs.

The diagnostic handler API is limited in the sense that the handler functions must not access the OCaml runtime system. But following the simplified FFI rules will not be enough to enable supporting arbitrary handler functions. That would be another orthogonal change.

jberdine: My main point is not so much about whether or not to most desirable final situation involves…

alanAuthorUnsubmitted

Done

I can respect the view that a smaller diff is better and that we can add the macros in a separate patch and focus this one on making the code work on OCaml 5. I've removed most of the CAML macros I added. There were some functions that took a pointer into the OCaml heap (e.g. an OCaml string) and called the OCaml runtime (e.g. to allocate a block or throw an exception), and I kept the macros in those cases because I think that not using the macros would be incorrect. Hopefully the diff should be smaller and easier to review now.

alan: I can respect the view that a smaller diff is better and that we can add the macros in a…

\*===----------------------------------------------------------------------===*/ \*===----------------------------------------------------------------------===*/

#include <assert.h> #include <assert.h>

#include <stdlib.h> #include <stdlib.h>

#include <string.h> #include <string.h>

#include "llvm-c/Core.h" #include "llvm-c/Core.h"

#include "llvm-c/Support.h" #include "llvm-c/Support.h"

#include "llvm/Config/llvm-config.h" #include "llvm/Config/llvm-config.h"

#include "caml/memory.h" #include "caml/memory.h"

#include "caml/fail.h" #include "caml/fail.h"

#include "caml/callback.h" #include "caml/callback.h"

#include "llvm_ocaml.h" #include "llvm_ocaml.h"

#if OCAML_VERSION < 41200 #if OCAML_VERSION < 41200

value caml_alloc_some(value v) { value caml_alloc_some(value v) {

CAMLparam1(v); CAMLparam1(v);

value Some = caml_alloc_small(1, 0); value Some = caml_alloc_small(1, 0);

Field(Some, 0) = v; Field(Some, 0) = v;

CAMLreturn(Some); CAMLreturn(Some);

} }

#endif #endif

value caml_alloc_tuple_uninit(mlsize_t wosize) { value to_val(void *ptr) {

if (wosize <= Max_young_wosize) { assert((((value)ptr) & 1) == 0 &&

jberdineUnsubmitted

Done

value to_val(void *ptr) {

- assert((((value)ptr) & 1) == 0);

+ assert((((value)ptr) & 1) == 0

+ && "OCaml bindings assume LLVM objects are at least 2-byte aligned");

return ((value)ptr) | 1;

It is common practice elsewhere in the LLVM codebase to add an informative message to assertions, in a way that does not affect the meaning:

jberdine: It is common practice elsewhere in the LLVM codebase to add an informative message to…

return caml_alloc_small(wosize, 0); "OCaml bindings assume LLVM objects are at least 2-byte aligned");

} else { return ((value)ptr) | 1;

return caml_alloc_shr(wosize, 0);

} }

void *from_val(value v) {

assert(Is_long(v) && "OCaml values representing LLVM objects should have the "

"low bit set so that the OCaml GC "

"treats them as integers");

return (void *)(v ^ 1);

KakaduUnsubmitted

Not Done

Could you add a comment why these two functions are needed? I always though that out-of-heap values should be wrapped into Abstract_tag. At least the manual says that https://v2.ocaml.org/manual/intfc.html#ss:c-outside-head

Sorry for asking stupid questions, I was teleported there from https://discuss.ocaml.org/t/proposal-care-more-about-ocaml-bindings-for-popular-libraries/11451

Kakadu: Could you add a comment why these two functions are needed? I always though that out-of-heap…

alanAuthorUnsubmitted

Done

When I first wrote this patch, my original approach was to wrap LLVM values in an OCaml block of Abstract_tag. In a discussion with @jberdine, he said that I could assume that all pointers from LLVM are 2-byte aligned, and set the low bit to 1 when exposing them to OCaml (https://github.com/llvm/llvm-project/issues/58134#issuecomment-1271544642). The OCaml GC distinguishes pointers from integers from the low bit; the low bit of integers is 1. Therefore, the OCaml GC will treat out-of-OCaml-heap LLVM pointers as integers.

The OCaml documentation that you link also recommends this representation:

For pointers that are at least 2-aligned (the low bit is guaranteed to be zero), we have yet another valid representation as an OCaml tagged integer.

This approach avoids an extra allocation. This design choice is documented in the comments and assert messages. Is there anything else I need to add to make it clear for people unfamiliar with the code?

alan: When I first wrote this patch, my original approach was to wrap LLVM values in an OCaml block…

KakaduUnsubmitted

Done

Sorry, I forgot that there is an optimization to avoid Abstract_tag. It would be great to have a comment explicitly saying that.

Kakadu: Sorry, I forgot that there is an optimization to avoid Abstract_tag. It would be great to have…

jrtc27Unsubmitted

Not Done

Pointers are not integers.

jrtc27: Pointers are not integers.

jberdineUnsubmitted

Not Done

Pointers are not integers.

From the perspective of the FFI, bit patterns with the lsb set are not interpreted as pointers that the runtime system should follow. It happens that integers in OCaml are represented with bit patterns where the lsb is set, so it is common, perhaps imprecise, usage to refer to pointers where their lsb has been set as "integers".

jberdine: > Pointers are not integers. From the perspective of the FFI, bit patterns with the lsb set…

alanAuthorUnsubmitted

Done

From the perspective of program analysis, pointers are not integers because pointers have provenance. From the perspective of the runtime system, everything is a word. To be pedantic: A word is a sequence of bits; pointers, integers, Booleans, and nullary data constructors are all possible meanings ascribed to words. OCaml's GC, being a precise GC, distinguishes between pointers, which it may follow and relocate, and non-pointers, through the low bit. Setting the low bit of a pointer originating from LLVM causes the OCaml GC to treat it as a word that the GC does not follow.

alan: From the perspective of program analysis, pointers are not integers because pointers have…

} }

value llvm_string_of_message(char *Message) { value llvm_string_of_message(char *Message) {

jberdineUnsubmitted

Not Done

It might not hurt to add a comment before to_val and from_val saying that they encode pointers to LLVM objects as OCaml tagged integers, following the 3rd encoding suggested by the OCaml FFI documentation at https://ocaml.org/releases/5.0/htmlman/intfc.html#ss:c-outside-head . I don't know how stable such urls are expected to be though.

jberdine: It might not hurt to add a comment before `to_val` and `from_val` saying that they encode…

alanAuthorUnsubmitted

Done

I added comments to the header file explaining how these functions work. Should I put additional comments in the source file?

alan: I added comments to the header file explaining how these functions work. Should I put…

jberdineUnsubmitted

Not Done

The comment in the header is good but I think since it discusses the implementation details of the encoding, I would have put it in the .c and used a comment in the header that just said that the functions implement an encoding without specifying which one. But I have not checked if the uses in other files need to know about details of the encoding. Those are the things I think of, but go with your preference.

jberdine: The comment in the header is good but I think since it discusses the implementation details of…

alanAuthorUnsubmitted

Done

The reason I would rather have the comments in the header is that if the functions were to be used for some LLVM type that is not 2-byte aligned, or the implementation of some type changed so that it is no longer 2-byte aligned, the code will break. (In that case, the specific type that is not 2-byte aligned should have a dedicated alloc_ function, just like the ones that already exist for types that need custom finalizers.) Therefore, I think that the 2-byte alignment aspect is a contract that users of the functions need to know about, not an implementation detail.

alan: The reason I would rather have the comments in the header is that if the functions were to be…

jberdineUnsubmitted

Not Done

Yes, that makes sense.

jberdine: Yes, that makes sense.

value String = caml_copy_string(Message); value String = caml_copy_string(Message);

LLVMDisposeMessage(Message); LLVMDisposeMessage(Message);

return String; return String;

} }

value ptr_to_option(void *Ptr) { value ptr_to_option(void *Ptr) {

if (!Ptr) if (!Ptr)

return Val_none; return Val_none;

jberdineUnsubmitted

Not Done

"low bit set so that the OCaml GC "

- "treats them as integers");

+ "treats them as tagged integers");

return (void *)(v ^ 1);

jberdine:

return caml_alloc_some((value)Ptr); return caml_alloc_some(to_val(Ptr));

} }

value cstr_to_string(const char *Str, mlsize_t Len) { value cstr_to_string(const char *Str, mlsize_t Len) {

KakaduUnsubmitted

Not Done

Am I understanding right... LLVM uses non-zero-terminated strings under the hood, so this function is need?

In case of zero terminated string it would be better to use caml_copy_string https://github.com/ocaml/ocaml/blob/5.0/runtime/alloc.c#L208

Kakadu: Am I understanding right... LLVM uses non-zero-terminated strings under the hood, so this…

alanAuthorUnsubmitted

Done

This code is what exists on the main branch and my patch does not touch it. The code passes the tests; changing this function is not the business of my patch.

It seems that this function accepts NULL pointers and handles the NULL case by allocating a zero-length OCaml-heap-allocated string.

alan: This code is what exists on the main branch and my patch does not touch it. The code passes the…

KakaduUnsubmitted

Not Done

Yeah, you are right. The caml_alloc_string+memcpy could be probably be replaced by caml_copy_string, but it could be a topic for a distinct patch....

Kakadu: Yeah, you are right. The caml_alloc_string+memcpy could be probably be replaced by…

jberdineUnsubmitted

Not Done

Yes, this code is old, and the same as the implementation of caml_copy_string except for also treating NULL as an empty string.

jberdine: Yes, this code is old, and the same as the implementation of `caml_copy_string` except for also…

if (!Str) if (!Str)

return caml_alloc_string(0); return caml_alloc_string(0);

value String = caml_alloc_string(Len); value String = caml_alloc_string(Len);

jberdineUnsubmitted

Not Done

@nikic this section of code is something that it would be good to get eyes on from someone familiar with the LLVM C API without needing any familiarity with OCaml specifics.

The to_val function is used to "encode" pointers returned from the LLVM C API to the client OCaml code, and from_val performs the corresponding "decode". What to_val does is to test if the pointer is at least 2-byte aligned, and if so encodes it by setting the low bit. If the pointer is not 2-aligned, a wrapper object is allocated and the pointer stored in it. The OCaml runtime system guarantees that the wrapper object will be word aligned, and so the decode done in from_val tests the low bit with Is_long to distinguish the two cases.

This implementation LGTM (I have not had time yet to check the usages in this diff), but a question for those more familiar with the LLVM C API is whether the case where pointers are not aligned is impossible due to guarantees about alignment? The implementation in this diff is conservative and supports unaligned pointers, but is perhaps not as efficient as possible if there are reasons to know all pointers from LLVM will be aligned.

jberdine: @nikic this section of code is something that it would be good to get eyes on from someone…

nikicUnsubmitted

Not Done

I believe it's safe to assume that LLVM allocations are at least 4 byte aligned (we commonly use 2 bits for pointer tags). Only problem would be cases where something other than an allocation base pointer is returned, e.g. some arbitrary substring of a larger string. I don't know if we have any APIs that do something like this though.

nikic: I believe it's safe to assume that LLVM allocations are at least 4 byte aligned (we commonly…

jrtc27Unsubmitted

Not Done

m68k's ABI caps alignment at 2 bytes (unless you __attribute__((aligned(...))) or alignas(...)), FWIW, though there are currently places where LLVM itself breaks as a result of that

jrtc27: m68k's ABI caps alignment at 2 bytes (unless you `__attribute__((aligned(...)))` or `alignas(...

memcpy((char *)String_val(String), Str, Len); memcpy((char *)String_val(String), Str, Len);

return String; return String;

} }

value cstr_to_string_option(const char *CStr, mlsize_t Len) { value cstr_to_string_option(const char *CStr, mlsize_t Len) {

if (!CStr) if (!CStr)

return Val_none; return Val_none;

value String = caml_alloc_string(Len); value String = caml_alloc_string(Len);

memcpy((char *)String_val(String), CStr, Len); memcpy((char *)String_val(String), CStr, Len);

return caml_alloc_some(String); return caml_alloc_some(String);

} }

void llvm_raise(value Prototype, char *Message) { void llvm_raise(value Prototype, char *Message) {

caml_raise_with_arg(Prototype, llvm_string_of_message(Message)); caml_raise_with_arg(Prototype, llvm_string_of_message(Message));

} }

static value llvm_fatal_error_handler; static value llvm_fatal_error_handler;

static void llvm_fatal_error_trampoline(const char *Reason) { static void llvm_fatal_error_trampoline(const char *Reason) {

callback(llvm_fatal_error_handler, caml_copy_string(Reason)); caml_callback(llvm_fatal_error_handler, caml_copy_string(Reason));

} }

value llvm_install_fatal_error_handler(value Handler) { value llvm_install_fatal_error_handler(value Handler) {

LLVMInstallFatalErrorHandler(llvm_fatal_error_trampoline); LLVMInstallFatalErrorHandler(llvm_fatal_error_trampoline);

llvm_fatal_error_handler = Handler; llvm_fatal_error_handler = Handler;

caml_register_global_root(&llvm_fatal_error_handler); caml_register_global_root(&llvm_fatal_error_handler);

return Val_unit; return Val_unit;

} }

Show All 16 Lines value llvm_parse_command_line_options(value Overview, value Args) {

} else { } else {

COverview = String_val(Field(Overview, 0)); COverview = String_val(Field(Overview, 0));

} }

LLVMParseCommandLineOptions(Wosize_val(Args), LLVMParseCommandLineOptions(Wosize_val(Args),

(const char *const *)Op_val(Args), COverview); (const char *const *)Op_val(Args), COverview);

return Val_unit; return Val_unit;

} }

static value alloc_variant(int tag, void *Value) { void *alloc_temp(value Elements) {

unsigned Length = Wosize_val(Elements);

jberdineUnsubmitted

Not Done

Note that Wosize_val returns type mlsize_t, which is defined in a platform-specific way because it needs to be different on 32 vs 64 bit systems (it will be uint64_t on 64-bit systems, so usually wider than unsigned). It would probably be better to use mlsize_t instead of unsigned where the values come from OCaml and keep unsigned where the values come from LLVM. In cases where both are involved, I think but am not sure that it would generally be clearer to have the local variables with the unconverted types, and leave the casts between unsigned and mlsize_t implicit when passing arguments to functions.

jberdine: Note that `Wosize_val` returns type `mlsize_t`, which is defined in a platform-specific way…

void **Temp = malloc(sizeof(void *) * Length);

if (Temp == NULL)

caml_raise_out_of_memory();

for (unsigned I = 0; I < Length; ++I) {

Temp[I] = from_val(Field(Elements, I));

jberdineUnsubmitted

Not Done

Just a note to ourselves for maybe later: If we want to make the bindings safe for concurrent clients, we may want something stronger than a non-atomic store here. (The load from Elements is volatile.)

jberdine: Just a note to ourselves for maybe later: If we want to make the bindings safe for concurrent…

}

return Temp;

}

static value alloc_variant(int tag, value Value) {

KakaduUnsubmitted

Not Done

I'm not 100% follow the intent of this function. It looks like it tries to convert OCaml array of OCaml values to C array of OCaml values. But if it is true, I'm not sure that llvm_struct_element_types works as expected.

In I understood intent correctly, it should be renamed to array_of_ocaml_array or something.....

Kakadu: I'm not 100% follow the intent of this function. It looks like it tries to convert OCaml array…

alanAuthorUnsubmitted

Done

Yes, it converts an OCaml array to a C array. The code on the main branch uses the fact that pointers are naked to directly cast OCaml blocks to C arrays, which is no longer possible now that OCaml 5 disallows naked pointers.

The x_of_y naming style is an OCaml quirk. I don't want to name this helper function that.

alan: Yes, it converts an OCaml array to a C array. The code on the main branch uses the fact that…

jberdineUnsubmitted

Not Done

This function could probably use a comment explaining its usage since its functionality is quite specific and has a general sounding name. I don't feel strongly, but there might be a better name possible. It is basically from_val lifted to operate on arrays, so perhaps from_val_array.

jberdine: This function could probably use a comment explaining its usage since its functionality is…

value Iter = caml_alloc_small(1, tag); value Iter = caml_alloc_small(1, tag);

Field(Iter, 0) = Val_op(Value); Field(Iter, 0) = Value;

return Iter; return Iter;

} }

/* Macro to convert the C first/next/last/prev idiom to the Ocaml llpos/ /* Macro to convert the C first/next/last/prev idiom to the Ocaml llpos/

llrev_pos idiom. */ llrev_pos idiom. */

#define DEFINE_ITERATORS(camlname, cname, pty, cty, pfun) \ #define DEFINE_ITERATORS(camlname, cname, pty_val, cty, cty_val, pfun) \

/* llmodule -> ('a, 'b) llpos */ \ /* llmodule -> ('a, 'b) llpos */ \

value llvm_##camlname##_begin(pty Mom) { \ value llvm_##camlname##_begin(value Mom) { \

cty First = LLVMGetFirst##cname(Mom); \ cty First = LLVMGetFirst##cname(pty_val(Mom)); \

if (First) \ if (First) \

return alloc_variant(1, First); \ return alloc_variant(1, to_val(First)); \

return alloc_variant(0, Mom); \ return alloc_variant(0, Mom); \

} \ } \

\ \

/* llvalue -> ('a, 'b) llpos */ \ /* llvalue -> ('a, 'b) llpos */ \

value llvm_##camlname##_succ(cty Kid) { \ value llvm_##camlname##_succ(value Kid) { \

cty Next = LLVMGetNext##cname(Kid); \ cty Next = LLVMGetNext##cname(cty_val(Kid)); \

if (Next) \ if (Next) \

return alloc_variant(1, Next); \ return alloc_variant(1, to_val(Next)); \

return alloc_variant(0, pfun(Kid)); \ return alloc_variant(0, to_val(pfun(cty_val(Kid)))); \

} \ } \

\ \

/* llmodule -> ('a, 'b) llrev_pos */ \ /* llmodule -> ('a, 'b) llrev_pos */ \

value llvm_##camlname##_end(pty Mom) { \ value llvm_##camlname##_end(value Mom) { \

cty Last = LLVMGetLast##cname(Mom); \ cty Last = LLVMGetLast##cname(pty_val(Mom)); \

if (Last) \ if (Last) \

return alloc_variant(1, Last); \ return alloc_variant(1, to_val(Last)); \

return alloc_variant(0, Mom); \ return alloc_variant(0, Mom); \

} \ } \

\ \

/* llvalue -> ('a, 'b) llrev_pos */ \ /* llvalue -> ('a, 'b) llrev_pos */ \

value llvm_##camlname##_pred(cty Kid) { \ value llvm_##camlname##_pred(value Kid) { \

cty Prev = LLVMGetPrevious##cname(Kid); \ cty Prev = LLVMGetPrevious##cname(cty_val(Kid)); \

if (Prev) \ if (Prev) \

return alloc_variant(1, Prev); \ return alloc_variant(1, to_val(Prev)); \

return alloc_variant(0, pfun(Kid)); \ return alloc_variant(0, to_val(pfun(cty_val(Kid)))); \

} }

/*===-- Context error handling --------------------------------------------===*/ /*===-- Context error handling --------------------------------------------===*/

void llvm_diagnostic_handler_trampoline(LLVMDiagnosticInfoRef DI, void llvm_diagnostic_handler_trampoline(LLVMDiagnosticInfoRef DI,

void *DiagnosticContext) { void *DiagnosticContext) {

caml_callback(*((value *)DiagnosticContext), (value)DI); caml_callback(*((value *)DiagnosticContext), to_val(DI));

} }

/* Diagnostic.t -> string */ /* Diagnostic.t -> string */

value llvm_get_diagnostic_description(value Diagnostic) { value llvm_get_diagnostic_description(value Diagnostic) {

return llvm_string_of_message( return llvm_string_of_message(

LLVMGetDiagInfoDescription((LLVMDiagnosticInfoRef)Diagnostic)); LLVMGetDiagInfoDescription(DiagnosticInfo_val(Diagnostic)));

} }

/* Diagnostic.t -> DiagnosticSeverity.t */ /* Diagnostic.t -> DiagnosticSeverity.t */

value llvm_get_diagnostic_severity(value Diagnostic) { value llvm_get_diagnostic_severity(value Diagnostic) {

return Val_int(LLVMGetDiagInfoSeverity((LLVMDiagnosticInfoRef)Diagnostic)); return Val_int(LLVMGetDiagInfoSeverity(DiagnosticInfo_val(Diagnostic)));

} }

static void llvm_remove_diagnostic_handler(LLVMContextRef C) { static void llvm_remove_diagnostic_handler(value C) {

if (LLVMContextGetDiagnosticHandler(C) == CAMLparam1(C);

LLVMContextRef context = Context_val(C);

if (LLVMContextGetDiagnosticHandler(context) ==

llvm_diagnostic_handler_trampoline) { llvm_diagnostic_handler_trampoline) {

value *Handler = (value *)LLVMContextGetDiagnosticContext(C); value *Handler = (value *)LLVMContextGetDiagnosticContext(context);

remove_global_root(Handler); caml_remove_global_root(Handler);

free(Handler); free(Handler);

} }

CAMLreturn0;

} }

/* llcontext -> (Diagnostic.t -> unit) option -> unit */ /* llcontext -> (Diagnostic.t -> unit) option -> unit */

value llvm_set_diagnostic_handler(LLVMContextRef C, value Handler) { value llvm_set_diagnostic_handler(value C, value Handler) {

CAMLparam2(C, Handler);

LLVMContextRef context = Context_val(C);

llvm_remove_diagnostic_handler(C); llvm_remove_diagnostic_handler(C);

if (Handler == Val_none) { if (Handler == Val_none) {

LLVMContextSetDiagnosticHandler(C, NULL, NULL); LLVMContextSetDiagnosticHandler(context, NULL, NULL);

} else { } else {

value *DiagnosticContext = malloc(sizeof(value)); value *DiagnosticContext = malloc(sizeof(value));

if (DiagnosticContext == NULL) if (DiagnosticContext == NULL)

caml_raise_out_of_memory(); caml_raise_out_of_memory();

caml_register_global_root(DiagnosticContext); caml_register_global_root(DiagnosticContext);

*DiagnosticContext = Field(Handler, 0); *DiagnosticContext = Field(Handler, 0);

LLVMContextSetDiagnosticHandler(C, llvm_diagnostic_handler_trampoline, LLVMContextSetDiagnosticHandler(context, llvm_diagnostic_handler_trampoline,

DiagnosticContext); DiagnosticContext);

} }

return Val_unit; CAMLreturn(Val_unit);

} }

/*===-- Contexts ----------------------------------------------------------===*/ /*===-- Contexts ----------------------------------------------------------===*/

/* unit -> llcontext */ /* unit -> llcontext */

LLVMContextRef llvm_create_context(value Unit) { return LLVMContextCreate(); } value llvm_create_context(value Unit) { return to_val(LLVMContextCreate()); }

/* llcontext -> unit */ /* llcontext -> unit */

value llvm_dispose_context(LLVMContextRef C) { value llvm_dispose_context(value C) {

llvm_remove_diagnostic_handler(C); llvm_remove_diagnostic_handler(C);

LLVMContextDispose(C); LLVMContextDispose(Context_val(C));

return Val_unit; return Val_unit;

} }

/* unit -> llcontext */ /* unit -> llcontext */

LLVMContextRef llvm_global_context(value Unit) { value llvm_global_context(value Unit) { return to_val(LLVMGetGlobalContext()); }

return LLVMGetGlobalContext();

}

/* llcontext -> string -> int */ /* llcontext -> string -> int */

value llvm_mdkind_id(LLVMContextRef C, value Name) { value llvm_mdkind_id(value C, value Name) {

unsigned MDKindID = unsigned MDKindID = LLVMGetMDKindIDInContext(Context_val(C), String_val(Name),

LLVMGetMDKindIDInContext(C, String_val(Name), caml_string_length(Name)); caml_string_length(Name));

return Val_int(MDKindID); return Val_int(MDKindID);

} }

/*===-- Attributes --------------------------------------------------------===*/ /*===-- Attributes --------------------------------------------------------===*/

/* string -> llattrkind */ /* string -> llattrkind */

value llvm_enum_attr_kind(value Name) { value llvm_enum_attr_kind(value Name) {

CAMLparam1(Name);

jberdineUnsubmitted

Not Done

Is this CAMLparam/CAMLreturn left over from combining the two diffs, or necessary for a reason I am overlooking?

jberdine: Is this CAMLparam/CAMLreturn left over from combining the two diffs, or necessary for a reason…

unsigned Kind = LLVMGetEnumAttributeKindForName(String_val(Name), unsigned Kind = LLVMGetEnumAttributeKindForName(String_val(Name),

caml_string_length(Name)); caml_string_length(Name));

if (Kind == 0) if (Kind == 0)

caml_raise_with_arg(*caml_named_value("Llvm.UnknownAttribute"), Name); caml_raise_with_arg(*caml_named_value("Llvm.UnknownAttribute"), Name);

return Val_int(Kind); CAMLreturn(Val_int(Kind));

} }

/* llcontext -> int -> int64 -> llattribute */ /* llcontext -> int -> int64 -> llattribute */

LLVMAttributeRef llvm_create_enum_attr_by_kind(LLVMContextRef C, value Kind, value llvm_create_enum_attr_by_kind(value C, value Kind, value Value) {

value Value) { return to_val(

return LLVMCreateEnumAttribute(C, Int_val(Kind), Int64_val(Value)); LLVMCreateEnumAttribute(Context_val(C), Int_val(Kind), Int64_val(Value)));

} }

/* llattribute -> bool */ /* llattribute -> bool */

value llvm_is_enum_attr(LLVMAttributeRef A) { value llvm_is_enum_attr(value A) {

return Val_int(LLVMIsEnumAttribute(A)); return Val_int(LLVMIsEnumAttribute(Attribute_val(A)));

} }

/* llattribute -> llattrkind */ /* llattribute -> llattrkind */

value llvm_get_enum_attr_kind(LLVMAttributeRef A) { value llvm_get_enum_attr_kind(value A) {

return Val_int(LLVMGetEnumAttributeKind(A)); return Val_int(LLVMGetEnumAttributeKind(Attribute_val(A)));

} }

/* llattribute -> int64 */ /* llattribute -> int64 */

value llvm_get_enum_attr_value(LLVMAttributeRef A) { value llvm_get_enum_attr_value(value A) {

return caml_copy_int64(LLVMGetEnumAttributeValue(A)); return caml_copy_int64(LLVMGetEnumAttributeValue(Attribute_val(A)));

} }

/* llcontext -> kind:string -> name:string -> llattribute */ /* llcontext -> kind:string -> name:string -> llattribute */

LLVMAttributeRef llvm_create_string_attr(LLVMContextRef C, value Kind, value llvm_create_string_attr(value C, value Kind, value Value) {

value Value) { return to_val(LLVMCreateStringAttribute(

return LLVMCreateStringAttribute(C, String_val(Kind), Context_val(C), String_val(Kind), caml_string_length(Kind),

caml_string_length(Kind), String_val(Value), String_val(Value), caml_string_length(Value)));

caml_string_length(Value));

} }

/* llattribute -> bool */ /* llattribute -> bool */

value llvm_is_string_attr(LLVMAttributeRef A) { value llvm_is_string_attr(value A) {

return Val_int(LLVMIsStringAttribute(A)); return Val_int(LLVMIsStringAttribute(Attribute_val(A)));

} }

/* llattribute -> string */ /* llattribute -> string */

value llvm_get_string_attr_kind(LLVMAttributeRef A) { value llvm_get_string_attr_kind(value A) {

unsigned Length; unsigned Length;

const char *String = LLVMGetStringAttributeKind(A, &Length); const char *String = LLVMGetStringAttributeKind(Attribute_val(A), &Length);

return cstr_to_string(String, Length); return cstr_to_string(String, Length);

} }

/* llattribute -> string */ /* llattribute -> string */

value llvm_get_string_attr_value(LLVMAttributeRef A) { value llvm_get_string_attr_value(value A) {

unsigned Length; unsigned Length;

const char *String = LLVMGetStringAttributeValue(A, &Length); const char *String = LLVMGetStringAttributeValue(Attribute_val(A), &Length);

return cstr_to_string(String, Length); return cstr_to_string(String, Length);

} }

/*===-- Modules -----------------------------------------------------------===*/ /*===-- Modules -----------------------------------------------------------===*/

/* llcontext -> string -> llmodule */ /* llcontext -> string -> llmodule */

LLVMModuleRef llvm_create_module(LLVMContextRef C, value ModuleID) { value llvm_create_module(value C, value ModuleID) {

return LLVMModuleCreateWithNameInContext(String_val(ModuleID), C); return to_val(

LLVMModuleCreateWithNameInContext(String_val(ModuleID), Context_val(C)));

} }

/* llmodule -> unit */ /* llmodule -> unit */

value llvm_dispose_module(LLVMModuleRef M) { value llvm_dispose_module(value M) {

LLVMDisposeModule(M); LLVMDisposeModule(Module_val(M));

return Val_unit; return Val_unit;

} }

/* llmodule -> string */ /* llmodule -> string */

value llvm_target_triple(LLVMModuleRef M) { value llvm_target_triple(value M) {

return caml_copy_string(LLVMGetTarget(M)); return caml_copy_string(LLVMGetTarget(Module_val(M)));

} }

/* string -> llmodule -> unit */ /* string -> llmodule -> unit */

value llvm_set_target_triple(value Trip, LLVMModuleRef M) { value llvm_set_target_triple(value Trip, value M) {

LLVMSetTarget(M, String_val(Trip)); LLVMSetTarget(Module_val(M), String_val(Trip));

return Val_unit; return Val_unit;

} }

/* llmodule -> string */ /* llmodule -> string */

value llvm_data_layout(LLVMModuleRef M) { value llvm_data_layout(value M) {

return caml_copy_string(LLVMGetDataLayout(M)); return caml_copy_string(LLVMGetDataLayout(Module_val(M)));

} }

/* string -> llmodule -> unit */ /* string -> llmodule -> unit */

value llvm_set_data_layout(value Layout, LLVMModuleRef M) { value llvm_set_data_layout(value Layout, value M) {

LLVMSetDataLayout(M, String_val(Layout)); LLVMSetDataLayout(Module_val(M), String_val(Layout));

return Val_unit; return Val_unit;

} }

/* llmodule -> unit */ /* llmodule -> unit */

value llvm_dump_module(LLVMModuleRef M) { value llvm_dump_module(value M) {

LLVMDumpModule(M); LLVMDumpModule(Module_val(M));

return Val_unit; return Val_unit;

} }

/* string -> llmodule -> unit */ /* string -> llmodule -> unit */

value llvm_print_module(value Filename, LLVMModuleRef M) { value llvm_print_module(value Filename, value M) {

CAMLparam1(Filename);

jberdineUnsubmitted

Not Done

I don't see why adding this CAMLparam is necessary

jberdine: I don't see why adding this CAMLparam is necessary

char *Message; char *Message;

if (LLVMPrintModuleToFile(M, String_val(Filename), &Message)) if (LLVMPrintModuleToFile(Module_val(M), String_val(Filename), &Message))

llvm_raise(*caml_named_value("Llvm.IoError"), Message); llvm_raise(*caml_named_value("Llvm.IoError"), Message);

return Val_unit; CAMLreturn(Val_unit);

} }

/* llmodule -> string */ /* llmodule -> string */

value llvm_string_of_llmodule(LLVMModuleRef M) { value llvm_string_of_llmodule(value M) {

char *ModuleCStr = LLVMPrintModuleToString(M); char *ModuleCStr = LLVMPrintModuleToString(Module_val(M));

value ModuleStr = caml_copy_string(ModuleCStr); value ModuleStr = caml_copy_string(ModuleCStr);

LLVMDisposeMessage(ModuleCStr); LLVMDisposeMessage(ModuleCStr);

return ModuleStr; return ModuleStr;

} }

/* llmodule -> string -> unit */

value llvm_set_module_inline_asm(value M, value Asm) {

LLVMSetModuleInlineAsm(Module_val(M), String_val(Asm));

return Val_unit;

}

jberdineUnsubmitted

Not Done

No big deal, but I don't know why this function was moved up a few lines

jberdine: No big deal, but I don't know why this function was moved up a few lines

/* llmodule -> llcontext */

value llvm_get_module_context(value M) {

LLVMContextRef C = LLVMGetModuleContext(Module_val(M));

return to_val(C);

}

/* llmodule -> string */ /* llmodule -> string */

value llvm_get_module_identifier(LLVMModuleRef M) { value llvm_get_module_identifier(value M) {

size_t Len; size_t Len;

const char *Name = LLVMGetModuleIdentifier(M, &Len); const char *Name = LLVMGetModuleIdentifier(Module_val(M), &Len);

return cstr_to_string(Name, (mlsize_t)Len); return cstr_to_string(Name, (mlsize_t)Len);

} }

/* llmodule -> string -> unit */ /* llmodule -> string -> unit */

value llvm_set_module_identifier(LLVMModuleRef M, value Id) { value llvm_set_module_identifier(value M, value Id) {

LLVMSetModuleIdentifier(M, String_val(Id), caml_string_length(Id)); LLVMSetModuleIdentifier(Module_val(M), String_val(Id),

return Val_unit; caml_string_length(Id));

}

/* llmodule -> string -> unit */

value llvm_set_module_inline_asm(LLVMModuleRef M, value Asm) {

LLVMSetModuleInlineAsm(M, String_val(Asm));

return Val_unit; return Val_unit;

} }

/* llmodule -> string -> llmetadata option */ /* llmodule -> string -> llmetadata option */

value llvm_get_module_flag(LLVMModuleRef M, value Key) { value llvm_get_module_flag(value M, value Key) {

return ptr_to_option( return ptr_to_option(LLVMGetModuleFlag(Module_val(M), String_val(Key),

LLVMGetModuleFlag(M, String_val(Key), caml_string_length(Key))); caml_string_length(Key)));

} }

value llvm_add_module_flag(LLVMModuleRef M, LLVMModuleFlagBehavior Behaviour, /* llmodule -> ModuleFlagBehavior.t -> string -> llmetadata -> unit */

value Key, LLVMMetadataRef Val) { value llvm_add_module_flag(value M, value Behaviour, value Key, value Val) {

LLVMAddModuleFlag(M, Int_val(Behaviour), String_val(Key), LLVMAddModuleFlag(Module_val(M), Int_val(Behaviour), String_val(Key),

caml_string_length(Key), Val); caml_string_length(Key), Metadata_val(Val));

return Val_unit; return Val_unit;

} }

/*===-- Types -------------------------------------------------------------===*/ /*===-- Types -------------------------------------------------------------===*/

/* lltype -> TypeKind.t */ /* lltype -> TypeKind.t */

value llvm_classify_type(LLVMTypeRef Ty) { value llvm_classify_type(value Ty) {

return Val_int(LLVMGetTypeKind(Ty)); return Val_int(LLVMGetTypeKind(Type_val(Ty)));

} }

value llvm_type_is_sized(LLVMTypeRef Ty) { /* lltype -> bool */

return Val_bool(LLVMTypeIsSized(Ty)); value llvm_type_is_sized(value Ty) {

return Val_bool(LLVMTypeIsSized(Type_val(Ty)));

} }

/* lltype -> llcontext */ /* lltype -> llcontext */

LLVMContextRef llvm_type_context(LLVMTypeRef Ty) { value llvm_type_context(value Ty) {

return LLVMGetTypeContext(Ty); return to_val(LLVMGetTypeContext(Type_val(Ty)));

} }

/* lltype -> unit */ /* lltype -> unit */

value llvm_dump_type(LLVMTypeRef Val) { value llvm_dump_type(value Val) {

#if !defined(NDEBUG) || defined(LLVM_ENABLE_DUMP) #if !defined(NDEBUG) || defined(LLVM_ENABLE_DUMP)

LLVMDumpType(Val); LLVMDumpType(Type_val(Val));

#else #else

caml_raise_with_arg(*caml_named_value("Llvm.FeatureDisabled"), caml_raise_with_arg(*caml_named_value("Llvm.FeatureDisabled"),

caml_copy_string("dump")); caml_copy_string("dump"));

#endif #endif

return Val_unit; return Val_unit;

} }

/* lltype -> string */ /* lltype -> string */

value llvm_string_of_lltype(LLVMTypeRef M) { value llvm_string_of_lltype(value M) {

char *TypeCStr = LLVMPrintTypeToString(M); CAMLparam0();

value TypeStr = caml_copy_string(TypeCStr); CAMLlocal1(TypeStr);

jberdineUnsubmitted

Not Done

Left over from combining the 2 diffs?

jberdine: Left over from combining the 2 diffs?

char *TypeCStr = LLVMPrintTypeToString(Type_val(M));

TypeStr = caml_copy_string(TypeCStr);

LLVMDisposeMessage(TypeCStr); LLVMDisposeMessage(TypeCStr);

return TypeStr; CAMLreturn(TypeStr);

} }

/*--... Operations on integer types ........................................--*/ /*--... Operations on integer types ........................................--*/

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_i1_type(LLVMContextRef Context) { value llvm_i1_type(value Context) {

return LLVMInt1TypeInContext(Context); return to_val(LLVMInt1TypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_i8_type(LLVMContextRef Context) { value llvm_i8_type(value Context) {

return LLVMInt8TypeInContext(Context); return to_val(LLVMInt8TypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_i16_type(LLVMContextRef Context) { value llvm_i16_type(value Context) {

return LLVMInt16TypeInContext(Context); return to_val(LLVMInt16TypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_i32_type(LLVMContextRef Context) { value llvm_i32_type(value Context) {

return LLVMInt32TypeInContext(Context); return to_val(LLVMInt32TypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_i64_type(LLVMContextRef Context) { value llvm_i64_type(value Context) {

return LLVMInt64TypeInContext(Context); return to_val(LLVMInt64TypeInContext(Context_val(Context)));

} }

/* llcontext -> int -> lltype */ /* llcontext -> int -> lltype */

LLVMTypeRef llvm_integer_type(LLVMContextRef Context, value Width) { value llvm_integer_type(value Context, value Width) {

return LLVMIntTypeInContext(Context, Int_val(Width)); return to_val(LLVMIntTypeInContext(Context_val(Context), Int_val(Width)));

} }

/* lltype -> int */ /* lltype -> int */

value llvm_integer_bitwidth(LLVMTypeRef IntegerTy) { value llvm_integer_bitwidth(value IntegerTy) {

return Val_int(LLVMGetIntTypeWidth(IntegerTy)); return Val_int(LLVMGetIntTypeWidth(Type_val(IntegerTy)));

} }

/*--... Operations on real types ...........................................--*/ /*--... Operations on real types ...........................................--*/

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_float_type(LLVMContextRef Context) { value llvm_float_type(value Context) {

return LLVMFloatTypeInContext(Context); return to_val(LLVMFloatTypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_double_type(LLVMContextRef Context) { value llvm_double_type(value Context) {

return LLVMDoubleTypeInContext(Context); return to_val(LLVMDoubleTypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_x86fp80_type(LLVMContextRef Context) { value llvm_x86fp80_type(value Context) {

return LLVMX86FP80TypeInContext(Context); return to_val(LLVMX86FP80TypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_fp128_type(LLVMContextRef Context) { value llvm_fp128_type(value Context) {

return LLVMFP128TypeInContext(Context); return to_val(LLVMFP128TypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_ppc_fp128_type(LLVMContextRef Context) { value llvm_ppc_fp128_type(value Context) {

return LLVMPPCFP128TypeInContext(Context); return to_val(LLVMPPCFP128TypeInContext(Context_val(Context)));

} }

/*--... Operations on function types .......................................--*/ /*--... Operations on function types .......................................--*/

/* lltype -> lltype array -> lltype */ /* lltype -> lltype array -> lltype */

LLVMTypeRef llvm_function_type(LLVMTypeRef RetTy, value ParamTys) { value llvm_function_type(value RetTy, value ParamTys) {

return LLVMFunctionType(RetTy, (LLVMTypeRef *)ParamTys, Wosize_val(ParamTys), CAMLparam1(ParamTys);

jberdineUnsubmitted

Not Done

I think this CAMLparam is not needed since alloc_temp allocates off the OCaml heap. And if this one is needed, then RetTy should also be a root.

jberdine: I think this CAMLparam is not needed since alloc_temp allocates off the OCaml heap. And if this…

0); size_t len = Wosize_val(ParamTys);

LLVMTypeRef *Temp = alloc_temp(ParamTys);

LLVMTypeRef Type = LLVMFunctionType(Type_val(RetTy), Temp, len, 0);

free(Temp);

CAMLreturn(to_val(Type));

} }

/* lltype -> lltype array -> lltype */ /* lltype -> lltype array -> lltype */

LLVMTypeRef llvm_var_arg_function_type(LLVMTypeRef RetTy, value ParamTys) { value llvm_var_arg_function_type(value RetTy, value ParamTys) {

return LLVMFunctionType(RetTy, (LLVMTypeRef *)ParamTys, Wosize_val(ParamTys), CAMLparam1(ParamTys);

jberdineUnsubmitted

Not Done

Same as function above

jberdine: Same as function above

1); size_t len = Wosize_val(ParamTys);

LLVMTypeRef *Temp = alloc_temp(ParamTys);

LLVMTypeRef Type = LLVMFunctionType(Type_val(RetTy), Temp, len, 1);

free(Temp);

CAMLreturn(to_val(Type));

} }

/* lltype -> bool */ /* lltype -> bool */

value llvm_is_var_arg(LLVMTypeRef FunTy) { value llvm_is_var_arg(value FunTy) {

return Val_bool(LLVMIsFunctionVarArg(FunTy)); return Val_bool(LLVMIsFunctionVarArg(Type_val(FunTy)));

}

/* lltype -> lltype */

value llvm_return_type(value FunTy) {

LLVMTypeRef Type = LLVMGetReturnType(Type_val(FunTy));

return to_val(Type);

} }

/* lltype -> lltype array */ /* lltype -> lltype array */

value llvm_param_types(LLVMTypeRef FunTy) { value llvm_param_types(value FunTy) {

value Tys = caml_alloc_tuple_uninit(LLVMCountParamTypes(FunTy)); CAMLparam0();

LLVMGetParamTypes(FunTy, (LLVMTypeRef *)Op_val(Tys)); CAMLlocal1(Tys);

return Tys; unsigned Length = LLVMCountParamTypes(Type_val(FunTy));

LLVMTypeRef *Temp = malloc(sizeof(LLVMTypeRef) * Length);

if (Temp == NULL)

caml_raise_out_of_memory();

LLVMGetParamTypes(Type_val(FunTy), Temp);

Tys = caml_alloc_tuple(Length);

for (unsigned I = 0; I < Length; ++I) {

Store_field(Tys, I, to_val(Temp[I]));

}

free(Temp);

CAMLreturn(Tys);

} }

jberdineUnsubmitted

Not Done

/* lltype -> lltype array */

value llvm_param_types(value FunTy) {

- CAMLparam1(FunTy);

- CAMLlocal1(Tys);

unsigned Length = LLVMCountParamTypes(Type_val(FunTy));

- LLVMTypeRef *Temp = malloc(sizeof(LLVMTypeRef) * Length);

- LLVMGetParamTypes(Type_val(FunTy), Temp);

- Tys = caml_alloc_tuple(Length);

- for (unsigned I = 0; I < Length; ++I) {

- Store_field(Tys, I, to_val(Temp[I]));

- }

- free(Temp);

- CAMLreturn(Tys);

+ value Tys = caml_alloc_tuple_uninit(Length);

+ LLVMGetParamTypes(Type_val(FunTy), (LLVMTypeRef *)Op_val(Tys));

+ for (unsigned I = 0; I < Length; ++I)

+ Field(Tys, I) = to_val((LLVMTypeRef *)Field(Tys, I));

+ return Tys;

}

/*--... Operations on struct types .........................................--*/

To take this function as a specific example, I think that the suggested change would be a much more minimal change that yields code that does not suffer from naked pointers, is safe in a sequential context, and is probably safe (up to the best of my understanding) in a parallel context.

jberdine: To take this function as a specific example, I think that the suggested change would be a much…

/*--... Operations on struct types .........................................--*/ /*--... Operations on struct types .........................................--*/

/* llcontext -> lltype array -> lltype */ /* llcontext -> lltype array -> lltype */

LLVMTypeRef llvm_struct_type(LLVMContextRef C, value ElementTypes) { value llvm_struct_type(value C, value ElementTypes) {

return LLVMStructTypeInContext(C, (LLVMTypeRef *)ElementTypes, CAMLparam1(ElementTypes);

jberdineUnsubmitted

Not Done

here too

jberdine: here too

Wosize_val(ElementTypes), 0); size_t Length = Wosize_val(ElementTypes);

LLVMTypeRef *Temp = alloc_temp(ElementTypes);

LLVMTypeRef Type = LLVMStructTypeInContext(Context_val(C), Temp, Length, 0);

free(Temp);

CAMLreturn(to_val(Type));

} }

/* llcontext -> lltype array -> lltype */ /* llcontext -> lltype array -> lltype */

LLVMTypeRef llvm_packed_struct_type(LLVMContextRef C, value ElementTypes) { value llvm_packed_struct_type(value C, value ElementTypes) {

return LLVMStructTypeInContext(C, (LLVMTypeRef *)ElementTypes, CAMLparam1(ElementTypes);

jberdineUnsubmitted

Not Done

and here

jberdine: and here

Wosize_val(ElementTypes), 1); size_t Length = Wosize_val(ElementTypes);

LLVMTypeRef *Temp = alloc_temp(ElementTypes);

LLVMTypeRef Type = LLVMStructTypeInContext(Context_val(C), Temp, Length, 1);

free(Temp);

CAMLreturn(to_val(Type));

} }

/* llcontext -> string -> lltype */ /* llcontext -> string -> lltype */

LLVMTypeRef llvm_named_struct_type(LLVMContextRef C, value Name) { value llvm_named_struct_type(value C, value Name) {

return LLVMStructCreateNamed(C, String_val(Name)); return to_val(LLVMStructCreateNamed(Context_val(C), String_val(Name)));

} }

value llvm_struct_set_body(LLVMTypeRef Ty, value ElementTypes, value Packed) { /* lltype -> lltype array -> bool -> unit */

LLVMStructSetBody(Ty, (LLVMTypeRef *)ElementTypes, Wosize_val(ElementTypes), value llvm_struct_set_body(value Ty, value ElementTypes, value Packed) {

Bool_val(Packed)); CAMLparam1(ElementTypes);

jberdineUnsubmitted

Not Done

here

jberdine: here

return Val_unit; unsigned Length = Wosize_val(ElementTypes);

jberdineUnsubmitted

Not Done

Related to the comment on alloc_temp about unsigned, I think it would be clearer if this unsigned was instead mlsize_t, leaving the case to unsigned implicit in the call to LLVMStructSetBody below.

There are several other similar uses, I would look around each call to alloc_temp and at each call to Wosize_val.

jberdine: Related to the comment on `alloc_temp` about `unsigned`, I think it would be clearer if this…

LLVMTypeRef *Temp = alloc_temp(ElementTypes);

LLVMStructSetBody(Type_val(Ty), Temp, Length, Bool_val(Packed));

CAMLreturn(Val_unit);

} }

/* lltype -> string option */ /* lltype -> string option */

value llvm_struct_name(LLVMTypeRef Ty) { value llvm_struct_name(value Ty) {

const char *CStr = LLVMGetStructName(Ty); const char *CStr = LLVMGetStructName(Type_val(Ty));

size_t Len; size_t Len;

if (!CStr) if (!CStr)

return Val_none; return Val_none;

Len = strlen(CStr); Len = strlen(CStr);

return cstr_to_string_option(CStr, Len); return cstr_to_string_option(CStr, Len);

} }

/* lltype -> lltype array */ /* lltype -> lltype array */

value llvm_struct_element_types(LLVMTypeRef StructTy) { value llvm_struct_element_types(value StructTy) {

value Tys = caml_alloc_tuple_uninit(LLVMCountStructElementTypes(StructTy)); CAMLparam0();

LLVMGetStructElementTypes(StructTy, (LLVMTypeRef *)Op_val(Tys)); CAMLlocal1(Tys);

return Tys; unsigned Length = LLVMCountStructElementTypes(Type_val(StructTy));

KakaduUnsubmitted

Not Done

In the function above we can see the usage of size_t instead of unsigned. I'm far from being expert about C++, but heard that size_t should be preferred nowadays. Is it? If you are going to change, than in other functions probably too.

Kakadu: In the function above we can see the usage of size_t instead of unsigned. I'm far from being…

LLVMTypeRef *Temp = malloc(sizeof(LLVMTypeRef) * Length);

KakaduUnsubmitted

Not Done

Could you double check that there is no bug here? See my comment about alloc_temp.

Kakadu: Could you double check that there is no bug here? See my comment about alloc_temp.

alanAuthorUnsubmitted

Done

This code allocates a temporary, intermediate array as a buffer to store the output of LLVMGetStructElementTypes. Then, it copies them over to an OCaml-heap-allocated array (which internally have the same representation as OCaml tuples) and copies over the elements, wrapping them by setting the low bit to 1.

alan: This code allocates a temporary, intermediate array as a buffer to store the output of…

KakaduUnsubmitted

Not Done

Yes, but it looks like alloc_temp accepts array as an argument, but you pass unsigned Length here...

Kakadu: Yes, but it looks like alloc_temp accepts array as an argument, but you pass `unsigned Length`…

jberdineUnsubmitted

Not Done

Yes, alloc_temp should be replaced by a call to malloc here. I made a similar comment on D136537 a while ago but didn't notice that I hadn't submitted it. :-(

jberdine: Yes, `alloc_temp` should be replaced by a call to `malloc` here. I made a similar comment on…

alanAuthorUnsubmitted

Done

Thank you for the catch @Kakadu! That function wasn't tested, and when I added a test, it segfaulted. I've pushed a fix. With a patch this big, it's easy for mistakes to slip under the radar, so it's important to have a lot of eyes reviewing it,

alan: Thank you for the catch @Kakadu! That function wasn't tested, and when I added a test, it…

if (Temp == NULL)

caml_raise_out_of_memory();

LLVMGetStructElementTypes(Type_val(StructTy), Temp);

Tys = caml_alloc_tuple(Length);

for (unsigned I = 0; I < Length; ++I) {

Store_field(Tys, I, to_val(Temp[I]));

}

free(Temp);

CAMLreturn(Tys);

} }

/* lltype -> bool */ /* lltype -> bool */

value llvm_is_packed(LLVMTypeRef StructTy) { value llvm_is_packed(value StructTy) {

return Val_bool(LLVMIsPackedStruct(StructTy)); return Val_bool(LLVMIsPackedStruct(Type_val(StructTy)));

} }

/* lltype -> bool */ /* lltype -> bool */

value llvm_is_opaque(LLVMTypeRef StructTy) { value llvm_is_opaque(value StructTy) {

return Val_bool(LLVMIsOpaqueStruct(StructTy)); return Val_bool(LLVMIsOpaqueStruct(Type_val(StructTy)));

} }

/* lltype -> bool */ /* lltype -> bool */

value llvm_is_literal(LLVMTypeRef StructTy) { value llvm_is_literal(value StructTy) {

return Val_bool(LLVMIsLiteralStruct(StructTy)); return Val_bool(LLVMIsLiteralStruct(Type_val(StructTy)));

} }

/*--... Operations on array, pointer, and vector types .....................--*/ /*--... Operations on array, pointer, and vector types .....................--*/

/* lltype -> lltype array */ /* lltype -> lltype array */

value llvm_subtypes(LLVMTypeRef Ty) { value llvm_subtypes(value Ty) {

unsigned Size = LLVMGetNumContainedTypes(Ty); CAMLparam0();

value Arr = caml_alloc_tuple_uninit(Size); CAMLlocal1(Arr);

LLVMGetSubtypes(Ty, (LLVMTypeRef *)Op_val(Arr)); unsigned Length = LLVMGetNumContainedTypes(Type_val(Ty));

return Arr; Arr = caml_alloc_tuple(Length);

LLVMTypeRef *Temp = malloc(sizeof(LLVMTypeRef) * Length);

if (Temp == NULL)

caml_raise_out_of_memory();

LLVMGetSubtypes(Type_val(Ty), Temp);

for (unsigned I = 0; I < Length; ++I) {

Store_field(Arr, I, to_val(Temp[I]));

}

KakaduUnsubmitted

Not Done

This code looks suspicious. If we are going to return an array, why not to try to use caml_alloc_array function?

Kakadu: This code looks suspicious. If we are going to return an array, why not to try to use…

alanAuthorUnsubmitted

Done

The original code uses caml_alloc_tuple, so that's what I did as well. I think caml_alloc_array (which takes a callback that converts the array elements to OCaml values) would work as well. Thanks for suggesting it.

alan: The original code uses `caml_alloc_tuple`, so that's what I did as well. I think…

alanAuthorUnsubmitted

Done

I investigated more into [caml_alloc_array](https://github.com/ocaml/ocaml/blob/92adb0ff67dea9c14643a1c2eb6eeaf9d48629ef/runtime/alloc.c#L218) and found out that it expects the array to have a 0 sentinel value to mark the end rather than taking the length as an argument. This code can be adapted to use caml_alloc_array if it allocates Length + 1 elements instead and sets the last element to NULL. Do the reviewers think this is a change I should make?

alan: I investigated more into [`caml_alloc_array`](https://github.

KakaduUnsubmitted

Done

Using caml_alloc_array is indeed cumbersome. It should be better to left it as it is. I would move allocation of OCaml array closer to the for-loop, to make more obvious that no other allocations are between these two things, but it is minor improvement.

Kakadu: Using `caml_alloc_array` is indeed cumbersome. It should be better to left it as it is. I would…

free(Temp);

CAMLreturn(Arr);

} }

/* lltype -> int -> lltype */ /* lltype -> int -> lltype */

LLVMTypeRef llvm_array_type(LLVMTypeRef ElementTy, value Count) { value llvm_array_type(value ElementTy, value Count) {

return LLVMArrayType(ElementTy, Int_val(Count)); return to_val(LLVMArrayType(Type_val(ElementTy), Int_val(Count)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_pointer_type(LLVMContextRef C) { value llvm_pointer_type(value C) {

return LLVMPointerTypeInContext(C, 0); LLVMTypeRef Type = LLVMPointerTypeInContext(Context_val(C), 0);

return to_val(Type);

} }

/* llcontext -> int -> lltype */ /* llcontext -> int -> lltype */

LLVMTypeRef llvm_qualified_pointer_type(LLVMContextRef C, value AddressSpace) { value llvm_qualified_pointer_type(value C, value AddressSpace) {

return LLVMPointerTypeInContext(C, Int_val(AddressSpace)); LLVMTypeRef Type =

LLVMPointerTypeInContext(Context_val(C), Int_val(AddressSpace));

return to_val(Type);

} }

/* lltype -> int -> lltype */ /* lltype -> int -> lltype */

LLVMTypeRef llvm_vector_type(LLVMTypeRef ElementTy, value Count) { value llvm_vector_type(value ElementTy, value Count) {

return LLVMVectorType(ElementTy, Int_val(Count)); return to_val(LLVMVectorType(Type_val(ElementTy), Int_val(Count)));

}

/* lltype -> lltype */

value llvm_get_element_type(value Ty) {

return to_val(LLVMGetElementType(Type_val(Ty)));

} }

/* lltype -> int */ /* lltype -> int */

value llvm_array_length(LLVMTypeRef ArrayTy) { value llvm_array_length(value ArrayTy) {

return Val_int(LLVMGetArrayLength2(ArrayTy)); return Val_int(LLVMGetArrayLength2(Type_val(ArrayTy)));

} }

/* lltype -> int */ /* lltype -> int */

value llvm_address_space(LLVMTypeRef PtrTy) { value llvm_address_space(value PtrTy) {

return Val_int(LLVMGetPointerAddressSpace(PtrTy)); return Val_int(LLVMGetPointerAddressSpace(Type_val(PtrTy)));

} }

/* lltype -> int */ /* lltype -> int */

value llvm_vector_size(LLVMTypeRef VectorTy) { value llvm_vector_size(value VectorTy) {

return Val_int(LLVMGetVectorSize(VectorTy)); return Val_int(LLVMGetVectorSize(Type_val(VectorTy)));

} }

/*--... Operations on other types ..........................................--*/ /*--... Operations on other types ..........................................--*/

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_void_type(LLVMContextRef Context) { value llvm_void_type(value Context) {

return LLVMVoidTypeInContext(Context); return to_val(LLVMVoidTypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_label_type(LLVMContextRef Context) { value llvm_label_type(value Context) {

return LLVMLabelTypeInContext(Context); return to_val(LLVMLabelTypeInContext(Context_val(Context)));

} }

/* llcontext -> lltype */ /* llcontext -> lltype */

LLVMTypeRef llvm_x86_mmx_type(LLVMContextRef Context) { value llvm_x86_mmx_type(value Context) {

return LLVMX86MMXTypeInContext(Context); return to_val(LLVMX86MMXTypeInContext(Context_val(Context)));

} }

value llvm_type_by_name(LLVMModuleRef M, value Name) { /* llmodule -> string -> lltype option */

return ptr_to_option(LLVMGetTypeByName(M, String_val(Name))); value llvm_type_by_name(value M, value Name) {

return ptr_to_option(LLVMGetTypeByName(Module_val(M), String_val(Name)));

} }

/*===-- VALUES ------------------------------------------------------------===*/ /*===-- VALUES ------------------------------------------------------------===*/

/* llvalue -> lltype */ /* llvalue -> lltype */

LLVMTypeRef llvm_type_of(LLVMValueRef Val) { return LLVMTypeOf(Val); } value llvm_type_of(value Val) { return to_val(LLVMTypeOf(Value_val(Val))); }

/* keep in sync with ValueKind.t */ /* keep in sync with ValueKind.t */

enum ValueKind { enum ValueKind {

NullValue = 0, NullValue = 0,

Argument, Argument,

BasicBlock, BasicBlock,

InlineAsm, InlineAsm,

MDNode, MDNode,

Show All 14 Lines enum ValueKind {

GlobalIFunc, GlobalIFunc,

GlobalVariable, GlobalVariable,

UndefValue, UndefValue,

PoisonValue, PoisonValue,

Instruction Instruction

}; };

/* llvalue -> ValueKind.t */ /* llvalue -> ValueKind.t */

#define DEFINE_CASE(Val, Kind) \ #define DEFINE_CASE(Val, Kind) \

do {if (LLVMIsA##Kind(Val)) return Val_int(Kind);} while(0) do { \

if (LLVMIsA##Kind(Val)) \

return Val_int(Kind); \

} while (0)

value llvm_classify_value(LLVMValueRef Val) { value llvm_classify_value(value V) {

if (!Val) CAMLparam0();

jberdineUnsubmitted

Not Done

Left over?

jberdine: Left over?

return Val_int(NullValue); CAMLlocal1(Result);

LLVMValueRef Val = Value_val(V);

if (!Val) {

CAMLreturn(Val_int(NullValue));

}

if (LLVMIsAConstant(Val)) { if (LLVMIsAConstant(Val)) {

DEFINE_CASE(Val, BlockAddress); DEFINE_CASE(Val, BlockAddress);

DEFINE_CASE(Val, ConstantAggregateZero); DEFINE_CASE(Val, ConstantAggregateZero);

DEFINE_CASE(Val, ConstantArray); DEFINE_CASE(Val, ConstantArray);

DEFINE_CASE(Val, ConstantDataArray); DEFINE_CASE(Val, ConstantDataArray);

DEFINE_CASE(Val, ConstantDataVector); DEFINE_CASE(Val, ConstantDataVector);

DEFINE_CASE(Val, ConstantExpr); DEFINE_CASE(Val, ConstantExpr);

DEFINE_CASE(Val, ConstantFP); DEFINE_CASE(Val, ConstantFP);

DEFINE_CASE(Val, ConstantInt); DEFINE_CASE(Val, ConstantInt);

DEFINE_CASE(Val, ConstantPointerNull); DEFINE_CASE(Val, ConstantPointerNull);

DEFINE_CASE(Val, ConstantStruct); DEFINE_CASE(Val, ConstantStruct);

DEFINE_CASE(Val, ConstantVector); DEFINE_CASE(Val, ConstantVector);

} }

if (LLVMIsAInstruction(Val)) { if (LLVMIsAInstruction(Val)) {

value result = caml_alloc_small(1, 0); Result = caml_alloc_small(1, 0);

Field(result, 0) = Val_int(LLVMGetInstructionOpcode(Val)); Field(Result, 0) = Val_int(LLVMGetInstructionOpcode(Val));

return result; CAMLreturn(Result);

} }

if (LLVMIsAGlobalValue(Val)) { if (LLVMIsAGlobalValue(Val)) {

DEFINE_CASE(Val, Function); DEFINE_CASE(Val, Function);

DEFINE_CASE(Val, GlobalAlias); DEFINE_CASE(Val, GlobalAlias);

DEFINE_CASE(Val, GlobalIFunc); DEFINE_CASE(Val, GlobalIFunc);

DEFINE_CASE(Val, GlobalVariable); DEFINE_CASE(Val, GlobalVariable);

} }

DEFINE_CASE(Val, Argument); DEFINE_CASE(Val, Argument);

DEFINE_CASE(Val, BasicBlock); DEFINE_CASE(Val, BasicBlock);

DEFINE_CASE(Val, InlineAsm); DEFINE_CASE(Val, InlineAsm);

DEFINE_CASE(Val, MDNode); DEFINE_CASE(Val, MDNode);

DEFINE_CASE(Val, MDString); DEFINE_CASE(Val, MDString);

DEFINE_CASE(Val, UndefValue); DEFINE_CASE(Val, UndefValue);

DEFINE_CASE(Val, PoisonValue); DEFINE_CASE(Val, PoisonValue);

failwith("Unknown Value class"); caml_failwith("Unknown Value class");

} }

/* llvalue -> string */ /* llvalue -> string */

value llvm_value_name(LLVMValueRef Val) { value llvm_value_name(value Val) {

return caml_copy_string(LLVMGetValueName(Val)); return caml_copy_string(LLVMGetValueName(Value_val(Val)));

} }

/* string -> llvalue -> unit */ /* string -> llvalue -> unit */

value llvm_set_value_name(value Name, LLVMValueRef Val) { value llvm_set_value_name(value Name, value Val) {

LLVMSetValueName(Val, String_val(Name)); LLVMSetValueName(Value_val(Val), String_val(Name));

return Val_unit; return Val_unit;

} }

/* llvalue -> unit */ /* llvalue -> unit */

value llvm_dump_value(LLVMValueRef Val) { value llvm_dump_value(value Val) {

LLVMDumpValue(Val); LLVMDumpValue(Value_val(Val));

return Val_unit; return Val_unit;

} }

/* llvalue -> string */ /* llvalue -> string */

value llvm_string_of_llvalue(LLVMValueRef M) { value llvm_string_of_llvalue(value M) {

char *ValueCStr = LLVMPrintValueToString(M); CAMLparam0();

value ValueStr = caml_copy_string(ValueCStr); CAMLlocal1(ValueStr);

jberdineUnsubmitted

Not Done

Left over?

jberdine: Left over?

jberdineUnsubmitted

Not Done

still left over

jberdine: still left over

char *ValueCStr = LLVMPrintValueToString(Value_val(M));

ValueStr = caml_copy_string(ValueCStr);

LLVMDisposeMessage(ValueCStr); LLVMDisposeMessage(ValueCStr);

return ValueStr; CAMLreturn(ValueStr);

} }

/* llvalue -> llvalue -> unit */ /* llvalue -> llvalue -> unit */

value llvm_replace_all_uses_with(LLVMValueRef OldVal, LLVMValueRef NewVal) { value llvm_replace_all_uses_with(value OldVal, value NewVal) {

LLVMReplaceAllUsesWith(OldVal, NewVal); LLVMReplaceAllUsesWith(Value_val(OldVal), Value_val(NewVal));

return Val_unit; return Val_unit;

} }

/*--... Operations on users ................................................--*/ /*--... Operations on users ................................................--*/

/* llvalue -> int -> llvalue */ /* llvalue -> int -> llvalue */

LLVMValueRef llvm_operand(LLVMValueRef V, value I) { value llvm_operand(value V, value I) {

return LLVMGetOperand(V, Int_val(I)); return to_val(LLVMGetOperand(Value_val(V), Int_val(I)));

} }

/* llvalue -> int -> lluse */ /* llvalue -> int -> lluse */

LLVMUseRef llvm_operand_use(LLVMValueRef V, value I) { value llvm_operand_use(value V, value I) {

return LLVMGetOperandUse(V, Int_val(I)); return to_val(LLVMGetOperandUse(Value_val(V), Int_val(I)));

} }

/* llvalue -> int -> llvalue -> unit */ /* llvalue -> int -> llvalue -> unit */

value llvm_set_operand(LLVMValueRef U, value I, LLVMValueRef V) { value llvm_set_operand(value U, value I, value V) {

LLVMSetOperand(U, Int_val(I), V); LLVMSetOperand(Value_val(U), Int_val(I), Value_val(V));

return Val_unit; return Val_unit;

} }

/* llvalue -> int */ /* llvalue -> int */

value llvm_num_operands(LLVMValueRef V) { value llvm_num_operands(value V) {

return Val_int(LLVMGetNumOperands(V)); return Val_int(LLVMGetNumOperands(Value_val(V)));

} }

/* llvalue -> int array */ /* llvalue -> int array */

value llvm_indices(LLVMValueRef Instr) { value llvm_indices(value Instr) {

unsigned n = LLVMGetNumIndices(Instr); CAMLparam0();

const unsigned *Indices = LLVMGetIndices(Instr); CAMLlocal1(Array);

value indices = caml_alloc_tuple_uninit(n); unsigned Length = LLVMGetNumIndices(Value_val(Instr));

for (unsigned i = 0; i < n; i++) { const unsigned *Indices = LLVMGetIndices(Value_val(Instr));

jberdineUnsubmitted

Not Done

It is pre-existing, but while you are at it, it may be clearer and more uniform to change to ++I.

jberdine: It is pre-existing, but while you are at it, it may be clearer and more uniform to change to…

Op_val(indices)[i] = Val_int(Indices[i]); Array = caml_alloc_tuple(Length);

KakaduUnsubmitted

Not Done

Here we again allocate a tuple and return an array. Looks weird.

Kakadu: Here we again allocate a tuple and return an array. Looks weird.

for (unsigned I = 0; I < Length; I++) {

Store_field(Array, I, Val_int(Indices[I]));

} }

return indices; CAMLreturn(Array);

} }

/*--... Operations on constants of (mostly) any type .......................--*/ /*--... Operations on constants of (mostly) any type .......................--*/

/* llvalue -> bool */ /* llvalue -> bool */

value llvm_is_constant(LLVMValueRef Val) { value llvm_is_constant(value Val) {

return Val_bool(LLVMIsConstant(Val)); return Val_bool(LLVMIsConstant(Value_val(Val)));

}

/* lltype -> llvalue */

value llvm_const_null(value Ty) {

LLVMValueRef Value = LLVMConstNull(Type_val(Ty));

return to_val(Value);

}

/* lltype -> llvalue */

value llvm_const_all_ones(value Ty) {

LLVMValueRef Value = LLVMConstAllOnes(Type_val(Ty));

return to_val(Value);

}

/* lltype -> llvalue */

value llvm_const_pointer_null(value Ty) {

LLVMValueRef Value = LLVMConstPointerNull(Type_val(Ty));

return to_val(Value);

}

/* lltype -> llvalue */

value llvm_get_undef(value Ty) {

LLVMValueRef Value = LLVMGetUndef(Type_val(Ty));

return to_val(Value);

}

/* lltype -> llvalue */

value llvm_get_poison(value Ty) {

LLVMValueRef Value = LLVMGetPoison(Type_val(Ty));

return to_val(Value);

} }

/* llvalue -> bool */ /* llvalue -> bool */

value llvm_is_null(LLVMValueRef Val) { return Val_bool(LLVMIsNull(Val)); } value llvm_is_null(value Val) { return Val_bool(LLVMIsNull(Value_val(Val))); }

/* llvalue -> bool */ /* llvalue -> bool */

value llvm_is_undef(LLVMValueRef Val) { return Val_bool(LLVMIsUndef(Val)); } value llvm_is_undef(value Val) { return Val_bool(LLVMIsUndef(Value_val(Val))); }

/* llvalue -> bool */ /* llvalue -> bool */

value llvm_is_poison(LLVMValueRef Val) { return Val_bool(LLVMIsPoison(Val)); } value llvm_is_poison(value Val) {

return Val_bool(LLVMIsPoison(Value_val(Val)));

}

/* llvalue -> Opcode.t */ /* llvalue -> Opcode.t */

value llvm_constexpr_get_opcode(LLVMValueRef Val) { value llvm_constexpr_get_opcode(value Val) {

return LLVMIsAConstantExpr(Val) ? Val_int(LLVMGetConstOpcode(Val)) return LLVMIsAConstantExpr(Value_val(Val))

? Val_int(LLVMGetConstOpcode(Value_val(Val)))

: Val_int(0); : Val_int(0);

} }

/*--... Operations on instructions .........................................--*/ /*--... Operations on instructions .........................................--*/

/* llvalue -> bool */ /* llvalue -> bool */

value llvm_has_metadata(LLVMValueRef Val) { value llvm_has_metadata(value Val) {

return Val_bool(LLVMHasMetadata(Val)); return Val_bool(LLVMHasMetadata(Value_val(Val)));

} }

/* llvalue -> int -> llvalue option */ /* llvalue -> int -> llvalue option */

value llvm_metadata(LLVMValueRef Val, value MDKindID) { value llvm_metadata(value Val, value MDKindID) {

return ptr_to_option(LLVMGetMetadata(Val, Int_val(MDKindID))); return ptr_to_option(LLVMGetMetadata(Value_val(Val), Int_val(MDKindID)));

} }

/* llvalue -> int -> llvalue -> unit */ /* llvalue -> int -> llvalue -> unit */

value llvm_set_metadata(LLVMValueRef Val, value MDKindID, LLVMValueRef MD) { value llvm_set_metadata(value Val, value MDKindID, value MD) {

LLVMSetMetadata(Val, Int_val(MDKindID), MD); LLVMSetMetadata(Value_val(Val), Int_val(MDKindID), Value_val(MD));

return Val_unit; return Val_unit;

} }

/* llvalue -> int -> unit */ /* llvalue -> int -> unit */

value llvm_clear_metadata(LLVMValueRef Val, value MDKindID) { value llvm_clear_metadata(value Val, value MDKindID) {

LLVMSetMetadata(Val, Int_val(MDKindID), NULL); LLVMSetMetadata(Value_val(Val), Int_val(MDKindID), NULL);

return Val_unit; return Val_unit;

} }

/*--... Operations on metadata .............................................--*/ /*--... Operations on metadata .............................................--*/

/* llcontext -> string -> llvalue */ /* llcontext -> string -> llvalue */

LLVMValueRef llvm_mdstring(LLVMContextRef C, value S) { value llvm_mdstring(value C, value S) {

return LLVMMDStringInContext(C, String_val(S), caml_string_length(S)); return to_val(LLVMMDStringInContext(Context_val(C), String_val(S),

caml_string_length(S)));

} }

/* llcontext -> llvalue array -> llvalue */ /* llcontext -> llvalue array -> llvalue */

LLVMValueRef llvm_mdnode(LLVMContextRef C, value ElementVals) { value llvm_mdnode(value C, value ElementVals) {

return LLVMMDNodeInContext(C, (LLVMValueRef *)Op_val(ElementVals), unsigned Length = Wosize_val(ElementVals);

Wosize_val(ElementVals)); LLVMValueRef *Temp = alloc_temp(ElementVals);

LLVMValueRef Value = LLVMMDNodeInContext(Context_val(C), Temp, Length);

free(Temp);

return to_val(Value);

} }

/* llcontext -> llvalue */ /* llcontext -> llvalue */

LLVMValueRef llvm_mdnull(LLVMContextRef C) { return NULL; } value llvm_mdnull(value C) { return to_val(NULL); }

/* llvalue -> string option */ /* llvalue -> string option */

value llvm_get_mdstring(LLVMValueRef V) { value llvm_get_mdstring(value V) {

unsigned Len; unsigned Len;

const char *CStr = LLVMGetMDString(V, &Len); const char *CStr = LLVMGetMDString(Value_val(V), &Len);

return cstr_to_string_option(CStr, Len); return cstr_to_string_option(CStr, Len);

} }

value llvm_get_mdnode_operands(LLVMValueRef V) { /* llvalue -> llvalue array */

unsigned int n = LLVMGetMDNodeNumOperands(V); value llvm_get_mdnode_operands(value Value) {

value Operands = caml_alloc_tuple_uninit(n); CAMLparam0();

LLVMGetMDNodeOperands(V, (LLVMValueRef *)Op_val(Operands)); CAMLlocal1(Operands);

return Operands; LLVMValueRef V = Value_val(Value);

unsigned Length = LLVMGetMDNodeNumOperands(V);

Operands = caml_alloc_tuple(Length);

LLVMValueRef *Temp = malloc(sizeof(LLVMValueRef) * Length);

if (Temp == NULL)

caml_raise_out_of_memory();

LLVMGetMDNodeOperands(V, Temp);

for (unsigned I = 0; I < Length; ++I) {

Store_field(Operands, I, to_val(Temp[I]));

}

free(Temp);

CAMLreturn(Operands);

} }

/* llmodule -> string -> llvalue array */ /* llmodule -> string -> llvalue array */

value llvm_get_namedmd(LLVMModuleRef M, value Name) { value llvm_get_namedmd(value M, value Name) {

CAMLparam1(Name); CAMLparam1(Name);

jberdineUnsubmitted

Not Done

This CAMLparam needs to be kept since Name needs to survive the allocation of Nodes.

jberdine: This CAMLparam needs to be kept since Name needs to survive the allocation of Nodes.

value Nodes = caml_alloc_tuple_uninit( CAMLlocal1(Nodes);

LLVMGetNamedMetadataNumOperands(M, String_val(Name))); unsigned Length =

LLVMGetNamedMetadataOperands(M, String_val(Name), LLVMGetNamedMetadataNumOperands(Module_val(M), String_val(Name));

(LLVMValueRef *)Op_val(Nodes)); Nodes = caml_alloc_tuple(Length);

LLVMValueRef *Temp = malloc(sizeof(LLVMValueRef) * Length);

if (Temp == NULL)

caml_raise_out_of_memory();

LLVMGetNamedMetadataOperands(Module_val(M), String_val(Name), Temp);

for (unsigned I = 0; I < Length; ++I) {

Store_field(Nodes, I, to_val(Temp[I]));

}

free(Temp);

CAMLreturn(Nodes); CAMLreturn(Nodes);

} }

/* llmodule -> string -> llvalue -> unit */ /* llmodule -> string -> llvalue -> unit */

value llvm_append_namedmd(LLVMModuleRef M, value Name, LLVMValueRef Val) { value llvm_append_namedmd(value M, value Name, value Val) {

LLVMAddNamedMetadataOperand(M, String_val(Name), Val); LLVMAddNamedMetadataOperand(Module_val(M), String_val(Name), Value_val(Val));

return Val_unit; return Val_unit;

} }

/* llvalue -> llmetadata */ /* llvalue -> llmetadata */

LLVMMetadataRef llvm_value_as_metadata(LLVMValueRef Val) { value llvm_value_as_metadata(value Val) {

return LLVMValueAsMetadata(Val); return to_val(LLVMValueAsMetadata(Value_val(Val)));

} }

/* llcontext -> llmetadata -> llvalue */ /* llcontext -> llmetadata -> llvalue */

LLVMValueRef llvm_metadata_as_value(LLVMContextRef C, LLVMMetadataRef MD) { value llvm_metadata_as_value(value C, value MD) {

return LLVMMetadataAsValue(C, MD); return to_val(LLVMMetadataAsValue(Context_val(C), Metadata_val(MD)));

} }

/*--... Operations on scalar constants .....................................--*/ /*--... Operations on scalar constants .....................................--*/

/* lltype -> int -> llvalue */ /* lltype -> int -> llvalue */

LLVMValueRef llvm_const_int(LLVMTypeRef IntTy, value N) { value llvm_const_int(value IntTy, value N) {

return LLVMConstInt(IntTy, (long long)Long_val(N), 1); return to_val(LLVMConstInt(Type_val(IntTy), (long long)Long_val(N), 1));

} }

/* lltype -> Int64.t -> bool -> llvalue */ /* lltype -> Int64.t -> bool -> llvalue */

LLVMValueRef llvm_const_of_int64(LLVMTypeRef IntTy, value N, value SExt) { value llvm_const_of_int64(value IntTy, value N, value SExt) {

return LLVMConstInt(IntTy, Int64_val(N), Bool_val(SExt)); return to_val(LLVMConstInt(Type_val(IntTy), Int64_val(N), Bool_val(SExt)));

} }

/* llvalue -> Int64.t */ /* llvalue -> Int64.t option */

value llvm_int64_of_const(LLVMValueRef Const) { value llvm_int64_of_const(value C) {

LLVMValueRef Const = Value_val(C);

if (!(LLVMIsAConstantInt(Const)) || if (!(LLVMIsAConstantInt(Const)) ||

!(LLVMGetIntTypeWidth(LLVMTypeOf(Const)) <= 64)) !(LLVMGetIntTypeWidth(LLVMTypeOf(Const)) <= 64))

return Val_none; return Val_none;

return caml_alloc_some(caml_copy_int64(LLVMConstIntGetSExtValue(Const))); return caml_alloc_some(caml_copy_int64(LLVMConstIntGetSExtValue(Const)));

} }

/* lltype -> string -> int -> llvalue */ /* lltype -> string -> int -> llvalue */

LLVMValueRef llvm_const_int_of_string(LLVMTypeRef IntTy, value S, value Radix) { value llvm_const_int_of_string(value IntTy, value S, value Radix) {

return LLVMConstIntOfStringAndSize(IntTy, String_val(S), return to_val(LLVMConstIntOfStringAndSize(

caml_string_length(S), Int_val(Radix)); Type_val(IntTy), String_val(S), caml_string_length(S), Int_val(Radix)));

} }

/* lltype -> float -> llvalue */ /* lltype -> float -> llvalue */

LLVMValueRef llvm_const_float(LLVMTypeRef RealTy, value N) { value llvm_const_float(value RealTy, value N) {

return LLVMConstReal(RealTy, Double_val(N)); return to_val(LLVMConstReal(Type_val(RealTy), Double_val(N)));

} }

/* llvalue -> float */ /* llvalue -> float option */

value llvm_float_of_const(LLVMValueRef Const) { value llvm_float_of_const(value C) {

LLVMValueRef Const = Value_val(C);

LLVMBool LosesInfo; LLVMBool LosesInfo;

double Result; double Result;

if (!LLVMIsAConstantFP(Const)) if (!LLVMIsAConstantFP(Const))

return Val_none; return Val_none;

Result = LLVMConstRealGetDouble(Const, &LosesInfo); Result = LLVMConstRealGetDouble(Const, &LosesInfo);

if (LosesInfo) if (LosesInfo)

return Val_none; return Val_none;

return caml_alloc_some(caml_copy_double(Result)); return caml_alloc_some(caml_copy_double(Result));

} }

/* lltype -> string -> llvalue */ /* lltype -> string -> llvalue */

LLVMValueRef llvm_const_float_of_string(LLVMTypeRef RealTy, value S) { value llvm_const_float_of_string(value RealTy, value S) {

return LLVMConstRealOfStringAndSize(RealTy, String_val(S), return to_val(LLVMConstRealOfStringAndSize(Type_val(RealTy), String_val(S),

caml_string_length(S)); caml_string_length(S)));

} }

/*--... Operations on composite constants ..................................--*/ /*--... Operations on composite constants ..................................--*/

/* llcontext -> string -> llvalue */ /* llcontext -> string -> llvalue */

LLVMValueRef llvm_const_string(LLVMContextRef Context, value Str, value llvm_const_string(value Context, value Str) {

value NullTerminate) { return to_val(LLVMConstStringInContext(Context_val(Context), String_val(Str),

return LLVMConstStringInContext(Context, String_val(Str), string_length(Str), caml_string_length(Str), 1));

1);

} }

/* llcontext -> string -> llvalue */ /* llcontext -> string -> llvalue */

LLVMValueRef llvm_const_stringz(LLVMContextRef Context, value Str, value llvm_const_stringz(value Context, value Str) {

value NullTerminate) { return to_val(LLVMConstStringInContext(Context_val(Context), String_val(Str),

return LLVMConstStringInContext(Context, String_val(Str), string_length(Str), caml_string_length(Str), 0));

0);

} }

/* lltype -> llvalue array -> llvalue */ /* lltype -> llvalue array -> llvalue */

LLVMValueRef llvm_const_array(LLVMTypeRef ElementTy, value ElementVals) { value llvm_const_array(value ElementTy, value ElementVals) {

return LLVMConstArray(ElementTy, (LLVMValueRef *)Op_val(ElementVals), unsigned Length = Wosize_val(ElementVals);

Wosize_val(ElementVals)); LLVMValueRef *Temp = alloc_temp(ElementVals);

LLVMValueRef Value = LLVMConstArray(Type_val(ElementTy), Temp, Length);

free(Temp);

return to_val(Value);

} }

/* llcontext -> llvalue array -> llvalue */ /* llcontext -> llvalue array -> llvalue */

LLVMValueRef llvm_const_struct(LLVMContextRef C, value ElementVals) { value llvm_const_struct(value C, value ElementVals) {

return LLVMConstStructInContext(C, (LLVMValueRef *)Op_val(ElementVals), unsigned Length = Wosize_val(ElementVals);

Wosize_val(ElementVals), 0); LLVMValueRef *Temp = alloc_temp(ElementVals);

LLVMValueRef Value =

LLVMConstStructInContext(Context_val(C), Temp, Length, 0);

free(Temp);

return to_val(Value);

} }

/* lltype -> llvalue array -> llvalue */ /* lltype -> llvalue array -> llvalue */

LLVMValueRef llvm_const_named_struct(LLVMTypeRef Ty, value ElementVals) { value llvm_const_named_struct(value Ty, value ElementVals) {

return LLVMConstNamedStruct(Ty, (LLVMValueRef *)Op_val(ElementVals), unsigned Length = Wosize_val(ElementVals);

Wosize_val(ElementVals)); LLVMValueRef *Temp = alloc_temp(ElementVals);

LLVMValueRef Value =

LLVMConstNamedStruct(Type_val(Ty), (LLVMValueRef *)Temp, Length);

free(Temp);

return to_val(Value);

} }

/* llcontext -> llvalue array -> llvalue */ /* llcontext -> llvalue array -> llvalue */

LLVMValueRef llvm_const_packed_struct(LLVMContextRef C, value ElementVals) { value llvm_const_packed_struct(value C, value ElementVals) {

return LLVMConstStructInContext(C, (LLVMValueRef *)Op_val(ElementVals), unsigned Length = Wosize_val(ElementVals);

Wosize_val(ElementVals), 1); LLVMValueRef *Temp = alloc_temp(ElementVals);

LLVMValueRef Value =

LLVMConstStructInContext(Context_val(C), Temp, Length, 1);

free(Temp);

return to_val(Value);

} }

/* llvalue array -> llvalue */ /* llvalue array -> llvalue */

LLVMValueRef llvm_const_vector(value ElementVals) { value llvm_const_vector(value ElementVals) {

return LLVMConstVector((LLVMValueRef *)Op_val(ElementVals), unsigned Length = Wosize_val(ElementVals);

Wosize_val(ElementVals)); LLVMValueRef *Temp = alloc_temp(ElementVals);

LLVMValueRef Value = LLVMConstVector(Temp, Length);

free(Temp);

return to_val(Value);

} }

/* llvalue -> string option */ /* llvalue -> string option */

value llvm_string_of_const(LLVMValueRef Const) { value llvm_string_of_const(value C) {

size_t Len; size_t Len;

const char *CStr; const char *CStr;

LLVMValueRef Const = Value_val(C);

if (!LLVMIsAConstantDataSequential(Const) || !LLVMIsConstantString(Const)) if (!LLVMIsAConstantDataSequential(Const) || !LLVMIsConstantString(Const))

return Val_none; return Val_none;

CStr = LLVMGetAsString(Const, &Len); CStr = LLVMGetAsString(Const, &Len);

return cstr_to_string_option(CStr, Len); return cstr_to_string_option(CStr, Len);

} }

/* llvalue -> int -> llvalue option */ /* llvalue -> int -> llvalue option */

value llvm_aggregate_element(LLVMValueRef Const, value N) { value llvm_aggregate_element(value Const, value N) {

return ptr_to_option(LLVMGetAggregateElement(Const, Int_val(N))); return ptr_to_option(LLVMGetAggregateElement(Value_val(Const), Int_val(N)));

} }

/*--... Constant expressions ...............................................--*/ /*--... Constant expressions ...............................................--*/

/* lltype -> llvalue */

value llvm_align_of(value Type) {

LLVMValueRef Value = LLVMAlignOf(Type_val(Type));

return to_val(Value);

}

/* lltype -> llvalue */

value llvm_size_of(value Type) {

LLVMValueRef Value = LLVMSizeOf(Type_val(Type));

return to_val(Value);

}

/* llvalue -> llvalue */

value llvm_const_neg(value Value) {

LLVMValueRef NegValue = LLVMConstNeg(Value_val(Value));

return to_val(NegValue);

}

/* llvalue -> llvalue */

value llvm_const_nsw_neg(value Value) {

LLVMValueRef NegValue = LLVMConstNSWNeg(Value_val(Value));

return to_val(NegValue);

}

/* llvalue -> llvalue */

value llvm_const_nuw_neg(value Value) {

LLVMValueRef NegValue = LLVMConstNUWNeg(Value_val(Value));

return to_val(NegValue);

}

/* llvalue -> llvalue */

value llvm_const_not(value Value) {

LLVMValueRef NotValue = LLVMConstNot(Value_val(Value));

return to_val(NotValue);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_add(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstAdd(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_nsw_add(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstNSWAdd(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_nuw_add(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstNUWAdd(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_sub(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstSub(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_nsw_sub(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstNSWSub(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_nuw_sub(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstNUWSub(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_mul(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstMul(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_nsw_mul(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstNSWMul(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_nuw_mul(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstNUWMul(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_and(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstAnd(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_or(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstOr(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_xor(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstXor(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* Icmp.t -> llvalue -> llvalue -> llvalue */ /* Icmp.t -> llvalue -> llvalue -> llvalue */

LLVMValueRef llvm_const_icmp(value Pred, LLVMValueRef LHSConstant, value llvm_const_icmp(value Pred, value LHSConstant, value RHSConstant) {

LLVMValueRef RHSConstant) { return to_val(LLVMConstICmp(Int_val(Pred) + LLVMIntEQ, Value_val(LHSConstant),

return LLVMConstICmp(Int_val(Pred) + LLVMIntEQ, LHSConstant, RHSConstant); Value_val(RHSConstant)));

} }

/* Fcmp.t -> llvalue -> llvalue -> llvalue */ /* Fcmp.t -> llvalue -> llvalue -> llvalue */

LLVMValueRef llvm_const_fcmp(value Pred, LLVMValueRef LHSConstant, value llvm_const_fcmp(value Pred, value LHSConstant, value RHSConstant) {

LLVMValueRef RHSConstant) { return to_val(LLVMConstFCmp(Int_val(Pred), Value_val(LHSConstant),

return LLVMConstFCmp(Int_val(Pred), LHSConstant, RHSConstant); Value_val(RHSConstant)));

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_shl(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstShl(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

KakaduUnsubmitted

Not Done

I'm wondering... Is it a good idea to define a macro for more short definitions of binary operations above?

Kakadu: I'm wondering... Is it a good idea to define a macro for more short definitions of binary…

alanAuthorUnsubmitted

Done

For this patch, I just did things by-hand. I think this is simpler than a macro for now, as a lot of this code wraps functions by hand. If you really want a macro, I can change it to one.

alan: For this patch, I just did things by-hand. I think this is simpler than a macro for now, as a…

KakaduUnsubmitted

Not Done

Nonono, this patch is OK without a macro.

Kakadu: Nonono, this patch is OK without a macro.

/* llvalue -> llvalue -> llvalue */

value llvm_const_lshr(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstLShr(Value_val(LHS), Value_val(RHS));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_ashr(value LHS, value RHS) {

LLVMValueRef Value = LLVMConstAShr(Value_val(LHS), Value_val(RHS));

return to_val(Value);

} }

/* lltype -> llvalue -> llvalue array -> llvalue */ /* lltype -> llvalue -> llvalue array -> llvalue */

LLVMValueRef llvm_const_gep(LLVMTypeRef Ty, LLVMValueRef ConstantVal, value llvm_const_gep(value Ty, value ConstantVal, value Indices) {

value Indices) { unsigned Length = Wosize_val(Indices);

return LLVMConstGEP2(Ty, ConstantVal, (LLVMValueRef *)Op_val(Indices), LLVMValueRef *Temp = alloc_temp(Indices);

Wosize_val(Indices)); LLVMValueRef Value =

LLVMConstGEP2(Type_val(Ty), Value_val(ConstantVal), Temp, Length);

free(Temp);

return to_val(Value);

}

/* lltype -> llvalue -> llvalue array -> llvalue */

value llvm_const_in_bounds_gep(value Ty, value ConstantVal, value Indices) {

unsigned Length = Wosize_val(Indices);

LLVMValueRef *Temp = alloc_temp(Indices);

LLVMValueRef Value =

LLVMConstInBoundsGEP2(Type_val(Ty), Value_val(ConstantVal), Temp, Length);

free(Temp);

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_trunc(value CV, value T) {

LLVMValueRef Value = LLVMConstTrunc(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_sext(value CV, value T) {

LLVMValueRef Value = LLVMConstSExt(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_zext(value CV, value T) {

LLVMValueRef Value = LLVMConstZExt(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_fptrunc(value CV, value T) {

LLVMValueRef Value = LLVMConstFPTrunc(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_fpext(value CV, value T) {

LLVMValueRef Value = LLVMConstFPExt(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_uitofp(value CV, value T) {

LLVMValueRef Value = LLVMConstUIToFP(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_sitofp(value CV, value T) {

LLVMValueRef Value = LLVMConstSIToFP(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_fptoui(value CV, value T) {

LLVMValueRef Value = LLVMConstFPToUI(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_fptosi(value CV, value T) {

LLVMValueRef Value = LLVMConstFPToSI(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_ptrtoint(value CV, value T) {

LLVMValueRef Value = LLVMConstPtrToInt(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_inttoptr(value CV, value T) {

LLVMValueRef Value = LLVMConstIntToPtr(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_bitcast(value CV, value T) {

LLVMValueRef Value = LLVMConstBitCast(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_zext_or_bitcast(value CV, value T) {

LLVMValueRef Value = LLVMConstZExtOrBitCast(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> lltype -> llvalue */

value llvm_const_sext_or_bitcast(value CV, value T) {

LLVMValueRef Value = LLVMConstSExtOrBitCast(Value_val(CV), Type_val(T));

return to_val(Value);

} }

/* llvalue -> llvalue array -> llvalue */ /* llvalue -> lltype -> llvalue */

LLVMValueRef llvm_const_in_bounds_gep(LLVMTypeRef Ty, LLVMValueRef ConstantVal, value llvm_const_trunc_or_bitcast(value CV, value T) {

value Indices) { LLVMValueRef Value = LLVMConstTruncOrBitCast(Value_val(CV), Type_val(T));

return LLVMConstInBoundsGEP2(Ty, ConstantVal, (LLVMValueRef *)Op_val(Indices), return to_val(Value);

Wosize_val(Indices)); }

/* llvalue -> lltype -> llvalue */

value llvm_const_pointercast(value CV, value T) {

LLVMValueRef Value = LLVMConstPointerCast(Value_val(CV), Type_val(T));

return to_val(Value);

} }

/* llvalue -> lltype -> is_signed:bool -> llvalue */ /* llvalue -> lltype -> is_signed:bool -> llvalue */

LLVMValueRef llvm_const_intcast(LLVMValueRef CV, LLVMTypeRef T, value llvm_const_intcast(value CV, value T, value IsSigned) {

value IsSigned) { return to_val(

return LLVMConstIntCast(CV, T, Bool_val(IsSigned)); LLVMConstIntCast(Value_val(CV), Type_val(T), Bool_val(IsSigned)));

}

/* llvalue -> lltype -> llvalue */

value llvm_const_fpcast(value CV, value T) {

LLVMValueRef Value = LLVMConstFPCast(Value_val(CV), Type_val(T));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue -> llvalue */

value llvm_const_select(value Cond, value IfTrue, value IfFalse) {

LLVMValueRef Value =

LLVMConstSelect(Value_val(Cond), Value_val(IfTrue), Value_val(IfFalse));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue */

value llvm_const_extractelement(value V, value I) {

LLVMValueRef Value = LLVMConstExtractElement(Value_val(V), Value_val(I));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue -> llvalue */

value llvm_const_insertelement(value V, value E, value I) {

LLVMValueRef Value =

LLVMConstInsertElement(Value_val(V), Value_val(E), Value_val(I));

return to_val(Value);

}

/* llvalue -> llvalue -> llvalue -> llvalue */

value llvm_const_shufflevector(value VA, value VB, value Mask) {

LLVMValueRef Value =

LLVMConstShuffleVector(Value_val(VA), Value_val(VB), Value_val(Mask));

return to_val(Value);

} }

/* lltype -> string -> string -> bool -> bool -> llvalue */ /* lltype -> string -> string -> bool -> bool -> llvalue */

LLVMValueRef llvm_const_inline_asm(LLVMTypeRef Ty, value Asm, value Constraints, value llvm_const_inline_asm(value Ty, value Asm, value Constraints,

value HasSideEffects, value IsAlignStack) { value HasSideEffects, value IsAlignStack) {

return LLVMConstInlineAsm(Ty, String_val(Asm), String_val(Constraints), return to_val(

Bool_val(HasSideEffects), Bool_val(IsAlignStack)); LLVMConstInlineAsm(Type_val(Ty), String_val(Asm), String_val(Constraints),

Bool_val(HasSideEffects), Bool_val(IsAlignStack)));

}

/* llvalue -> llbasicblock -> llvalue */

value llvm_blockaddress(value V, value B) {

LLVMValueRef Value = LLVMBlockAddress(Value_val(V), BasicBlock_val(B));

return to_val(Value);

} }

/*--... Operations on global variables, functions, and aliases (globals) ...--*/ /*--... Operations on global variables, functions, and aliases (globals) ...--*/

/* llvalue -> llmodule */

value llvm_global_parent(value Value) {

LLVMModuleRef Module = LLVMGetGlobalParent(Value_val(Value));

return to_val(Module);

}

/* llvalue -> bool */ /* llvalue -> bool */

value llvm_is_declaration(LLVMValueRef Global) { value llvm_is_declaration(value Global) {

return Val_bool(LLVMIsDeclaration(Global)); return Val_bool(LLVMIsDeclaration(Value_val(Global)));

} }

/* llvalue -> Linkage.t */ /* llvalue -> Linkage.t */

value llvm_linkage(LLVMValueRef Global) { value llvm_linkage(value Global) {

return Val_int(LLVMGetLinkage(Global)); return Val_int(LLVMGetLinkage(Value_val(Global)));

} }

/* Linkage.t -> llvalue -> unit */ /* Linkage.t -> llvalue -> unit */

value llvm_set_linkage(value Linkage, LLVMValueRef Global) { value llvm_set_linkage(value Linkage, value Global) {

LLVMSetLinkage(Global, Int_val(Linkage)); LLVMSetLinkage(Value_val(Global), Int_val(Linkage));

return Val_unit; return Val_unit;

} }

/* llvalue -> bool */ /* llvalue -> bool */

value llvm_unnamed_addr(LLVMValueRef Global) { value llvm_unnamed_addr(value Global) {

return Val_bool(LLVMHasUnnamedAddr(Global)); return Val_bool(LLVMHasUnnamedAddr(Value_val(Global)));

} }

/* bool -> llvalue -> unit */ /* bool -> llvalue -> unit */

value llvm_set_unnamed_addr(value UseUnnamedAddr, LLVMValueRef Global) { value llvm_set_unnamed_addr(value UseUnnamedAddr, value Global) {

LLVMSetUnnamedAddr(Global, Bool_val(UseUnnamedAddr)); LLVMSetUnnamedAddr(Value_val(Global), Bool_val(UseUnnamedAddr));

return Val_unit; return Val_unit;

} }

/* llvalue -> string */ /* llvalue -> string */

value llvm_section(LLVMValueRef Global) { value llvm_section(value Global) {

return caml_copy_string(LLVMGetSection(Global)); return caml_copy_string(LLVMGetSection(Value_val(Global)));

} }

/* string -> llvalue -> unit */ /* string -> llvalue -> unit */

value llvm_set_section(value Section, LLVMValueRef Global) { value llvm_set_section(value Section, value Global) {

LLVMSetSection(Global, String_val(Section)); LLVMSetSection(Value_val(Global), String_val(Section));

return Val_unit; return Val_unit;

} }

/* llvalue -> Visibility.t */ /* llvalue -> Visibility.t */

value llvm_visibility(LLVMValueRef Global) { value llvm_visibility(value Global) {

return Val_int(LLVMGetVisibility(Global)); return Val_int(LLVMGetVisibility(Value_val(Global)));

} }

/* Visibility.t -> llvalue -> unit */ /* Visibility.t -> llvalue -> unit */

value llvm_set_visibility(value Viz, LLVMValueRef Global) { value llvm_set_visibility(value Viz, value Global) {

LLVMSetVisibility(Global, Int_val(Viz)); LLVMSetVisibility(Value_val(Global), Int_val(Viz));

return Val_unit; return Val_unit;

} }

/* llvalue -> DLLStorageClass.t */ /* llvalue -> DLLStorageClass.t */

value llvm_dll_storage_class(LLVMValueRef Global) { value llvm_dll_storage_class(value Global) {

return Val_int(LLVMGetDLLStorageClass(Global)); return Val_int(LLVMGetDLLStorageClass(Value_val(Global)));

} }

/* DLLStorageClass.t -> llvalue -> unit */ /* DLLStorageClass.t -> llvalue -> unit */

value llvm_set_dll_storage_class(value Viz, LLVMValueRef Global) { value llvm_set_dll_storage_class(value Viz, value Global) {

LLVMSetDLLStorageClass(Global, Int_val(Viz)); LLVMSetDLLStorageClass(Value_val(Global), Int_val(Viz));

return Val_unit; return Val_unit;

} }

/* llvalue -> int */ /* llvalue -> int */

value llvm_alignment(LLVMValueRef Global) { value llvm_alignment(value Global) {

return Val_int(LLVMGetAlignment(Global)); return Val_int(LLVMGetAlignment(Value_val(Global)));

} }

/* int -> llvalue -> unit */ /* int -> llvalue -> unit */

value llvm_set_alignment(value Bytes, LLVMValueRef Global) { value llvm_set_alignment(value Bytes, value Global) {

LLVMSetAlignment(Global, Int_val(Bytes)); LLVMSetAlignment(Value_val(Global), Int_val(Bytes));

return Val_unit; return Val_unit;

} }

/* llvalue -> (llmdkind * llmetadata) array */ /* llvalue -> (llmdkind * llmetadata) array */

value llvm_global_copy_all_metadata(LLVMValueRef Global) { value llvm_global_copy_all_metadata(value Global) {

CAMLparam0(); CAMLparam0();

CAMLlocal1(Array); CAMLlocal1(Array);

size_t NumEntries; size_t NumEntries;

LLVMValueMetadataEntry *Entries = LLVMValueMetadataEntry *Entries =

LLVMGlobalCopyAllMetadata(Global, &NumEntries); LLVMGlobalCopyAllMetadata(Value_val(Global), &NumEntries);

Array = caml_alloc_tuple(NumEntries); Array = caml_alloc_tuple(NumEntries);

for (int i = 0; i < NumEntries; i++) { for (unsigned I = 0; I < NumEntries; ++I) {

value Metadata = to_val(LLVMValueMetadataEntriesGetMetadata(Entries, I));

value Pair = caml_alloc_small(2, 0); value Pair = caml_alloc_small(2, 0);

Field(Pair, 0) = Val_int(LLVMValueMetadataEntriesGetKind(Entries, i)); Field(Pair, 0) = Val_int(LLVMValueMetadataEntriesGetKind(Entries, I));

Field(Pair, 1) = (value)LLVMValueMetadataEntriesGetMetadata(Entries, i); Field(Pair, 1) = Metadata;

Store_field(Array, i, Pair); Store_field(Array, I, Pair);

} }

LLVMDisposeValueMetadataEntries(Entries); LLVMDisposeValueMetadataEntries(Entries);

CAMLreturn(Array); CAMLreturn(Array);

} }

/*--... Operations on uses .................................................--*/ /*--... Operations on uses .................................................--*/

/* llvalue -> lluse option */ /* llvalue -> lluse option */

value llvm_use_begin(LLVMValueRef Val) { value llvm_use_begin(value Val) {

return ptr_to_option(LLVMGetFirstUse(Val)); return ptr_to_option(LLVMGetFirstUse(Value_val(Val)));

} }

/* lluse -> lluse option */ /* lluse -> lluse option */

value llvm_use_succ(LLVMUseRef U) { return ptr_to_option(LLVMGetNextUse(U)); } value llvm_use_succ(value U) {

return ptr_to_option(LLVMGetNextUse(Use_val(U)));

}

/* lluse -> llvalue */ /* lluse -> llvalue */

LLVMValueRef llvm_user(LLVMUseRef UR) { return LLVMGetUser(UR); } value llvm_user(value UR) { return to_val(LLVMGetUser(Use_val(UR))); }

/* lluse -> llvalue */ /* lluse -> llvalue */

LLVMValueRef llvm_used_value(LLVMUseRef UR) { return LLVMGetUsedValue(UR); } value llvm_used_value(value UR) {

return to_val(LLVMGetUsedValue(Use_val(UR)));

}

/*--... Operations on global variables .....................................--*/ /*--... Operations on global variables .....................................--*/

DEFINE_ITERATORS(global, Global, LLVMModuleRef, LLVMValueRef, DEFINE_ITERATORS(global, Global, Module_val, LLVMValueRef, Value_val,

LLVMGetGlobalParent) LLVMGetGlobalParent)

/* lltype -> string -> llmodule -> llvalue */ /* lltype -> string -> llmodule -> llvalue */

LLVMValueRef llvm_declare_global(LLVMTypeRef Ty, value Name, LLVMModuleRef M) { value llvm_declare_global(value Ty, value Name, value M) {

LLVMValueRef GlobalVar; LLVMValueRef GlobalVar;

if ((GlobalVar = LLVMGetNamedGlobal(M, String_val(Name)))) { if ((GlobalVar = LLVMGetNamedGlobal(Module_val(M), String_val(Name)))) {

if (LLVMGlobalGetValueType(GlobalVar) != Ty) if (LLVMGlobalGetValueType(GlobalVar) != Type_val(Ty))

return LLVMConstBitCast(GlobalVar, LLVMPointerType(Ty, 0)); return to_val(

return GlobalVar; LLVMConstBitCast(GlobalVar, LLVMPointerType(Type_val(Ty), 0)));

return to_val(GlobalVar);

} }

return LLVMAddGlobal(M, Ty, String_val(Name)); return to_val(LLVMAddGlobal(Module_val(M), Type_val(Ty), String_val(Name)));

} }

/* lltype -> string -> int -> llmodule -> llvalue */ /* lltype -> string -> int -> llmodule -> llvalue */

LLVMValueRef llvm_declare_qualified_global(LLVMTypeRef Ty, value Name, value llvm_declare_qualified_global(value Ty, value Name, value AddressSpace,

value AddressSpace, value M) {

LLVMModuleRef M) {

LLVMValueRef GlobalVar; LLVMValueRef GlobalVar;

if ((GlobalVar = LLVMGetNamedGlobal(M, String_val(Name)))) { if (GlobalVar = LLVMGetNamedGlobal(Module_val(M), String_val(Name))) {

jberdineUnsubmitted

Not Done

Removing these parens triggers warning: using the result of an assignment as a condition without parentheses [-Wparentheses]

jberdine: Removing these parens triggers `warning: using the result of an assignment as a condition…

if (LLVMGlobalGetValueType(GlobalVar) != Ty) if (LLVMGlobalGetValueType(GlobalVar) != Type_val(Ty))

return LLVMConstBitCast(GlobalVar, return to_val(LLVMConstBitCast(

LLVMPointerType(Ty, Int_val(AddressSpace))); GlobalVar, LLVMPointerType(Type_val(Ty), Int_val(AddressSpace))));

return GlobalVar; return to_val(GlobalVar);

} }

return LLVMAddGlobalInAddressSpace(M, Ty, String_val(Name), return to_val(LLVMAddGlobalInAddressSpace(

Int_val(AddressSpace)); Module_val(M), Type_val(Ty), String_val(Name), Int_val(AddressSpace)));

} }

/* string -> llmodule -> llvalue option */ /* string -> llmodule -> llvalue option */

value llvm_lookup_global(value Name, LLVMModuleRef M) { value llvm_lookup_global(value Name, value M) {

return ptr_to_option(LLVMGetNamedGlobal(M, String_val(Name))); return ptr_to_option(LLVMGetNamedGlobal(Module_val(M), String_val(Name)));

} }

/* string -> llvalue -> llmodule -> llvalue */ /* string -> llvalue -> llmodule -> llvalue */

LLVMValueRef llvm_define_global(value Name, LLVMValueRef Initializer, value llvm_define_global(value Name, value Initializer, value M) {

LLVMModuleRef M) { LLVMValueRef GlobalVar = LLVMAddGlobal(

LLVMValueRef GlobalVar = Module_val(M), LLVMTypeOf(Value_val(Initializer)), String_val(Name));

LLVMAddGlobal(M, LLVMTypeOf(Initializer), String_val(Name)); LLVMSetInitializer(GlobalVar, Value_val(Initializer));

LLVMSetInitializer(GlobalVar, Initializer); return to_val(GlobalVar);

return GlobalVar;

} }

/* string -> llvalue -> int -> llmodule -> llvalue */ /* string -> llvalue -> int -> llmodule -> llvalue */

LLVMValueRef llvm_define_qualified_global(value Name, LLVMValueRef Initializer, value llvm_define_qualified_global(value Name, value Initializer,

value AddressSpace, LLVMModuleRef M) { value AddressSpace, value M) {

LLVMValueRef GlobalVar