1 (*===-- llvm/llvm.ml - LLVM Ocaml Interface --------------------------------===* 2 * 3 * The LLVM Compiler Infrastructure 4 * 5 * This file is distributed under the University of Illinois Open Source 6 * License. See LICENSE.TXT for details. 7 * 8 *===----------------------------------------------------------------------===*) 9 10 11 type llcontext 12 type llmodule 13 type lltype 14 type llvalue 15 type lluse 16 type llbasicblock 17 type llbuilder 18 type llmemorybuffer 19 20 module TypeKind = struct 21 type t = 22 | Void 23 | Half 24 | Float 25 | Double 26 | X86fp80 27 | Fp128 28 | Ppc_fp128 29 | Label 30 | Integer 31 | Function 32 | Struct 33 | Array 34 | Pointer 35 | Vector 36 | Metadata 37 end 38 39 module Linkage = struct 40 type t = 41 | External 42 | Available_externally 43 | Link_once 44 | Link_once_odr 45 | Weak 46 | Weak_odr 47 | Appending 48 | Internal 49 | Private 50 | Dllimport 51 | Dllexport 52 | External_weak 53 | Ghost 54 | Common 55 | Linker_private 56 end 57 58 module Visibility = struct 59 type t = 60 | Default 61 | Hidden 62 | Protected 63 end 64 65 module CallConv = struct 66 let c = 0 67 let fast = 8 68 let cold = 9 69 let x86_stdcall = 64 70 let x86_fastcall = 65 71 end 72 73 module Attribute = struct 74 type t = 75 | Zext 76 | Sext 77 | Noreturn 78 | Inreg 79 | Structret 80 | Nounwind 81 | Noalias 82 | Byval 83 | Nest 84 | Readnone 85 | Readonly 86 | Noinline 87 | Alwaysinline 88 | Optsize 89 | Ssp 90 | Sspreq 91 | Alignment of int 92 | Nocapture 93 | Noredzone 94 | Noimplicitfloat 95 | Naked 96 | Inlinehint 97 | Stackalignment of int 98 | ReturnsTwice 99 | UWTable 100 | NonLazyBind 101 end 102 103 module Icmp = struct 104 type t = 105 | Eq 106 | Ne 107 | Ugt 108 | Uge 109 | Ult 110 | Ule 111 | Sgt 112 | Sge 113 | Slt 114 | Sle 115 end 116 117 module Fcmp = struct 118 type t = 119 | False 120 | Oeq 121 | Ogt 122 | Oge 123 | Olt 124 | Ole 125 | One 126 | Ord 127 | Uno 128 | Ueq 129 | Ugt 130 | Uge 131 | Ult 132 | Ule 133 | Une 134 | True 135 end 136 137 module Opcode = struct 138 type t = 139 | Invalid (* not an instruction *) 140 (* Terminator Instructions *) 141 | Ret 142 | Br 143 | Switch 144 | IndirectBr 145 | Invoke 146 | Invalid2 147 | Unreachable 148 (* Standard Binary Operators *) 149 | Add 150 | FAdd 151 | Sub 152 | FSub 153 | Mul 154 | FMul 155 | UDiv 156 | SDiv 157 | FDiv 158 | URem 159 | SRem 160 | FRem 161 (* Logical Operators *) 162 | Shl 163 | LShr 164 | AShr 165 | And 166 | Or 167 | Xor 168 (* Memory Operators *) 169 | Alloca 170 | Load 171 | Store 172 | GetElementPtr 173 (* Cast Operators *) 174 | Trunc 175 | ZExt 176 | SExt 177 | FPToUI 178 | FPToSI 179 | UIToFP 180 | SIToFP 181 | FPTrunc 182 | FPExt 183 | PtrToInt 184 | IntToPtr 185 | BitCast 186 (* Other Operators *) 187 | ICmp 188 | FCmp 189 | PHI 190 | Call 191 | Select 192 | UserOp1 193 | UserOp2 194 | VAArg 195 | ExtractElement 196 | InsertElement 197 | ShuffleVector 198 | ExtractValue 199 | InsertValue 200 | Fence 201 | AtomicCmpXchg 202 | AtomicRMW 203 | Resume 204 | LandingPad 205 | Unwind 206 end 207 208 module ValueKind = struct 209 type t = 210 | NullValue 211 | Argument 212 | BasicBlock 213 | InlineAsm 214 | MDNode 215 | MDString 216 | BlockAddress 217 | ConstantAggregateZero 218 | ConstantArray 219 | ConstantExpr 220 | ConstantFP 221 | ConstantInt 222 | ConstantPointerNull 223 | ConstantStruct 224 | ConstantVector 225 | Function 226 | GlobalAlias 227 | GlobalVariable 228 | UndefValue 229 | Instruction of Opcode.t 230 end 231 232 exception IoError of string 233 234 external register_exns : exn -> unit = "llvm_register_core_exns" 235 let _ = register_exns (IoError "") 236 237 type ('a, 'b) llpos = 238 | At_end of 'a 239 | Before of 'b 240 241 type ('a, 'b) llrev_pos = 242 | At_start of 'a 243 | After of 'b 244 245 (*===-- Contexts ----------------------------------------------------------===*) 246 external create_context : unit -> llcontext = "llvm_create_context" 247 external dispose_context : llcontext -> unit = "llvm_dispose_context" 248 external global_context : unit -> llcontext = "llvm_global_context" 249 external mdkind_id : llcontext -> string -> int = "llvm_mdkind_id" 250 251 (*===-- Modules -----------------------------------------------------------===*) 252 external create_module : llcontext -> string -> llmodule = "llvm_create_module" 253 external dispose_module : llmodule -> unit = "llvm_dispose_module" 254 external target_triple: llmodule -> string 255 = "llvm_target_triple" 256 external set_target_triple: string -> llmodule -> unit 257 = "llvm_set_target_triple" 258 external data_layout: llmodule -> string 259 = "llvm_data_layout" 260 external set_data_layout: string -> llmodule -> unit 261 = "llvm_set_data_layout" 262 external dump_module : llmodule -> unit = "llvm_dump_module" 263 external set_module_inline_asm : llmodule -> string -> unit 264 = "llvm_set_module_inline_asm" 265 external module_context : llmodule -> llcontext = "LLVMGetModuleContext" 266 267 (*===-- Types -------------------------------------------------------------===*) 268 external classify_type : lltype -> TypeKind.t = "llvm_classify_type" 269 external type_context : lltype -> llcontext = "llvm_type_context" 270 external type_is_sized : lltype -> bool = "llvm_type_is_sized" 271 272 (*--... Operations on integer types ........................................--*) 273 external i1_type : llcontext -> lltype = "llvm_i1_type" 274 external i8_type : llcontext -> lltype = "llvm_i8_type" 275 external i16_type : llcontext -> lltype = "llvm_i16_type" 276 external i32_type : llcontext -> lltype = "llvm_i32_type" 277 external i64_type : llcontext -> lltype = "llvm_i64_type" 278 279 external integer_type : llcontext -> int -> lltype = "llvm_integer_type" 280 external integer_bitwidth : lltype -> int = "llvm_integer_bitwidth" 281 282 (*--... Operations on real types ...........................................--*) 283 external float_type : llcontext -> lltype = "llvm_float_type" 284 external double_type : llcontext -> lltype = "llvm_double_type" 285 external x86fp80_type : llcontext -> lltype = "llvm_x86fp80_type" 286 external fp128_type : llcontext -> lltype = "llvm_fp128_type" 287 external ppc_fp128_type : llcontext -> lltype = "llvm_ppc_fp128_type" 288 289 (*--... Operations on function types .......................................--*) 290 external function_type : lltype -> lltype array -> lltype = "llvm_function_type" 291 external var_arg_function_type : lltype -> lltype array -> lltype 292 = "llvm_var_arg_function_type" 293 external is_var_arg : lltype -> bool = "llvm_is_var_arg" 294 external return_type : lltype -> lltype = "LLVMGetReturnType" 295 external param_types : lltype -> lltype array = "llvm_param_types" 296 297 (*--... Operations on struct types .........................................--*) 298 external struct_type : llcontext -> lltype array -> lltype = "llvm_struct_type" 299 external packed_struct_type : llcontext -> lltype array -> lltype 300 = "llvm_packed_struct_type" 301 external struct_name : lltype -> string option = "llvm_struct_name" 302 external named_struct_type : llcontext -> string -> lltype = 303 "llvm_named_struct_type" 304 external struct_set_body : lltype -> lltype array -> bool -> unit = 305 "llvm_struct_set_body" 306 external struct_element_types : lltype -> lltype array 307 = "llvm_struct_element_types" 308 external is_packed : lltype -> bool = "llvm_is_packed" 309 external is_opaque : lltype -> bool = "llvm_is_opaque" 310 311 (*--... Operations on pointer, vector, and array types .....................--*) 312 external array_type : lltype -> int -> lltype = "llvm_array_type" 313 external pointer_type : lltype -> lltype = "llvm_pointer_type" 314 external qualified_pointer_type : lltype -> int -> lltype 315 = "llvm_qualified_pointer_type" 316 external vector_type : lltype -> int -> lltype = "llvm_vector_type" 317 318 external element_type : lltype -> lltype = "LLVMGetElementType" 319 external array_length : lltype -> int = "llvm_array_length" 320 external address_space : lltype -> int = "llvm_address_space" 321 external vector_size : lltype -> int = "llvm_vector_size" 322 323 (*--... Operations on other types ..........................................--*) 324 external void_type : llcontext -> lltype = "llvm_void_type" 325 external label_type : llcontext -> lltype = "llvm_label_type" 326 external type_by_name : llmodule -> string -> lltype option = "llvm_type_by_name" 327 328 external classify_value : llvalue -> ValueKind.t = "llvm_classify_value" 329 (*===-- Values ------------------------------------------------------------===*) 330 external type_of : llvalue -> lltype = "llvm_type_of" 331 external value_name : llvalue -> string = "llvm_value_name" 332 external set_value_name : string -> llvalue -> unit = "llvm_set_value_name" 333 external dump_value : llvalue -> unit = "llvm_dump_value" 334 external replace_all_uses_with : llvalue -> llvalue -> unit 335 = "LLVMReplaceAllUsesWith" 336 337 (*--... Operations on uses .................................................--*) 338 external use_begin : llvalue -> lluse option = "llvm_use_begin" 339 external use_succ : lluse -> lluse option = "llvm_use_succ" 340 external user : lluse -> llvalue = "llvm_user" 341 external used_value : lluse -> llvalue = "llvm_used_value" 342 343 let iter_uses f v = 344 let rec aux = function 345 | None -> () 346 | Some u -> 347 f u; 348 aux (use_succ u) 349 in 350 aux (use_begin v) 351 352 let fold_left_uses f init v = 353 let rec aux init u = 354 match u with 355 | None -> init 356 | Some u -> aux (f init u) (use_succ u) 357 in 358 aux init (use_begin v) 359 360 let fold_right_uses f v init = 361 let rec aux u init = 362 match u with 363 | None -> init 364 | Some u -> f u (aux (use_succ u) init) 365 in 366 aux (use_begin v) init 367 368 369 (*--... Operations on users ................................................--*) 370 external operand : llvalue -> int -> llvalue = "llvm_operand" 371 external set_operand : llvalue -> int -> llvalue -> unit = "llvm_set_operand" 372 external num_operands : llvalue -> int = "llvm_num_operands" 373 374 (*--... Operations on constants of (mostly) any type .......................--*) 375 external is_constant : llvalue -> bool = "llvm_is_constant" 376 external const_null : lltype -> llvalue = "LLVMConstNull" 377 external const_all_ones : (*int|vec*)lltype -> llvalue = "LLVMConstAllOnes" 378 external const_pointer_null : lltype -> llvalue = "LLVMConstPointerNull" 379 external undef : lltype -> llvalue = "LLVMGetUndef" 380 external is_null : llvalue -> bool = "llvm_is_null" 381 external is_undef : llvalue -> bool = "llvm_is_undef" 382 external constexpr_opcode : llvalue -> Opcode.t = "llvm_constexpr_get_opcode" 383 384 (*--... Operations on instructions .........................................--*) 385 external has_metadata : llvalue -> bool = "llvm_has_metadata" 386 external metadata : llvalue -> int -> llvalue option = "llvm_metadata" 387 external set_metadata : llvalue -> int -> llvalue -> unit = "llvm_set_metadata" 388 external clear_metadata : llvalue -> int -> unit = "llvm_clear_metadata" 389 390 (*--... Operations on metadata .......,.....................................--*) 391 external mdstring : llcontext -> string -> llvalue = "llvm_mdstring" 392 external mdnode : llcontext -> llvalue array -> llvalue = "llvm_mdnode" 393 external get_mdstring : llvalue -> string option = "llvm_get_mdstring" 394 external get_named_metadata : llmodule -> string -> llvalue array = "llvm_get_namedmd" 395 396 (*--... Operations on scalar constants .....................................--*) 397 external const_int : lltype -> int -> llvalue = "llvm_const_int" 398 external const_of_int64 : lltype -> Int64.t -> bool -> llvalue 399 = "llvm_const_of_int64" 400 external int64_of_const : llvalue -> Int64.t option 401 = "llvm_int64_of_const" 402 external const_int_of_string : lltype -> string -> int -> llvalue 403 = "llvm_const_int_of_string" 404 external const_float : lltype -> float -> llvalue = "llvm_const_float" 405 external const_float_of_string : lltype -> string -> llvalue 406 = "llvm_const_float_of_string" 407 408 (*--... Operations on composite constants ..................................--*) 409 external const_string : llcontext -> string -> llvalue = "llvm_const_string" 410 external const_stringz : llcontext -> string -> llvalue = "llvm_const_stringz" 411 external const_array : lltype -> llvalue array -> llvalue = "llvm_const_array" 412 external const_struct : llcontext -> llvalue array -> llvalue 413 = "llvm_const_struct" 414 external const_named_struct : lltype -> llvalue array -> llvalue 415 = "llvm_const_named_struct" 416 external const_packed_struct : llcontext -> llvalue array -> llvalue 417 = "llvm_const_packed_struct" 418 external const_vector : llvalue array -> llvalue = "llvm_const_vector" 419 420 (*--... Constant expressions ...............................................--*) 421 external align_of : lltype -> llvalue = "LLVMAlignOf" 422 external size_of : lltype -> llvalue = "LLVMSizeOf" 423 external const_neg : llvalue -> llvalue = "LLVMConstNeg" 424 external const_nsw_neg : llvalue -> llvalue = "LLVMConstNSWNeg" 425 external const_nuw_neg : llvalue -> llvalue = "LLVMConstNUWNeg" 426 external const_fneg : llvalue -> llvalue = "LLVMConstFNeg" 427 external const_not : llvalue -> llvalue = "LLVMConstNot" 428 external const_add : llvalue -> llvalue -> llvalue = "LLVMConstAdd" 429 external const_nsw_add : llvalue -> llvalue -> llvalue = "LLVMConstNSWAdd" 430 external const_nuw_add : llvalue -> llvalue -> llvalue = "LLVMConstNUWAdd" 431 external const_fadd : llvalue -> llvalue -> llvalue = "LLVMConstFAdd" 432 external const_sub : llvalue -> llvalue -> llvalue = "LLVMConstSub" 433 external const_nsw_sub : llvalue -> llvalue -> llvalue = "LLVMConstNSWSub" 434 external const_nuw_sub : llvalue -> llvalue -> llvalue = "LLVMConstNUWSub" 435 external const_fsub : llvalue -> llvalue -> llvalue = "LLVMConstFSub" 436 external const_mul : llvalue -> llvalue -> llvalue = "LLVMConstMul" 437 external const_nsw_mul : llvalue -> llvalue -> llvalue = "LLVMConstNSWMul" 438 external const_nuw_mul : llvalue -> llvalue -> llvalue = "LLVMConstNUWMul" 439 external const_fmul : llvalue -> llvalue -> llvalue = "LLVMConstFMul" 440 external const_udiv : llvalue -> llvalue -> llvalue = "LLVMConstUDiv" 441 external const_sdiv : llvalue -> llvalue -> llvalue = "LLVMConstSDiv" 442 external const_exact_sdiv : llvalue -> llvalue -> llvalue = "LLVMConstExactSDiv" 443 external const_fdiv : llvalue -> llvalue -> llvalue = "LLVMConstFDiv" 444 external const_urem : llvalue -> llvalue -> llvalue = "LLVMConstURem" 445 external const_srem : llvalue -> llvalue -> llvalue = "LLVMConstSRem" 446 external const_frem : llvalue -> llvalue -> llvalue = "LLVMConstFRem" 447 external const_and : llvalue -> llvalue -> llvalue = "LLVMConstAnd" 448 external const_or : llvalue -> llvalue -> llvalue = "LLVMConstOr" 449 external const_xor : llvalue -> llvalue -> llvalue = "LLVMConstXor" 450 external const_icmp : Icmp.t -> llvalue -> llvalue -> llvalue 451 = "llvm_const_icmp" 452 external const_fcmp : Fcmp.t -> llvalue -> llvalue -> llvalue 453 = "llvm_const_fcmp" 454 external const_shl : llvalue -> llvalue -> llvalue = "LLVMConstShl" 455 external const_lshr : llvalue -> llvalue -> llvalue = "LLVMConstLShr" 456 external const_ashr : llvalue -> llvalue -> llvalue = "LLVMConstAShr" 457 external const_gep : llvalue -> llvalue array -> llvalue = "llvm_const_gep" 458 external const_in_bounds_gep : llvalue -> llvalue array -> llvalue 459 = "llvm_const_in_bounds_gep" 460 external const_trunc : llvalue -> lltype -> llvalue = "LLVMConstTrunc" 461 external const_sext : llvalue -> lltype -> llvalue = "LLVMConstSExt" 462 external const_zext : llvalue -> lltype -> llvalue = "LLVMConstZExt" 463 external const_fptrunc : llvalue -> lltype -> llvalue = "LLVMConstFPTrunc" 464 external const_fpext : llvalue -> lltype -> llvalue = "LLVMConstFPExt" 465 external const_uitofp : llvalue -> lltype -> llvalue = "LLVMConstUIToFP" 466 external const_sitofp : llvalue -> lltype -> llvalue = "LLVMConstSIToFP" 467 external const_fptoui : llvalue -> lltype -> llvalue = "LLVMConstFPToUI" 468 external const_fptosi : llvalue -> lltype -> llvalue = "LLVMConstFPToSI" 469 external const_ptrtoint : llvalue -> lltype -> llvalue = "LLVMConstPtrToInt" 470 external const_inttoptr : llvalue -> lltype -> llvalue = "LLVMConstIntToPtr" 471 external const_bitcast : llvalue -> lltype -> llvalue = "LLVMConstBitCast" 472 external const_zext_or_bitcast : llvalue -> lltype -> llvalue 473 = "LLVMConstZExtOrBitCast" 474 external const_sext_or_bitcast : llvalue -> lltype -> llvalue 475 = "LLVMConstSExtOrBitCast" 476 external const_trunc_or_bitcast : llvalue -> lltype -> llvalue 477 = "LLVMConstTruncOrBitCast" 478 external const_pointercast : llvalue -> lltype -> llvalue 479 = "LLVMConstPointerCast" 480 external const_intcast : llvalue -> lltype -> llvalue = "LLVMConstIntCast" 481 external const_fpcast : llvalue -> lltype -> llvalue = "LLVMConstFPCast" 482 external const_select : llvalue -> llvalue -> llvalue -> llvalue 483 = "LLVMConstSelect" 484 external const_extractelement : llvalue -> llvalue -> llvalue 485 = "LLVMConstExtractElement" 486 external const_insertelement : llvalue -> llvalue -> llvalue -> llvalue 487 = "LLVMConstInsertElement" 488 external const_shufflevector : llvalue -> llvalue -> llvalue -> llvalue 489 = "LLVMConstShuffleVector" 490 external const_extractvalue : llvalue -> int array -> llvalue 491 = "llvm_const_extractvalue" 492 external const_insertvalue : llvalue -> llvalue -> int array -> llvalue 493 = "llvm_const_insertvalue" 494 external const_inline_asm : lltype -> string -> string -> bool -> bool -> 495 llvalue 496 = "llvm_const_inline_asm" 497 external block_address : llvalue -> llbasicblock -> llvalue = "LLVMBlockAddress" 498 499 (*--... Operations on global variables, functions, and aliases (globals) ...--*) 500 external global_parent : llvalue -> llmodule = "LLVMGetGlobalParent" 501 external is_declaration : llvalue -> bool = "llvm_is_declaration" 502 external linkage : llvalue -> Linkage.t = "llvm_linkage" 503 external set_linkage : Linkage.t -> llvalue -> unit = "llvm_set_linkage" 504 external section : llvalue -> string = "llvm_section" 505 external set_section : string -> llvalue -> unit = "llvm_set_section" 506 external visibility : llvalue -> Visibility.t = "llvm_visibility" 507 external set_visibility : Visibility.t -> llvalue -> unit = "llvm_set_visibility" 508 external alignment : llvalue -> int = "llvm_alignment" 509 external set_alignment : int -> llvalue -> unit = "llvm_set_alignment" 510 external is_global_constant : llvalue -> bool = "llvm_is_global_constant" 511 external set_global_constant : bool -> llvalue -> unit 512 = "llvm_set_global_constant" 513 514 (*--... Operations on global variables .....................................--*) 515 external declare_global : lltype -> string -> llmodule -> llvalue 516 = "llvm_declare_global" 517 external declare_qualified_global : lltype -> string -> int -> llmodule -> 518 llvalue 519 = "llvm_declare_qualified_global" 520 external define_global : string -> llvalue -> llmodule -> llvalue 521 = "llvm_define_global" 522 external define_qualified_global : string -> llvalue -> int -> llmodule -> 523 llvalue 524 = "llvm_define_qualified_global" 525 external lookup_global : string -> llmodule -> llvalue option 526 = "llvm_lookup_global" 527 external delete_global : llvalue -> unit = "llvm_delete_global" 528 external global_initializer : llvalue -> llvalue = "LLVMGetInitializer" 529 external set_initializer : llvalue -> llvalue -> unit = "llvm_set_initializer" 530 external remove_initializer : llvalue -> unit = "llvm_remove_initializer" 531 external is_thread_local : llvalue -> bool = "llvm_is_thread_local" 532 external set_thread_local : bool -> llvalue -> unit = "llvm_set_thread_local" 533 external global_begin : llmodule -> (llmodule, llvalue) llpos 534 = "llvm_global_begin" 535 external global_succ : llvalue -> (llmodule, llvalue) llpos 536 = "llvm_global_succ" 537 external global_end : llmodule -> (llmodule, llvalue) llrev_pos 538 = "llvm_global_end" 539 external global_pred : llvalue -> (llmodule, llvalue) llrev_pos 540 = "llvm_global_pred" 541 542 let rec iter_global_range f i e = 543 if i = e then () else 544 match i with 545 | At_end _ -> raise (Invalid_argument "Invalid global variable range.") 546 | Before bb -> 547 f bb; 548 iter_global_range f (global_succ bb) e 549 550 let iter_globals f m = 551 iter_global_range f (global_begin m) (At_end m) 552 553 let rec fold_left_global_range f init i e = 554 if i = e then init else 555 match i with 556 | At_end _ -> raise (Invalid_argument "Invalid global variable range.") 557 | Before bb -> fold_left_global_range f (f init bb) (global_succ bb) e 558 559 let fold_left_globals f init m = 560 fold_left_global_range f init (global_begin m) (At_end m) 561 562 let rec rev_iter_global_range f i e = 563 if i = e then () else 564 match i with 565 | At_start _ -> raise (Invalid_argument "Invalid global variable range.") 566 | After bb -> 567 f bb; 568 rev_iter_global_range f (global_pred bb) e 569 570 let rev_iter_globals f m = 571 rev_iter_global_range f (global_end m) (At_start m) 572 573 let rec fold_right_global_range f i e init = 574 if i = e then init else 575 match i with 576 | At_start _ -> raise (Invalid_argument "Invalid global variable range.") 577 | After bb -> fold_right_global_range f (global_pred bb) e (f bb init) 578 579 let fold_right_globals f m init = 580 fold_right_global_range f (global_end m) (At_start m) init 581 582 (*--... Operations on aliases ..............................................--*) 583 external add_alias : llmodule -> lltype -> llvalue -> string -> llvalue 584 = "llvm_add_alias" 585 586 (*--... Operations on functions ............................................--*) 587 external declare_function : string -> lltype -> llmodule -> llvalue 588 = "llvm_declare_function" 589 external define_function : string -> lltype -> llmodule -> llvalue 590 = "llvm_define_function" 591 external lookup_function : string -> llmodule -> llvalue option 592 = "llvm_lookup_function" 593 external delete_function : llvalue -> unit = "llvm_delete_function" 594 external is_intrinsic : llvalue -> bool = "llvm_is_intrinsic" 595 external function_call_conv : llvalue -> int = "llvm_function_call_conv" 596 external set_function_call_conv : int -> llvalue -> unit 597 = "llvm_set_function_call_conv" 598 external gc : llvalue -> string option = "llvm_gc" 599 external set_gc : string option -> llvalue -> unit = "llvm_set_gc" 600 external function_begin : llmodule -> (llmodule, llvalue) llpos 601 = "llvm_function_begin" 602 external function_succ : llvalue -> (llmodule, llvalue) llpos 603 = "llvm_function_succ" 604 external function_end : llmodule -> (llmodule, llvalue) llrev_pos 605 = "llvm_function_end" 606 external function_pred : llvalue -> (llmodule, llvalue) llrev_pos 607 = "llvm_function_pred" 608 609 let rec iter_function_range f i e = 610 if i = e then () else 611 match i with 612 | At_end _ -> raise (Invalid_argument "Invalid function range.") 613 | Before fn -> 614 f fn; 615 iter_function_range f (function_succ fn) e 616 617 let iter_functions f m = 618 iter_function_range f (function_begin m) (At_end m) 619 620 let rec fold_left_function_range f init i e = 621 if i = e then init else 622 match i with 623 | At_end _ -> raise (Invalid_argument "Invalid function range.") 624 | Before fn -> fold_left_function_range f (f init fn) (function_succ fn) e 625 626 let fold_left_functions f init m = 627 fold_left_function_range f init (function_begin m) (At_end m) 628 629 let rec rev_iter_function_range f i e = 630 if i = e then () else 631 match i with 632 | At_start _ -> raise (Invalid_argument "Invalid function range.") 633 | After fn -> 634 f fn; 635 rev_iter_function_range f (function_pred fn) e 636 637 let rev_iter_functions f m = 638 rev_iter_function_range f (function_end m) (At_start m) 639 640 let rec fold_right_function_range f i e init = 641 if i = e then init else 642 match i with 643 | At_start _ -> raise (Invalid_argument "Invalid function range.") 644 | After fn -> fold_right_function_range f (function_pred fn) e (f fn init) 645 646 let fold_right_functions f m init = 647 fold_right_function_range f (function_end m) (At_start m) init 648 649 external llvm_add_function_attr : llvalue -> int32 -> unit 650 = "llvm_add_function_attr" 651 external llvm_remove_function_attr : llvalue -> int32 -> unit 652 = "llvm_remove_function_attr" 653 external llvm_function_attr : llvalue -> int32 = "llvm_function_attr" 654 655 let pack_attr (attr:Attribute.t) : int32 = 656 match attr with 657 Attribute.Zext -> Int32.shift_left 1l 0 658 | Attribute.Sext -> Int32.shift_left 1l 1 659 | Attribute.Noreturn -> Int32.shift_left 1l 2 660 | Attribute.Inreg -> Int32.shift_left 1l 3 661 | Attribute.Structret -> Int32.shift_left 1l 4 662 | Attribute.Nounwind -> Int32.shift_left 1l 5 663 | Attribute.Noalias -> Int32.shift_left 1l 6 664 | Attribute.Byval -> Int32.shift_left 1l 7 665 | Attribute.Nest -> Int32.shift_left 1l 8 666 | Attribute.Readnone -> Int32.shift_left 1l 9 667 | Attribute.Readonly -> Int32.shift_left 1l 10 668 | Attribute.Noinline -> Int32.shift_left 1l 11 669 | Attribute.Alwaysinline -> Int32.shift_left 1l 12 670 | Attribute.Optsize -> Int32.shift_left 1l 13 671 | Attribute.Ssp -> Int32.shift_left 1l 14 672 | Attribute.Sspreq -> Int32.shift_left 1l 15 673 | Attribute.Alignment n -> Int32.shift_left (Int32.of_int n) 16 674 | Attribute.Nocapture -> Int32.shift_left 1l 21 675 | Attribute.Noredzone -> Int32.shift_left 1l 22 676 | Attribute.Noimplicitfloat -> Int32.shift_left 1l 23 677 | Attribute.Naked -> Int32.shift_left 1l 24 678 | Attribute.Inlinehint -> Int32.shift_left 1l 25 679 | Attribute.Stackalignment n -> Int32.shift_left (Int32.of_int n) 26 680 | Attribute.ReturnsTwice -> Int32.shift_left 1l 29 681 | Attribute.UWTable -> Int32.shift_left 1l 30 682 | Attribute.NonLazyBind -> Int32.shift_left 1l 31 683 684 let unpack_attr (a : int32) : Attribute.t list = 685 let l = ref [] in 686 let check attr = 687 Int32.logand (pack_attr attr) a in 688 let checkattr attr = 689 if (check attr) <> 0l then begin 690 l := attr :: !l 691 end 692 in 693 checkattr Attribute.Zext; 694 checkattr Attribute.Sext; 695 checkattr Attribute.Noreturn; 696 checkattr Attribute.Inreg; 697 checkattr Attribute.Structret; 698 checkattr Attribute.Nounwind; 699 checkattr Attribute.Noalias; 700 checkattr Attribute.Byval; 701 checkattr Attribute.Nest; 702 checkattr Attribute.Readnone; 703 checkattr Attribute.Readonly; 704 checkattr Attribute.Noinline; 705 checkattr Attribute.Alwaysinline; 706 checkattr Attribute.Optsize; 707 checkattr Attribute.Ssp; 708 checkattr Attribute.Sspreq; 709 let align = Int32.logand (Int32.shift_right_logical a 16) 31l in 710 if align <> 0l then 711 l := Attribute.Alignment (Int32.to_int align) :: !l; 712 checkattr Attribute.Nocapture; 713 checkattr Attribute.Noredzone; 714 checkattr Attribute.Noimplicitfloat; 715 checkattr Attribute.Naked; 716 checkattr Attribute.Inlinehint; 717 let stackalign = Int32.logand (Int32.shift_right_logical a 26) 7l in 718 if stackalign <> 0l then 719 l := Attribute.Stackalignment (Int32.to_int stackalign) :: !l; 720 checkattr Attribute.ReturnsTwice; 721 checkattr Attribute.UWTable; 722 checkattr Attribute.NonLazyBind; 723 !l;; 724 725 let add_function_attr llval attr = 726 llvm_add_function_attr llval (pack_attr attr) 727 728 let remove_function_attr llval attr = 729 llvm_remove_function_attr llval (pack_attr attr) 730 731 let function_attr f = unpack_attr (llvm_function_attr f) 732 733 (*--... Operations on params ...............................................--*) 734 external params : llvalue -> llvalue array = "llvm_params" 735 external param : llvalue -> int -> llvalue = "llvm_param" 736 external llvm_param_attr : llvalue -> int32 = "llvm_param_attr" 737 let param_attr p = unpack_attr (llvm_param_attr p) 738 external param_parent : llvalue -> llvalue = "LLVMGetParamParent" 739 external param_begin : llvalue -> (llvalue, llvalue) llpos = "llvm_param_begin" 740 external param_succ : llvalue -> (llvalue, llvalue) llpos = "llvm_param_succ" 741 external param_end : llvalue -> (llvalue, llvalue) llrev_pos = "llvm_param_end" 742 external param_pred : llvalue -> (llvalue, llvalue) llrev_pos ="llvm_param_pred" 743 744 let rec iter_param_range f i e = 745 if i = e then () else 746 match i with 747 | At_end _ -> raise (Invalid_argument "Invalid parameter range.") 748 | Before p -> 749 f p; 750 iter_param_range f (param_succ p) e 751 752 let iter_params f fn = 753 iter_param_range f (param_begin fn) (At_end fn) 754 755 let rec fold_left_param_range f init i e = 756 if i = e then init else 757 match i with 758 | At_end _ -> raise (Invalid_argument "Invalid parameter range.") 759 | Before p -> fold_left_param_range f (f init p) (param_succ p) e 760 761 let fold_left_params f init fn = 762 fold_left_param_range f init (param_begin fn) (At_end fn) 763 764 let rec rev_iter_param_range f i e = 765 if i = e then () else 766 match i with 767 | At_start _ -> raise (Invalid_argument "Invalid parameter range.") 768 | After p -> 769 f p; 770 rev_iter_param_range f (param_pred p) e 771 772 let rev_iter_params f fn = 773 rev_iter_param_range f (param_end fn) (At_start fn) 774 775 let rec fold_right_param_range f init i e = 776 if i = e then init else 777 match i with 778 | At_start _ -> raise (Invalid_argument "Invalid parameter range.") 779 | After p -> fold_right_param_range f (f p init) (param_pred p) e 780 781 let fold_right_params f fn init = 782 fold_right_param_range f init (param_end fn) (At_start fn) 783 784 external llvm_add_param_attr : llvalue -> int32 -> unit 785 = "llvm_add_param_attr" 786 external llvm_remove_param_attr : llvalue -> int32 -> unit 787 = "llvm_remove_param_attr" 788 789 let add_param_attr llval attr = 790 llvm_add_param_attr llval (pack_attr attr) 791 792 let remove_param_attr llval attr = 793 llvm_remove_param_attr llval (pack_attr attr) 794 795 external set_param_alignment : llvalue -> int -> unit 796 = "llvm_set_param_alignment" 797 798 (*--... Operations on basic blocks .........................................--*) 799 external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue" 800 external value_is_block : llvalue -> bool = "llvm_value_is_block" 801 external block_of_value : llvalue -> llbasicblock = "LLVMValueAsBasicBlock" 802 external block_parent : llbasicblock -> llvalue = "LLVMGetBasicBlockParent" 803 external basic_blocks : llvalue -> llbasicblock array = "llvm_basic_blocks" 804 external entry_block : llvalue -> llbasicblock = "LLVMGetEntryBasicBlock" 805 external delete_block : llbasicblock -> unit = "llvm_delete_block" 806 external append_block : llcontext -> string -> llvalue -> llbasicblock 807 = "llvm_append_block" 808 external insert_block : llcontext -> string -> llbasicblock -> llbasicblock 809 = "llvm_insert_block" 810 external block_begin : llvalue -> (llvalue, llbasicblock) llpos 811 = "llvm_block_begin" 812 external block_succ : llbasicblock -> (llvalue, llbasicblock) llpos 813 = "llvm_block_succ" 814 external block_end : llvalue -> (llvalue, llbasicblock) llrev_pos 815 = "llvm_block_end" 816 external block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos 817 = "llvm_block_pred" 818 external block_terminator : llbasicblock -> llvalue option = 819 "llvm_block_terminator" 820 821 let rec iter_block_range f i e = 822 if i = e then () else 823 match i with 824 | At_end _ -> raise (Invalid_argument "Invalid block range.") 825 | Before bb -> 826 f bb; 827 iter_block_range f (block_succ bb) e 828 829 let iter_blocks f fn = 830 iter_block_range f (block_begin fn) (At_end fn) 831 832 let rec fold_left_block_range f init i e = 833 if i = e then init else 834 match i with 835 | At_end _ -> raise (Invalid_argument "Invalid block range.") 836 | Before bb -> fold_left_block_range f (f init bb) (block_succ bb) e 837 838 let fold_left_blocks f init fn = 839 fold_left_block_range f init (block_begin fn) (At_end fn) 840 841 let rec rev_iter_block_range f i e = 842 if i = e then () else 843 match i with 844 | At_start _ -> raise (Invalid_argument "Invalid block range.") 845 | After bb -> 846 f bb; 847 rev_iter_block_range f (block_pred bb) e 848 849 let rev_iter_blocks f fn = 850 rev_iter_block_range f (block_end fn) (At_start fn) 851 852 let rec fold_right_block_range f init i e = 853 if i = e then init else 854 match i with 855 | At_start _ -> raise (Invalid_argument "Invalid block range.") 856 | After bb -> fold_right_block_range f (f bb init) (block_pred bb) e 857 858 let fold_right_blocks f fn init = 859 fold_right_block_range f init (block_end fn) (At_start fn) 860 861 (*--... Operations on instructions .........................................--*) 862 external instr_parent : llvalue -> llbasicblock = "LLVMGetInstructionParent" 863 external instr_begin : llbasicblock -> (llbasicblock, llvalue) llpos 864 = "llvm_instr_begin" 865 external instr_succ : llvalue -> (llbasicblock, llvalue) llpos 866 = "llvm_instr_succ" 867 external instr_end : llbasicblock -> (llbasicblock, llvalue) llrev_pos 868 = "llvm_instr_end" 869 external instr_pred : llvalue -> (llbasicblock, llvalue) llrev_pos 870 = "llvm_instr_pred" 871 872 external instr_opcode : llvalue -> Opcode.t = "llvm_instr_get_opcode" 873 external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate" 874 875 external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate" 876 877 let rec iter_instrs_range f i e = 878 if i = e then () else 879 match i with 880 | At_end _ -> raise (Invalid_argument "Invalid instruction range.") 881 | Before i -> 882 f i; 883 iter_instrs_range f (instr_succ i) e 884 885 let iter_instrs f bb = 886 iter_instrs_range f (instr_begin bb) (At_end bb) 887 888 let rec fold_left_instrs_range f init i e = 889 if i = e then init else 890 match i with 891 | At_end _ -> raise (Invalid_argument "Invalid instruction range.") 892 | Before i -> fold_left_instrs_range f (f init i) (instr_succ i) e 893 894 let fold_left_instrs f init bb = 895 fold_left_instrs_range f init (instr_begin bb) (At_end bb) 896 897 let rec rev_iter_instrs_range f i e = 898 if i = e then () else 899 match i with 900 | At_start _ -> raise (Invalid_argument "Invalid instruction range.") 901 | After i -> 902 f i; 903 rev_iter_instrs_range f (instr_pred i) e 904 905 let rev_iter_instrs f bb = 906 rev_iter_instrs_range f (instr_end bb) (At_start bb) 907 908 let rec fold_right_instr_range f i e init = 909 if i = e then init else 910 match i with 911 | At_start _ -> raise (Invalid_argument "Invalid instruction range.") 912 | After i -> fold_right_instr_range f (instr_pred i) e (f i init) 913 914 let fold_right_instrs f bb init = 915 fold_right_instr_range f (instr_end bb) (At_start bb) init 916 917 918 (*--... Operations on call sites ...........................................--*) 919 external instruction_call_conv: llvalue -> int 920 = "llvm_instruction_call_conv" 921 external set_instruction_call_conv: int -> llvalue -> unit 922 = "llvm_set_instruction_call_conv" 923 924 external llvm_add_instruction_param_attr : llvalue -> int -> int32 -> unit 925 = "llvm_add_instruction_param_attr" 926 external llvm_remove_instruction_param_attr : llvalue -> int -> int32 -> unit 927 = "llvm_remove_instruction_param_attr" 928 929 let add_instruction_param_attr llval i attr = 930 llvm_add_instruction_param_attr llval i (pack_attr attr) 931 932 let remove_instruction_param_attr llval i attr = 933 llvm_remove_instruction_param_attr llval i (pack_attr attr) 934 935 (*--... Operations on call instructions (only) .............................--*) 936 external is_tail_call : llvalue -> bool = "llvm_is_tail_call" 937 external set_tail_call : bool -> llvalue -> unit = "llvm_set_tail_call" 938 939 (*--... Operations on phi nodes ............................................--*) 940 external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit 941 = "llvm_add_incoming" 942 external incoming : llvalue -> (llvalue * llbasicblock) list = "llvm_incoming" 943 944 external delete_instruction : llvalue -> unit = "llvm_delete_instruction" 945 946 (*===-- Instruction builders ----------------------------------------------===*) 947 external builder : llcontext -> llbuilder = "llvm_builder" 948 external position_builder : (llbasicblock, llvalue) llpos -> llbuilder -> unit 949 = "llvm_position_builder" 950 external insertion_block : llbuilder -> llbasicblock = "llvm_insertion_block" 951 external insert_into_builder : llvalue -> string -> llbuilder -> unit 952 = "llvm_insert_into_builder" 953 954 let builder_at context ip = 955 let b = builder context in 956 position_builder ip b; 957 b 958 959 let builder_before context i = builder_at context (Before i) 960 let builder_at_end context bb = builder_at context (At_end bb) 961 962 let position_before i = position_builder (Before i) 963 let position_at_end bb = position_builder (At_end bb) 964 965 966 (*--... Metadata ...........................................................--*) 967 external set_current_debug_location : llbuilder -> llvalue -> unit 968 = "llvm_set_current_debug_location" 969 external clear_current_debug_location : llbuilder -> unit 970 = "llvm_clear_current_debug_location" 971 external current_debug_location : llbuilder -> llvalue option 972 = "llvm_current_debug_location" 973 external set_inst_debug_location : llbuilder -> llvalue -> unit 974 = "llvm_set_inst_debug_location" 975 976 977 (*--... Terminators ........................................................--*) 978 external build_ret_void : llbuilder -> llvalue = "llvm_build_ret_void" 979 external build_ret : llvalue -> llbuilder -> llvalue = "llvm_build_ret" 980 external build_aggregate_ret : llvalue array -> llbuilder -> llvalue 981 = "llvm_build_aggregate_ret" 982 external build_br : llbasicblock -> llbuilder -> llvalue = "llvm_build_br" 983 external build_cond_br : llvalue -> llbasicblock -> llbasicblock -> llbuilder -> 984 llvalue = "llvm_build_cond_br" 985 external build_switch : llvalue -> llbasicblock -> int -> llbuilder -> llvalue 986 = "llvm_build_switch" 987 external build_malloc : lltype -> string -> llbuilder -> llvalue = 988 "llvm_build_malloc" 989 external build_array_malloc : lltype -> llvalue -> string -> llbuilder -> 990 llvalue = "llvm_build_array_malloc" 991 external build_free : llvalue -> llbuilder -> llvalue = "llvm_build_free" 992 external add_case : llvalue -> llvalue -> llbasicblock -> unit 993 = "llvm_add_case" 994 external switch_default_dest : llvalue -> llbasicblock = 995 "LLVMGetSwitchDefaultDest" 996 external build_indirect_br : llvalue -> int -> llbuilder -> llvalue 997 = "llvm_build_indirect_br" 998 external add_destination : llvalue -> llbasicblock -> unit 999 = "llvm_add_destination" 1000 external build_invoke : llvalue -> llvalue array -> llbasicblock -> 1001 llbasicblock -> string -> llbuilder -> llvalue 1002 = "llvm_build_invoke_bc" "llvm_build_invoke_nat" 1003 external build_landingpad : lltype -> llvalue -> int -> string -> llbuilder -> 1004 llvalue = "llvm_build_landingpad" 1005 external set_cleanup : llvalue -> bool -> unit = "llvm_set_cleanup" 1006 external add_clause : llvalue -> llvalue -> unit = "llvm_add_clause" 1007 external build_resume : llvalue -> llbuilder -> llvalue = "llvm_build_resume" 1008 external build_unreachable : llbuilder -> llvalue = "llvm_build_unreachable" 1009 1010 (*--... Arithmetic .........................................................--*) 1011 external build_add : llvalue -> llvalue -> string -> llbuilder -> llvalue 1012 = "llvm_build_add" 1013 external build_nsw_add : llvalue -> llvalue -> string -> llbuilder -> llvalue 1014 = "llvm_build_nsw_add" 1015 external build_nuw_add : llvalue -> llvalue -> string -> llbuilder -> llvalue 1016 = "llvm_build_nuw_add" 1017 external build_fadd : llvalue -> llvalue -> string -> llbuilder -> llvalue 1018 = "llvm_build_fadd" 1019 external build_sub : llvalue -> llvalue -> string -> llbuilder -> llvalue 1020 = "llvm_build_sub" 1021 external build_nsw_sub : llvalue -> llvalue -> string -> llbuilder -> llvalue 1022 = "llvm_build_nsw_sub" 1023 external build_nuw_sub : llvalue -> llvalue -> string -> llbuilder -> llvalue 1024 = "llvm_build_nuw_sub" 1025 external build_fsub : llvalue -> llvalue -> string -> llbuilder -> llvalue 1026 = "llvm_build_fsub" 1027 external build_mul : llvalue -> llvalue -> string -> llbuilder -> llvalue 1028 = "llvm_build_mul" 1029 external build_nsw_mul : llvalue -> llvalue -> string -> llbuilder -> llvalue 1030 = "llvm_build_nsw_mul" 1031 external build_nuw_mul : llvalue -> llvalue -> string -> llbuilder -> llvalue 1032 = "llvm_build_nuw_mul" 1033 external build_fmul : llvalue -> llvalue -> string -> llbuilder -> llvalue 1034 = "llvm_build_fmul" 1035 external build_udiv : llvalue -> llvalue -> string -> llbuilder -> llvalue 1036 = "llvm_build_udiv" 1037 external build_sdiv : llvalue -> llvalue -> string -> llbuilder -> llvalue 1038 = "llvm_build_sdiv" 1039 external build_exact_sdiv : llvalue -> llvalue -> string -> llbuilder -> llvalue 1040 = "llvm_build_exact_sdiv" 1041 external build_fdiv : llvalue -> llvalue -> string -> llbuilder -> llvalue 1042 = "llvm_build_fdiv" 1043 external build_urem : llvalue -> llvalue -> string -> llbuilder -> llvalue 1044 = "llvm_build_urem" 1045 external build_srem : llvalue -> llvalue -> string -> llbuilder -> llvalue 1046 = "llvm_build_srem" 1047 external build_frem : llvalue -> llvalue -> string -> llbuilder -> llvalue 1048 = "llvm_build_frem" 1049 external build_shl : llvalue -> llvalue -> string -> llbuilder -> llvalue 1050 = "llvm_build_shl" 1051 external build_lshr : llvalue -> llvalue -> string -> llbuilder -> llvalue 1052 = "llvm_build_lshr" 1053 external build_ashr : llvalue -> llvalue -> string -> llbuilder -> llvalue 1054 = "llvm_build_ashr" 1055 external build_and : llvalue -> llvalue -> string -> llbuilder -> llvalue 1056 = "llvm_build_and" 1057 external build_or : llvalue -> llvalue -> string -> llbuilder -> llvalue 1058 = "llvm_build_or" 1059 external build_xor : llvalue -> llvalue -> string -> llbuilder -> llvalue 1060 = "llvm_build_xor" 1061 external build_neg : llvalue -> string -> llbuilder -> llvalue 1062 = "llvm_build_neg" 1063 external build_nsw_neg : llvalue -> string -> llbuilder -> llvalue 1064 = "llvm_build_nsw_neg" 1065 external build_nuw_neg : llvalue -> string -> llbuilder -> llvalue 1066 = "llvm_build_nuw_neg" 1067 external build_fneg : llvalue -> string -> llbuilder -> llvalue 1068 = "llvm_build_fneg" 1069 external build_not : llvalue -> string -> llbuilder -> llvalue 1070 = "llvm_build_not" 1071 1072 (*--... Memory .............................................................--*) 1073 external build_alloca : lltype -> string -> llbuilder -> llvalue 1074 = "llvm_build_alloca" 1075 external build_array_alloca : lltype -> llvalue -> string -> llbuilder -> 1076 llvalue = "llvm_build_array_alloca" 1077 external build_load : llvalue -> string -> llbuilder -> llvalue 1078 = "llvm_build_load" 1079 external build_store : llvalue -> llvalue -> llbuilder -> llvalue 1080 = "llvm_build_store" 1081 external build_gep : llvalue -> llvalue array -> string -> llbuilder -> llvalue 1082 = "llvm_build_gep" 1083 external build_in_bounds_gep : llvalue -> llvalue array -> string -> 1084 llbuilder -> llvalue = "llvm_build_in_bounds_gep" 1085 external build_struct_gep : llvalue -> int -> string -> llbuilder -> llvalue 1086 = "llvm_build_struct_gep" 1087 1088 external build_global_string : string -> string -> llbuilder -> llvalue 1089 = "llvm_build_global_string" 1090 external build_global_stringptr : string -> string -> llbuilder -> llvalue 1091 = "llvm_build_global_stringptr" 1092 1093 (*--... Casts ..............................................................--*) 1094 external build_trunc : llvalue -> lltype -> string -> llbuilder -> llvalue 1095 = "llvm_build_trunc" 1096 external build_zext : llvalue -> lltype -> string -> llbuilder -> llvalue 1097 = "llvm_build_zext" 1098 external build_sext : llvalue -> lltype -> string -> llbuilder -> llvalue 1099 = "llvm_build_sext" 1100 external build_fptoui : llvalue -> lltype -> string -> llbuilder -> llvalue 1101 = "llvm_build_fptoui" 1102 external build_fptosi : llvalue -> lltype -> string -> llbuilder -> llvalue 1103 = "llvm_build_fptosi" 1104 external build_uitofp : llvalue -> lltype -> string -> llbuilder -> llvalue 1105 = "llvm_build_uitofp" 1106 external build_sitofp : llvalue -> lltype -> string -> llbuilder -> llvalue 1107 = "llvm_build_sitofp" 1108 external build_fptrunc : llvalue -> lltype -> string -> llbuilder -> llvalue 1109 = "llvm_build_fptrunc" 1110 external build_fpext : llvalue -> lltype -> string -> llbuilder -> llvalue 1111 = "llvm_build_fpext" 1112 external build_ptrtoint : llvalue -> lltype -> string -> llbuilder -> llvalue 1113 = "llvm_build_prttoint" 1114 external build_inttoptr : llvalue -> lltype -> string -> llbuilder -> llvalue 1115 = "llvm_build_inttoptr" 1116 external build_bitcast : llvalue -> lltype -> string -> llbuilder -> llvalue 1117 = "llvm_build_bitcast" 1118 external build_zext_or_bitcast : llvalue -> lltype -> string -> llbuilder -> 1119 llvalue = "llvm_build_zext_or_bitcast" 1120 external build_sext_or_bitcast : llvalue -> lltype -> string -> llbuilder -> 1121 llvalue = "llvm_build_sext_or_bitcast" 1122 external build_trunc_or_bitcast : llvalue -> lltype -> string -> llbuilder -> 1123 llvalue = "llvm_build_trunc_or_bitcast" 1124 external build_pointercast : llvalue -> lltype -> string -> llbuilder -> llvalue 1125 = "llvm_build_pointercast" 1126 external build_intcast : llvalue -> lltype -> string -> llbuilder -> llvalue 1127 = "llvm_build_intcast" 1128 external build_fpcast : llvalue -> lltype -> string -> llbuilder -> llvalue 1129 = "llvm_build_fpcast" 1130 1131 (*--... Comparisons ........................................................--*) 1132 external build_icmp : Icmp.t -> llvalue -> llvalue -> string -> 1133 llbuilder -> llvalue = "llvm_build_icmp" 1134 external build_fcmp : Fcmp.t -> llvalue -> llvalue -> string -> 1135 llbuilder -> llvalue = "llvm_build_fcmp" 1136 1137 (*--... Miscellaneous instructions .........................................--*) 1138 external build_phi : (llvalue * llbasicblock) list -> string -> llbuilder -> 1139 llvalue = "llvm_build_phi" 1140 external build_call : llvalue -> llvalue array -> string -> llbuilder -> llvalue 1141 = "llvm_build_call" 1142 external build_select : llvalue -> llvalue -> llvalue -> string -> llbuilder -> 1143 llvalue = "llvm_build_select" 1144 external build_va_arg : llvalue -> lltype -> string -> llbuilder -> llvalue 1145 = "llvm_build_va_arg" 1146 external build_extractelement : llvalue -> llvalue -> string -> llbuilder -> 1147 llvalue = "llvm_build_extractelement" 1148 external build_insertelement : llvalue -> llvalue -> llvalue -> string -> 1149 llbuilder -> llvalue = "llvm_build_insertelement" 1150 external build_shufflevector : llvalue -> llvalue -> llvalue -> string -> 1151 llbuilder -> llvalue = "llvm_build_shufflevector" 1152 external build_extractvalue : llvalue -> int -> string -> llbuilder -> llvalue 1153 = "llvm_build_extractvalue" 1154 external build_insertvalue : llvalue -> llvalue -> int -> string -> llbuilder -> 1155 llvalue = "llvm_build_insertvalue" 1156 1157 external build_is_null : llvalue -> string -> llbuilder -> llvalue 1158 = "llvm_build_is_null" 1159 external build_is_not_null : llvalue -> string -> llbuilder -> llvalue 1160 = "llvm_build_is_not_null" 1161 external build_ptrdiff : llvalue -> llvalue -> string -> llbuilder -> llvalue 1162 = "llvm_build_ptrdiff" 1163 1164 1165 (*===-- Memory buffers ----------------------------------------------------===*) 1166 1167 module MemoryBuffer = struct 1168 external of_file : string -> llmemorybuffer = "llvm_memorybuffer_of_file" 1169 external of_stdin : unit -> llmemorybuffer = "llvm_memorybuffer_of_stdin" 1170 external dispose : llmemorybuffer -> unit = "llvm_memorybuffer_dispose" 1171 end 1172 1173 1174 (*===-- Pass Manager ------------------------------------------------------===*) 1175 1176 module PassManager = struct 1177 type 'a t 1178 type any = [ `Module | `Function ] 1179 external create : unit -> [ `Module ] t = "llvm_passmanager_create" 1180 external create_function : llmodule -> [ `Function ] t 1181 = "LLVMCreateFunctionPassManager" 1182 external run_module : llmodule -> [ `Module ] t -> bool 1183 = "llvm_passmanager_run_module" 1184 external initialize : [ `Function ] t -> bool = "llvm_passmanager_initialize" 1185 external run_function : llvalue -> [ `Function ] t -> bool 1186 = "llvm_passmanager_run_function" 1187 external finalize : [ `Function ] t -> bool = "llvm_passmanager_finalize" 1188 external dispose : [< any ] t -> unit = "llvm_passmanager_dispose" 1189 end 1190 1191 1192 (*===-- Non-Externs -------------------------------------------------------===*) 1193 (* These functions are built using the externals, so must be declared late. *) 1194 1195 let concat2 sep arr = 1196 let s = ref "" in 1197 if 0 < Array.length arr then begin 1198 s := !s ^ arr.(0); 1199 for i = 1 to (Array.length arr) - 1 do 1200 s := !s ^ sep ^ arr.(i) 1201 done 1202 end; 1203 !s 1204 1205 let rec string_of_lltype ty = 1206 (* FIXME: stop infinite recursion! :) *) 1207 match classify_type ty with 1208 TypeKind.Integer -> "i" ^ string_of_int (integer_bitwidth ty) 1209 | TypeKind.Pointer -> 1210 (let ety = element_type ty in 1211 match classify_type ety with 1212 | TypeKind.Struct -> 1213 (match struct_name ety with 1214 | None -> (string_of_lltype ety) 1215 | Some s -> s) ^ "*" 1216 | _ -> (string_of_lltype (element_type ty)) ^ "*") 1217 | TypeKind.Struct -> 1218 let s = "{ " ^ (concat2 ", " ( 1219 Array.map string_of_lltype (struct_element_types ty) 1220 )) ^ " }" in 1221 if is_packed ty 1222 then "<" ^ s ^ ">" 1223 else s 1224 | TypeKind.Array -> "[" ^ (string_of_int (array_length ty)) ^ 1225 " x " ^ (string_of_lltype (element_type ty)) ^ "]" 1226 | TypeKind.Vector -> "<" ^ (string_of_int (vector_size ty)) ^ 1227 " x " ^ (string_of_lltype (element_type ty)) ^ ">" 1228 | TypeKind.Function -> string_of_lltype (return_type ty) ^ 1229 " (" ^ (concat2 ", " ( 1230 Array.map string_of_lltype (param_types ty) 1231 )) ^ ")" 1232 | TypeKind.Label -> "label" 1233 | TypeKind.Ppc_fp128 -> "ppc_fp128" 1234 | TypeKind.Fp128 -> "fp128" 1235 | TypeKind.X86fp80 -> "x86_fp80" 1236 | TypeKind.Double -> "double" 1237 | TypeKind.Float -> "float" 1238 | TypeKind.Half -> "half" 1239 | TypeKind.Void -> "void" 1240 | TypeKind.Metadata -> "metadata" 1241
