1 /*===-- llvm_ocaml.c - LLVM OCaml Glue --------------------------*- C++ -*-===*\ 2 |* *| 3 |* Part of the LLVM Project, under the Apache License v2.0 with LLVM *| 4 |* Exceptions. *| 5 |* See https://llvm.org/LICENSE.txt for license information. *| 6 |* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception *| 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 <assert.h> 19 #include <stdlib.h> 20 #include <string.h> 21 #include "llvm-c/Core.h" 22 #include "llvm-c/Support.h" 23 #include "llvm/Config/llvm-config.h" 24 #include "caml/memory.h" 25 #include "caml/fail.h" 26 #include "caml/callback.h" 27 #include "llvm_ocaml.h" 28 29 #if OCAML_VERSION < 41200 30 value caml_alloc_some(value v) { 31 CAMLparam1(v); 32 value Some = caml_alloc_small(1, 0); 33 Field(Some, 0) = v; 34 CAMLreturn(Some); 35 } 36 #endif 37 38 value caml_alloc_tuple_uninit(mlsize_t wosize) { 39 if (wosize <= Max_young_wosize) { 40 return caml_alloc_small(wosize, 0); 41 } else { 42 return caml_alloc_shr(wosize, 0); 43 } 44 } 45 46 value to_val(void *ptr) { 47 assert((((value)ptr) & 1) == 0 && 48 "OCaml bindings assume LLVM objects are at least 2-byte aligned"); 49 return ((value)ptr) | 1; 50 } 51 52 void *from_val(value v) { 53 assert(Is_long(v) && "OCaml values representing LLVM objects should have the " 54 "low bit set so that the OCaml GC " 55 "treats them as tagged integers"); 56 return (void *)(v ^ 1); 57 } 58 59 value llvm_string_of_message(char *Message) { 60 value String = caml_copy_string(Message); 61 LLVMDisposeMessage(Message); 62 63 return String; 64 } 65 66 value ptr_to_option(void *Ptr) { 67 if (!Ptr) 68 return Val_none; 69 return caml_alloc_some(to_val(Ptr)); 70 } 71 72 value cstr_to_string(const char *Str, mlsize_t Len) { 73 if (!Str) 74 return caml_alloc_string(0); 75 value String = caml_alloc_string(Len); 76 memcpy((char *)String_val(String), Str, Len); 77 return String; 78 } 79 80 value cstr_to_string_option(const char *CStr, mlsize_t Len) { 81 if (!CStr) 82 return Val_none; 83 value String = caml_alloc_string(Len); 84 memcpy((char *)String_val(String), CStr, Len); 85 return caml_alloc_some(String); 86 } 87 88 void llvm_raise(value Prototype, char *Message) { 89 caml_raise_with_arg(Prototype, llvm_string_of_message(Message)); 90 } 91 92 static value llvm_fatal_error_handler; 93 94 static void llvm_fatal_error_trampoline(const char *Reason) { 95 caml_callback(llvm_fatal_error_handler, caml_copy_string(Reason)); 96 } 97 98 value llvm_install_fatal_error_handler(value Handler) { 99 LLVMInstallFatalErrorHandler(llvm_fatal_error_trampoline); 100 llvm_fatal_error_handler = Handler; 101 caml_register_global_root(&llvm_fatal_error_handler); 102 return Val_unit; 103 } 104 105 value llvm_reset_fatal_error_handler(value Unit) { 106 caml_remove_global_root(&llvm_fatal_error_handler); 107 LLVMResetFatalErrorHandler(); 108 return Val_unit; 109 } 110 111 value llvm_enable_pretty_stacktrace(value Unit) { 112 LLVMEnablePrettyStackTrace(); 113 return Val_unit; 114 } 115 116 value llvm_parse_command_line_options(value Overview, value Args) { 117 const char *COverview; 118 if (Overview == Val_int(0)) { 119 COverview = NULL; 120 } else { 121 COverview = String_val(Field(Overview, 0)); 122 } 123 LLVMParseCommandLineOptions(Wosize_val(Args), 124 (const char *const *)Op_val(Args), COverview); 125 return Val_unit; 126 } 127 128 void *from_val_array(value Elements) { 129 mlsize_t Length = Wosize_val(Elements); 130 void **Temp = malloc(sizeof(void *) * Length); 131 if (Temp == NULL) 132 caml_raise_out_of_memory(); 133 for (unsigned I = 0; I < Length; ++I) { 134 Temp[I] = from_val(Field(Elements, I)); 135 } 136 return Temp; 137 } 138 139 static value alloc_variant(int tag, value Value) { 140 value Iter = caml_alloc_small(1, tag); 141 Field(Iter, 0) = Value; 142 return Iter; 143 } 144 145 /* Macro to convert the C first/next/last/prev idiom to the Ocaml llpos/ 146 llrev_pos idiom. */ 147 #define DEFINE_ITERATORS(camlname, cname, pty_val, cty, cty_val, pfun) \ 148 /* llmodule -> ('a, 'b) llpos */ \ 149 value llvm_##camlname##_begin(value Mom) { \ 150 cty First = LLVMGetFirst##cname(pty_val(Mom)); \ 151 if (First) \ 152 return alloc_variant(1, to_val(First)); \ 153 return alloc_variant(0, Mom); \ 154 } \ 155 \ 156 /* llvalue -> ('a, 'b) llpos */ \ 157 value llvm_##camlname##_succ(value Kid) { \ 158 cty Next = LLVMGetNext##cname(cty_val(Kid)); \ 159 if (Next) \ 160 return alloc_variant(1, to_val(Next)); \ 161 return alloc_variant(0, to_val(pfun(cty_val(Kid)))); \ 162 } \ 163 \ 164 /* llmodule -> ('a, 'b) llrev_pos */ \ 165 value llvm_##camlname##_end(value Mom) { \ 166 cty Last = LLVMGetLast##cname(pty_val(Mom)); \ 167 if (Last) \ 168 return alloc_variant(1, to_val(Last)); \ 169 return alloc_variant(0, Mom); \ 170 } \ 171 \ 172 /* llvalue -> ('a, 'b) llrev_pos */ \ 173 value llvm_##camlname##_pred(value Kid) { \ 174 cty Prev = LLVMGetPrevious##cname(cty_val(Kid)); \ 175 if (Prev) \ 176 return alloc_variant(1, to_val(Prev)); \ 177 return alloc_variant(0, to_val(pfun(cty_val(Kid)))); \ 178 } 179 180 /*===-- Context error handling --------------------------------------------===*/ 181 182 void llvm_diagnostic_handler_trampoline(LLVMDiagnosticInfoRef DI, 183 void *DiagnosticContext) { 184 caml_callback(*((value *)DiagnosticContext), to_val(DI)); 185 } 186 187 /* Diagnostic.t -> string */ 188 value llvm_get_diagnostic_description(value Diagnostic) { 189 return llvm_string_of_message( 190 LLVMGetDiagInfoDescription(DiagnosticInfo_val(Diagnostic))); 191 } 192 193 /* Diagnostic.t -> DiagnosticSeverity.t */ 194 value llvm_get_diagnostic_severity(value Diagnostic) { 195 return Val_int(LLVMGetDiagInfoSeverity(DiagnosticInfo_val(Diagnostic))); 196 } 197 198 static void llvm_remove_diagnostic_handler(value C) { 199 CAMLparam1(C); 200 LLVMContextRef context = Context_val(C); 201 if (LLVMContextGetDiagnosticHandler(context) == 202 llvm_diagnostic_handler_trampoline) { 203 value *Handler = (value *)LLVMContextGetDiagnosticContext(context); 204 caml_remove_global_root(Handler); 205 free(Handler); 206 } 207 CAMLreturn0; 208 } 209 210 /* llcontext -> (Diagnostic.t -> unit) option -> unit */ 211 value llvm_set_diagnostic_handler(value C, value Handler) { 212 CAMLparam2(C, Handler); 213 LLVMContextRef context = Context_val(C); 214 llvm_remove_diagnostic_handler(C); 215 if (Handler == Val_none) { 216 LLVMContextSetDiagnosticHandler(context, NULL, NULL); 217 } else { 218 value *DiagnosticContext = malloc(sizeof(value)); 219 if (DiagnosticContext == NULL) 220 caml_raise_out_of_memory(); 221 caml_register_global_root(DiagnosticContext); 222 *DiagnosticContext = Field(Handler, 0); 223 LLVMContextSetDiagnosticHandler(context, llvm_diagnostic_handler_trampoline, 224 DiagnosticContext); 225 } 226 CAMLreturn(Val_unit); 227 } 228 229 /*===-- Contexts ----------------------------------------------------------===*/ 230 231 /* unit -> llcontext */ 232 value llvm_create_context(value Unit) { return to_val(LLVMContextCreate()); } 233 234 /* llcontext -> unit */ 235 value llvm_dispose_context(value C) { 236 llvm_remove_diagnostic_handler(C); 237 LLVMContextDispose(Context_val(C)); 238 return Val_unit; 239 } 240 241 /* unit -> llcontext */ 242 value llvm_global_context(value Unit) { return to_val(LLVMGetGlobalContext()); } 243 244 /* llcontext -> string -> int */ 245 value llvm_mdkind_id(value C, value Name) { 246 unsigned MDKindID = LLVMGetMDKindIDInContext(Context_val(C), String_val(Name), 247 caml_string_length(Name)); 248 return Val_int(MDKindID); 249 } 250 251 /*===-- Attributes --------------------------------------------------------===*/ 252 253 /* string -> llattrkind */ 254 value llvm_enum_attr_kind(value Name) { 255 unsigned Kind = LLVMGetEnumAttributeKindForName(String_val(Name), 256 caml_string_length(Name)); 257 if (Kind == 0) 258 caml_raise_with_arg(*caml_named_value("Llvm.UnknownAttribute"), Name); 259 return Val_int(Kind); 260 } 261 262 /* llcontext -> int -> int64 -> llattribute */ 263 value llvm_create_enum_attr_by_kind(value C, value Kind, value Value) { 264 return to_val( 265 LLVMCreateEnumAttribute(Context_val(C), Int_val(Kind), Int64_val(Value))); 266 } 267 268 /* llattribute -> bool */ 269 value llvm_is_enum_attr(value A) { 270 return Val_int(LLVMIsEnumAttribute(Attribute_val(A))); 271 } 272 273 /* llattribute -> llattrkind */ 274 value llvm_get_enum_attr_kind(value A) { 275 return Val_int(LLVMGetEnumAttributeKind(Attribute_val(A))); 276 } 277 278 /* llattribute -> int64 */ 279 value llvm_get_enum_attr_value(value A) { 280 return caml_copy_int64(LLVMGetEnumAttributeValue(Attribute_val(A))); 281 } 282 283 /* llcontext -> kind:string -> name:string -> llattribute */ 284 value llvm_create_string_attr(value C, value Kind, value Value) { 285 return to_val(LLVMCreateStringAttribute( 286 Context_val(C), String_val(Kind), caml_string_length(Kind), 287 String_val(Value), caml_string_length(Value))); 288 } 289 290 /* llattribute -> bool */ 291 value llvm_is_string_attr(value A) { 292 return Val_int(LLVMIsStringAttribute(Attribute_val(A))); 293 } 294 295 /* llattribute -> string */ 296 value llvm_get_string_attr_kind(value A) { 297 unsigned Length; 298 const char *String = LLVMGetStringAttributeKind(Attribute_val(A), &Length); 299 return cstr_to_string(String, Length); 300 } 301 302 /* llattribute -> string */ 303 value llvm_get_string_attr_value(value A) { 304 unsigned Length; 305 const char *String = LLVMGetStringAttributeValue(Attribute_val(A), &Length); 306 return cstr_to_string(String, Length); 307 } 308 309 /*===-- Modules -----------------------------------------------------------===*/ 310 311 /* llcontext -> string -> llmodule */ 312 value llvm_create_module(value C, value ModuleID) { 313 return to_val( 314 LLVMModuleCreateWithNameInContext(String_val(ModuleID), Context_val(C))); 315 } 316 317 /* llmodule -> unit */ 318 value llvm_dispose_module(value M) { 319 LLVMDisposeModule(Module_val(M)); 320 return Val_unit; 321 } 322 323 /* llmodule -> string */ 324 value llvm_target_triple(value M) { 325 return caml_copy_string(LLVMGetTarget(Module_val(M))); 326 } 327 328 /* string -> llmodule -> unit */ 329 value llvm_set_target_triple(value Trip, value M) { 330 LLVMSetTarget(Module_val(M), String_val(Trip)); 331 return Val_unit; 332 } 333 334 /* llmodule -> string */ 335 value llvm_data_layout(value M) { 336 return caml_copy_string(LLVMGetDataLayout(Module_val(M))); 337 } 338 339 /* string -> llmodule -> unit */ 340 value llvm_set_data_layout(value Layout, value M) { 341 LLVMSetDataLayout(Module_val(M), String_val(Layout)); 342 return Val_unit; 343 } 344 345 /* llmodule -> unit */ 346 value llvm_dump_module(value M) { 347 LLVMDumpModule(Module_val(M)); 348 return Val_unit; 349 } 350 351 /* string -> llmodule -> unit */ 352 value llvm_print_module(value Filename, value M) { 353 char *Message; 354 355 if (LLVMPrintModuleToFile(Module_val(M), String_val(Filename), &Message)) 356 llvm_raise(*caml_named_value("Llvm.IoError"), Message); 357 358 return Val_unit; 359 } 360 361 /* llmodule -> string */ 362 value llvm_string_of_llmodule(value M) { 363 char *ModuleCStr = LLVMPrintModuleToString(Module_val(M)); 364 value ModuleStr = caml_copy_string(ModuleCStr); 365 LLVMDisposeMessage(ModuleCStr); 366 367 return ModuleStr; 368 } 369 370 /* llmodule -> llcontext */ 371 value llvm_get_module_context(value M) { 372 LLVMContextRef C = LLVMGetModuleContext(Module_val(M)); 373 return to_val(C); 374 } 375 376 /* llmodule -> string */ 377 value llvm_get_module_identifier(value M) { 378 size_t Len; 379 const char *Name = LLVMGetModuleIdentifier(Module_val(M), &Len); 380 return cstr_to_string(Name, (mlsize_t)Len); 381 } 382 383 /* llmodule -> string -> unit */ 384 value llvm_set_module_identifier(value M, value Id) { 385 LLVMSetModuleIdentifier(Module_val(M), String_val(Id), 386 caml_string_length(Id)); 387 return Val_unit; 388 } 389 390 /* llmodule -> string -> unit */ 391 value llvm_set_module_inline_asm(value M, value Asm) { 392 LLVMSetModuleInlineAsm(Module_val(M), String_val(Asm)); 393 return Val_unit; 394 } 395 396 /* llmodule -> string -> llmetadata option */ 397 value llvm_get_module_flag(value M, value Key) { 398 return ptr_to_option(LLVMGetModuleFlag(Module_val(M), String_val(Key), 399 caml_string_length(Key))); 400 } 401 402 /* llmodule -> ModuleFlagBehavior.t -> string -> llmetadata -> unit */ 403 value llvm_add_module_flag(value M, value Behaviour, value Key, value Val) { 404 LLVMAddModuleFlag(Module_val(M), Int_val(Behaviour), String_val(Key), 405 caml_string_length(Key), Metadata_val(Val)); 406 return Val_unit; 407 } 408 409 /*===-- Types -------------------------------------------------------------===*/ 410 411 /* lltype -> TypeKind.t */ 412 value llvm_classify_type(value Ty) { 413 return Val_int(LLVMGetTypeKind(Type_val(Ty))); 414 } 415 416 /* lltype -> bool */ 417 value llvm_type_is_sized(value Ty) { 418 return Val_bool(LLVMTypeIsSized(Type_val(Ty))); 419 } 420 421 /* lltype -> llcontext */ 422 value llvm_type_context(value Ty) { 423 return to_val(LLVMGetTypeContext(Type_val(Ty))); 424 } 425 426 /* lltype -> unit */ 427 value llvm_dump_type(value Val) { 428 #if !defined(NDEBUG) || defined(LLVM_ENABLE_DUMP) 429 LLVMDumpType(Type_val(Val)); 430 #else 431 caml_raise_with_arg(*caml_named_value("Llvm.FeatureDisabled"), 432 caml_copy_string("dump")); 433 #endif 434 return Val_unit; 435 } 436 437 /* lltype -> string */ 438 value llvm_string_of_lltype(value M) { 439 char *TypeCStr = LLVMPrintTypeToString(Type_val(M)); 440 value TypeStr = caml_copy_string(TypeCStr); 441 LLVMDisposeMessage(TypeCStr); 442 443 return TypeStr; 444 } 445 446 /*--... Operations on integer types ........................................--*/ 447 448 /* llcontext -> lltype */ 449 value llvm_i1_type(value Context) { 450 return to_val(LLVMInt1TypeInContext(Context_val(Context))); 451 } 452 453 /* llcontext -> lltype */ 454 value llvm_i8_type(value Context) { 455 return to_val(LLVMInt8TypeInContext(Context_val(Context))); 456 } 457 458 /* llcontext -> lltype */ 459 value llvm_i16_type(value Context) { 460 return to_val(LLVMInt16TypeInContext(Context_val(Context))); 461 } 462 463 /* llcontext -> lltype */ 464 value llvm_i32_type(value Context) { 465 return to_val(LLVMInt32TypeInContext(Context_val(Context))); 466 } 467 468 /* llcontext -> lltype */ 469 value llvm_i64_type(value Context) { 470 return to_val(LLVMInt64TypeInContext(Context_val(Context))); 471 } 472 473 /* llcontext -> int -> lltype */ 474 value llvm_integer_type(value Context, value Width) { 475 return to_val(LLVMIntTypeInContext(Context_val(Context), Int_val(Width))); 476 } 477 478 /* lltype -> int */ 479 value llvm_integer_bitwidth(value IntegerTy) { 480 return Val_int(LLVMGetIntTypeWidth(Type_val(IntegerTy))); 481 } 482 483 /*--... Operations on real types ...........................................--*/ 484 485 /* llcontext -> lltype */ 486 value llvm_float_type(value Context) { 487 return to_val(LLVMFloatTypeInContext(Context_val(Context))); 488 } 489 490 /* llcontext -> lltype */ 491 value llvm_double_type(value Context) { 492 return to_val(LLVMDoubleTypeInContext(Context_val(Context))); 493 } 494 495 /* llcontext -> lltype */ 496 value llvm_x86fp80_type(value Context) { 497 return to_val(LLVMX86FP80TypeInContext(Context_val(Context))); 498 } 499 500 /* llcontext -> lltype */ 501 value llvm_fp128_type(value Context) { 502 return to_val(LLVMFP128TypeInContext(Context_val(Context))); 503 } 504 505 /* llcontext -> lltype */ 506 value llvm_ppc_fp128_type(value Context) { 507 return to_val(LLVMPPCFP128TypeInContext(Context_val(Context))); 508 } 509 510 /*--... Operations on function types .......................................--*/ 511 512 /* lltype -> lltype array -> lltype */ 513 value llvm_function_type(value RetTy, value ParamTys) { 514 mlsize_t len = Wosize_val(ParamTys); 515 LLVMTypeRef *Temp = from_val_array(ParamTys); 516 LLVMTypeRef Type = LLVMFunctionType(Type_val(RetTy), Temp, len, 0); 517 free(Temp); 518 return to_val(Type); 519 } 520 521 /* lltype -> lltype array -> lltype */ 522 value llvm_var_arg_function_type(value RetTy, value ParamTys) { 523 mlsize_t len = Wosize_val(ParamTys); 524 LLVMTypeRef *Temp = from_val_array(ParamTys); 525 LLVMTypeRef Type = LLVMFunctionType(Type_val(RetTy), Temp, len, 1); 526 free(Temp); 527 return to_val(Type); 528 } 529 530 /* lltype -> bool */ 531 value llvm_is_var_arg(value FunTy) { 532 return Val_bool(LLVMIsFunctionVarArg(Type_val(FunTy))); 533 } 534 535 /* lltype -> lltype */ 536 value llvm_return_type(value FunTy) { 537 LLVMTypeRef Type = LLVMGetReturnType(Type_val(FunTy)); 538 return to_val(Type); 539 } 540 541 /* lltype -> lltype array */ 542 value llvm_param_types(value FunTy) { 543 unsigned Length = LLVMCountParamTypes(Type_val(FunTy)); 544 value Tys = caml_alloc_tuple_uninit(Length); 545 LLVMGetParamTypes(Type_val(FunTy), (LLVMTypeRef *)Op_val(Tys)); 546 for (unsigned I = 0; I < Length; ++I) { 547 Field(Tys, I) = to_val((LLVMTypeRef)Field(Tys, I)); 548 } 549 return Tys; 550 } 551 552 /*--... Operations on struct types .........................................--*/ 553 554 /* llcontext -> lltype array -> lltype */ 555 value llvm_struct_type(value C, value ElementTypes) { 556 mlsize_t Length = Wosize_val(ElementTypes); 557 LLVMTypeRef *Temp = from_val_array(ElementTypes); 558 LLVMTypeRef Type = LLVMStructTypeInContext(Context_val(C), Temp, Length, 0); 559 free(Temp); 560 return to_val(Type); 561 } 562 563 /* llcontext -> lltype array -> lltype */ 564 value llvm_packed_struct_type(value C, value ElementTypes) { 565 mlsize_t Length = Wosize_val(ElementTypes); 566 LLVMTypeRef *Temp = from_val_array(ElementTypes); 567 LLVMTypeRef Type = LLVMStructTypeInContext(Context_val(C), Temp, Length, 1); 568 free(Temp); 569 return to_val(Type); 570 } 571 572 /* llcontext -> string -> lltype */ 573 value llvm_named_struct_type(value C, value Name) { 574 return to_val(LLVMStructCreateNamed(Context_val(C), String_val(Name))); 575 } 576 577 /* lltype -> lltype array -> bool -> unit */ 578 value llvm_struct_set_body(value Ty, value ElementTypes, value Packed) { 579 mlsize_t Length = Wosize_val(ElementTypes); 580 LLVMTypeRef *Temp = from_val_array(ElementTypes); 581 LLVMStructSetBody(Type_val(Ty), Temp, Length, Bool_val(Packed)); 582 return Val_unit; 583 } 584 585 /* lltype -> string option */ 586 value llvm_struct_name(value Ty) { 587 const char *CStr = LLVMGetStructName(Type_val(Ty)); 588 size_t Len; 589 if (!CStr) 590 return Val_none; 591 Len = strlen(CStr); 592 return cstr_to_string_option(CStr, Len); 593 } 594 595 /* lltype -> lltype array */ 596 value llvm_struct_element_types(value StructTy) { 597 unsigned Length = LLVMCountStructElementTypes(Type_val(StructTy)); 598 value Tys = caml_alloc_tuple_uninit(Length); 599 LLVMGetStructElementTypes(Type_val(StructTy), (LLVMTypeRef *)Op_val(Tys)); 600 for (unsigned I = 0; I < Length; ++I) { 601 Field(Tys, I) = to_val((LLVMTypeRef)Field(Tys, I)); 602 } 603 return Tys; 604 } 605 606 /* lltype -> bool */ 607 value llvm_is_packed(value StructTy) { 608 return Val_bool(LLVMIsPackedStruct(Type_val(StructTy))); 609 } 610 611 /* lltype -> bool */ 612 value llvm_is_opaque(value StructTy) { 613 return Val_bool(LLVMIsOpaqueStruct(Type_val(StructTy))); 614 } 615 616 /* lltype -> bool */ 617 value llvm_is_literal(value StructTy) { 618 return Val_bool(LLVMIsLiteralStruct(Type_val(StructTy))); 619 } 620 621 /*--... Operations on array, pointer, and vector types .....................--*/ 622 623 /* lltype -> lltype array */ 624 value llvm_subtypes(value Ty) { 625 unsigned Length = LLVMGetNumContainedTypes(Type_val(Ty)); 626 value Arr = caml_alloc_tuple_uninit(Length); 627 LLVMGetSubtypes(Type_val(Ty), (LLVMTypeRef *)Op_val(Arr)); 628 for (unsigned I = 0; I < Length; ++I) { 629 Field(Arr, I) = to_val((LLVMTypeRef)Field(Arr, I)); 630 } 631 return Arr; 632 } 633 634 /* lltype -> int -> lltype */ 635 value llvm_array_type(value ElementTy, value Count) { 636 return to_val(LLVMArrayType(Type_val(ElementTy), Int_val(Count))); 637 } 638 639 /* llcontext -> lltype */ 640 value llvm_pointer_type(value C) { 641 LLVMTypeRef Type = LLVMPointerTypeInContext(Context_val(C), 0); 642 return to_val(Type); 643 } 644 645 /* llcontext -> int -> lltype */ 646 value llvm_qualified_pointer_type(value C, value AddressSpace) { 647 LLVMTypeRef Type = 648 LLVMPointerTypeInContext(Context_val(C), Int_val(AddressSpace)); 649 return to_val(Type); 650 } 651 652 /* lltype -> int -> lltype */ 653 value llvm_vector_type(value ElementTy, value Count) { 654 return to_val(LLVMVectorType(Type_val(ElementTy), Int_val(Count))); 655 } 656 657 /* lltype -> lltype */ 658 value llvm_get_element_type(value Ty) { 659 return to_val(LLVMGetElementType(Type_val(Ty))); 660 } 661 662 /* lltype -> int */ 663 value llvm_array_length(value ArrayTy) { 664 return Val_int(LLVMGetArrayLength2(Type_val(ArrayTy))); 665 } 666 667 /* lltype -> int */ 668 value llvm_address_space(value PtrTy) { 669 return Val_int(LLVMGetPointerAddressSpace(Type_val(PtrTy))); 670 } 671 672 /* lltype -> int */ 673 value llvm_vector_size(value VectorTy) { 674 return Val_int(LLVMGetVectorSize(Type_val(VectorTy))); 675 } 676 677 /*--... Operations on other types ..........................................--*/ 678 679 /* llcontext -> lltype */ 680 value llvm_void_type(value Context) { 681 return to_val(LLVMVoidTypeInContext(Context_val(Context))); 682 } 683 684 /* llcontext -> lltype */ 685 value llvm_label_type(value Context) { 686 return to_val(LLVMLabelTypeInContext(Context_val(Context))); 687 } 688 689 /* llcontext -> lltype */ 690 value llvm_x86_amx_type(value Context) { 691 return to_val(LLVMX86AMXTypeInContext(Context_val(Context))); 692 } 693 694 /* llcontext -> lltype */ 695 value llvm_token_type(value Context) { 696 return to_val(LLVMTokenTypeInContext(Context_val(Context))); 697 } 698 699 /* llcontext -> lltype */ 700 value llvm_metadata_type(value Context) { 701 return to_val(LLVMMetadataTypeInContext(Context_val(Context))); 702 } 703 704 /* llmodule -> string -> lltype option */ 705 value llvm_type_by_name(value M, value Name) { 706 return ptr_to_option(LLVMGetTypeByName(Module_val(M), String_val(Name))); 707 } 708 709 /*===-- VALUES ------------------------------------------------------------===*/ 710 711 /* llvalue -> lltype */ 712 value llvm_type_of(value Val) { return to_val(LLVMTypeOf(Value_val(Val))); } 713 714 /* keep in sync with ValueKind.t */ 715 enum ValueKind { 716 NullValue = 0, 717 Argument, 718 BasicBlock, 719 InlineAsm, 720 MDNode, 721 MDString, 722 BlockAddress, 723 ConstantAggregateZero, 724 ConstantArray, 725 ConstantDataArray, 726 ConstantDataVector, 727 ConstantExpr, 728 ConstantFP, 729 ConstantInt, 730 ConstantPointerNull, 731 ConstantStruct, 732 ConstantVector, 733 Function, 734 GlobalAlias, 735 GlobalIFunc, 736 GlobalVariable, 737 UndefValue, 738 PoisonValue, 739 Instruction 740 }; 741 742 /* llvalue -> ValueKind.t */ 743 #define DEFINE_CASE(Val, Kind) \ 744 do { \ 745 if (LLVMIsA##Kind(Val)) \ 746 return Val_int(Kind); \ 747 } while (0) 748 749 value llvm_classify_value(value V) { 750 LLVMValueRef Val = Value_val(V); 751 if (!Val) 752 return Val_int(NullValue); 753 if (LLVMIsAConstant(Val)) { 754 DEFINE_CASE(Val, BlockAddress); 755 DEFINE_CASE(Val, ConstantAggregateZero); 756 DEFINE_CASE(Val, ConstantArray); 757 DEFINE_CASE(Val, ConstantDataArray); 758 DEFINE_CASE(Val, ConstantDataVector); 759 DEFINE_CASE(Val, ConstantExpr); 760 DEFINE_CASE(Val, ConstantFP); 761 DEFINE_CASE(Val, ConstantInt); 762 DEFINE_CASE(Val, ConstantPointerNull); 763 DEFINE_CASE(Val, ConstantStruct); 764 DEFINE_CASE(Val, ConstantVector); 765 } 766 if (LLVMIsAInstruction(Val)) { 767 value result = caml_alloc_small(1, 0); 768 Field(result, 0) = Val_int(LLVMGetInstructionOpcode(Val)); 769 return result; 770 } 771 if (LLVMIsAGlobalValue(Val)) { 772 DEFINE_CASE(Val, Function); 773 DEFINE_CASE(Val, GlobalAlias); 774 DEFINE_CASE(Val, GlobalIFunc); 775 DEFINE_CASE(Val, GlobalVariable); 776 } 777 DEFINE_CASE(Val, Argument); 778 DEFINE_CASE(Val, BasicBlock); 779 DEFINE_CASE(Val, InlineAsm); 780 DEFINE_CASE(Val, MDNode); 781 DEFINE_CASE(Val, MDString); 782 DEFINE_CASE(Val, UndefValue); 783 DEFINE_CASE(Val, PoisonValue); 784 caml_failwith("Unknown Value class"); 785 } 786 787 /* llvalue -> string */ 788 value llvm_value_name(value Val) { 789 return caml_copy_string(LLVMGetValueName(Value_val(Val))); 790 } 791 792 /* string -> llvalue -> unit */ 793 value llvm_set_value_name(value Name, value Val) { 794 LLVMSetValueName(Value_val(Val), String_val(Name)); 795 return Val_unit; 796 } 797 798 /* llvalue -> unit */ 799 value llvm_dump_value(value Val) { 800 LLVMDumpValue(Value_val(Val)); 801 return Val_unit; 802 } 803 804 /* llvalue -> string */ 805 value llvm_string_of_llvalue(value M) { 806 char *ValueCStr = LLVMPrintValueToString(Value_val(M)); 807 value ValueStr = caml_copy_string(ValueCStr); 808 LLVMDisposeMessage(ValueCStr); 809 810 return ValueStr; 811 } 812 813 /* lldbgrecord -> string */ 814 value llvm_string_of_lldbgrecord(value Record) { 815 char *ValueCStr = LLVMPrintDbgRecordToString(DbgRecord_val(Record)); 816 value ValueStr = caml_copy_string(ValueCStr); 817 LLVMDisposeMessage(ValueCStr); 818 819 return ValueStr; 820 } 821 822 /* llvalue -> llvalue -> unit */ 823 value llvm_replace_all_uses_with(value OldVal, value NewVal) { 824 LLVMReplaceAllUsesWith(Value_val(OldVal), Value_val(NewVal)); 825 return Val_unit; 826 } 827 828 /*--... Operations on users ................................................--*/ 829 830 /* llvalue -> int -> llvalue */ 831 value llvm_operand(value V, value I) { 832 return to_val(LLVMGetOperand(Value_val(V), Int_val(I))); 833 } 834 835 /* llvalue -> int -> lluse */ 836 value llvm_operand_use(value V, value I) { 837 return to_val(LLVMGetOperandUse(Value_val(V), Int_val(I))); 838 } 839 840 /* llvalue -> int -> llvalue -> unit */ 841 value llvm_set_operand(value U, value I, value V) { 842 LLVMSetOperand(Value_val(U), Int_val(I), Value_val(V)); 843 return Val_unit; 844 } 845 846 /* llvalue -> int */ 847 value llvm_num_operands(value V) { 848 return Val_int(LLVMGetNumOperands(Value_val(V))); 849 } 850 851 /* llvalue -> int array */ 852 value llvm_indices(value Instr) { 853 unsigned Length = LLVMGetNumIndices(Value_val(Instr)); 854 const unsigned *Indices = LLVMGetIndices(Value_val(Instr)); 855 value Array = caml_alloc_tuple_uninit(Length); 856 for (unsigned I = 0; I < Length; ++I) { 857 Field(Array, I) = Val_int(Indices[I]); 858 } 859 return Array; 860 } 861 862 /*--... Operations on constants of (mostly) any type .......................--*/ 863 864 /* llvalue -> bool */ 865 value llvm_is_constant(value Val) { 866 return Val_bool(LLVMIsConstant(Value_val(Val))); 867 } 868 869 /* lltype -> llvalue */ 870 value llvm_const_null(value Ty) { 871 LLVMValueRef Value = LLVMConstNull(Type_val(Ty)); 872 return to_val(Value); 873 } 874 875 /* lltype -> llvalue */ 876 value llvm_const_all_ones(value Ty) { 877 LLVMValueRef Value = LLVMConstAllOnes(Type_val(Ty)); 878 return to_val(Value); 879 } 880 881 /* lltype -> llvalue */ 882 value llvm_const_pointer_null(value Ty) { 883 LLVMValueRef Value = LLVMConstPointerNull(Type_val(Ty)); 884 return to_val(Value); 885 } 886 887 /* lltype -> llvalue */ 888 value llvm_get_undef(value Ty) { 889 LLVMValueRef Value = LLVMGetUndef(Type_val(Ty)); 890 return to_val(Value); 891 } 892 893 /* lltype -> llvalue */ 894 value llvm_get_poison(value Ty) { 895 LLVMValueRef Value = LLVMGetPoison(Type_val(Ty)); 896 return to_val(Value); 897 } 898 899 /* llvalue -> bool */ 900 value llvm_is_null(value Val) { return Val_bool(LLVMIsNull(Value_val(Val))); } 901 902 /* llvalue -> bool */ 903 value llvm_is_undef(value Val) { return Val_bool(LLVMIsUndef(Value_val(Val))); } 904 905 /* llvalue -> bool */ 906 value llvm_is_poison(value Val) { 907 return Val_bool(LLVMIsPoison(Value_val(Val))); 908 } 909 910 /* llvalue -> Opcode.t */ 911 value llvm_constexpr_get_opcode(value Val) { 912 return LLVMIsAConstantExpr(Value_val(Val)) 913 ? Val_int(LLVMGetConstOpcode(Value_val(Val))) 914 : Val_int(0); 915 } 916 917 /*--... Operations on instructions .........................................--*/ 918 919 /* llvalue -> bool */ 920 value llvm_has_metadata(value Val) { 921 return Val_bool(LLVMHasMetadata(Value_val(Val))); 922 } 923 924 /* llvalue -> int -> llvalue option */ 925 value llvm_metadata(value Val, value MDKindID) { 926 return ptr_to_option(LLVMGetMetadata(Value_val(Val), Int_val(MDKindID))); 927 } 928 929 /* llvalue -> int -> llvalue -> unit */ 930 value llvm_set_metadata(value Val, value MDKindID, value MD) { 931 LLVMSetMetadata(Value_val(Val), Int_val(MDKindID), Value_val(MD)); 932 return Val_unit; 933 } 934 935 /* llvalue -> int -> unit */ 936 value llvm_clear_metadata(value Val, value MDKindID) { 937 LLVMSetMetadata(Value_val(Val), Int_val(MDKindID), NULL); 938 return Val_unit; 939 } 940 941 /*--... Operations on metadata .............................................--*/ 942 943 /* llcontext -> string -> llvalue */ 944 value llvm_mdstring(value C, value S) { 945 return to_val(LLVMMDStringInContext(Context_val(C), String_val(S), 946 caml_string_length(S))); 947 } 948 949 /* llcontext -> llvalue array -> llvalue */ 950 value llvm_mdnode(value C, value ElementVals) { 951 mlsize_t Length = Wosize_val(ElementVals); 952 LLVMValueRef *Temp = from_val_array(ElementVals); 953 LLVMValueRef Value = LLVMMDNodeInContext(Context_val(C), Temp, Length); 954 free(Temp); 955 return to_val(Value); 956 } 957 958 /* llcontext -> llvalue */ 959 value llvm_mdnull(value C) { return to_val(NULL); } 960 961 /* llvalue -> string option */ 962 value llvm_get_mdstring(value V) { 963 unsigned Len; 964 const char *CStr = LLVMGetMDString(Value_val(V), &Len); 965 return cstr_to_string_option(CStr, Len); 966 } 967 968 /* llvalue -> llvalue array */ 969 value llvm_get_mdnode_operands(value Value) { 970 LLVMValueRef V = Value_val(Value); 971 unsigned Length = LLVMGetMDNodeNumOperands(V); 972 value Operands = caml_alloc_tuple_uninit(Length); 973 LLVMGetMDNodeOperands(V, (LLVMValueRef *)Op_val(Operands)); 974 for (unsigned I = 0; I < Length; ++I) { 975 Field(Operands, I) = to_val((LLVMValueRef)Field(Operands, I)); 976 } 977 return Operands; 978 } 979 980 /* llmodule -> string -> llvalue array */ 981 value llvm_get_namedmd(value M, value Name) { 982 CAMLparam1(Name); 983 unsigned Length = 984 LLVMGetNamedMetadataNumOperands(Module_val(M), String_val(Name)); 985 value Nodes = caml_alloc_tuple_uninit(Length); 986 LLVMGetNamedMetadataOperands(Module_val(M), String_val(Name), 987 (LLVMValueRef *)Op_val(Nodes)); 988 for (unsigned I = 0; I < Length; ++I) { 989 Field(Nodes, I) = to_val((LLVMValueRef)Field(Nodes, I)); 990 } 991 CAMLreturn(Nodes); 992 } 993 994 /* llmodule -> string -> llvalue -> unit */ 995 value llvm_append_namedmd(value M, value Name, value Val) { 996 LLVMAddNamedMetadataOperand(Module_val(M), String_val(Name), Value_val(Val)); 997 return Val_unit; 998 } 999 1000 /* llvalue -> llmetadata */ 1001 value llvm_value_as_metadata(value Val) { 1002 return to_val(LLVMValueAsMetadata(Value_val(Val))); 1003 } 1004 1005 /* llcontext -> llmetadata -> llvalue */ 1006 value llvm_metadata_as_value(value C, value MD) { 1007 return to_val(LLVMMetadataAsValue(Context_val(C), Metadata_val(MD))); 1008 } 1009 1010 /*--... Operations on scalar constants .....................................--*/ 1011 1012 /* lltype -> int -> llvalue */ 1013 value llvm_const_int(value IntTy, value N) { 1014 return to_val(LLVMConstInt(Type_val(IntTy), (long long)Long_val(N), 1)); 1015 } 1016 1017 /* lltype -> Int64.t -> bool -> llvalue */ 1018 value llvm_const_of_int64(value IntTy, value N, value SExt) { 1019 return to_val(LLVMConstInt(Type_val(IntTy), Int64_val(N), Bool_val(SExt))); 1020 } 1021 1022 /* llvalue -> Int64.t option */ 1023 value llvm_int64_of_const(value C) { 1024 LLVMValueRef Const = Value_val(C); 1025 if (!(LLVMIsAConstantInt(Const)) || 1026 !(LLVMGetIntTypeWidth(LLVMTypeOf(Const)) <= 64)) 1027 return Val_none; 1028 return caml_alloc_some(caml_copy_int64(LLVMConstIntGetSExtValue(Const))); 1029 } 1030 1031 /* lltype -> string -> int -> llvalue */ 1032 value llvm_const_int_of_string(value IntTy, value S, value Radix) { 1033 return to_val(LLVMConstIntOfStringAndSize( 1034 Type_val(IntTy), String_val(S), caml_string_length(S), Int_val(Radix))); 1035 } 1036 1037 /* lltype -> float -> llvalue */ 1038 value llvm_const_float(value RealTy, value N) { 1039 return to_val(LLVMConstReal(Type_val(RealTy), Double_val(N))); 1040 } 1041 1042 /* llvalue -> float option */ 1043 value llvm_float_of_const(value C) { 1044 LLVMValueRef Const = Value_val(C); 1045 LLVMBool LosesInfo; 1046 double Result; 1047 if (!LLVMIsAConstantFP(Const)) 1048 return Val_none; 1049 Result = LLVMConstRealGetDouble(Const, &LosesInfo); 1050 if (LosesInfo) 1051 return Val_none; 1052 return caml_alloc_some(caml_copy_double(Result)); 1053 } 1054 1055 /* lltype -> string -> llvalue */ 1056 value llvm_const_float_of_string(value RealTy, value S) { 1057 return to_val(LLVMConstRealOfStringAndSize(Type_val(RealTy), String_val(S), 1058 caml_string_length(S))); 1059 } 1060 1061 /*--... Operations on composite constants ..................................--*/ 1062 1063 /* llcontext -> string -> llvalue */ 1064 value llvm_const_string(value Context, value Str) { 1065 return to_val(LLVMConstStringInContext2(Context_val(Context), String_val(Str), 1066 caml_string_length(Str), 1)); 1067 } 1068 1069 /* llcontext -> string -> llvalue */ 1070 value llvm_const_stringz(value Context, value Str) { 1071 return to_val(LLVMConstStringInContext2(Context_val(Context), String_val(Str), 1072 caml_string_length(Str), 0)); 1073 } 1074 1075 /* lltype -> llvalue array -> llvalue */ 1076 value llvm_const_array(value ElementTy, value ElementVals) { 1077 mlsize_t Length = Wosize_val(ElementVals); 1078 LLVMValueRef *Temp = from_val_array(ElementVals); 1079 LLVMValueRef Value = LLVMConstArray(Type_val(ElementTy), Temp, Length); 1080 free(Temp); 1081 return to_val(Value); 1082 } 1083 1084 /* llcontext -> llvalue array -> llvalue */ 1085 value llvm_const_struct(value C, value ElementVals) { 1086 mlsize_t Length = Wosize_val(ElementVals); 1087 LLVMValueRef *Temp = from_val_array(ElementVals); 1088 LLVMValueRef Value = 1089 LLVMConstStructInContext(Context_val(C), Temp, Length, 0); 1090 free(Temp); 1091 return to_val(Value); 1092 } 1093 1094 /* lltype -> llvalue array -> llvalue */ 1095 value llvm_const_named_struct(value Ty, value ElementVals) { 1096 mlsize_t Length = Wosize_val(ElementVals); 1097 LLVMValueRef *Temp = from_val_array(ElementVals); 1098 LLVMValueRef Value = 1099 LLVMConstNamedStruct(Type_val(Ty), (LLVMValueRef *)Temp, Length); 1100 free(Temp); 1101 return to_val(Value); 1102 } 1103 1104 /* llcontext -> llvalue array -> llvalue */ 1105 value llvm_const_packed_struct(value C, value ElementVals) { 1106 mlsize_t Length = Wosize_val(ElementVals); 1107 LLVMValueRef *Temp = from_val_array(ElementVals); 1108 LLVMValueRef Value = 1109 LLVMConstStructInContext(Context_val(C), Temp, Length, 1); 1110 free(Temp); 1111 return to_val(Value); 1112 } 1113 1114 /* llvalue array -> llvalue */ 1115 value llvm_const_vector(value ElementVals) { 1116 mlsize_t Length = Wosize_val(ElementVals); 1117 LLVMValueRef *Temp = from_val_array(ElementVals); 1118 LLVMValueRef Value = LLVMConstVector(Temp, Length); 1119 free(Temp); 1120 return to_val(Value); 1121 } 1122 1123 /* llvalue -> string option */ 1124 value llvm_string_of_const(value C) { 1125 size_t Len; 1126 const char *CStr; 1127 LLVMValueRef Const = Value_val(C); 1128 if (!LLVMIsAConstantDataSequential(Const) || !LLVMIsConstantString(Const)) 1129 return Val_none; 1130 CStr = LLVMGetAsString(Const, &Len); 1131 return cstr_to_string_option(CStr, Len); 1132 } 1133 1134 /* llvalue -> int -> llvalue option */ 1135 value llvm_aggregate_element(value Const, value N) { 1136 return ptr_to_option(LLVMGetAggregateElement(Value_val(Const), Int_val(N))); 1137 } 1138 1139 /*--... Constant expressions ...............................................--*/ 1140 1141 /* lltype -> llvalue */ 1142 value llvm_align_of(value Type) { 1143 LLVMValueRef Value = LLVMAlignOf(Type_val(Type)); 1144 return to_val(Value); 1145 } 1146 1147 /* lltype -> llvalue */ 1148 value llvm_size_of(value Type) { 1149 LLVMValueRef Value = LLVMSizeOf(Type_val(Type)); 1150 return to_val(Value); 1151 } 1152 1153 /* llvalue -> llvalue */ 1154 value llvm_const_neg(value Value) { 1155 LLVMValueRef NegValue = LLVMConstNeg(Value_val(Value)); 1156 return to_val(NegValue); 1157 } 1158 1159 /* llvalue -> llvalue */ 1160 value llvm_const_nsw_neg(value Value) { 1161 LLVMValueRef NegValue = LLVMConstNSWNeg(Value_val(Value)); 1162 return to_val(NegValue); 1163 } 1164 1165 /* llvalue -> llvalue */ 1166 value llvm_const_nuw_neg(value Value) { 1167 LLVMValueRef NegValue = LLVMConstNUWNeg(Value_val(Value)); 1168 return to_val(NegValue); 1169 } 1170 1171 /* llvalue -> llvalue */ 1172 value llvm_const_not(value Value) { 1173 LLVMValueRef NotValue = LLVMConstNot(Value_val(Value)); 1174 return to_val(NotValue); 1175 } 1176 1177 /* llvalue -> llvalue -> llvalue */ 1178 value llvm_const_add(value LHS, value RHS) { 1179 LLVMValueRef Value = LLVMConstAdd(Value_val(LHS), Value_val(RHS)); 1180 return to_val(Value); 1181 } 1182 1183 /* llvalue -> llvalue -> llvalue */ 1184 value llvm_const_nsw_add(value LHS, value RHS) { 1185 LLVMValueRef Value = LLVMConstNSWAdd(Value_val(LHS), Value_val(RHS)); 1186 return to_val(Value); 1187 } 1188 1189 /* llvalue -> llvalue -> llvalue */ 1190 value llvm_const_nuw_add(value LHS, value RHS) { 1191 LLVMValueRef Value = LLVMConstNUWAdd(Value_val(LHS), Value_val(RHS)); 1192 return to_val(Value); 1193 } 1194 1195 /* llvalue -> llvalue -> llvalue */ 1196 value llvm_const_sub(value LHS, value RHS) { 1197 LLVMValueRef Value = LLVMConstSub(Value_val(LHS), Value_val(RHS)); 1198 return to_val(Value); 1199 } 1200 1201 /* llvalue -> llvalue -> llvalue */ 1202 value llvm_const_nsw_sub(value LHS, value RHS) { 1203 LLVMValueRef Value = LLVMConstNSWSub(Value_val(LHS), Value_val(RHS)); 1204 return to_val(Value); 1205 } 1206 1207 /* llvalue -> llvalue -> llvalue */ 1208 value llvm_const_nuw_sub(value LHS, value RHS) { 1209 LLVMValueRef Value = LLVMConstNUWSub(Value_val(LHS), Value_val(RHS)); 1210 return to_val(Value); 1211 } 1212 1213 /* llvalue -> llvalue -> llvalue */ 1214 value llvm_const_mul(value LHS, value RHS) { 1215 LLVMValueRef Value = LLVMConstMul(Value_val(LHS), Value_val(RHS)); 1216 return to_val(Value); 1217 } 1218 1219 /* llvalue -> llvalue -> llvalue */ 1220 value llvm_const_nsw_mul(value LHS, value RHS) { 1221 LLVMValueRef Value = LLVMConstNSWMul(Value_val(LHS), Value_val(RHS)); 1222 return to_val(Value); 1223 } 1224 1225 /* llvalue -> llvalue -> llvalue */ 1226 value llvm_const_nuw_mul(value LHS, value RHS) { 1227 LLVMValueRef Value = LLVMConstNUWMul(Value_val(LHS), Value_val(RHS)); 1228 return to_val(Value); 1229 } 1230 1231 /* llvalue -> llvalue -> llvalue */ 1232 value llvm_const_xor(value LHS, value RHS) { 1233 LLVMValueRef Value = LLVMConstXor(Value_val(LHS), Value_val(RHS)); 1234 return to_val(Value); 1235 } 1236 1237 /* lltype -> llvalue -> llvalue array -> llvalue */ 1238 value llvm_const_gep(value Ty, value ConstantVal, value Indices) { 1239 mlsize_t Length = Wosize_val(Indices); 1240 LLVMValueRef *Temp = from_val_array(Indices); 1241 LLVMValueRef Value = 1242 LLVMConstGEP2(Type_val(Ty), Value_val(ConstantVal), Temp, Length); 1243 free(Temp); 1244 return to_val(Value); 1245 } 1246 1247 /* lltype -> llvalue -> llvalue array -> llvalue */ 1248 value llvm_const_in_bounds_gep(value Ty, value ConstantVal, value Indices) { 1249 mlsize_t Length = Wosize_val(Indices); 1250 LLVMValueRef *Temp = from_val_array(Indices); 1251 LLVMValueRef Value = 1252 LLVMConstInBoundsGEP2(Type_val(Ty), Value_val(ConstantVal), Temp, Length); 1253 free(Temp); 1254 return to_val(Value); 1255 } 1256 1257 /* llvalue -> lltype -> llvalue */ 1258 value llvm_const_trunc(value CV, value T) { 1259 LLVMValueRef Value = LLVMConstTrunc(Value_val(CV), Type_val(T)); 1260 return to_val(Value); 1261 } 1262 1263 /* llvalue -> lltype -> llvalue */ 1264 value llvm_const_ptrtoint(value CV, value T) { 1265 LLVMValueRef Value = LLVMConstPtrToInt(Value_val(CV), Type_val(T)); 1266 return to_val(Value); 1267 } 1268 1269 /* llvalue -> lltype -> llvalue */ 1270 value llvm_const_inttoptr(value CV, value T) { 1271 LLVMValueRef Value = LLVMConstIntToPtr(Value_val(CV), Type_val(T)); 1272 return to_val(Value); 1273 } 1274 1275 /* llvalue -> lltype -> llvalue */ 1276 value llvm_const_bitcast(value CV, value T) { 1277 LLVMValueRef Value = LLVMConstBitCast(Value_val(CV), Type_val(T)); 1278 return to_val(Value); 1279 } 1280 1281 /* llvalue -> lltype -> llvalue */ 1282 value llvm_const_trunc_or_bitcast(value CV, value T) { 1283 LLVMValueRef Value = LLVMConstTruncOrBitCast(Value_val(CV), Type_val(T)); 1284 return to_val(Value); 1285 } 1286 1287 /* llvalue -> lltype -> llvalue */ 1288 value llvm_const_pointercast(value CV, value T) { 1289 LLVMValueRef Value = LLVMConstPointerCast(Value_val(CV), Type_val(T)); 1290 return to_val(Value); 1291 } 1292 1293 /* llvalue -> llvalue -> llvalue */ 1294 value llvm_const_extractelement(value V, value I) { 1295 LLVMValueRef Value = LLVMConstExtractElement(Value_val(V), Value_val(I)); 1296 return to_val(Value); 1297 } 1298 1299 /* llvalue -> llvalue -> llvalue -> llvalue */ 1300 value llvm_const_insertelement(value V, value E, value I) { 1301 LLVMValueRef Value = 1302 LLVMConstInsertElement(Value_val(V), Value_val(E), Value_val(I)); 1303 return to_val(Value); 1304 } 1305 1306 /* llvalue -> llvalue -> llvalue -> llvalue */ 1307 value llvm_const_shufflevector(value VA, value VB, value Mask) { 1308 LLVMValueRef Value = 1309 LLVMConstShuffleVector(Value_val(VA), Value_val(VB), Value_val(Mask)); 1310 return to_val(Value); 1311 } 1312 1313 /* lltype -> string -> string -> bool -> bool -> llvalue */ 1314 value llvm_const_inline_asm(value Ty, value Asm, value Constraints, 1315 value HasSideEffects, value IsAlignStack) { 1316 return to_val( 1317 LLVMConstInlineAsm(Type_val(Ty), String_val(Asm), String_val(Constraints), 1318 Bool_val(HasSideEffects), Bool_val(IsAlignStack))); 1319 } 1320 1321 /* llvalue -> llbasicblock -> llvalue */ 1322 value llvm_blockaddress(value V, value B) { 1323 LLVMValueRef Value = LLVMBlockAddress(Value_val(V), BasicBlock_val(B)); 1324 return to_val(Value); 1325 } 1326 1327 /*--... Operations on global variables, functions, and aliases (globals) ...--*/ 1328 1329 /* llvalue -> llmodule */ 1330 value llvm_global_parent(value Value) { 1331 LLVMModuleRef Module = LLVMGetGlobalParent(Value_val(Value)); 1332 return to_val(Module); 1333 } 1334 1335 /* llvalue -> bool */ 1336 value llvm_is_declaration(value Global) { 1337 return Val_bool(LLVMIsDeclaration(Value_val(Global))); 1338 } 1339 1340 /* llvalue -> Linkage.t */ 1341 value llvm_linkage(value Global) { 1342 return Val_int(LLVMGetLinkage(Value_val(Global))); 1343 } 1344 1345 /* Linkage.t -> llvalue -> unit */ 1346 value llvm_set_linkage(value Linkage, value Global) { 1347 LLVMSetLinkage(Value_val(Global), Int_val(Linkage)); 1348 return Val_unit; 1349 } 1350 1351 /* llvalue -> bool */ 1352 value llvm_unnamed_addr(value Global) { 1353 return Val_bool(LLVMHasUnnamedAddr(Value_val(Global))); 1354 } 1355 1356 /* bool -> llvalue -> unit */ 1357 value llvm_set_unnamed_addr(value UseUnnamedAddr, value Global) { 1358 LLVMSetUnnamedAddr(Value_val(Global), Bool_val(UseUnnamedAddr)); 1359 return Val_unit; 1360 } 1361 1362 /* llvalue -> string */ 1363 value llvm_section(value Global) { 1364 return caml_copy_string(LLVMGetSection(Value_val(Global))); 1365 } 1366 1367 /* string -> llvalue -> unit */ 1368 value llvm_set_section(value Section, value Global) { 1369 LLVMSetSection(Value_val(Global), String_val(Section)); 1370 return Val_unit; 1371 } 1372 1373 /* llvalue -> Visibility.t */ 1374 value llvm_visibility(value Global) { 1375 return Val_int(LLVMGetVisibility(Value_val(Global))); 1376 } 1377 1378 /* Visibility.t -> llvalue -> unit */ 1379 value llvm_set_visibility(value Viz, value Global) { 1380 LLVMSetVisibility(Value_val(Global), Int_val(Viz)); 1381 return Val_unit; 1382 } 1383 1384 /* llvalue -> DLLStorageClass.t */ 1385 value llvm_dll_storage_class(value Global) { 1386 return Val_int(LLVMGetDLLStorageClass(Value_val(Global))); 1387 } 1388 1389 /* DLLStorageClass.t -> llvalue -> unit */ 1390 value llvm_set_dll_storage_class(value Viz, value Global) { 1391 LLVMSetDLLStorageClass(Value_val(Global), Int_val(Viz)); 1392 return Val_unit; 1393 } 1394 1395 /* llvalue -> int */ 1396 value llvm_alignment(value Global) { 1397 return Val_int(LLVMGetAlignment(Value_val(Global))); 1398 } 1399 1400 /* int -> llvalue -> unit */ 1401 value llvm_set_alignment(value Bytes, value Global) { 1402 LLVMSetAlignment(Value_val(Global), Int_val(Bytes)); 1403 return Val_unit; 1404 } 1405 1406 /* llvalue -> (llmdkind * llmetadata) array */ 1407 value llvm_global_copy_all_metadata(value Global) { 1408 CAMLparam0(); 1409 CAMLlocal1(Array); 1410 size_t NumEntries; 1411 LLVMValueMetadataEntry *Entries = 1412 LLVMGlobalCopyAllMetadata(Value_val(Global), &NumEntries); 1413 Array = caml_alloc_tuple(NumEntries); 1414 for (int i = 0; i < NumEntries; ++i) { 1415 value Pair = caml_alloc_small(2, 0); 1416 Field(Pair, 0) = Val_int(LLVMValueMetadataEntriesGetKind(Entries, i)); 1417 Field(Pair, 1) = to_val(LLVMValueMetadataEntriesGetMetadata(Entries, i)); 1418 Store_field(Array, i, Pair); 1419 } 1420 LLVMDisposeValueMetadataEntries(Entries); 1421 CAMLreturn(Array); 1422 } 1423 1424 /*--... Operations on uses .................................................--*/ 1425 1426 /* llvalue -> lluse option */ 1427 value llvm_use_begin(value Val) { 1428 return ptr_to_option(LLVMGetFirstUse(Value_val(Val))); 1429 } 1430 1431 /* lluse -> lluse option */ 1432 value llvm_use_succ(value U) { 1433 return ptr_to_option(LLVMGetNextUse(Use_val(U))); 1434 } 1435 1436 /* lluse -> llvalue */ 1437 value llvm_user(value UR) { return to_val(LLVMGetUser(Use_val(UR))); } 1438 1439 /* lluse -> llvalue */ 1440 value llvm_used_value(value UR) { 1441 return to_val(LLVMGetUsedValue(Use_val(UR))); 1442 } 1443 1444 /*--... Operations on global variables .....................................--*/ 1445 1446 DEFINE_ITERATORS(global, Global, Module_val, LLVMValueRef, Value_val, 1447 LLVMGetGlobalParent) 1448 1449 /* lltype -> string -> llmodule -> llvalue */ 1450 value llvm_declare_global(value Ty, value Name, value M) { 1451 LLVMValueRef GlobalVar; 1452 if ((GlobalVar = LLVMGetNamedGlobal(Module_val(M), String_val(Name)))) { 1453 if (LLVMGlobalGetValueType(GlobalVar) != Type_val(Ty)) 1454 return to_val( 1455 LLVMConstBitCast(GlobalVar, LLVMPointerType(Type_val(Ty), 0))); 1456 return to_val(GlobalVar); 1457 } 1458 return to_val(LLVMAddGlobal(Module_val(M), Type_val(Ty), String_val(Name))); 1459 } 1460 1461 /* lltype -> string -> int -> llmodule -> llvalue */ 1462 value llvm_declare_qualified_global(value Ty, value Name, value AddressSpace, 1463 value M) { 1464 LLVMValueRef GlobalVar; 1465 if ((GlobalVar = LLVMGetNamedGlobal(Module_val(M), String_val(Name)))) { 1466 if (LLVMGlobalGetValueType(GlobalVar) != Type_val(Ty)) 1467 return to_val(LLVMConstBitCast( 1468 GlobalVar, LLVMPointerType(Type_val(Ty), Int_val(AddressSpace)))); 1469 return to_val(GlobalVar); 1470 } 1471 return to_val(LLVMAddGlobalInAddressSpace( 1472 Module_val(M), Type_val(Ty), String_val(Name), Int_val(AddressSpace))); 1473 } 1474 1475 /* string -> llmodule -> llvalue option */ 1476 value llvm_lookup_global(value Name, value M) { 1477 return ptr_to_option(LLVMGetNamedGlobal(Module_val(M), String_val(Name))); 1478 } 1479 1480 /* string -> llvalue -> llmodule -> llvalue */ 1481 value llvm_define_global(value Name, value Initializer, value M) { 1482 LLVMValueRef GlobalVar = LLVMAddGlobal( 1483 Module_val(M), LLVMTypeOf(Value_val(Initializer)), String_val(Name)); 1484 LLVMSetInitializer(GlobalVar, Value_val(Initializer)); 1485 return to_val(GlobalVar); 1486 } 1487 1488 /* string -> llvalue -> int -> llmodule -> llvalue */ 1489 value llvm_define_qualified_global(value Name, value Initializer, 1490 value AddressSpace, value M) { 1491 LLVMValueRef GlobalVar = LLVMAddGlobalInAddressSpace( 1492 Module_val(M), LLVMTypeOf(Value_val(Initializer)), String_val(Name), 1493 Int_val(AddressSpace)); 1494 LLVMSetInitializer(GlobalVar, Value_val(Initializer)); 1495 return to_val(GlobalVar); 1496 } 1497 1498 /* llvalue -> unit */ 1499 value llvm_delete_global(value GlobalVar) { 1500 LLVMDeleteGlobal(Value_val(GlobalVar)); 1501 return Val_unit; 1502 } 1503 1504 /* llvalue -> llvalue option */ 1505 value llvm_global_initializer(value GlobalVar) { 1506 return ptr_to_option(LLVMGetInitializer(Value_val(GlobalVar))); 1507 } 1508 1509 /* llvalue -> llvalue -> unit */ 1510 value llvm_set_initializer(value ConstantVal, value GlobalVar) { 1511 LLVMSetInitializer(Value_val(GlobalVar), Value_val(ConstantVal)); 1512 return Val_unit; 1513 } 1514 1515 /* llvalue -> unit */ 1516 value llvm_remove_initializer(value GlobalVar) { 1517 LLVMSetInitializer(Value_val(GlobalVar), NULL); 1518 return Val_unit; 1519 } 1520 1521 /* llvalue -> bool */ 1522 value llvm_is_thread_local(value GlobalVar) { 1523 return Val_bool(LLVMIsThreadLocal(Value_val(GlobalVar))); 1524 } 1525 1526 /* bool -> llvalue -> unit */ 1527 value llvm_set_thread_local(value IsThreadLocal, value GlobalVar) { 1528 LLVMSetThreadLocal(Value_val(GlobalVar), Bool_val(IsThreadLocal)); 1529 return Val_unit; 1530 } 1531 1532 /* llvalue -> ThreadLocalMode.t */ 1533 value llvm_thread_local_mode(value GlobalVar) { 1534 return Val_int(LLVMGetThreadLocalMode(Value_val(GlobalVar))); 1535 } 1536 1537 /* ThreadLocalMode.t -> llvalue -> unit */ 1538 value llvm_set_thread_local_mode(value ThreadLocalMode, value GlobalVar) { 1539 LLVMSetThreadLocalMode(Value_val(GlobalVar), Int_val(ThreadLocalMode)); 1540 return Val_unit; 1541 } 1542 1543 /* llvalue -> bool */ 1544 value llvm_is_externally_initialized(value GlobalVar) { 1545 return Val_bool(LLVMIsExternallyInitialized(Value_val(GlobalVar))); 1546 } 1547 1548 /* bool -> llvalue -> unit */ 1549 value llvm_set_externally_initialized(value IsExternallyInitialized, 1550 value GlobalVar) { 1551 LLVMSetExternallyInitialized(Value_val(GlobalVar), 1552 Bool_val(IsExternallyInitialized)); 1553 return Val_unit; 1554 } 1555 1556 /* llvalue -> bool */ 1557 value llvm_is_global_constant(value GlobalVar) { 1558 return Val_bool(LLVMIsGlobalConstant(Value_val(GlobalVar))); 1559 } 1560 1561 /* bool -> llvalue -> unit */ 1562 value llvm_set_global_constant(value Flag, value GlobalVar) { 1563 LLVMSetGlobalConstant(Value_val(GlobalVar), Bool_val(Flag)); 1564 return Val_unit; 1565 } 1566 1567 /*--... Operations on aliases ..............................................--*/ 1568 1569 /* llmodule -> lltype -> int -> llvalue -> string -> llvalue */ 1570 value llvm_add_alias(value M, value ValueTy, value AddrSpace, value Aliasee, 1571 value Name) { 1572 return to_val(LLVMAddAlias2(Module_val(M), Type_val(ValueTy), 1573 Int_val(AddrSpace), Value_val(Aliasee), 1574 String_val(Name))); 1575 } 1576 1577 /*--... Operations on functions ............................................--*/ 1578 1579 DEFINE_ITERATORS(function, Function, Module_val, LLVMValueRef, Value_val, 1580 LLVMGetGlobalParent) 1581 1582 /* string -> lltype -> llmodule -> llvalue */ 1583 value llvm_declare_function(value Name, value Ty, value M) { 1584 LLVMValueRef Fn; 1585 if ((Fn = LLVMGetNamedFunction(Module_val(M), String_val(Name)))) { 1586 if (LLVMGlobalGetValueType(Fn) != Type_val(Ty)) 1587 return to_val(LLVMConstBitCast(Fn, LLVMPointerType(Type_val(Ty), 0))); 1588 return to_val(Fn); 1589 } 1590 return to_val(LLVMAddFunction(Module_val(M), String_val(Name), Type_val(Ty))); 1591 } 1592 1593 /* string -> llmodule -> llvalue option */ 1594 value llvm_lookup_function(value Name, value M) { 1595 return ptr_to_option(LLVMGetNamedFunction(Module_val(M), String_val(Name))); 1596 } 1597 1598 /* string -> lltype -> llmodule -> llvalue */ 1599 value llvm_define_function(value Name, value Ty, value M) { 1600 LLVMValueRef Fn = 1601 LLVMAddFunction(Module_val(M), String_val(Name), Type_val(Ty)); 1602 LLVMAppendBasicBlockInContext(LLVMGetTypeContext(Type_val(Ty)), Fn, "entry"); 1603 return to_val(Fn); 1604 } 1605 1606 /* llvalue -> unit */ 1607 value llvm_delete_function(value Fn) { 1608 LLVMDeleteFunction(Value_val(Fn)); 1609 return Val_unit; 1610 } 1611 1612 /* llvalue -> bool */ 1613 value llvm_is_intrinsic(value Fn) { 1614 return Val_bool(LLVMGetIntrinsicID(Value_val(Fn))); 1615 } 1616 1617 /* llvalue -> int */ 1618 value llvm_function_call_conv(value Fn) { 1619 return Val_int(LLVMGetFunctionCallConv(Value_val(Fn))); 1620 } 1621 1622 /* int -> llvalue -> unit */ 1623 value llvm_set_function_call_conv(value Id, value Fn) { 1624 LLVMSetFunctionCallConv(Value_val(Fn), Int_val(Id)); 1625 return Val_unit; 1626 } 1627 1628 /* llvalue -> string option */ 1629 value llvm_gc(value Fn) { 1630 const char *GC = LLVMGetGC(Value_val(Fn)); 1631 if (!GC) 1632 return Val_none; 1633 return caml_alloc_some(caml_copy_string(GC)); 1634 } 1635 1636 /* string option -> llvalue -> unit */ 1637 value llvm_set_gc(value GC, value Fn) { 1638 LLVMSetGC(Value_val(Fn), GC == Val_none ? 0 : String_val(Field(GC, 0))); 1639 return Val_unit; 1640 } 1641 1642 /* llvalue -> llattribute -> int -> unit */ 1643 value llvm_add_function_attr(value F, value A, value Index) { 1644 LLVMAddAttributeAtIndex(Value_val(F), Int_val(Index), Attribute_val(A)); 1645 return Val_unit; 1646 } 1647 1648 /* llvalue -> int -> llattribute array */ 1649 value llvm_function_attrs(value F, value Index) { 1650 unsigned Length = LLVMGetAttributeCountAtIndex(Value_val(F), Int_val(Index)); 1651 value Array = caml_alloc_tuple_uninit(Length); 1652 LLVMGetAttributesAtIndex(Value_val(F), Int_val(Index), 1653 (LLVMAttributeRef *)Op_val(Array)); 1654 for (unsigned I = 0; I < Length; ++I) { 1655 Field(Array, I) = to_val((LLVMAttributeRef)Field(Array, I)); 1656 } 1657 return Array; 1658 } 1659 1660 /* llvalue -> llattrkind -> int -> unit */ 1661 value llvm_remove_enum_function_attr(value F, value Kind, value Index) { 1662 LLVMRemoveEnumAttributeAtIndex(Value_val(F), Int_val(Index), Int_val(Kind)); 1663 return Val_unit; 1664 } 1665 1666 /* llvalue -> string -> int -> unit */ 1667 value llvm_remove_string_function_attr(value F, value Kind, value Index) { 1668 LLVMRemoveStringAttributeAtIndex(Value_val(F), Int_val(Index), 1669 String_val(Kind), caml_string_length(Kind)); 1670 return Val_unit; 1671 } 1672 1673 /*--... Operations on parameters ...........................................--*/ 1674 1675 DEFINE_ITERATORS(param, Param, Value_val, LLVMValueRef, Value_val, 1676 LLVMGetParamParent) 1677 1678 /* llvalue -> int -> llvalue */ 1679 value llvm_param(value Fn, value Index) { 1680 return to_val(LLVMGetParam(Value_val(Fn), Int_val(Index))); 1681 } 1682 1683 /* llvalue -> llvalue array */ 1684 value llvm_params(value Fn) { 1685 unsigned Length = LLVMCountParams(Value_val(Fn)); 1686 value Params = caml_alloc_tuple_uninit(Length); 1687 LLVMGetParams(Value_val(Fn), (LLVMValueRef *)Op_val(Params)); 1688 for (unsigned I = 0; I < Length; ++I) { 1689 Field(Params, I) = to_val((LLVMValueRef)Field(Params, I)); 1690 } 1691 return Params; 1692 } 1693 1694 /* llvalue -> llvalue */ 1695 value llvm_param_parent(value Value) { 1696 LLVMValueRef Parent = LLVMGetParamParent(Value_val(Value)); 1697 return to_val(Parent); 1698 } 1699 1700 /*--... Operations on basic blocks .........................................--*/ 1701 1702 DEFINE_ITERATORS(block, BasicBlock, Value_val, LLVMBasicBlockRef, 1703 BasicBlock_val, LLVMGetBasicBlockParent) 1704 1705 /* llbasicblock -> llvalue option */ 1706 value llvm_block_terminator(value Block) { 1707 return ptr_to_option(LLVMGetBasicBlockTerminator(BasicBlock_val(Block))); 1708 } 1709 1710 /* llvalue -> llbasicblock array */ 1711 value llvm_basic_blocks(value Fn) { 1712 unsigned Length = LLVMCountBasicBlocks(Value_val(Fn)); 1713 value MLArray = caml_alloc_tuple_uninit(Length); 1714 LLVMGetBasicBlocks(Value_val(Fn), (LLVMBasicBlockRef *)Op_val(MLArray)); 1715 for (unsigned I = 0; I < Length; ++I) { 1716 Field(MLArray, I) = to_val((LLVMBasicBlockRef)Field(MLArray, I)); 1717 } 1718 return MLArray; 1719 } 1720 1721 /* llbasicblock -> unit */ 1722 value llvm_delete_block(value BB) { 1723 LLVMDeleteBasicBlock(BasicBlock_val(BB)); 1724 return Val_unit; 1725 } 1726 1727 /* llbasicblock -> unit */ 1728 value llvm_remove_block(value BB) { 1729 LLVMRemoveBasicBlockFromParent(BasicBlock_val(BB)); 1730 return Val_unit; 1731 } 1732 1733 /* llbasicblock -> llbasicblock -> unit */ 1734 value llvm_move_block_before(value Pos, value BB) { 1735 LLVMMoveBasicBlockBefore(BasicBlock_val(BB), BasicBlock_val(Pos)); 1736 return Val_unit; 1737 } 1738 1739 /* llbasicblock -> llbasicblock -> unit */ 1740 value llvm_move_block_after(value Pos, value BB) { 1741 LLVMMoveBasicBlockAfter(BasicBlock_val(BB), BasicBlock_val(Pos)); 1742 return Val_unit; 1743 } 1744 1745 /* string -> llvalue -> llbasicblock */ 1746 value llvm_append_block(value Context, value Name, value Fn) { 1747 return to_val(LLVMAppendBasicBlockInContext(Context_val(Context), 1748 Value_val(Fn), String_val(Name))); 1749 } 1750 1751 /* llcontext -> string -> llbasicblock -> llbasicblock */ 1752 value llvm_insert_block(value Context, value Name, value BB) { 1753 return to_val(LLVMInsertBasicBlockInContext( 1754 Context_val(Context), BasicBlock_val(BB), String_val(Name))); 1755 } 1756 1757 /* llbasicblock -> llvalue */ 1758 value llvm_value_of_block(value BB) { 1759 return to_val(LLVMBasicBlockAsValue(BasicBlock_val(BB))); 1760 } 1761 1762 /* llvalue -> bool */ 1763 value llvm_value_is_block(value Val) { 1764 return Val_bool(LLVMValueIsBasicBlock(Value_val(Val))); 1765 } 1766 1767 /* llbasicblock -> llvalue */ 1768 value llvm_block_of_value(value Val) { 1769 return to_val(LLVMValueAsBasicBlock(Value_val(Val))); 1770 } 1771 1772 /* llbasicblock -> llvalue */ 1773 value llvm_block_parent(value BB) { 1774 return to_val(LLVMGetBasicBlockParent(BasicBlock_val(BB))); 1775 } 1776 1777 /* llvalue -> llbasicblock */ 1778 value llvm_entry_block(value Val) { 1779 LLVMBasicBlockRef BB = LLVMGetEntryBasicBlock(Value_val(Val)); 1780 return to_val(BB); 1781 } 1782 1783 /*--... Operations on instructions .........................................--*/ 1784 1785 /* llvalue -> llbasicblock */ 1786 value llvm_instr_parent(value Inst) { 1787 LLVMBasicBlockRef BB = LLVMGetInstructionParent(Value_val(Inst)); 1788 return to_val(BB); 1789 } 1790 1791 DEFINE_ITERATORS(instr, Instruction, BasicBlock_val, LLVMValueRef, Value_val, 1792 LLVMGetInstructionParent) 1793 1794 /* llvalue -> Opcode.t */ 1795 value llvm_instr_get_opcode(value Inst) { 1796 LLVMOpcode o; 1797 if (!LLVMIsAInstruction(Value_val(Inst))) 1798 caml_failwith("Not an instruction"); 1799 o = LLVMGetInstructionOpcode(Value_val(Inst)); 1800 assert(o <= LLVMFreeze); 1801 return Val_int(o); 1802 } 1803 1804 /* llvalue -> ICmp.t option */ 1805 value llvm_instr_icmp_predicate(value Val) { 1806 int x = LLVMGetICmpPredicate(Value_val(Val)); 1807 if (!x) 1808 return Val_none; 1809 return caml_alloc_some(Val_int(x - LLVMIntEQ)); 1810 } 1811 1812 /* llvalue -> FCmp.t option */ 1813 value llvm_instr_fcmp_predicate(value Val) { 1814 int x = LLVMGetFCmpPredicate(Value_val(Val)); 1815 if (!x) 1816 return Val_none; 1817 return caml_alloc_some(Val_int(x - LLVMRealPredicateFalse)); 1818 } 1819 1820 /* llvalue -> llvalue */ 1821 value llvm_instr_clone(value Inst) { 1822 if (!LLVMIsAInstruction(Value_val(Inst))) 1823 caml_failwith("Not an instruction"); 1824 return to_val(LLVMInstructionClone(Value_val(Inst))); 1825 } 1826 1827 /*--... Operations on call sites ...........................................--*/ 1828 1829 /* llvalue -> int */ 1830 value llvm_instruction_call_conv(value Inst) { 1831 return Val_int(LLVMGetInstructionCallConv(Value_val(Inst))); 1832 } 1833 1834 /* int -> llvalue -> unit */ 1835 value llvm_set_instruction_call_conv(value CC, value Inst) { 1836 LLVMSetInstructionCallConv(Value_val(Inst), Int_val(CC)); 1837 return Val_unit; 1838 } 1839 1840 /* llvalue -> llattribute -> int -> unit */ 1841 value llvm_add_call_site_attr(value F, value A, value Index) { 1842 LLVMAddCallSiteAttribute(Value_val(F), Int_val(Index), Attribute_val(A)); 1843 return Val_unit; 1844 } 1845 1846 /* llvalue -> int -> llattribute array */ 1847 value llvm_call_site_attrs(value F, value Index) { 1848 unsigned Count = LLVMGetCallSiteAttributeCount(Value_val(F), Int_val(Index)); 1849 value Array = caml_alloc_tuple_uninit(Count); 1850 LLVMGetCallSiteAttributes(Value_val(F), Int_val(Index), 1851 (LLVMAttributeRef *)Op_val(Array)); 1852 for (unsigned I = 0; I < Count; ++I) { 1853 Field(Array, I) = to_val((LLVMAttributeRef)Field(Array, I)); 1854 } 1855 return Array; 1856 } 1857 1858 /* llvalue -> llattrkind -> int -> unit */ 1859 value llvm_remove_enum_call_site_attr(value F, value Kind, value Index) { 1860 LLVMRemoveCallSiteEnumAttribute(Value_val(F), Int_val(Index), Int_val(Kind)); 1861 return Val_unit; 1862 } 1863 1864 /* llvalue -> string -> int -> unit */ 1865 value llvm_remove_string_call_site_attr(value F, value Kind, value Index) { 1866 LLVMRemoveCallSiteStringAttribute(Value_val(F), Int_val(Index), 1867 String_val(Kind), caml_string_length(Kind)); 1868 return Val_unit; 1869 } 1870 1871 /*--... Operations on call instructions (only) .............................--*/ 1872 1873 /* llvalue -> int */ 1874 value llvm_num_arg_operands(value V) { 1875 return Val_int(LLVMGetNumArgOperands(Value_val(V))); 1876 } 1877 1878 /* llvalue -> bool */ 1879 value llvm_is_tail_call(value CallInst) { 1880 return Val_bool(LLVMIsTailCall(Value_val(CallInst))); 1881 } 1882 1883 /* bool -> llvalue -> unit */ 1884 value llvm_set_tail_call(value IsTailCall, value CallInst) { 1885 LLVMSetTailCall(Value_val(CallInst), Bool_val(IsTailCall)); 1886 return Val_unit; 1887 } 1888 1889 /* llvalue -> llbasicblock */ 1890 value llvm_get_normal_dest(value Val) { 1891 LLVMBasicBlockRef BB = LLVMGetNormalDest(Value_val(Val)); 1892 return to_val(BB); 1893 } 1894 1895 /* llvalue -> llbasicblock */ 1896 value llvm_get_unwind_dest(value Val) { 1897 LLVMBasicBlockRef BB = LLVMGetUnwindDest(Value_val(Val)); 1898 return to_val(BB); 1899 } 1900 1901 /*--... Operations on load/store instructions (only)........................--*/ 1902 1903 /* llvalue -> bool */ 1904 value llvm_is_volatile(value MemoryInst) { 1905 return Val_bool(LLVMGetVolatile(Value_val(MemoryInst))); 1906 } 1907 1908 /* bool -> llvalue -> unit */ 1909 value llvm_set_volatile(value IsVolatile, value MemoryInst) { 1910 LLVMSetVolatile(Value_val(MemoryInst), Bool_val(IsVolatile)); 1911 return Val_unit; 1912 } 1913 1914 /*--.. Operations on terminators ...........................................--*/ 1915 1916 /* llvalue -> int -> llbasicblock */ 1917 value llvm_successor(value V, value I) { 1918 return to_val(LLVMGetSuccessor(Value_val(V), Int_val(I))); 1919 } 1920 1921 /* llvalue -> int -> llvalue -> unit */ 1922 value llvm_set_successor(value U, value I, value B) { 1923 LLVMSetSuccessor(Value_val(U), Int_val(I), BasicBlock_val(B)); 1924 return Val_unit; 1925 } 1926 1927 /* llvalue -> int */ 1928 value llvm_num_successors(value V) { 1929 return Val_int(LLVMGetNumSuccessors(Value_val(V))); 1930 } 1931 1932 /*--.. Operations on branch ................................................--*/ 1933 1934 /* llvalue -> llvalue */ 1935 value llvm_condition(value V) { return to_val(LLVMGetCondition(Value_val(V))); } 1936 1937 /* llvalue -> llvalue -> unit */ 1938 value llvm_set_condition(value B, value C) { 1939 LLVMSetCondition(Value_val(B), Value_val(C)); 1940 return Val_unit; 1941 } 1942 1943 /* llvalue -> bool */ 1944 value llvm_is_conditional(value V) { 1945 return Val_bool(LLVMIsConditional(Value_val(V))); 1946 } 1947 1948 /*--... Operations on phi nodes ............................................--*/ 1949 1950 /* (llvalue * llbasicblock) -> llvalue -> unit */ 1951 value llvm_add_incoming(value Incoming, value PhiNode) { 1952 LLVMValueRef V = Value_val(Field(Incoming, 0)); 1953 LLVMBasicBlockRef BB = BasicBlock_val(Field(Incoming, 1)); 1954 LLVMAddIncoming(Value_val(PhiNode), &V, &BB, 1); 1955 return Val_unit; 1956 } 1957 1958 /* llvalue -> (llvalue * llbasicblock) list */ 1959 value llvm_incoming(value Phi) { 1960 CAMLparam0(); 1961 CAMLlocal2(Hd, Tl); 1962 LLVMValueRef PhiNode = Value_val(Phi); 1963 1964 /* Build a tuple list of them. */ 1965 Tl = Val_int(0); 1966 for (unsigned I = LLVMCountIncoming(PhiNode); I != 0;) { 1967 Hd = caml_alloc_small(2, 0); 1968 Field(Hd, 0) = to_val(LLVMGetIncomingValue(PhiNode, --I)); 1969 Field(Hd, 1) = to_val(LLVMGetIncomingBlock(PhiNode, I)); 1970 1971 value Tmp = caml_alloc_small(2, 0); 1972 Field(Tmp, 0) = Hd; 1973 Field(Tmp, 1) = Tl; 1974 Tl = Tmp; 1975 } 1976 1977 CAMLreturn(Tl); 1978 } 1979 1980 /* llvalue -> unit */ 1981 value llvm_delete_instruction(value Instruction) { 1982 LLVMInstructionEraseFromParent(Value_val(Instruction)); 1983 return Val_unit; 1984 } 1985 1986 /*===-- Instruction builders ----------------------------------------------===*/ 1987 1988 #define Builder_val(v) (*(LLVMBuilderRef *)(Data_custom_val(v))) 1989 1990 static void llvm_finalize_builder(value B) { 1991 LLVMDisposeBuilder(Builder_val(B)); 1992 } 1993 1994 static struct custom_operations builder_ops = { 1995 (char *)"Llvm.llbuilder", llvm_finalize_builder, 1996 custom_compare_default, custom_hash_default, 1997 custom_serialize_default, custom_deserialize_default, 1998 custom_compare_ext_default}; 1999 2000 static value alloc_builder(LLVMBuilderRef B) { 2001 value V = caml_alloc_custom(&builder_ops, sizeof(LLVMBuilderRef), 0, 1); 2002 Builder_val(V) = B; 2003 return V; 2004 } 2005 2006 /* llcontext -> llbuilder */ 2007 value llvm_builder(value C) { 2008 return alloc_builder(LLVMCreateBuilderInContext(Context_val(C))); 2009 } 2010 2011 /* (llbasicblock, llvalue) llpos -> llbuilder -> unit */ 2012 value llvm_position_builder_before_dbg_records(value Pos, value B) { 2013 if (Tag_val(Pos) == 0) { 2014 LLVMBasicBlockRef BB = BasicBlock_val(Field(Pos, 0)); 2015 LLVMPositionBuilderAtEnd(Builder_val(B), BB); 2016 } else { 2017 LLVMValueRef I = Value_val(Field(Pos, 0)); 2018 LLVMPositionBuilderBeforeInstrAndDbgRecords(Builder_val(B), I); 2019 } 2020 return Val_unit; 2021 } 2022 2023 /* (llbasicblock, llvalue) llpos -> llbuilder -> unit */ 2024 value llvm_position_builder(value Pos, value B) { 2025 if (Tag_val(Pos) == 0) { 2026 LLVMBasicBlockRef BB = BasicBlock_val(Field(Pos, 0)); 2027 LLVMPositionBuilderAtEnd(Builder_val(B), BB); 2028 } else { 2029 LLVMValueRef I = Value_val(Field(Pos, 0)); 2030 LLVMPositionBuilderBefore(Builder_val(B), I); 2031 } 2032 return Val_unit; 2033 } 2034 2035 /* llbuilder -> llbasicblock */ 2036 value llvm_insertion_block(value B) { 2037 LLVMBasicBlockRef InsertBlock = LLVMGetInsertBlock(Builder_val(B)); 2038 if (!InsertBlock) 2039 caml_raise_not_found(); 2040 return to_val(InsertBlock); 2041 } 2042 2043 /* llvalue -> string -> llbuilder -> unit */ 2044 value llvm_insert_into_builder(value I, value Name, value B) { 2045 LLVMInsertIntoBuilderWithName(Builder_val(B), Value_val(I), String_val(Name)); 2046 return Val_unit; 2047 } 2048 2049 /*--... Metadata ...........................................................--*/ 2050 2051 /* llbuilder -> llvalue -> unit */ 2052 value llvm_set_current_debug_location(value B, value V) { 2053 LLVMSetCurrentDebugLocation(Builder_val(B), Value_val(V)); 2054 return Val_unit; 2055 } 2056 2057 /* llbuilder -> unit */ 2058 value llvm_clear_current_debug_location(value B) { 2059 LLVMSetCurrentDebugLocation(Builder_val(B), NULL); 2060 return Val_unit; 2061 } 2062 2063 /* llbuilder -> llvalue option */ 2064 value llvm_current_debug_location(value B) { 2065 return ptr_to_option(LLVMGetCurrentDebugLocation(Builder_val(B))); 2066 } 2067 2068 /* llbuilder -> llvalue -> unit */ 2069 value llvm_set_inst_debug_location(value B, value V) { 2070 LLVMSetInstDebugLocation(Builder_val(B), Value_val(V)); 2071 return Val_unit; 2072 } 2073 2074 /*--... Terminators ........................................................--*/ 2075 2076 /* llbuilder -> llvalue */ 2077 value llvm_build_ret_void(value B) { 2078 return to_val(LLVMBuildRetVoid(Builder_val(B))); 2079 } 2080 2081 /* llvalue -> llbuilder -> llvalue */ 2082 value llvm_build_ret(value Val, value B) { 2083 return to_val(LLVMBuildRet(Builder_val(B), Value_val(Val))); 2084 } 2085 2086 /* llvalue array -> llbuilder -> llvalue */ 2087 value llvm_build_aggregate_ret(value RetVals, value B) { 2088 mlsize_t Length = Wosize_val(RetVals); 2089 LLVMValueRef *Temp = from_val_array(RetVals); 2090 LLVMValueRef Value = LLVMBuildAggregateRet(Builder_val(B), Temp, Length); 2091 free(Temp); 2092 return to_val(Value); 2093 } 2094 2095 /* llbasicblock -> llbuilder -> llvalue */ 2096 value llvm_build_br(value BB, value B) { 2097 return to_val(LLVMBuildBr(Builder_val(B), BasicBlock_val(BB))); 2098 } 2099 2100 /* llvalue -> llbasicblock -> llbasicblock -> llbuilder -> llvalue */ 2101 value llvm_build_cond_br(value If, value Then, value Else, value B) { 2102 return to_val(LLVMBuildCondBr(Builder_val(B), Value_val(If), 2103 BasicBlock_val(Then), BasicBlock_val(Else))); 2104 } 2105 2106 /* llvalue -> llbasicblock -> int -> llbuilder -> llvalue */ 2107 value llvm_build_switch(value Of, value Else, value EstimatedCount, value B) { 2108 return to_val(LLVMBuildSwitch(Builder_val(B), Value_val(Of), 2109 BasicBlock_val(Else), Int_val(EstimatedCount))); 2110 } 2111 2112 /* lltype -> string -> llbuilder -> llvalue */ 2113 value llvm_build_malloc(value Ty, value Name, value B) { 2114 return to_val( 2115 LLVMBuildMalloc(Builder_val(B), Type_val(Ty), String_val(Name))); 2116 } 2117 2118 /* lltype -> llvalue -> string -> llbuilder -> llvalue */ 2119 value llvm_build_array_malloc(value Ty, value Val, value Name, value B) { 2120 return to_val(LLVMBuildArrayMalloc(Builder_val(B), Type_val(Ty), 2121 Value_val(Val), String_val(Name))); 2122 } 2123 2124 /* llvalue -> llbuilder -> llvalue */ 2125 value llvm_build_free(value P, value B) { 2126 return to_val(LLVMBuildFree(Builder_val(B), Value_val(P))); 2127 } 2128 2129 /* llvalue -> llvalue -> llbasicblock -> unit */ 2130 value llvm_add_case(value Switch, value OnVal, value Dest) { 2131 LLVMAddCase(Value_val(Switch), Value_val(OnVal), BasicBlock_val(Dest)); 2132 return Val_unit; 2133 } 2134 2135 /* llvalue -> llbasicblock */ 2136 value llvm_switch_default_dest(value Val) { 2137 LLVMBasicBlockRef BB = LLVMGetSwitchDefaultDest(Value_val(Val)); 2138 return to_val(BB); 2139 } 2140 2141 /* llvalue -> int -> llbuilder -> llvalue */ 2142 value llvm_build_indirect_br(value Addr, value EstimatedDests, value B) { 2143 return to_val(LLVMBuildIndirectBr(Builder_val(B), Value_val(Addr), 2144 Int_val(EstimatedDests))); 2145 } 2146 2147 /* llvalue -> llbasicblock -> unit */ 2148 value llvm_add_destination(value IndirectBr, value Dest) { 2149 LLVMAddDestination(Value_val(IndirectBr), BasicBlock_val(Dest)); 2150 return Val_unit; 2151 } 2152 2153 /* lltype -> llvalue -> llvalue array -> llbasicblock -> llbasicblock -> 2154 string -> llbuilder -> llvalue */ 2155 value llvm_build_invoke_nat(value FnTy, value Fn, value Args, value Then, 2156 value Catch, value Name, value B) { 2157 mlsize_t Length = Wosize_val(Args); 2158 LLVMValueRef *Temp = from_val_array(Args); 2159 LLVMValueRef Value = LLVMBuildInvoke2( 2160 Builder_val(B), Type_val(FnTy), Value_val(Fn), Temp, Length, 2161 BasicBlock_val(Then), BasicBlock_val(Catch), String_val(Name)); 2162 free(Temp); 2163 return to_val(Value); 2164 } 2165 2166 /* lltype -> llvalue -> llvalue array -> llbasicblock -> llbasicblock -> 2167 string -> llbuilder -> llvalue */ 2168 value llvm_build_invoke_bc(value Args[], int NumArgs) { 2169 return llvm_build_invoke_nat(Args[0], Args[1], Args[2], Args[3], Args[4], 2170 Args[5], Args[6]); 2171 } 2172 2173 /* lltype -> llvalue -> int -> string -> llbuilder -> llvalue */ 2174 value llvm_build_landingpad(value Ty, value PersFn, value NumClauses, 2175 value Name, value B) { 2176 return to_val(LLVMBuildLandingPad(Builder_val(B), Type_val(Ty), 2177 Value_val(PersFn), Int_val(NumClauses), 2178 String_val(Name))); 2179 } 2180 2181 /* llvalue -> llvalue -> unit */ 2182 value llvm_add_clause(value LandingPadInst, value ClauseVal) { 2183 LLVMAddClause(Value_val(LandingPadInst), Value_val(ClauseVal)); 2184 return Val_unit; 2185 } 2186 2187 /* llvalue -> bool */ 2188 value llvm_is_cleanup(value LandingPadInst) { 2189 return Val_bool(LLVMIsCleanup(Value_val(LandingPadInst))); 2190 } 2191 2192 /* llvalue -> bool -> unit */ 2193 value llvm_set_cleanup(value LandingPadInst, value flag) { 2194 LLVMSetCleanup(Value_val(LandingPadInst), Bool_val(flag)); 2195 return Val_unit; 2196 } 2197 2198 /* llvalue -> llbuilder -> llvalue */ 2199 value llvm_build_resume(value Exn, value B) { 2200 return to_val(LLVMBuildResume(Builder_val(B), Value_val(Exn))); 2201 } 2202 2203 /* llbuilder -> llvalue */ 2204 value llvm_build_unreachable(value B) { 2205 return to_val(LLVMBuildUnreachable(Builder_val(B))); 2206 } 2207 2208 /*--... Arithmetic .........................................................--*/ 2209 2210 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2211 value llvm_build_add(value LHS, value RHS, value Name, value B) { 2212 return to_val(LLVMBuildAdd(Builder_val(B), Value_val(LHS), Value_val(RHS), 2213 String_val(Name))); 2214 } 2215 2216 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2217 value llvm_build_nsw_add(value LHS, value RHS, value Name, value B) { 2218 return to_val(LLVMBuildNSWAdd(Builder_val(B), Value_val(LHS), Value_val(RHS), 2219 String_val(Name))); 2220 } 2221 2222 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2223 value llvm_build_nuw_add(value LHS, value RHS, value Name, value B) { 2224 return to_val(LLVMBuildNUWAdd(Builder_val(B), Value_val(LHS), Value_val(RHS), 2225 String_val(Name))); 2226 } 2227 2228 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2229 value llvm_build_fadd(value LHS, value RHS, value Name, value B) { 2230 return to_val(LLVMBuildFAdd(Builder_val(B), Value_val(LHS), Value_val(RHS), 2231 String_val(Name))); 2232 } 2233 2234 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2235 value llvm_build_sub(value LHS, value RHS, value Name, value B) { 2236 return to_val(LLVMBuildSub(Builder_val(B), Value_val(LHS), Value_val(RHS), 2237 String_val(Name))); 2238 } 2239 2240 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2241 value llvm_build_nsw_sub(value LHS, value RHS, value Name, value B) { 2242 return to_val(LLVMBuildNSWSub(Builder_val(B), Value_val(LHS), Value_val(RHS), 2243 String_val(Name))); 2244 } 2245 2246 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2247 value llvm_build_nuw_sub(value LHS, value RHS, value Name, value B) { 2248 return to_val(LLVMBuildNUWSub(Builder_val(B), Value_val(LHS), Value_val(RHS), 2249 String_val(Name))); 2250 } 2251 2252 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2253 value llvm_build_fsub(value LHS, value RHS, value Name, value B) { 2254 return to_val(LLVMBuildFSub(Builder_val(B), Value_val(LHS), Value_val(RHS), 2255 String_val(Name))); 2256 } 2257 2258 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2259 value llvm_build_mul(value LHS, value RHS, value Name, value B) { 2260 return to_val(LLVMBuildMul(Builder_val(B), Value_val(LHS), Value_val(RHS), 2261 String_val(Name))); 2262 } 2263 2264 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2265 value llvm_build_nsw_mul(value LHS, value RHS, value Name, value B) { 2266 return to_val(LLVMBuildNSWMul(Builder_val(B), Value_val(LHS), Value_val(RHS), 2267 String_val(Name))); 2268 } 2269 2270 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2271 value llvm_build_nuw_mul(value LHS, value RHS, value Name, value B) { 2272 return to_val(LLVMBuildNUWMul(Builder_val(B), Value_val(LHS), Value_val(RHS), 2273 String_val(Name))); 2274 } 2275 2276 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2277 value llvm_build_fmul(value LHS, value RHS, value Name, value B) { 2278 return to_val(LLVMBuildFMul(Builder_val(B), Value_val(LHS), Value_val(RHS), 2279 String_val(Name))); 2280 } 2281 2282 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2283 value llvm_build_udiv(value LHS, value RHS, value Name, value B) { 2284 return to_val(LLVMBuildUDiv(Builder_val(B), Value_val(LHS), Value_val(RHS), 2285 String_val(Name))); 2286 } 2287 2288 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2289 value llvm_build_sdiv(value LHS, value RHS, value Name, value B) { 2290 return to_val(LLVMBuildSDiv(Builder_val(B), Value_val(LHS), Value_val(RHS), 2291 String_val(Name))); 2292 } 2293 2294 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2295 value llvm_build_exact_sdiv(value LHS, value RHS, value Name, value B) { 2296 return to_val(LLVMBuildExactSDiv(Builder_val(B), Value_val(LHS), 2297 Value_val(RHS), String_val(Name))); 2298 } 2299 2300 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2301 value llvm_build_fdiv(value LHS, value RHS, value Name, value B) { 2302 return to_val(LLVMBuildFDiv(Builder_val(B), Value_val(LHS), Value_val(RHS), 2303 String_val(Name))); 2304 } 2305 2306 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2307 value llvm_build_urem(value LHS, value RHS, value Name, value B) { 2308 return to_val(LLVMBuildURem(Builder_val(B), Value_val(LHS), Value_val(RHS), 2309 String_val(Name))); 2310 } 2311 2312 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2313 value llvm_build_srem(value LHS, value RHS, value Name, value B) { 2314 return to_val(LLVMBuildSRem(Builder_val(B), Value_val(LHS), Value_val(RHS), 2315 String_val(Name))); 2316 } 2317 2318 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2319 value llvm_build_frem(value LHS, value RHS, value Name, value B) { 2320 return to_val(LLVMBuildFRem(Builder_val(B), Value_val(LHS), Value_val(RHS), 2321 String_val(Name))); 2322 } 2323 2324 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2325 value llvm_build_shl(value LHS, value RHS, value Name, value B) { 2326 return to_val(LLVMBuildShl(Builder_val(B), Value_val(LHS), Value_val(RHS), 2327 String_val(Name))); 2328 } 2329 2330 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2331 value llvm_build_lshr(value LHS, value RHS, value Name, value B) { 2332 return to_val(LLVMBuildLShr(Builder_val(B), Value_val(LHS), Value_val(RHS), 2333 String_val(Name))); 2334 } 2335 2336 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2337 value llvm_build_ashr(value LHS, value RHS, value Name, value B) { 2338 return to_val(LLVMBuildAShr(Builder_val(B), Value_val(LHS), Value_val(RHS), 2339 String_val(Name))); 2340 } 2341 2342 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2343 value llvm_build_and(value LHS, value RHS, value Name, value B) { 2344 return to_val(LLVMBuildAnd(Builder_val(B), Value_val(LHS), Value_val(RHS), 2345 String_val(Name))); 2346 } 2347 2348 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2349 value llvm_build_or(value LHS, value RHS, value Name, value B) { 2350 return to_val(LLVMBuildOr(Builder_val(B), Value_val(LHS), Value_val(RHS), 2351 String_val(Name))); 2352 } 2353 2354 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2355 value llvm_build_xor(value LHS, value RHS, value Name, value B) { 2356 return to_val(LLVMBuildXor(Builder_val(B), Value_val(LHS), Value_val(RHS), 2357 String_val(Name))); 2358 } 2359 2360 /* llvalue -> string -> llbuilder -> llvalue */ 2361 value llvm_build_neg(value X, value Name, value B) { 2362 return to_val(LLVMBuildNeg(Builder_val(B), Value_val(X), String_val(Name))); 2363 } 2364 2365 /* llvalue -> string -> llbuilder -> llvalue */ 2366 value llvm_build_nsw_neg(value X, value Name, value B) { 2367 return to_val( 2368 LLVMBuildNSWNeg(Builder_val(B), Value_val(X), String_val(Name))); 2369 } 2370 2371 /* llvalue -> string -> llbuilder -> llvalue */ 2372 value llvm_build_nuw_neg(value X, value Name, value B) { 2373 return to_val( 2374 LLVMBuildNUWNeg(Builder_val(B), Value_val(X), String_val(Name))); 2375 } 2376 2377 /* llvalue -> string -> llbuilder -> llvalue */ 2378 value llvm_build_fneg(value X, value Name, value B) { 2379 return to_val(LLVMBuildFNeg(Builder_val(B), Value_val(X), String_val(Name))); 2380 } 2381 2382 /* llvalue -> string -> llbuilder -> llvalue */ 2383 value llvm_build_not(value X, value Name, value B) { 2384 return to_val(LLVMBuildNot(Builder_val(B), Value_val(X), String_val(Name))); 2385 } 2386 2387 /*--... Memory .............................................................--*/ 2388 2389 /* lltype -> string -> llbuilder -> llvalue */ 2390 value llvm_build_alloca(value Ty, value Name, value B) { 2391 return to_val( 2392 LLVMBuildAlloca(Builder_val(B), Type_val(Ty), String_val(Name))); 2393 } 2394 2395 /* lltype -> llvalue -> string -> llbuilder -> llvalue */ 2396 value llvm_build_array_alloca(value Ty, value Size, value Name, value B) { 2397 return to_val(LLVMBuildArrayAlloca(Builder_val(B), Type_val(Ty), 2398 Value_val(Size), String_val(Name))); 2399 } 2400 2401 /* lltype -> llvalue -> string -> llbuilder -> llvalue */ 2402 value llvm_build_load(value Ty, value Pointer, value Name, value B) { 2403 return to_val(LLVMBuildLoad2(Builder_val(B), Type_val(Ty), Value_val(Pointer), 2404 String_val(Name))); 2405 } 2406 2407 /* llvalue -> llvalue -> llbuilder -> llvalue */ 2408 value llvm_build_store(value Value, value Pointer, value B) { 2409 return to_val( 2410 LLVMBuildStore(Builder_val(B), Value_val(Value), Value_val(Pointer))); 2411 } 2412 2413 /* AtomicRMWBinOp.t -> llvalue -> llvalue -> AtomicOrdering.t -> 2414 bool -> string -> llbuilder -> llvalue */ 2415 value llvm_build_atomicrmw_native(value BinOp, value Ptr, value Val, value Ord, 2416 value ST, value Name, value B) { 2417 LLVMValueRef Instr; 2418 Instr = LLVMBuildAtomicRMW(Builder_val(B), Int_val(BinOp), Value_val(Ptr), 2419 Value_val(Val), Int_val(Ord), Bool_val(ST)); 2420 LLVMSetValueName(Instr, String_val(Name)); 2421 return to_val(Instr); 2422 } 2423 2424 value llvm_build_atomicrmw_bytecode(value *argv, int argn) { 2425 return llvm_build_atomicrmw_native(argv[0], argv[1], argv[2], argv[3], 2426 argv[4], argv[5], argv[6]); 2427 } 2428 2429 /* lltype -> llvalue -> llvalue array -> string -> llbuilder -> llvalue */ 2430 value llvm_build_gep(value Ty, value Pointer, value Indices, value Name, 2431 value B) { 2432 mlsize_t Length = Wosize_val(Indices); 2433 LLVMValueRef *Temp = from_val_array(Indices); 2434 LLVMValueRef Value = 2435 LLVMBuildGEP2(Builder_val(B), Type_val(Ty), Value_val(Pointer), Temp, 2436 Length, String_val(Name)); 2437 free(Temp); 2438 return to_val(Value); 2439 } 2440 2441 /* lltype -> llvalue -> llvalue array -> string -> llbuilder -> llvalue */ 2442 value llvm_build_in_bounds_gep(value Ty, value Pointer, value Indices, 2443 value Name, value B) { 2444 mlsize_t Length = Wosize_val(Indices); 2445 LLVMValueRef *Temp = from_val_array(Indices); 2446 LLVMValueRef Value = 2447 LLVMBuildInBoundsGEP2(Builder_val(B), Type_val(Ty), Value_val(Pointer), 2448 Temp, Length, String_val(Name)); 2449 free(Temp); 2450 return to_val(Value); 2451 } 2452 2453 /* lltype -> llvalue -> int -> string -> llbuilder -> llvalue */ 2454 value llvm_build_struct_gep(value Ty, value Pointer, value Index, value Name, 2455 value B) { 2456 return to_val(LLVMBuildStructGEP2(Builder_val(B), Type_val(Ty), 2457 Value_val(Pointer), Int_val(Index), 2458 String_val(Name))); 2459 } 2460 2461 /* string -> string -> llbuilder -> llvalue */ 2462 value llvm_build_global_string(value Str, value Name, value B) { 2463 return to_val( 2464 LLVMBuildGlobalString(Builder_val(B), String_val(Str), String_val(Name))); 2465 } 2466 2467 /* string -> string -> llbuilder -> llvalue */ 2468 value llvm_build_global_stringptr(value Str, value Name, value B) { 2469 return to_val(LLVMBuildGlobalStringPtr(Builder_val(B), String_val(Str), 2470 String_val(Name))); 2471 } 2472 2473 /*--... Casts ..............................................................--*/ 2474 2475 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2476 value llvm_build_trunc(value X, value Ty, value Name, value B) { 2477 return to_val(LLVMBuildTrunc(Builder_val(B), Value_val(X), Type_val(Ty), 2478 String_val(Name))); 2479 } 2480 2481 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2482 value llvm_build_zext(value X, value Ty, value Name, value B) { 2483 return to_val(LLVMBuildZExt(Builder_val(B), Value_val(X), Type_val(Ty), 2484 String_val(Name))); 2485 } 2486 2487 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2488 value llvm_build_sext(value X, value Ty, value Name, value B) { 2489 return to_val(LLVMBuildSExt(Builder_val(B), Value_val(X), Type_val(Ty), 2490 String_val(Name))); 2491 } 2492 2493 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2494 value llvm_build_fptoui(value X, value Ty, value Name, value B) { 2495 return to_val(LLVMBuildFPToUI(Builder_val(B), Value_val(X), Type_val(Ty), 2496 String_val(Name))); 2497 } 2498 2499 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2500 value llvm_build_fptosi(value X, value Ty, value Name, value B) { 2501 return to_val(LLVMBuildFPToSI(Builder_val(B), Value_val(X), Type_val(Ty), 2502 String_val(Name))); 2503 } 2504 2505 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2506 value llvm_build_uitofp(value X, value Ty, value Name, value B) { 2507 return to_val(LLVMBuildUIToFP(Builder_val(B), Value_val(X), Type_val(Ty), 2508 String_val(Name))); 2509 } 2510 2511 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2512 value llvm_build_sitofp(value X, value Ty, value Name, value B) { 2513 return to_val(LLVMBuildSIToFP(Builder_val(B), Value_val(X), Type_val(Ty), 2514 String_val(Name))); 2515 } 2516 2517 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2518 value llvm_build_fptrunc(value X, value Ty, value Name, value B) { 2519 return to_val(LLVMBuildFPTrunc(Builder_val(B), Value_val(X), Type_val(Ty), 2520 String_val(Name))); 2521 } 2522 2523 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2524 value llvm_build_fpext(value X, value Ty, value Name, value B) { 2525 return to_val(LLVMBuildFPExt(Builder_val(B), Value_val(X), Type_val(Ty), 2526 String_val(Name))); 2527 } 2528 2529 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2530 value llvm_build_prttoint(value X, value Ty, value Name, value B) { 2531 return to_val(LLVMBuildPtrToInt(Builder_val(B), Value_val(X), Type_val(Ty), 2532 String_val(Name))); 2533 } 2534 2535 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2536 value llvm_build_inttoptr(value X, value Ty, value Name, value B) { 2537 return to_val(LLVMBuildIntToPtr(Builder_val(B), Value_val(X), Type_val(Ty), 2538 String_val(Name))); 2539 } 2540 2541 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2542 value llvm_build_bitcast(value X, value Ty, value Name, value B) { 2543 return to_val(LLVMBuildBitCast(Builder_val(B), Value_val(X), Type_val(Ty), 2544 String_val(Name))); 2545 } 2546 2547 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2548 value llvm_build_zext_or_bitcast(value X, value Ty, value Name, value B) { 2549 return to_val(LLVMBuildZExtOrBitCast(Builder_val(B), Value_val(X), 2550 Type_val(Ty), String_val(Name))); 2551 } 2552 2553 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2554 value llvm_build_sext_or_bitcast(value X, value Ty, value Name, value B) { 2555 return to_val(LLVMBuildSExtOrBitCast(Builder_val(B), Value_val(X), 2556 Type_val(Ty), String_val(Name))); 2557 } 2558 2559 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2560 value llvm_build_trunc_or_bitcast(value X, value Ty, value Name, value B) { 2561 return to_val(LLVMBuildTruncOrBitCast(Builder_val(B), Value_val(X), 2562 Type_val(Ty), String_val(Name))); 2563 } 2564 2565 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2566 value llvm_build_pointercast(value X, value Ty, value Name, value B) { 2567 return to_val(LLVMBuildPointerCast(Builder_val(B), Value_val(X), Type_val(Ty), 2568 String_val(Name))); 2569 } 2570 2571 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2572 value llvm_build_intcast(value X, value Ty, value Name, value B) { 2573 return to_val(LLVMBuildIntCast(Builder_val(B), Value_val(X), Type_val(Ty), 2574 String_val(Name))); 2575 } 2576 2577 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2578 value llvm_build_fpcast(value X, value Ty, value Name, value B) { 2579 return to_val(LLVMBuildFPCast(Builder_val(B), Value_val(X), Type_val(Ty), 2580 String_val(Name))); 2581 } 2582 2583 /*--... Comparisons ........................................................--*/ 2584 2585 /* Icmp.t -> llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2586 value llvm_build_icmp(value Pred, value LHS, value RHS, value Name, value B) { 2587 return to_val(LLVMBuildICmp(Builder_val(B), Int_val(Pred) + LLVMIntEQ, 2588 Value_val(LHS), Value_val(RHS), 2589 String_val(Name))); 2590 } 2591 2592 /* Fcmp.t -> llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2593 value llvm_build_fcmp(value Pred, value LHS, value RHS, value Name, value B) { 2594 return to_val(LLVMBuildFCmp(Builder_val(B), Int_val(Pred), Value_val(LHS), 2595 Value_val(RHS), String_val(Name))); 2596 } 2597 2598 /*--... Miscellaneous instructions .........................................--*/ 2599 2600 /* (llvalue * llbasicblock) list -> string -> llbuilder -> llvalue */ 2601 value llvm_build_phi(value Incoming, value Name, value B) { 2602 value Hd, Tl; 2603 LLVMValueRef FirstValue, PhiNode; 2604 2605 assert(Incoming != Val_int(0) && "Empty list passed to Llvm.build_phi!"); 2606 2607 Hd = Field(Incoming, 0); 2608 FirstValue = Value_val(Field(Hd, 0)); 2609 PhiNode = 2610 LLVMBuildPhi(Builder_val(B), LLVMTypeOf(FirstValue), String_val(Name)); 2611 2612 for (Tl = Incoming; Tl != Val_int(0); Tl = Field(Tl, 1)) { 2613 Hd = Field(Tl, 0); 2614 LLVMValueRef V = Value_val(Field(Hd, 0)); 2615 LLVMBasicBlockRef BB = BasicBlock_val(Field(Hd, 1)); 2616 LLVMAddIncoming(PhiNode, &V, &BB, 1); 2617 } 2618 2619 return to_val(PhiNode); 2620 } 2621 2622 /* lltype -> string -> llbuilder -> value */ 2623 value llvm_build_empty_phi(value Type, value Name, value B) { 2624 return to_val(LLVMBuildPhi(Builder_val(B), Type_val(Type), String_val(Name))); 2625 } 2626 2627 /* lltype -> llvalue -> llvalue array -> string -> llbuilder -> llvalue */ 2628 value llvm_build_call(value FnTy, value Fn, value Params, value Name, value B) { 2629 mlsize_t Length = Wosize_val(Params); 2630 LLVMValueRef *Temp = from_val_array(Params); 2631 LLVMValueRef Value = 2632 LLVMBuildCall2(Builder_val(B), Type_val(FnTy), Value_val(Fn), Temp, 2633 Length, String_val(Name)); 2634 free(Temp); 2635 return to_val(Value); 2636 } 2637 2638 /* llvalue -> llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2639 value llvm_build_select(value If, value Then, value Else, value Name, value B) { 2640 return to_val(LLVMBuildSelect(Builder_val(B), Value_val(If), Value_val(Then), 2641 Value_val(Else), String_val(Name))); 2642 } 2643 2644 /* llvalue -> lltype -> string -> llbuilder -> llvalue */ 2645 value llvm_build_va_arg(value List, value Ty, value Name, value B) { 2646 return to_val(LLVMBuildVAArg(Builder_val(B), Value_val(List), Type_val(Ty), 2647 String_val(Name))); 2648 } 2649 2650 /* llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2651 value llvm_build_extractelement(value Vec, value Idx, value Name, value B) { 2652 return to_val(LLVMBuildExtractElement(Builder_val(B), Value_val(Vec), 2653 Value_val(Idx), String_val(Name))); 2654 } 2655 2656 /* llvalue -> llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2657 value llvm_build_insertelement(value Vec, value Element, value Idx, value Name, 2658 value B) { 2659 return to_val(LLVMBuildInsertElement(Builder_val(B), Value_val(Vec), 2660 Value_val(Element), Value_val(Idx), 2661 String_val(Name))); 2662 } 2663 2664 /* llvalue -> llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2665 value llvm_build_shufflevector(value V1, value V2, value Mask, value Name, 2666 value B) { 2667 return to_val(LLVMBuildShuffleVector(Builder_val(B), Value_val(V1), 2668 Value_val(V2), Value_val(Mask), 2669 String_val(Name))); 2670 } 2671 2672 /* llvalue -> int -> string -> llbuilder -> llvalue */ 2673 value llvm_build_extractvalue(value Aggregate, value Idx, value Name, value B) { 2674 return to_val(LLVMBuildExtractValue(Builder_val(B), Value_val(Aggregate), 2675 Int_val(Idx), String_val(Name))); 2676 } 2677 2678 /* llvalue -> llvalue -> int -> string -> llbuilder -> llvalue */ 2679 value llvm_build_insertvalue(value Aggregate, value Val, value Idx, value Name, 2680 value B) { 2681 return to_val(LLVMBuildInsertValue(Builder_val(B), Value_val(Aggregate), 2682 Value_val(Val), Int_val(Idx), 2683 String_val(Name))); 2684 } 2685 2686 /* llvalue -> string -> llbuilder -> llvalue */ 2687 value llvm_build_is_null(value Val, value Name, value B) { 2688 return to_val( 2689 LLVMBuildIsNull(Builder_val(B), Value_val(Val), String_val(Name))); 2690 } 2691 2692 /* llvalue -> string -> llbuilder -> llvalue */ 2693 value llvm_build_is_not_null(value Val, value Name, value B) { 2694 return to_val( 2695 LLVMBuildIsNotNull(Builder_val(B), Value_val(Val), String_val(Name))); 2696 } 2697 2698 /* lltype -> llvalue -> llvalue -> string -> llbuilder -> llvalue */ 2699 value llvm_build_ptrdiff(value ElemTy, value LHS, value RHS, value Name, 2700 value B) { 2701 return to_val(LLVMBuildPtrDiff2(Builder_val(B), Type_val(ElemTy), 2702 Value_val(LHS), Value_val(RHS), 2703 String_val(Name))); 2704 } 2705 2706 /* llvalue -> string -> llbuilder -> llvalue */ 2707 value llvm_build_freeze(value X, value Name, value B) { 2708 return to_val( 2709 LLVMBuildFreeze(Builder_val(B), Value_val(X), String_val(Name))); 2710 } 2711 2712 /*===-- Memory buffers ----------------------------------------------------===*/ 2713 2714 /* string -> llmemorybuffer 2715 raises IoError msg on error */ 2716 value llvm_memorybuffer_of_file(value Path) { 2717 char *Message; 2718 LLVMMemoryBufferRef MemBuf; 2719 2720 if (LLVMCreateMemoryBufferWithContentsOfFile(String_val(Path), &MemBuf, 2721 &Message)) 2722 llvm_raise(*caml_named_value("Llvm.IoError"), Message); 2723 return to_val(MemBuf); 2724 } 2725 2726 /* unit -> llmemorybuffer 2727 raises IoError msg on error */ 2728 value llvm_memorybuffer_of_stdin(value Unit) { 2729 char *Message; 2730 LLVMMemoryBufferRef MemBuf; 2731 2732 if (LLVMCreateMemoryBufferWithSTDIN(&MemBuf, &Message)) 2733 llvm_raise(*caml_named_value("Llvm.IoError"), Message); 2734 return to_val(MemBuf); 2735 } 2736 2737 /* ?name:string -> string -> llmemorybuffer */ 2738 value llvm_memorybuffer_of_string(value Name, value String) { 2739 LLVMMemoryBufferRef MemBuf; 2740 const char *NameCStr; 2741 2742 if (Name == Val_int(0)) 2743 NameCStr = ""; 2744 else 2745 NameCStr = String_val(Field(Name, 0)); 2746 2747 MemBuf = LLVMCreateMemoryBufferWithMemoryRangeCopy( 2748 String_val(String), caml_string_length(String), NameCStr); 2749 return to_val(MemBuf); 2750 } 2751 2752 /* llmemorybuffer -> string */ 2753 value llvm_memorybuffer_as_string(value MB) { 2754 LLVMMemoryBufferRef MemBuf = MemoryBuffer_val(MB); 2755 size_t BufferSize = LLVMGetBufferSize(MemBuf); 2756 const char *BufferStart = LLVMGetBufferStart(MemBuf); 2757 return cstr_to_string(BufferStart, BufferSize); 2758 } 2759 2760 /* llmemorybuffer -> unit */ 2761 value llvm_memorybuffer_dispose(value MemBuf) { 2762 LLVMDisposeMemoryBuffer(MemoryBuffer_val(MemBuf)); 2763 return Val_unit; 2764 } 2765