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