PageRenderTime 72ms CodeModel.GetById 14ms app.highlight 49ms RepoModel.GetById 1ms app.codeStats 0ms

/3rd_party/llvm/bindings/ocaml/llvm/llvm_ocaml.c

https://code.google.com/p/softart/
C | 2235 lines | 1516 code | 378 blank | 341 comment | 50 complexity | 8d3240b7a20638d4bc091a0cef5caaf5 MD5 | raw file
Possible License(s): LGPL-2.1, BSD-3-Clause, JSON, MPL-2.0-no-copyleft-exception, GPL-2.0, GPL-3.0, LGPL-3.0, BSD-2-Clause

Large files files are truncated, but you can click here to view the full file

   1/*===-- llvm_ocaml.c - LLVM OCaml Glue --------------------------*- C++ -*-===*\
   2|*                                                                            *|
   3|*                     The LLVM Compiler Infrastructure                       *|
   4|*                                                                            *|
   5|* This file is distributed under the University of Illinois Open Source      *|
   6|* License. See LICENSE.TXT for details.                                      *|
   7|*                                                                            *|
   8|*===----------------------------------------------------------------------===*|
   9|*                                                                            *|
  10|* This file glues LLVM's OCaml interface to its C interface. These functions *|
  11|* are by and large transparent wrappers to the corresponding C functions.    *|
  12|*                                                                            *|
  13|* Note that these functions intentionally take liberties with the CAMLparamX *|
  14|* macros, since most of the parameters are not GC heap objects.              *|
  15|*                                                                            *|
  16\*===----------------------------------------------------------------------===*/
  17
  18#include "llvm-c/Core.h"
  19#include "caml/alloc.h"
  20#include "caml/custom.h"
  21#include "caml/memory.h"
  22#include "caml/fail.h"
  23#include "caml/callback.h"
  24#include <assert.h>
  25#include <stdlib.h>
  26#include <string.h>
  27
  28
  29/* Can't use the recommended caml_named_value mechanism for backwards
  30   compatibility reasons. This is largely equivalent. */
  31static value llvm_ioerror_exn;
  32
  33CAMLprim value llvm_register_core_exns(value IoError) {
  34  llvm_ioerror_exn = Field(IoError, 0);
  35  register_global_root(&llvm_ioerror_exn);
  36
  37  return Val_unit;
  38}
  39
  40static void llvm_raise(value Prototype, char *Message) {
  41  CAMLparam1(Prototype);
  42  CAMLlocal1(CamlMessage);
  43  
  44  CamlMessage = copy_string(Message);
  45  LLVMDisposeMessage(Message);
  46  
  47  raise_with_arg(Prototype, CamlMessage);
  48  abort(); /* NOTREACHED */
  49#ifdef CAMLnoreturn
  50  CAMLnoreturn; /* Silences warnings, but is missing in some versions. */
  51#endif
  52}
  53
  54static value llvm_fatal_error_handler;
  55
  56static void llvm_fatal_error_trampoline(const char *Reason) {
  57  callback(llvm_fatal_error_handler, copy_string(Reason));
  58}
  59
  60CAMLprim value llvm_install_fatal_error_handler(value Handler) {
  61  LLVMInstallFatalErrorHandler(llvm_fatal_error_trampoline);
  62  llvm_fatal_error_handler = Handler;
  63  caml_register_global_root(&llvm_fatal_error_handler);
  64  return Val_unit;
  65}
  66
  67CAMLprim value llvm_reset_fatal_error_handler(value Unit) {
  68  caml_remove_global_root(&llvm_fatal_error_handler);
  69  LLVMResetFatalErrorHandler();
  70  return Val_unit;
  71}
  72
  73CAMLprim value llvm_enable_pretty_stacktrace(value Unit) {
  74  LLVMEnablePrettyStackTrace();
  75  return Val_unit;
  76}
  77
  78static value alloc_variant(int tag, void *Value) {
  79  value Iter = alloc_small(1, tag);
  80  Field(Iter, 0) = Val_op(Value);
  81  return Iter;
  82}
  83
  84/* Macro to convert the C first/next/last/prev idiom to the Ocaml llpos/
  85   llrev_pos idiom. */
  86#define DEFINE_ITERATORS(camlname, cname, pty, cty, pfun) \
  87  /* llmodule -> ('a, 'b) llpos */                        \
  88  CAMLprim value llvm_##camlname##_begin(pty Mom) {       \
  89    cty First = LLVMGetFirst##cname(Mom);                 \
  90    if (First)                                            \
  91      return alloc_variant(1, First);                     \
  92    return alloc_variant(0, Mom);                         \
  93  }                                                       \
  94                                                          \
  95  /* llvalue -> ('a, 'b) llpos */                         \
  96  CAMLprim value llvm_##camlname##_succ(cty Kid) {        \
  97    cty Next = LLVMGetNext##cname(Kid);                   \
  98    if (Next)                                             \
  99      return alloc_variant(1, Next);                      \
 100    return alloc_variant(0, pfun(Kid));                   \
 101  }                                                       \
 102                                                          \
 103  /* llmodule -> ('a, 'b) llrev_pos */                    \
 104  CAMLprim value llvm_##camlname##_end(pty Mom) {         \
 105    cty Last = LLVMGetLast##cname(Mom);                   \
 106    if (Last)                                             \
 107      return alloc_variant(1, Last);                      \
 108    return alloc_variant(0, Mom);                         \
 109  }                                                       \
 110                                                          \
 111  /* llvalue -> ('a, 'b) llrev_pos */                     \
 112  CAMLprim value llvm_##camlname##_pred(cty Kid) {        \
 113    cty Prev = LLVMGetPrevious##cname(Kid);               \
 114    if (Prev)                                             \
 115      return alloc_variant(1, Prev);                      \
 116    return alloc_variant(0, pfun(Kid));                   \
 117  }
 118
 119
 120/*===-- Contexts ----------------------------------------------------------===*/
 121
 122/* unit -> llcontext */
 123CAMLprim LLVMContextRef llvm_create_context(value Unit) {
 124  return LLVMContextCreate();
 125}
 126
 127/* llcontext -> unit */
 128CAMLprim value llvm_dispose_context(LLVMContextRef C) {
 129  LLVMContextDispose(C);
 130  return Val_unit;
 131}
 132
 133/* unit -> llcontext */
 134CAMLprim LLVMContextRef llvm_global_context(value Unit) {
 135  return LLVMGetGlobalContext();
 136}
 137
 138/* llcontext -> string -> int */
 139CAMLprim value llvm_mdkind_id(LLVMContextRef C, value Name) {
 140  unsigned MDKindID = LLVMGetMDKindIDInContext(C, String_val(Name),
 141                                               caml_string_length(Name));
 142  return Val_int(MDKindID);
 143}
 144
 145/*===-- Modules -----------------------------------------------------------===*/
 146
 147/* llcontext -> string -> llmodule */
 148CAMLprim LLVMModuleRef llvm_create_module(LLVMContextRef C, value ModuleID) {
 149  return LLVMModuleCreateWithNameInContext(String_val(ModuleID), C);
 150}
 151
 152/* llmodule -> unit */
 153CAMLprim value llvm_dispose_module(LLVMModuleRef M) {
 154  LLVMDisposeModule(M);
 155  return Val_unit;
 156}
 157
 158/* llmodule -> string */
 159CAMLprim value llvm_target_triple(LLVMModuleRef M) {
 160  return copy_string(LLVMGetTarget(M));
 161}
 162
 163/* string -> llmodule -> unit */
 164CAMLprim value llvm_set_target_triple(value Trip, LLVMModuleRef M) {
 165  LLVMSetTarget(M, String_val(Trip));
 166  return Val_unit;
 167}
 168
 169/* llmodule -> string */
 170CAMLprim value llvm_data_layout(LLVMModuleRef M) {
 171  return copy_string(LLVMGetDataLayout(M));
 172}
 173
 174/* string -> llmodule -> unit */
 175CAMLprim value llvm_set_data_layout(value Layout, LLVMModuleRef M) {
 176  LLVMSetDataLayout(M, String_val(Layout));
 177  return Val_unit;
 178}
 179
 180/* llmodule -> unit */
 181CAMLprim value llvm_dump_module(LLVMModuleRef M) {
 182  LLVMDumpModule(M);
 183  return Val_unit;
 184}
 185
 186/* string -> llmodule -> unit */
 187CAMLprim value llvm_print_module(value Filename, LLVMModuleRef M) {
 188  char* Message;
 189  if(LLVMPrintModuleToFile(M, String_val(Filename), &Message)) {
 190    llvm_raise(llvm_ioerror_exn, Message);
 191  }
 192
 193  return Val_unit;
 194}
 195
 196/* llmodule -> string */
 197CAMLprim value llvm_string_of_llmodule(LLVMModuleRef M) {
 198  char* ModuleCStr;
 199  ModuleCStr = LLVMPrintModuleToString(M);
 200
 201  value ModuleStr = caml_copy_string(ModuleCStr);
 202  LLVMDisposeMessage(ModuleCStr);
 203
 204  return ModuleStr;
 205}
 206
 207/* llmodule -> string -> unit */
 208CAMLprim value llvm_set_module_inline_asm(LLVMModuleRef M, value Asm) {
 209  LLVMSetModuleInlineAsm(M, String_val(Asm));
 210  return Val_unit;
 211}
 212
 213/*===-- Types -------------------------------------------------------------===*/
 214
 215/* lltype -> TypeKind.t */
 216CAMLprim value llvm_classify_type(LLVMTypeRef Ty) {
 217  return Val_int(LLVMGetTypeKind(Ty));
 218}
 219
 220CAMLprim value llvm_type_is_sized(LLVMTypeRef Ty) {
 221    return Val_bool(LLVMTypeIsSized(Ty));
 222}
 223
 224/* lltype -> llcontext */
 225CAMLprim LLVMContextRef llvm_type_context(LLVMTypeRef Ty) {
 226  return LLVMGetTypeContext(Ty);
 227}
 228
 229/* lltype -> unit */
 230CAMLprim value llvm_dump_type(LLVMTypeRef Val) {
 231  LLVMDumpType(Val);
 232  return Val_unit;
 233}
 234
 235/* lltype -> string */
 236CAMLprim value llvm_string_of_lltype(LLVMTypeRef M) {
 237  char* TypeCStr;
 238  TypeCStr = LLVMPrintTypeToString(M);
 239
 240  value TypeStr = caml_copy_string(TypeCStr);
 241  LLVMDisposeMessage(TypeCStr);
 242
 243  return TypeStr;
 244}
 245
 246/*--... Operations on integer types ........................................--*/
 247
 248/* llcontext -> lltype */
 249CAMLprim LLVMTypeRef llvm_i1_type (LLVMContextRef Context) {
 250  return LLVMInt1TypeInContext(Context);
 251}
 252
 253/* llcontext -> lltype */
 254CAMLprim LLVMTypeRef llvm_i8_type (LLVMContextRef Context) {
 255  return LLVMInt8TypeInContext(Context);
 256}
 257
 258/* llcontext -> lltype */
 259CAMLprim LLVMTypeRef llvm_i16_type (LLVMContextRef Context) {
 260  return LLVMInt16TypeInContext(Context);
 261}
 262
 263/* llcontext -> lltype */
 264CAMLprim LLVMTypeRef llvm_i32_type (LLVMContextRef Context) {
 265  return LLVMInt32TypeInContext(Context);
 266}
 267
 268/* llcontext -> lltype */
 269CAMLprim LLVMTypeRef llvm_i64_type (LLVMContextRef Context) {
 270  return LLVMInt64TypeInContext(Context);
 271}
 272
 273/* llcontext -> int -> lltype */
 274CAMLprim LLVMTypeRef llvm_integer_type(LLVMContextRef Context, value Width) {
 275  return LLVMIntTypeInContext(Context, Int_val(Width));
 276}
 277
 278/* lltype -> int */
 279CAMLprim value llvm_integer_bitwidth(LLVMTypeRef IntegerTy) {
 280  return Val_int(LLVMGetIntTypeWidth(IntegerTy));
 281}
 282
 283/*--... Operations on real types ...........................................--*/
 284
 285/* llcontext -> lltype */
 286CAMLprim LLVMTypeRef llvm_float_type(LLVMContextRef Context) {
 287  return LLVMFloatTypeInContext(Context);
 288}
 289
 290/* llcontext -> lltype */
 291CAMLprim LLVMTypeRef llvm_double_type(LLVMContextRef Context) {
 292  return LLVMDoubleTypeInContext(Context);
 293}
 294
 295/* llcontext -> lltype */
 296CAMLprim LLVMTypeRef llvm_x86fp80_type(LLVMContextRef Context) {
 297  return LLVMX86FP80TypeInContext(Context);
 298}
 299
 300/* llcontext -> lltype */
 301CAMLprim LLVMTypeRef llvm_fp128_type(LLVMContextRef Context) {
 302  return LLVMFP128TypeInContext(Context);
 303}
 304
 305/* llcontext -> lltype */
 306CAMLprim LLVMTypeRef llvm_ppc_fp128_type(LLVMContextRef Context) {
 307  return LLVMPPCFP128TypeInContext(Context);
 308}
 309
 310/*--... Operations on function types .......................................--*/
 311
 312/* lltype -> lltype array -> lltype */
 313CAMLprim LLVMTypeRef llvm_function_type(LLVMTypeRef RetTy, value ParamTys) {
 314  return LLVMFunctionType(RetTy, (LLVMTypeRef *) ParamTys,
 315                          Wosize_val(ParamTys), 0);
 316}
 317
 318/* lltype -> lltype array -> lltype */
 319CAMLprim LLVMTypeRef llvm_var_arg_function_type(LLVMTypeRef RetTy,
 320                                                value ParamTys) {
 321  return LLVMFunctionType(RetTy, (LLVMTypeRef *) ParamTys,
 322                          Wosize_val(ParamTys), 1);
 323}
 324
 325/* lltype -> bool */
 326CAMLprim value llvm_is_var_arg(LLVMTypeRef FunTy) {
 327  return Val_bool(LLVMIsFunctionVarArg(FunTy));
 328}
 329
 330/* lltype -> lltype array */
 331CAMLprim value llvm_param_types(LLVMTypeRef FunTy) {
 332  value Tys = alloc(LLVMCountParamTypes(FunTy), 0);
 333  LLVMGetParamTypes(FunTy, (LLVMTypeRef *) Tys);
 334  return Tys;
 335}
 336
 337/*--... Operations on struct types .........................................--*/
 338
 339/* llcontext -> lltype array -> lltype */
 340CAMLprim LLVMTypeRef llvm_struct_type(LLVMContextRef C, value ElementTypes) {
 341  return LLVMStructTypeInContext(C, (LLVMTypeRef *) ElementTypes,
 342                                 Wosize_val(ElementTypes), 0);
 343}
 344
 345/* llcontext -> lltype array -> lltype */
 346CAMLprim LLVMTypeRef llvm_packed_struct_type(LLVMContextRef C,
 347                                             value ElementTypes) {
 348  return LLVMStructTypeInContext(C, (LLVMTypeRef *) ElementTypes,
 349                                 Wosize_val(ElementTypes), 1);
 350}
 351
 352/* llcontext -> string -> lltype */
 353CAMLprim LLVMTypeRef llvm_named_struct_type(LLVMContextRef C,
 354                                            value Name) {
 355  return LLVMStructCreateNamed(C, String_val(Name));
 356}
 357
 358CAMLprim value llvm_struct_set_body(LLVMTypeRef Ty,
 359                                    value ElementTypes,
 360                                    value Packed) {
 361  LLVMStructSetBody(Ty, (LLVMTypeRef *) ElementTypes,
 362                    Wosize_val(ElementTypes), Bool_val(Packed));
 363  return Val_unit;
 364}
 365
 366/* lltype -> string option */
 367CAMLprim value llvm_struct_name(LLVMTypeRef Ty)
 368{
 369  CAMLparam0();
 370  const char *C = LLVMGetStructName(Ty);
 371  if (C) {
 372    CAMLlocal1(result);
 373    result = caml_alloc_small(1, 0);
 374    Store_field(result, 0, caml_copy_string(C));
 375    CAMLreturn(result);
 376  }
 377  CAMLreturn(Val_int(0));
 378}
 379
 380/* lltype -> lltype array */
 381CAMLprim value llvm_struct_element_types(LLVMTypeRef StructTy) {
 382  value Tys = alloc(LLVMCountStructElementTypes(StructTy), 0);
 383  LLVMGetStructElementTypes(StructTy, (LLVMTypeRef *) Tys);
 384  return Tys;
 385}
 386
 387/* lltype -> bool */
 388CAMLprim value llvm_is_packed(LLVMTypeRef StructTy) {
 389  return Val_bool(LLVMIsPackedStruct(StructTy));
 390}
 391
 392/* lltype -> bool */
 393CAMLprim value llvm_is_opaque(LLVMTypeRef StructTy) {
 394  return Val_bool(LLVMIsOpaqueStruct(StructTy));
 395}
 396
 397/*--... Operations on array, pointer, and vector types .....................--*/
 398
 399/* lltype -> int -> lltype */
 400CAMLprim LLVMTypeRef llvm_array_type(LLVMTypeRef ElementTy, value Count) {
 401  return LLVMArrayType(ElementTy, Int_val(Count));
 402}
 403
 404/* lltype -> lltype */
 405CAMLprim LLVMTypeRef llvm_pointer_type(LLVMTypeRef ElementTy) {
 406  return LLVMPointerType(ElementTy, 0);
 407}
 408
 409/* lltype -> int -> lltype */
 410CAMLprim LLVMTypeRef llvm_qualified_pointer_type(LLVMTypeRef ElementTy,
 411                                                 value AddressSpace) {
 412  return LLVMPointerType(ElementTy, Int_val(AddressSpace));
 413}
 414
 415/* lltype -> int -> lltype */
 416CAMLprim LLVMTypeRef llvm_vector_type(LLVMTypeRef ElementTy, value Count) {
 417  return LLVMVectorType(ElementTy, Int_val(Count));
 418}
 419
 420/* lltype -> int */
 421CAMLprim value llvm_array_length(LLVMTypeRef ArrayTy) {
 422  return Val_int(LLVMGetArrayLength(ArrayTy));
 423}
 424
 425/* lltype -> int */
 426CAMLprim value llvm_address_space(LLVMTypeRef PtrTy) {
 427  return Val_int(LLVMGetPointerAddressSpace(PtrTy));
 428}
 429
 430/* lltype -> int */
 431CAMLprim value llvm_vector_size(LLVMTypeRef VectorTy) {
 432  return Val_int(LLVMGetVectorSize(VectorTy));
 433}
 434
 435/*--... Operations on other types ..........................................--*/
 436
 437/* llcontext -> lltype */
 438CAMLprim LLVMTypeRef llvm_void_type (LLVMContextRef Context) {
 439  return LLVMVoidTypeInContext(Context);
 440}
 441
 442/* llcontext -> lltype */
 443CAMLprim LLVMTypeRef llvm_label_type(LLVMContextRef Context) {
 444  return LLVMLabelTypeInContext(Context);
 445}
 446
 447/* llcontext -> lltype */
 448CAMLprim LLVMTypeRef llvm_x86_mmx_type(LLVMContextRef Context) {
 449  return LLVMX86MMXTypeInContext(Context);
 450}
 451
 452CAMLprim value llvm_type_by_name(LLVMModuleRef M, value Name)
 453{
 454  CAMLparam1(Name);
 455  LLVMTypeRef Ty = LLVMGetTypeByName(M, String_val(Name));
 456  if (Ty) {
 457    value Option = alloc(1, 0);
 458    Field(Option, 0) = (value) Ty;
 459    CAMLreturn(Option);
 460  }
 461  CAMLreturn(Val_int(0));
 462}
 463
 464/*===-- VALUES ------------------------------------------------------------===*/
 465
 466/* llvalue -> lltype */
 467CAMLprim LLVMTypeRef llvm_type_of(LLVMValueRef Val) {
 468  return LLVMTypeOf(Val);
 469}
 470
 471/* keep in sync with ValueKind.t */
 472enum ValueKind {
 473  NullValue=0,
 474  Argument,
 475  BasicBlock,
 476  InlineAsm,
 477  MDNode,
 478  MDString,
 479  BlockAddress,
 480  ConstantAggregateZero,
 481  ConstantArray,
 482  ConstantDataArray,
 483  ConstantDataVector,
 484  ConstantExpr,
 485  ConstantFP,
 486  ConstantInt,
 487  ConstantPointerNull,
 488  ConstantStruct,
 489  ConstantVector,
 490  Function,
 491  GlobalAlias,
 492  GlobalVariable,
 493  UndefValue,
 494  Instruction
 495};
 496
 497/* llvalue -> ValueKind.t */
 498#define DEFINE_CASE(Val, Kind) \
 499    do {if (LLVMIsA##Kind(Val)) CAMLreturn(Val_int(Kind));} while(0)
 500
 501CAMLprim value llvm_classify_value(LLVMValueRef Val) {
 502  CAMLparam0();
 503  if (!Val)
 504    CAMLreturn(Val_int(NullValue));
 505  if (LLVMIsAConstant(Val)) {
 506    DEFINE_CASE(Val, BlockAddress);
 507    DEFINE_CASE(Val, ConstantAggregateZero);
 508    DEFINE_CASE(Val, ConstantArray);
 509    DEFINE_CASE(Val, ConstantDataArray);
 510    DEFINE_CASE(Val, ConstantDataVector);
 511    DEFINE_CASE(Val, ConstantExpr);
 512    DEFINE_CASE(Val, ConstantFP);
 513    DEFINE_CASE(Val, ConstantInt);
 514    DEFINE_CASE(Val, ConstantPointerNull);
 515    DEFINE_CASE(Val, ConstantStruct);
 516    DEFINE_CASE(Val, ConstantVector);
 517  }
 518  if (LLVMIsAInstruction(Val)) {
 519    CAMLlocal1(result);
 520    result = caml_alloc_small(1, 0);
 521    Store_field(result, 0, Val_int(LLVMGetInstructionOpcode(Val)));
 522    CAMLreturn(result);
 523  }
 524  if (LLVMIsAGlobalValue(Val)) {
 525    DEFINE_CASE(Val, Function);
 526    DEFINE_CASE(Val, GlobalAlias);
 527    DEFINE_CASE(Val, GlobalVariable);
 528  }
 529  DEFINE_CASE(Val, Argument);
 530  DEFINE_CASE(Val, BasicBlock);
 531  DEFINE_CASE(Val, InlineAsm);
 532  DEFINE_CASE(Val, MDNode);
 533  DEFINE_CASE(Val, MDString);
 534  DEFINE_CASE(Val, UndefValue);
 535  failwith("Unknown Value class");
 536}
 537
 538/* llvalue -> string */
 539CAMLprim value llvm_value_name(LLVMValueRef Val) {
 540  return copy_string(LLVMGetValueName(Val));
 541}
 542
 543/* string -> llvalue -> unit */
 544CAMLprim value llvm_set_value_name(value Name, LLVMValueRef Val) {
 545  LLVMSetValueName(Val, String_val(Name));
 546  return Val_unit;
 547}
 548
 549/* llvalue -> unit */
 550CAMLprim value llvm_dump_value(LLVMValueRef Val) {
 551  LLVMDumpValue(Val);
 552  return Val_unit;
 553}
 554
 555/* llvalue -> string */
 556CAMLprim value llvm_string_of_llvalue(LLVMValueRef M) {
 557  char* ValueCStr;
 558  ValueCStr = LLVMPrintValueToString(M);
 559
 560  value ValueStr = caml_copy_string(ValueCStr);
 561  LLVMDisposeMessage(ValueCStr);
 562
 563  return ValueStr;
 564}
 565
 566/* llvalue -> llvalue -> unit */
 567CAMLprim value llvm_replace_all_uses_with(LLVMValueRef OldVal,
 568                                          LLVMValueRef NewVal) {
 569  LLVMReplaceAllUsesWith(OldVal, NewVal);
 570  return Val_unit;
 571}
 572
 573/*--... Operations on users ................................................--*/
 574
 575/* llvalue -> int -> llvalue */
 576CAMLprim LLVMValueRef llvm_operand(LLVMValueRef V, value I) {
 577  return LLVMGetOperand(V, Int_val(I));
 578}
 579
 580/* llvalue -> int -> llvalue -> unit */
 581CAMLprim value llvm_set_operand(LLVMValueRef U, value I, LLVMValueRef V) {
 582  LLVMSetOperand(U, Int_val(I), V);
 583  return Val_unit;
 584}
 585
 586/* llvalue -> int */
 587CAMLprim value llvm_num_operands(LLVMValueRef V) {
 588  return Val_int(LLVMGetNumOperands(V));
 589}
 590
 591/*--... Operations on constants of (mostly) any type .......................--*/
 592
 593/* llvalue -> bool */
 594CAMLprim value llvm_is_constant(LLVMValueRef Val) {
 595  return Val_bool(LLVMIsConstant(Val));
 596}
 597
 598/* llvalue -> bool */
 599CAMLprim value llvm_is_null(LLVMValueRef Val) {
 600  return Val_bool(LLVMIsNull(Val));
 601}
 602
 603/* llvalue -> bool */
 604CAMLprim value llvm_is_undef(LLVMValueRef Val) {
 605  return Val_bool(LLVMIsUndef(Val));
 606}
 607
 608/* llvalue -> Opcode.t */
 609CAMLprim value llvm_constexpr_get_opcode(LLVMValueRef Val) {
 610  return LLVMIsAConstantExpr(Val) ?
 611      Val_int(LLVMGetConstOpcode(Val)) : Val_int(0);
 612}
 613
 614/*--... Operations on instructions .........................................--*/
 615
 616/* llvalue -> bool */
 617CAMLprim value llvm_has_metadata(LLVMValueRef Val) {
 618  return Val_bool(LLVMHasMetadata(Val));
 619}
 620
 621/* llvalue -> int -> llvalue option */
 622CAMLprim value llvm_metadata(LLVMValueRef Val, value MDKindID) {
 623  CAMLparam1(MDKindID);
 624  LLVMValueRef MD;
 625  if ((MD = LLVMGetMetadata(Val, Int_val(MDKindID)))) {
 626    value Option = alloc(1, 0);
 627    Field(Option, 0) = (value) MD;
 628    CAMLreturn(Option);
 629  }
 630  CAMLreturn(Val_int(0));
 631}
 632
 633/* llvalue -> int -> llvalue -> unit */
 634CAMLprim value llvm_set_metadata(LLVMValueRef Val, value MDKindID,
 635                                 LLVMValueRef MD) {
 636  LLVMSetMetadata(Val, Int_val(MDKindID), MD);
 637  return Val_unit;
 638}
 639
 640/* llvalue -> int -> unit */
 641CAMLprim value llvm_clear_metadata(LLVMValueRef Val, value MDKindID) {
 642  LLVMSetMetadata(Val, Int_val(MDKindID), NULL);
 643  return Val_unit;
 644}
 645
 646
 647/*--... Operations on metadata .............................................--*/
 648
 649/* llcontext -> string -> llvalue */
 650CAMLprim LLVMValueRef llvm_mdstring(LLVMContextRef C, value S) {
 651  return LLVMMDStringInContext(C, String_val(S), caml_string_length(S));
 652}
 653
 654/* llcontext -> llvalue array -> llvalue */
 655CAMLprim LLVMValueRef llvm_mdnode(LLVMContextRef C, value ElementVals) {
 656  return LLVMMDNodeInContext(C, (LLVMValueRef*) Op_val(ElementVals),
 657                             Wosize_val(ElementVals));
 658}
 659
 660/* llvalue -> string option */
 661CAMLprim value llvm_get_mdstring(LLVMValueRef V) {
 662  CAMLparam0();
 663  const char *S;
 664  unsigned Len;
 665
 666  if ((S = LLVMGetMDString(V, &Len))) {
 667    CAMLlocal2(Option, Str);
 668
 669    Str = caml_alloc_string(Len);
 670    memcpy(String_val(Str), S, Len);
 671    Option = alloc(1,0);
 672    Store_field(Option, 0, Str);
 673    CAMLreturn(Option);
 674  }
 675  CAMLreturn(Val_int(0));
 676}
 677
 678/* llmodule -> string -> llvalue array */
 679CAMLprim value llvm_get_namedmd(LLVMModuleRef M, value Name)
 680{
 681  CAMLparam1(Name);
 682  CAMLlocal1(Nodes);
 683  Nodes = alloc(LLVMGetNamedMetadataNumOperands(M, String_val(Name)), 0);
 684  LLVMGetNamedMetadataOperands(M, String_val(Name), (LLVMValueRef *) Nodes);
 685  CAMLreturn(Nodes);
 686}
 687
 688/* llmodule -> string -> llvalue -> unit */
 689CAMLprim value llvm_append_namedmd(LLVMModuleRef M, value Name, LLVMValueRef Val) {
 690  LLVMAddNamedMetadataOperand(M, String_val(Name), Val);
 691  return Val_unit;
 692}
 693
 694/*--... Operations on scalar constants .....................................--*/
 695
 696/* lltype -> int -> llvalue */
 697CAMLprim LLVMValueRef llvm_const_int(LLVMTypeRef IntTy, value N) {
 698  return LLVMConstInt(IntTy, (long long) Int_val(N), 1);
 699}
 700
 701/* lltype -> Int64.t -> bool -> llvalue */
 702CAMLprim LLVMValueRef llvm_const_of_int64(LLVMTypeRef IntTy, value N,
 703                                          value SExt) {
 704  return LLVMConstInt(IntTy, Int64_val(N), Bool_val(SExt));
 705}
 706
 707/* llvalue -> Int64.t */
 708CAMLprim value llvm_int64_of_const(LLVMValueRef Const)
 709{
 710  CAMLparam0();
 711  if (LLVMIsAConstantInt(Const) &&
 712      LLVMGetIntTypeWidth(LLVMTypeOf(Const)) <= 64) {
 713    value Option = alloc(1, 0);
 714    Field(Option, 0) = caml_copy_int64(LLVMConstIntGetSExtValue(Const));
 715    CAMLreturn(Option);
 716  }
 717  CAMLreturn(Val_int(0));
 718}
 719
 720/* lltype -> string -> int -> llvalue */
 721CAMLprim LLVMValueRef llvm_const_int_of_string(LLVMTypeRef IntTy, value S,
 722                                               value Radix) {
 723  return LLVMConstIntOfStringAndSize(IntTy, String_val(S), caml_string_length(S),
 724                                     Int_val(Radix));
 725}
 726
 727/* lltype -> float -> llvalue */
 728CAMLprim LLVMValueRef llvm_const_float(LLVMTypeRef RealTy, value N) {
 729  return LLVMConstReal(RealTy, Double_val(N));
 730}
 731
 732/* lltype -> string -> llvalue */
 733CAMLprim LLVMValueRef llvm_const_float_of_string(LLVMTypeRef RealTy, value S) {
 734  return LLVMConstRealOfStringAndSize(RealTy, String_val(S),
 735                                      caml_string_length(S));
 736}
 737
 738/*--... Operations on composite constants ..................................--*/
 739
 740/* llcontext -> string -> llvalue */
 741CAMLprim LLVMValueRef llvm_const_string(LLVMContextRef Context, value Str,
 742                                        value NullTerminate) {
 743  return LLVMConstStringInContext(Context, String_val(Str), string_length(Str),
 744                                  1);
 745}
 746
 747/* llcontext -> string -> llvalue */
 748CAMLprim LLVMValueRef llvm_const_stringz(LLVMContextRef Context, value Str,
 749                                         value NullTerminate) {
 750  return LLVMConstStringInContext(Context, String_val(Str), string_length(Str),
 751                                  0);
 752}
 753
 754/* lltype -> llvalue array -> llvalue */
 755CAMLprim LLVMValueRef llvm_const_array(LLVMTypeRef ElementTy,
 756                                               value ElementVals) {
 757  return LLVMConstArray(ElementTy, (LLVMValueRef*) Op_val(ElementVals),
 758                        Wosize_val(ElementVals));
 759}
 760
 761/* llcontext -> llvalue array -> llvalue */
 762CAMLprim LLVMValueRef llvm_const_struct(LLVMContextRef C, value ElementVals) {
 763  return LLVMConstStructInContext(C, (LLVMValueRef *) Op_val(ElementVals),
 764                                  Wosize_val(ElementVals), 0);
 765}
 766
 767/* lltype -> llvalue array -> llvalue */
 768CAMLprim LLVMValueRef llvm_const_named_struct(LLVMTypeRef Ty, value ElementVals) {
 769    return LLVMConstNamedStruct(Ty, (LLVMValueRef *) Op_val(ElementVals),  Wosize_val(ElementVals));
 770}
 771
 772/* llcontext -> llvalue array -> llvalue */
 773CAMLprim LLVMValueRef llvm_const_packed_struct(LLVMContextRef C,
 774                                               value ElementVals) {
 775  return LLVMConstStructInContext(C, (LLVMValueRef *) Op_val(ElementVals),
 776                                  Wosize_val(ElementVals), 1);
 777}
 778
 779/* llvalue array -> llvalue */
 780CAMLprim LLVMValueRef llvm_const_vector(value ElementVals) {
 781  return LLVMConstVector((LLVMValueRef*) Op_val(ElementVals),
 782                         Wosize_val(ElementVals));
 783}
 784
 785/*--... Constant expressions ...............................................--*/
 786
 787/* Icmp.t -> llvalue -> llvalue -> llvalue */
 788CAMLprim LLVMValueRef llvm_const_icmp(value Pred,
 789                                      LLVMValueRef LHSConstant,
 790                                      LLVMValueRef RHSConstant) {
 791  return LLVMConstICmp(Int_val(Pred) + LLVMIntEQ, LHSConstant, RHSConstant);
 792}
 793
 794/* Fcmp.t -> llvalue -> llvalue -> llvalue */
 795CAMLprim LLVMValueRef llvm_const_fcmp(value Pred,
 796                                      LLVMValueRef LHSConstant,
 797                                      LLVMValueRef RHSConstant) {
 798  return LLVMConstFCmp(Int_val(Pred), LHSConstant, RHSConstant);
 799}
 800
 801/* llvalue -> llvalue array -> llvalue */
 802CAMLprim LLVMValueRef llvm_const_gep(LLVMValueRef ConstantVal, value Indices) {
 803  return LLVMConstGEP(ConstantVal, (LLVMValueRef*) Op_val(Indices),
 804                      Wosize_val(Indices));
 805}
 806
 807/* llvalue -> llvalue array -> llvalue */
 808CAMLprim LLVMValueRef llvm_const_in_bounds_gep(LLVMValueRef ConstantVal,
 809                                               value Indices) {
 810  return LLVMConstInBoundsGEP(ConstantVal, (LLVMValueRef*) Op_val(Indices),
 811                              Wosize_val(Indices));
 812}
 813
 814/* llvalue -> lltype -> is_signed:bool -> llvalue */
 815CAMLprim LLVMValueRef llvm_const_intcast(LLVMValueRef CV, LLVMTypeRef T,
 816                                         value IsSigned) {
 817  return LLVMConstIntCast(CV, T, Bool_val(IsSigned));
 818}
 819
 820/* llvalue -> int array -> llvalue */
 821CAMLprim LLVMValueRef llvm_const_extractvalue(LLVMValueRef Aggregate,
 822                                              value Indices) {
 823  CAMLparam1(Indices);
 824  int size = Wosize_val(Indices);
 825  int i;
 826  LLVMValueRef result;
 827
 828  unsigned* idxs = (unsigned*)malloc(size * sizeof(unsigned));
 829  for (i = 0; i < size; i++) {
 830    idxs[i] = Int_val(Field(Indices, i));
 831  }
 832
 833  result = LLVMConstExtractValue(Aggregate, idxs, size);
 834  free(idxs);
 835  CAMLreturnT(LLVMValueRef, result);
 836}
 837
 838/* llvalue -> llvalue -> int array -> llvalue */
 839CAMLprim LLVMValueRef llvm_const_insertvalue(LLVMValueRef Aggregate,
 840                                             LLVMValueRef Val, value Indices) {
 841  CAMLparam1(Indices);
 842  int size = Wosize_val(Indices);
 843  int i;
 844  LLVMValueRef result;
 845
 846  unsigned* idxs = (unsigned*)malloc(size * sizeof(unsigned));
 847  for (i = 0; i < size; i++) {
 848    idxs[i] = Int_val(Field(Indices, i));
 849  }
 850
 851  result = LLVMConstInsertValue(Aggregate, Val, idxs, size);
 852  free(idxs);
 853  CAMLreturnT(LLVMValueRef, result);
 854}
 855
 856/* lltype -> string -> string -> bool -> bool -> llvalue */
 857CAMLprim LLVMValueRef llvm_const_inline_asm(LLVMTypeRef Ty, value Asm,
 858                                     value Constraints, value HasSideEffects,
 859                                     value IsAlignStack) {
 860  return LLVMConstInlineAsm(Ty, String_val(Asm), String_val(Constraints),
 861                            Bool_val(HasSideEffects), Bool_val(IsAlignStack));
 862}
 863
 864/*--... Operations on global variables, functions, and aliases (globals) ...--*/
 865
 866/* llvalue -> bool */
 867CAMLprim value llvm_is_declaration(LLVMValueRef Global) {
 868  return Val_bool(LLVMIsDeclaration(Global));
 869}
 870
 871/* llvalue -> Linkage.t */
 872CAMLprim value llvm_linkage(LLVMValueRef Global) {
 873  return Val_int(LLVMGetLinkage(Global));
 874}
 875
 876/* Linkage.t -> llvalue -> unit */
 877CAMLprim value llvm_set_linkage(value Linkage, LLVMValueRef Global) {
 878  LLVMSetLinkage(Global, Int_val(Linkage));
 879  return Val_unit;
 880}
 881
 882/* llvalue -> string */
 883CAMLprim value llvm_section(LLVMValueRef Global) {
 884  return copy_string(LLVMGetSection(Global));
 885}
 886
 887/* string -> llvalue -> unit */
 888CAMLprim value llvm_set_section(value Section, LLVMValueRef Global) {
 889  LLVMSetSection(Global, String_val(Section));
 890  return Val_unit;
 891}
 892
 893/* llvalue -> Visibility.t */
 894CAMLprim value llvm_visibility(LLVMValueRef Global) {
 895  return Val_int(LLVMGetVisibility(Global));
 896}
 897
 898/* Visibility.t -> llvalue -> unit */
 899CAMLprim value llvm_set_visibility(value Viz, LLVMValueRef Global) {
 900  LLVMSetVisibility(Global, Int_val(Viz));
 901  return Val_unit;
 902}
 903
 904/* llvalue -> int */
 905CAMLprim value llvm_alignment(LLVMValueRef Global) {
 906  return Val_int(LLVMGetAlignment(Global));
 907}
 908
 909/* int -> llvalue -> unit */
 910CAMLprim value llvm_set_alignment(value Bytes, LLVMValueRef Global) {
 911  LLVMSetAlignment(Global, Int_val(Bytes));
 912  return Val_unit;
 913}
 914
 915/*--... Operations on uses .................................................--*/
 916
 917/* llvalue -> lluse option */
 918CAMLprim value llvm_use_begin(LLVMValueRef Val) {
 919  CAMLparam0();
 920  LLVMUseRef First;
 921  if ((First = LLVMGetFirstUse(Val))) {
 922    value Option = alloc(1, 0);
 923    Field(Option, 0) = (value) First;
 924    CAMLreturn(Option);
 925  }
 926  CAMLreturn(Val_int(0));
 927}
 928
 929/* lluse -> lluse option */
 930CAMLprim value llvm_use_succ(LLVMUseRef U) {
 931  CAMLparam0();
 932  LLVMUseRef Next;
 933  if ((Next = LLVMGetNextUse(U))) {
 934    value Option = alloc(1, 0);
 935    Field(Option, 0) = (value) Next;
 936    CAMLreturn(Option);
 937  }
 938  CAMLreturn(Val_int(0));
 939}
 940
 941/* lluse -> llvalue */
 942CAMLprim LLVMValueRef llvm_user(LLVMUseRef UR) {
 943  return LLVMGetUser(UR);
 944}
 945
 946/* lluse -> llvalue */
 947CAMLprim LLVMValueRef llvm_used_value(LLVMUseRef UR) {
 948  return LLVMGetUsedValue(UR);
 949}
 950
 951/*--... Operations on global variables .....................................--*/
 952
 953DEFINE_ITERATORS(global, Global, LLVMModuleRef, LLVMValueRef,
 954                 LLVMGetGlobalParent)
 955
 956/* lltype -> string -> llmodule -> llvalue */
 957CAMLprim LLVMValueRef llvm_declare_global(LLVMTypeRef Ty, value Name,
 958                                          LLVMModuleRef M) {
 959  LLVMValueRef GlobalVar;
 960  if ((GlobalVar = LLVMGetNamedGlobal(M, String_val(Name)))) {
 961    if (LLVMGetElementType(LLVMTypeOf(GlobalVar)) != Ty)
 962      return LLVMConstBitCast(GlobalVar, LLVMPointerType(Ty, 0));
 963    return GlobalVar;
 964  }
 965  return LLVMAddGlobal(M, Ty, String_val(Name));
 966}
 967
 968/* lltype -> string -> int -> llmodule -> llvalue */
 969CAMLprim LLVMValueRef llvm_declare_qualified_global(LLVMTypeRef Ty, value Name,
 970                                                    value AddressSpace,
 971                                                    LLVMModuleRef M) {
 972  LLVMValueRef GlobalVar;
 973  if ((GlobalVar = LLVMGetNamedGlobal(M, String_val(Name)))) {
 974    if (LLVMGetElementType(LLVMTypeOf(GlobalVar)) != Ty)
 975      return LLVMConstBitCast(GlobalVar,
 976                              LLVMPointerType(Ty, Int_val(AddressSpace)));
 977    return GlobalVar;
 978  }
 979  return LLVMAddGlobalInAddressSpace(M, Ty, String_val(Name),
 980                                     Int_val(AddressSpace));
 981}
 982
 983/* string -> llmodule -> llvalue option */
 984CAMLprim value llvm_lookup_global(value Name, LLVMModuleRef M) {
 985  CAMLparam1(Name);
 986  LLVMValueRef GlobalVar;
 987  if ((GlobalVar = LLVMGetNamedGlobal(M, String_val(Name)))) {
 988    value Option = alloc(1, 0);
 989    Field(Option, 0) = (value) GlobalVar;
 990    CAMLreturn(Option);
 991  }
 992  CAMLreturn(Val_int(0));
 993}
 994
 995/* string -> llvalue -> llmodule -> llvalue */
 996CAMLprim LLVMValueRef llvm_define_global(value Name, LLVMValueRef Initializer,
 997                                         LLVMModuleRef M) {
 998  LLVMValueRef GlobalVar = LLVMAddGlobal(M, LLVMTypeOf(Initializer),
 999                                         String_val(Name));
1000  LLVMSetInitializer(GlobalVar, Initializer);
1001  return GlobalVar;
1002}
1003
1004/* string -> llvalue -> int -> llmodule -> llvalue */
1005CAMLprim LLVMValueRef llvm_define_qualified_global(value Name,
1006                                                   LLVMValueRef Initializer,
1007                                                   value AddressSpace,
1008                                                   LLVMModuleRef M) {
1009  LLVMValueRef GlobalVar = LLVMAddGlobalInAddressSpace(M,
1010                                                       LLVMTypeOf(Initializer),
1011                                                       String_val(Name),
1012                                                       Int_val(AddressSpace));
1013  LLVMSetInitializer(GlobalVar, Initializer);
1014  return GlobalVar;
1015}
1016
1017/* llvalue -> unit */
1018CAMLprim value llvm_delete_global(LLVMValueRef GlobalVar) {
1019  LLVMDeleteGlobal(GlobalVar);
1020  return Val_unit;
1021}
1022
1023/* llvalue -> llvalue -> unit */
1024CAMLprim value llvm_set_initializer(LLVMValueRef ConstantVal,
1025                                    LLVMValueRef GlobalVar) {
1026  LLVMSetInitializer(GlobalVar, ConstantVal);
1027  return Val_unit;
1028}
1029
1030/* llvalue -> unit */
1031CAMLprim value llvm_remove_initializer(LLVMValueRef GlobalVar) {
1032  LLVMSetInitializer(GlobalVar, NULL);
1033  return Val_unit;
1034}
1035
1036/* llvalue -> bool */
1037CAMLprim value llvm_is_thread_local(LLVMValueRef GlobalVar) {
1038  return Val_bool(LLVMIsThreadLocal(GlobalVar));
1039}
1040
1041/* bool -> llvalue -> unit */
1042CAMLprim value llvm_set_thread_local(value IsThreadLocal,
1043                                     LLVMValueRef GlobalVar) {
1044  LLVMSetThreadLocal(GlobalVar, Bool_val(IsThreadLocal));
1045  return Val_unit;
1046}
1047
1048/* llvalue -> ThreadLocalMode.t */
1049CAMLprim value llvm_thread_local_mode(LLVMValueRef GlobalVar) {
1050  return Val_int(LLVMGetThreadLocalMode(GlobalVar));
1051}
1052
1053/* ThreadLocalMode.t -> llvalue -> unit */
1054CAMLprim value llvm_set_thread_local_mode(value ThreadLocalMode,
1055                                          LLVMValueRef GlobalVar) {
1056  LLVMSetThreadLocalMode(GlobalVar, Int_val(ThreadLocalMode));
1057  return Val_unit;
1058}
1059
1060/* llvalue -> bool */
1061CAMLprim value llvm_is_externally_initialized(LLVMValueRef GlobalVar) {
1062  return Val_bool(LLVMIsExternallyInitialized(GlobalVar));
1063}
1064
1065/* bool -> llvalue -> unit */
1066CAMLprim value llvm_set_externally_initialized(value IsExternallyInitialized,
1067                                               LLVMValueRef GlobalVar) {
1068  LLVMSetExternallyInitialized(GlobalVar, Bool_val(IsExternallyInitialized));
1069  return Val_unit;
1070}
1071
1072/* llvalue -> bool */
1073CAMLprim value llvm_is_global_constant(LLVMValueRef GlobalVar) {
1074  return Val_bool(LLVMIsGlobalConstant(GlobalVar));
1075}
1076
1077/* bool -> llvalue -> unit */
1078CAMLprim value llvm_set_global_constant(value Flag, LLVMValueRef GlobalVar) {
1079  LLVMSetGlobalConstant(GlobalVar, Bool_val(Flag));
1080  return Val_unit;
1081}
1082
1083/*--... Operations on aliases ..............................................--*/
1084
1085CAMLprim LLVMValueRef llvm_add_alias(LLVMModuleRef M, LLVMTypeRef Ty,
1086                                     LLVMValueRef Aliasee, value Name) {
1087  return LLVMAddAlias(M, Ty, Aliasee, String_val(Name));
1088}
1089
1090/*--... Operations on functions ............................................--*/
1091
1092DEFINE_ITERATORS(function, Function, LLVMModuleRef, LLVMValueRef,
1093                 LLVMGetGlobalParent)
1094
1095/* string -> lltype -> llmodule -> llvalue */
1096CAMLprim LLVMValueRef llvm_declare_function(value Name, LLVMTypeRef Ty,
1097                                            LLVMModuleRef M) {
1098  LLVMValueRef Fn;
1099  if ((Fn = LLVMGetNamedFunction(M, String_val(Name)))) {
1100    if (LLVMGetElementType(LLVMTypeOf(Fn)) != Ty)
1101      return LLVMConstBitCast(Fn, LLVMPointerType(Ty, 0));
1102    return Fn;
1103  }
1104  return LLVMAddFunction(M, String_val(Name), Ty);
1105}
1106
1107/* string -> llmodule -> llvalue option */
1108CAMLprim value llvm_lookup_function(value Name, LLVMModuleRef M) {
1109  CAMLparam1(Name);
1110  LLVMValueRef Fn;
1111  if ((Fn = LLVMGetNamedFunction(M, String_val(Name)))) {
1112    value Option = alloc(1, 0);
1113    Field(Option, 0) = (value) Fn;
1114    CAMLreturn(Option);
1115  }
1116  CAMLreturn(Val_int(0));
1117}
1118
1119/* string -> lltype -> llmodule -> llvalue */
1120CAMLprim LLVMValueRef llvm_define_function(value Name, LLVMTypeRef Ty,
1121                                           LLVMModuleRef M) {
1122  LLVMValueRef Fn = LLVMAddFunction(M, String_val(Name), Ty);
1123  LLVMAppendBasicBlockInContext(LLVMGetTypeContext(Ty), Fn, "entry");
1124  return Fn;
1125}
1126
1127/* llvalue -> unit */
1128CAMLprim value llvm_delete_function(LLVMValueRef Fn) {
1129  LLVMDeleteFunction(Fn);
1130  return Val_unit;
1131}
1132
1133/* llvalue -> bool */
1134CAMLprim value llvm_is_intrinsic(LLVMValueRef Fn) {
1135  return Val_bool(LLVMGetIntrinsicID(Fn));
1136}
1137
1138/* llvalue -> int */
1139CAMLprim value llvm_function_call_conv(LLVMValueRef Fn) {
1140  return Val_int(LLVMGetFunctionCallConv(Fn));
1141}
1142
1143/* int -> llvalue -> unit */
1144CAMLprim value llvm_set_function_call_conv(value Id, LLVMValueRef Fn) {
1145  LLVMSetFunctionCallConv(Fn, Int_val(Id));
1146  return Val_unit;
1147}
1148
1149/* llvalue -> string option */
1150CAMLprim value llvm_gc(LLVMValueRef Fn) {
1151  const char *GC;
1152  CAMLparam0();
1153  CAMLlocal2(Name, Option);
1154  
1155  if ((GC = LLVMGetGC(Fn))) {
1156    Name = copy_string(GC);
1157    
1158    Option = alloc(1, 0);
1159    Field(Option, 0) = Name;
1160    CAMLreturn(Option);
1161  } else {
1162    CAMLreturn(Val_int(0));
1163  }
1164}
1165
1166/* string option -> llvalue -> unit */
1167CAMLprim value llvm_set_gc(value GC, LLVMValueRef Fn) {
1168  LLVMSetGC(Fn, GC == Val_int(0)? 0 : String_val(Field(GC, 0)));
1169  return Val_unit;
1170}
1171
1172/* llvalue -> int32 -> unit */
1173CAMLprim value llvm_add_function_attr(LLVMValueRef Arg, value PA) {
1174  LLVMAddFunctionAttr(Arg, Int32_val(PA));
1175  return Val_unit;
1176}
1177
1178/* llvalue -> string -> string -> unit */
1179CAMLprim value llvm_add_target_dependent_function_attr(
1180                  LLVMValueRef Arg, value A, value V) {
1181  LLVMAddTargetDependentFunctionAttr(Arg, String_val(A), String_val(V));
1182  return Val_unit;
1183}
1184
1185/* llvalue -> int32 */
1186CAMLprim value llvm_function_attr(LLVMValueRef Fn)
1187{
1188    CAMLparam0();
1189    CAMLreturn(caml_copy_int32(LLVMGetFunctionAttr(Fn)));
1190}
1191
1192/* llvalue -> int32 -> unit */
1193CAMLprim value llvm_remove_function_attr(LLVMValueRef Arg, value PA) {
1194  LLVMRemoveFunctionAttr(Arg, Int32_val(PA));
1195  return Val_unit;
1196}
1197/*--... Operations on parameters ...........................................--*/
1198
1199DEFINE_ITERATORS(param, Param, LLVMValueRef, LLVMValueRef, LLVMGetParamParent)
1200
1201/* llvalue -> int -> llvalue */
1202CAMLprim LLVMValueRef llvm_param(LLVMValueRef Fn, value Index) {
1203  return LLVMGetParam(Fn, Int_val(Index));
1204}
1205
1206/* llvalue -> int */
1207CAMLprim value llvm_param_attr(LLVMValueRef Param)
1208{
1209    CAMLparam0();
1210    CAMLreturn(caml_copy_int32(LLVMGetAttribute(Param)));
1211}
1212
1213/* llvalue -> llvalue */
1214CAMLprim value llvm_params(LLVMValueRef Fn) {
1215  value Params = alloc(LLVMCountParams(Fn), 0);
1216  LLVMGetParams(Fn, (LLVMValueRef *) Op_val(Params));
1217  return Params;
1218}
1219
1220/* llvalue -> int32 -> unit */
1221CAMLprim value llvm_add_param_attr(LLVMValueRef Arg, value PA) {
1222  LLVMAddAttribute(Arg, Int32_val(PA));
1223  return Val_unit;
1224}
1225
1226/* llvalue -> int32 -> unit */
1227CAMLprim value llvm_remove_param_attr(LLVMValueRef Arg, value PA) {
1228  LLVMRemoveAttribute(Arg, Int32_val(PA));
1229  return Val_unit;
1230}
1231
1232/* llvalue -> int -> unit */
1233CAMLprim value llvm_set_param_alignment(LLVMValueRef Arg, value align) {
1234  LLVMSetParamAlignment(Arg, Int_val(align));
1235  return Val_unit;
1236}
1237
1238/*--... Operations on basic blocks .........................................--*/
1239
1240DEFINE_ITERATORS(
1241  block, BasicBlock, LLVMValueRef, LLVMBasicBlockRef, LLVMGetBasicBlockParent)
1242
1243/* llbasicblock -> llvalue option */
1244CAMLprim value llvm_block_terminator(LLVMBasicBlockRef Block)
1245{
1246  CAMLparam0();
1247  LLVMValueRef Term = LLVMGetBasicBlockTerminator(Block);
1248  if (Term) {
1249    value Option = alloc(1, 0);
1250    Field(Option, 0) = (value) Term;
1251    CAMLreturn(Option);
1252  }
1253  CAMLreturn(Val_int(0));
1254}
1255
1256/* llvalue -> llbasicblock array */
1257CAMLprim value llvm_basic_blocks(LLVMValueRef Fn) {
1258  value MLArray = alloc(LLVMCountBasicBlocks(Fn), 0);
1259  LLVMGetBasicBlocks(Fn, (LLVMBasicBlockRef *) Op_val(MLArray));
1260  return MLArray;
1261}
1262
1263/* llbasicblock -> unit */
1264CAMLprim value llvm_delete_block(LLVMBasicBlockRef BB) {
1265  LLVMDeleteBasicBlock(BB);
1266  return Val_unit;
1267}
1268
1269/* llbasicblock -> unit */
1270CAMLprim value llvm_remove_block(LLVMBasicBlockRef BB) {
1271  LLVMRemoveBasicBlockFromParent(BB);
1272  return Val_unit;
1273}
1274
1275/* llbasicblock -> llbasicblock -> unit */
1276CAMLprim value llvm_move_block_before(LLVMBasicBlockRef Pos, LLVMBasicBlockRef BB) {
1277  LLVMMoveBasicBlockBefore(BB, Pos);
1278  return Val_unit;
1279}
1280
1281/* llbasicblock -> llbasicblock -> unit */
1282CAMLprim value llvm_move_block_after(LLVMBasicBlockRef Pos, LLVMBasicBlockRef BB) {
1283  LLVMMoveBasicBlockAfter(BB, Pos);
1284  return Val_unit;
1285}
1286
1287/* string -> llvalue -> llbasicblock */
1288CAMLprim LLVMBasicBlockRef llvm_append_block(LLVMContextRef Context, value Name,
1289                                             LLVMValueRef Fn) {
1290  return LLVMAppendBasicBlockInContext(Context, Fn, String_val(Name));
1291}
1292
1293/* string -> llbasicblock -> llbasicblock */
1294CAMLprim LLVMBasicBlockRef llvm_insert_block(LLVMContextRef Context, value Name,
1295                                             LLVMBasicBlockRef BB) {
1296  return LLVMInsertBasicBlockInContext(Context, BB, String_val(Name));
1297}
1298
1299/* llvalue -> bool */
1300CAMLprim value llvm_value_is_block(LLVMValueRef Val) {
1301  return Val_bool(LLVMValueIsBasicBlock(Val));
1302}
1303
1304/*--... Operations on instructions .........................................--*/
1305
1306DEFINE_ITERATORS(instr, Instruction, LLVMBasicBlockRef, LLVMValueRef,
1307                 LLVMGetInstructionParent)
1308
1309/* llvalue -> Opcode.t */
1310CAMLprim value llvm_instr_get_opcode(LLVMValueRef Inst) {
1311  LLVMOpcode o;
1312  if (!LLVMIsAInstruction(Inst))
1313      failwith("Not an instruction");
1314  o = LLVMGetInstructionOpcode(Inst);
1315  assert (o <= LLVMLandingPad);
1316  return Val_int(o);
1317}
1318
1319/* llvalue -> ICmp.t option */
1320CAMLprim value llvm_instr_icmp_predicate(LLVMValueRef Val) {
1321  CAMLparam0();
1322  int x = LLVMGetICmpPredicate(Val);
1323  if (x) {
1324    value Option = alloc(1, 0);
1325    Field(Option, 0) = Val_int(x - LLVMIntEQ);
1326    CAMLreturn(Option);
1327  }
1328  CAMLreturn(Val_int(0));
1329}
1330
1331
1332/*--... Operations on call sites ...........................................--*/
1333
1334/* llvalue -> int */
1335CAMLprim value llvm_instruction_call_conv(LLVMValueRef Inst) {
1336  return Val_int(LLVMGetInstructionCallConv(Inst));
1337}
1338
1339/* int -> llvalue -> unit */
1340CAMLprim value llvm_set_instruction_call_conv(value CC, LLVMValueRef Inst) {
1341  LLVMSetInstructionCallConv(Inst, Int_val(CC));
1342  return Val_unit;
1343}
1344
1345/* llvalue -> int -> int32 -> unit */
1346CAMLprim value llvm_add_instruction_param_attr(LLVMValueRef Instr,
1347                                               value index,
1348                                               value PA) {
1349  LLVMAddInstrAttribute(Instr, Int_val(index), Int32_val(PA));
1350  return Val_unit;
1351}
1352
1353/* llvalue -> int -> int32 -> unit */
1354CAMLprim value llvm_remove_instruction_param_attr(LLVMValueRef Instr,
1355                                                  value index,
1356                                                  value PA) {
1357  LLVMRemoveInstrAttribute(Instr, Int_val(index), Int32_val(PA));
1358  return Val_unit;
1359}
1360
1361/*--... Operations on call instructions (only) .............................--*/
1362
1363/* llvalue -> bool */
1364CAMLprim value llvm_is_tail_call(LLVMValueRef CallInst) {
1365  return Val_bool(LLVMIsTailCall(CallInst));
1366}
1367
1368/* bool -> llvalue -> unit */
1369CAMLprim value llvm_set_tail_call(value IsTailCall,
1370                                  LLVMValueRef CallInst) {
1371  LLVMSetTailCall(CallInst, Bool_val(IsTailCall));
1372  return Val_unit;
1373}
1374
1375/*--... Operations on load/store instructions (only)........................--*/
1376
1377/* llvalue -> bool */
1378CAMLprim value llvm_is_volatile(LLVMValueRef MemoryInst) {
1379  return Val_bool(LLVMGetVolatile(MemoryInst));
1380}
1381
1382/* bool -> llvalue -> unit */
1383CAMLprim value llvm_set_volatile(value IsVolatile,
1384                                  LLVMValueRef MemoryInst) {
1385  LLVMSetVolatile(MemoryInst, Bool_val(IsVolatile));
1386  return Val_unit;
1387}
1388
1389/*--... Operations on phi nodes ............................................--*/
1390
1391/* (llvalue * llbasicblock) -> llvalue -> unit */
1392CAMLprim value llvm_add_incoming(value Incoming, LLVMValueRef PhiNode) {
1393  LLVMAddIncoming(PhiNode,
1394                  (LLVMValueRef*) &Field(Incoming, 0),
1395                  (LLVMBasicBlockRef*) &Field(Incoming, 1),
1396                  1);
1397  return Val_unit;
1398}
1399
1400/* llvalue -> (llvalue * llbasicblock) list */
1401CAMLprim value llvm_incoming(LLVMValueRef PhiNode) {
1402  unsigned I;
1403  CAMLparam0();
1404  CAMLlocal3(Hd, Tl, Tmp);
1405  
1406  /* Build a tuple list of them. */
1407  Tl = Val_int(0);
1408  for (I = LLVMCountIncoming(PhiNode); I != 0; ) {
1409    Hd = alloc(2, 0);
1410    Store_field(Hd, 0, (value) LLVMGetIncomingValue(PhiNode, --I));
1411    Store_field(Hd, 1, (value) LLVMGetIncomingBlock(PhiNode, I));
1412    
1413    Tmp = alloc(2, 0);
1414    Store_field(Tmp, 0, Hd);
1415    Store_field(Tmp, 1, Tl);
1416    Tl = Tmp;
1417  }
1418  
1419  CAMLreturn(Tl);
1420}
1421
1422/* llvalue -> unit */
1423CAMLprim value llvm_delete_instruction(LLVMValueRef Instruction) {
1424  LLVMInstructionEraseFromParent(Instruction);
1425  return Val_unit;
1426}
1427
1428/*===-- Instruction builders ----------------------------------------------===*/
1429
1430#define Builder_val(v)  (*(LLVMBuilderRef *)(Data_custom_val(v)))
1431
1432static void llvm_finalize_builder(value B) {
1433  LLVMDisposeBuilder(Builder_val(B));
1434}
1435
1436static struct custom_operations builder_ops = {
1437  (char *) "LLVMIRBuilder",
1438  llvm_finalize_builder,
1439  custom_compare_default,
1440  custom_hash_default,
1441  custom_serialize_default,
1442  custom_deserialize_default
1443#ifdef custom_compare_ext_default
1444  , custom_compare_ext_default
1445#endif
1446};
1447
1448static value alloc_builder(LLVMBuilderRef B) {
1449  value V = alloc_custom(&builder_ops, sizeof(LLVMBuilderRef), 0, 1);
1450  Builder_val(V) = B;
1451  return V;
1452}
1453
1454/* llcontext -> llbuilder */
1455CAMLprim value llvm_builder(LLVMContextRef C) {
1456  return alloc_builder(LLVMCreateBuilderInContext(C));
1457}
1458
1459/* (llbasicblock, llvalue) llpos -> llbuilder -> unit */
1460CAMLprim value llvm_position_builder(value Pos, value B) {
1461  if (Tag_val(Pos) == 0) {
1462    LLVMBasicBlockRef BB = (LLVMBasicBlockRef) Op_val(Field(Pos, 0));
1463    LLVMPositionBuilderAtEnd(Builder_val(B), BB);
1464  } else {
1465    LLVMValueRef I = (LLVMValueRef) Op_val(Field(Pos, 0));
1466    LLVMPositionBuilderBefore(Builder_val(B), I);
1467  }
1468  return Val_unit;
1469}
1470
1471/* llbuilder -> llbasicblock */
1472CAMLprim LLVMBasicBlockRef llvm_insertion_block(value B) {
1473  LLVMBasicBlockRef InsertBlock = LLVMGetInsertBlock(Builder_val(B));
1474  if (!InsertBlock)
1475    raise_not_found();
1476  return InsertBlock;
1477}
1478
1479/* llvalue -> string -> llbuilder -> unit */
1480CAMLprim value llvm_insert_into_builder(LLVMValueRef I, value Name, value B) {
1481  LLVMInsertIntoBuilderWithName(Builder_val(B), I, String_val(Name));
1482  return Val_unit;
1483}
1484
1485/*--... Metadata ...........................................................--*/
1486
1487/* llbuilder -> llvalue -> unit */
1488CAMLprim value llvm_set_current_debug_location(value B, LLVMValueRef V) {
1489  LLVMSetCurrentDebugLocation(Builder_val(B), V);
1490  return Val_unit;
1491}
1492
1493/* llbuilder -> unit */
1494CAMLprim value llvm_clear_current_debug_location(value B) {
1495  LLVMSetCurrentDebugLocation(Builder_val(B), NULL);
1496  return Val_unit;
1497}
1498
1499/* llbuilder -> llvalue option */
1500CAMLprim value llvm_current_debug_location(value B) {
1501  CAMLparam0();
1502  LLVMValueRef L;
1503  if ((L = LLVMGetCurrentDebugLocation(Builder_val(B)))) {
1504    value Option = alloc(1, 0);
1505    Field(Option, 0) = (value) L;
1506    CAMLreturn(Option);
1507  }
1508  CAMLreturn(Val_int(0));
1509}
1510
1511/* llbuilder -> llvalue -> unit */
1512CAMLprim value llvm_set_inst_debug_location(value B, LLVMValueRef V) {
1513  LLVMSetInstDebugLocation(Builder_val(B), V);
1514  return Val_unit;
1515}
1516
1517
1518/*--... Terminators ........................................................--*/
1519
1520/* llbuilder -> llvalue */
1521CAMLprim LLVMValueRef llvm_build_ret_void(value B) {
1522  return LLVMBuildRetVoid(Builder_val(B));
1523}
1524
1525/* llvalue -> llbuilder -> llvalue */
1526CAMLprim LLVMValueRef llvm_build_ret(LLVMValueRef Val, value B) {
1527  return LLVMBuildRet(Builder_val(B), Val);
1528}
1529
1530/* llvalue array -> llbuilder -> llvalue */
1531CAMLprim LLVMValueRef llvm_build_aggregate_ret(value RetVals, value B) {
1532  return LLVMBuildAggregateRet(Builder_val(B), (LLVMValueRef *) Op_val(RetVals),
1533                               Wosize_val(RetVals));
1534}
1535
1536/* llbasicblock -> llbuilder -> llvalue */
1537CAMLprim LLVMValueRef llvm_build_br(LLVMBasicBlockRef BB, value B) {
1538  return LLVMBuildBr(Builder_val(B), BB);
1539}
1540
1541/* llvalue -> llbasicblock -> llbasicblock -> llbuilder -> llvalue */
1542CAMLprim LLVMValueRef llvm_build_cond_br(LLVMValueRef If,
1543                                         LLVMBasicBlockRef Then,
1544                                         LLVMBasicBlockRef Else,
1545                                         value B) {
1546  return LLVMBuildCondBr(Builder_val(B), If, Then, Else);
1547}
1548
1549/* llvalue -> llbasicblock -> int -> llbuilder -> llvalue */
1550CAMLprim LLVMValueRef llvm_build_switch(LLVMValueRef Of,
1551                                        LLVMBasicBlockRef Else,
1552                                        value EstimatedCount,
1553                                        value B) {
1554  return LLVMBuildSwitch(Builder_val(B), Of, Else, Int_val(EstimatedCount));
1555}
1556
1557/* lltype -> string -> llbuilder -> llvalue */
1558CAMLprim LLVMValueRef llvm_build_malloc(LLVMTypeRef Ty, value Name,
1559                                        value B)
1560{
1561  return LLVMBuildMalloc(Builder_val(B), Ty, String_val(Name));
1562}
1563
1564/* lltype -> llvalue -> string -> llbuilder -> llvalue */
1565CAMLprim LLVMValueRef llvm_build_array_malloc(LLVMTypeRef Ty,
1566                                              LLVMValueRef Val,
1567                                              value Name, value B)
1568{
1569  return LLVMBuildArrayMalloc(Builder_val(B), Ty, Val, String_val(Name));
1570}
1571
1572/* llvalue -> llbuilder -> llvalue */
1573CAMLprim LLVMValueRef llvm_build_free(LLVMValueRef P, value B)
1574{
1575  return LLVMBuildFree(Builder_val(B), P);
1576}
1577
1578/* llvalue -> llvalue -> llbasicblock -> unit */
1579CAMLprim value llvm_add_case(LLVMValueRef Switch, LLVMValueRef OnVal,
1580                             LLVMBasicBlockRef Dest) {
1581  LLVMAddCase(Switch, OnVal, Dest);
1582  return Val_unit;
1583}
1584
1585/* llvalue -> llbasicblock -> llbuilder -> llvalue */
1586CAMLprim LLVMValueRef llvm_build_indirect_br(LLVMValueRef Addr,
1587                                             value 

Large files files are truncated, but you can click here to view the full file