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 11type llcontext 12type llmodule 13type lltype 14type llvalue 15type lluse 16type llbasicblock 17type llbuilder 18type llmemorybuffer 19 20module 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 36end 37 38module 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 55end 56 57module Visibility = struct 58 type t = 59 | Default 60 | Hidden 61 | Protected 62end 63 64module CallConv = struct 65 let c = 0 66 let fast = 8 67 let cold = 9 68 let x86_stdcall = 64 69 let x86_fastcall = 65 70end 71 72module 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 100end 101 102module 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 114end 115 116module 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 134end 135 136module 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 205end 206 207module 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 229end 230 231exception IoError of string 232 233external register_exns : exn -> unit = "llvm_register_core_exns" 234let _ = register_exns (IoError "") 235 236type ('a, 'b) llpos = 237| At_end of 'a 238| Before of 'b 239 240type ('a, 'b) llrev_pos = 241| At_start of 'a 242| After of 'b 243 244(*===-- Contexts ----------------------------------------------------------===*) 245external create_context : unit -> llcontext = "llvm_create_context" 246external dispose_context : llcontext -> unit = "llvm_dispose_context" 247external global_context : unit -> llcontext = "llvm_global_context" 248external mdkind_id : llcontext -> string -> int = "llvm_mdkind_id" 249 250(*===-- Modules -----------------------------------------------------------===*) 251external create_module : llcontext -> string -> llmodule = "llvm_create_module" 252external dispose_module : llmodule -> unit = "llvm_dispose_module" 253external target_triple: llmodule -> string 254 = "llvm_target_triple" 255external set_target_triple: string -> llmodule -> unit 256 = "llvm_set_target_triple" 257external data_layout: llmodule -> string 258 = "llvm_data_layout" 259external set_data_layout: string -> llmodule -> unit 260 = "llvm_set_data_layout" 261external dump_module : llmodule -> unit = "llvm_dump_module" 262external set_module_inline_asm : llmodule -> string -> unit 263 = "llvm_set_module_inline_asm" 264external module_context : llmodule -> llcontext = "LLVMGetModuleContext" 265 266(*===-- Types -------------------------------------------------------------===*) 267external classify_type : lltype -> TypeKind.t = "llvm_classify_type" 268external type_context : lltype -> llcontext = "llvm_type_context" 269external type_is_sized : lltype -> bool = "llvm_type_is_sized" 270 271(*--... Operations on integer types ........................................--*) 272external i1_type : llcontext -> lltype = "llvm_i1_type" 273external i8_type : llcontext -> lltype = "llvm_i8_type" 274external i16_type : llcontext -> lltype = "llvm_i16_type" 275external i32_type : llcontext -> lltype = "llvm_i32_type" 276external i64_type : llcontext -> lltype = "llvm_i64_type" 277 278external integer_type : llcontext -> int -> lltype = "llvm_integer_type" 279external integer_bitwidth : lltype -> int = "llvm_integer_bitwidth" 280 281(*--... Operations on real types ...........................................--*) 282external float_type : llcontext -> lltype = "llvm_float_type" 283external double_type : llcontext -> lltype = "llvm_double_type" 284external x86fp80_type : llcontext -> lltype = "llvm_x86fp80_type" 285external fp128_type : llcontext -> lltype = "llvm_fp128_type" 286external ppc_fp128_type : llcontext -> lltype = "llvm_ppc_fp128_type" 287 288(*--... Operations on function types .......................................--*) 289external function_type : lltype -> lltype array -> lltype = "llvm_function_type" 290external var_arg_function_type : lltype -> lltype array -> lltype 291 = "llvm_var_arg_function_type" 292external is_var_arg : lltype -> bool = "llvm_is_var_arg" 293external return_type : lltype -> lltype = "LLVMGetReturnType" 294external param_types : lltype -> lltype array = "llvm_param_types" 295 296(*--... Operations on struct types .........................................--*) 297external struct_type : llcontext -> lltype array -> lltype = "llvm_struct_type" 298external packed_struct_type : llcontext -> lltype array -> lltype 299 = "llvm_packed_struct_type" 300external struct_name : lltype -> string option = "llvm_struct_name" 301external named_struct_type : llcontext -> string -> lltype = 302 "llvm_named_struct_type" 303external struct_set_body : lltype -> lltype array -> bool -> unit = 304 "llvm_struct_set_body" 305external struct_element_types : lltype -> lltype array 306 = "llvm_struct_element_types" 307external is_packed : lltype -> bool = "llvm_is_packed" 308external is_opaque : lltype -> bool = "llvm_is_opaque" 309 310(*--... Operations on pointer, vector, and array types .....................--*) 311external array_type : lltype -> int -> lltype = "llvm_array_type" 312external pointer_type : lltype -> lltype = "llvm_pointer_type" 313external qualified_pointer_type : lltype -> int -> lltype 314 = "llvm_qualified_pointer_type" 315external vector_type : lltype -> int -> lltype = "llvm_vector_type" 316 317external element_type : lltype -> lltype = "LLVMGetElementType" 318external array_length : lltype -> int = "llvm_array_length" 319external address_space : lltype -> int = "llvm_address_space" 320external vector_size : lltype -> int = "llvm_vector_size" 321 322(*--... Operations on other types ..........................................--*) 323external void_type : llcontext -> lltype = "llvm_void_type" 324external label_type : llcontext -> lltype = "llvm_label_type" 325external type_by_name : llmodule -> string -> lltype option = "llvm_type_by_name" 326 327external classify_value : llvalue -> ValueKind.t = "llvm_classify_value" 328(*===-- Values ------------------------------------------------------------===*) 329external type_of : llvalue -> lltype = "llvm_type_of" 330external value_name : llvalue -> string = "llvm_value_name" 331external set_value_name : string -> llvalue -> unit = "llvm_set_value_name" 332external dump_value : llvalue -> unit = "llvm_dump_value" 333external replace_all_uses_with : llvalue -> llvalue -> unit 334 = "LLVMReplaceAllUsesWith" 335 336(*--... Operations on uses .................................................--*) 337external use_begin : llvalue -> lluse option = "llvm_use_begin" 338external use_succ : lluse -> lluse option = "llvm_use_succ" 339external user : lluse -> llvalue = "llvm_user" 340external used_value : lluse -> llvalue = "llvm_used_value" 341 342let 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 351let 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 359let 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 ................................................--*) 369external operand : llvalue -> int -> llvalue = "llvm_operand" 370external set_operand : llvalue -> int -> llvalue -> unit = "llvm_set_operand" 371external num_operands : llvalue -> int = "llvm_num_operands" 372 373(*--... Operations on constants of (mostly) any type .......................--*) 374external is_constant : llvalue -> bool = "llvm_is_constant" 375external const_null : lltype -> llvalue = "LLVMConstNull" 376external const_all_ones : (*int|vec*)lltype -> llvalue = "LLVMConstAllOnes" 377external const_pointer_null : lltype -> llvalue = "LLVMConstPointerNull" 378external undef : lltype -> llvalue = "LLVMGetUndef" 379external is_null : llvalue -> bool = "llvm_is_null" 380external is_undef : llvalue -> bool = "llvm_is_undef" 381external constexpr_opcode : llvalue -> Opcode.t = "llvm_constexpr_get_opcode" 382 383(*--... Operations on instructions .........................................--*) 384external has_metadata : llvalue -> bool = "llvm_has_metadata" 385external metadata : llvalue -> int -> llvalue option = "llvm_metadata" 386external set_metadata : llvalue -> int -> llvalue -> unit = "llvm_set_metadata" 387external clear_metadata : llvalue -> int -> unit = "llvm_clear_metadata" 388 389(*--... Operations on metadata .......,.....................................--*) 390external mdstring : llcontext -> string -> llvalue = "llvm_mdstring" 391external mdnode : llcontext -> llvalue array -> llvalue = "llvm_mdnode" 392external get_mdstring : llvalue -> string option = "llvm_get_mdstring" 393external get_named_metadata : llmodule -> string -> llvalue array = "llvm_get_namedmd" 394 395(*--... Operations on scalar constants .....................................--*) 396external const_int : lltype -> int -> llvalue = "llvm_const_int" 397external const_of_int64 : lltype -> Int64.t -> bool -> llvalue 398 = "llvm_const_of_int64" 399external int64_of_const : llvalue -> Int64.t option 400 = "llvm_int64_of_const" 401external const_int_of_string : lltype -> string -> int -> llvalue 402 = "llvm_const_int_of_string" 403external const_float : lltype -> float -> llvalue = "llvm_const_float" 404external const_float_of_string : lltype -> string -> llvalue 405 = "llvm_const_float_of_string" 406 407(*--... Operations on composite constants ..................................--*) 408external const_string : llcontext -> string -> llvalue = "llvm_const_string" 409external const_stringz : llcontext -> string -> llvalue = "llvm_const_stringz" 410external const_array : lltype -> llvalue array -> llvalue = "llvm_const_array" 411external const_struct : llcontext -> llvalue array -> llvalue 412 = "llvm_const_struct" 413external const_named_struct : lltype -> llvalue array -> llvalue 414 = "llvm_const_named_struct" 415external const_packed_struct : llcontext -> llvalue array -> llvalue 416 = "llvm_const_packed_struct" 417external const_vector : llvalue array -> llvalue = "llvm_const_vector" 418 419(*--... Constant expressions ...............................................--*) 420external align_of : lltype -> llvalue = "LLVMAlignOf" 421external size_of : lltype -> llvalue = "LLVMSizeOf" 422external const_neg : llvalue -> llvalue = "LLVMConstNeg" 423external const_nsw_neg : llvalue -> llvalue = "LLVMConstNSWNeg" 424external const_nuw_neg : llvalue -> llvalue = "LLVMConstNUWNeg" 425external const_fneg : llvalue -> llvalue = "LLVMConstFNeg" 426external const_not : llvalue -> llvalue = "LLVMConstNot" 427external const_add : llvalue -> llvalue -> llvalue = "LLVMConstAdd" 428external const_nsw_add : llvalue -> llvalue -> llvalue = "LLVMConstNSWAdd" 429external const_nuw_add : llvalue -> llvalue -> llvalue = "LLVMConstNUWAdd" 430external const_fadd : llvalue -> llvalue -> llvalue = "LLVMConstFAdd" 431external const_sub : llvalue -> llvalue -> llvalue = "LLVMConstSub" 432external const_nsw_sub : llvalue -> llvalue -> llvalue = "LLVMConstNSWSub" 433external const_nuw_sub : llvalue -> llvalue -> llvalue = "LLVMConstNUWSub" 434external const_fsub : llvalue -> llvalue -> llvalue = "LLVMConstFSub" 435external const_mul : llvalue -> llvalue -> llvalue = "LLVMConstMul" 436external const_nsw_mul : llvalue -> llvalue -> llvalue = "LLVMConstNSWMul" 437external const_nuw_mul : llvalue -> llvalue -> llvalue = "LLVMConstNUWMul" 438external const_fmul : llvalue -> llvalue -> llvalue = "LLVMConstFMul" 439external const_udiv : llvalue -> llvalue -> llvalue = "LLVMConstUDiv" 440external const_sdiv : llvalue -> llvalue -> llvalue = "LLVMConstSDiv" 441external const_exact_sdiv : llvalue -> llvalue -> llvalue = "LLVMConstExactSDiv" 442external const_fdiv : llvalue -> llvalue -> llvalue = "LLVMConstFDiv" 443external const_urem : llvalue -> llvalue -> llvalue = "LLVMConstURem" 444external const_srem : llvalue -> llvalue -> llvalue = "LLVMConstSRem" 445external const_frem : llvalue -> llvalue -> llvalue = "LLVMConstFRem" 446external const_and : llvalue -> llvalue -> llvalue = "LLVMConstAnd" 447external const_or : llvalue -> llvalue -> llvalue = "LLVMConstOr" 448external const_xor : llvalue -> llvalue -> llvalue = "LLVMConstXor" 449external const_icmp : Icmp.t -> llvalue -> llvalue -> llvalue 450 = "llvm_const_icmp" 451external const_fcmp : Fcmp.t -> llvalue -> llvalue -> llvalue 452 = "llvm_const_fcmp" 453external const_shl : llvalue -> llvalue -> llvalue = "LLVMConstShl" 454external const_lshr : llvalue -> llvalue -> llvalue = "LLVMConstLShr" 455external const_ashr : llvalue -> llvalue -> llvalue = "LLVMConstAShr" 456external const_gep : llvalue -> llvalue array -> llvalue = "llvm_const_gep" 457external const_in_bounds_gep : llvalue -> llvalue array -> llvalue 458 = "llvm_const_in_bounds_gep" 459external const_trunc : llvalue -> lltype -> llvalue = "LLVMConstTrunc" 460external const_sext : llvalue -> lltype -> llvalue = "LLVMConstSExt" 461external const_zext : llvalue -> lltype -> llvalue = "LLVMConstZExt" 462external const_fptrunc : llvalue -> lltype -> llvalue = "LLVMConstFPTrunc" 463external const_fpext : llvalue -> lltype -> llvalue = "LLVMConstFPExt" 464external const_uitofp : llvalue -> lltype -> llvalue = "LLVMConstUIToFP" 465external const_sitofp : llvalue -> lltype -> llvalue = "LLVMConstSIToFP" 466external const_fptoui : llvalue -> lltype -> llvalue = "LLVMConstFPToUI" 467external const_fptosi : llvalue -> lltype -> llvalue = "LLVMConstFPToSI" 468external const_ptrtoint : llvalue -> lltype -> llvalue = "LLVMConstPtrToInt" 469external const_inttoptr : llvalue -> lltype -> llvalue = "LLVMConstIntToPtr" 470external const_bitcast : llvalue -> lltype -> llvalue = "LLVMConstBitCast" 471external const_zext_or_bitcast : llvalue -> lltype -> llvalue 472 = "LLVMConstZExtOrBitCast" 473external const_sext_or_bitcast : llvalue -> lltype -> llvalue 474 = "LLVMConstSExtOrBitCast" 475external const_trunc_or_bitcast : llvalue -> lltype -> llvalue 476 = "LLVMConstTruncOrBitCast" 477external const_pointercast : llvalue -> lltype -> llvalue 478 = "LLVMConstPointerCast" 479external const_intcast : llvalue -> lltype -> llvalue = "LLVMConstIntCast" 480external const_fpcast : llvalue -> lltype -> llvalue = "LLVMConstFPCast" 481external const_select : llvalue -> llvalue -> llvalue -> llvalue 482 = "LLVMConstSelect" 483external const_extractelement : llvalue -> llvalue -> llvalue 484 = "LLVMConstExtractElement" 485external const_insertelement : llvalue -> llvalue -> llvalue -> llvalue 486 = "LLVMConstInsertElement" 487external const_shufflevector : llvalue -> llvalue -> llvalue -> llvalue 488 = "LLVMConstShuffleVector" 489external const_extractvalue : llvalue -> int array -> llvalue 490 = "llvm_const_extractvalue" 491external const_insertvalue : llvalue -> llvalue -> int array -> llvalue 492 = "llvm_const_insertvalue" 493external const_inline_asm : lltype -> string -> string -> bool -> bool -> 494 llvalue 495 = "llvm_const_inline_asm" 496external block_address : llvalue -> llbasicblock -> llvalue = "LLVMBlockAddress" 497 498(*--... Operations on global variables, functions, and aliases (globals) ...--*) 499external global_parent : llvalue -> llmodule = "LLVMGetGlobalParent" 500external is_declaration : llvalue -> bool = "llvm_is_declaration" 501external linkage : llvalue -> Linkage.t = "llvm_linkage" 502external set_linkage : Linkage.t -> llvalue -> unit = "llvm_set_linkage" 503external section : llvalue -> string = "llvm_section" 504external set_section : string -> llvalue -> unit = "llvm_set_section" 505external visibility : llvalue -> Visibility.t = "llvm_visibility" 506external set_visibility : Visibility.t -> llvalue -> unit = "llvm_set_visibility" 507external alignment : llvalue -> int = "llvm_alignment" 508external set_alignment : int -> llvalue -> unit = "llvm_set_alignment" 509external is_global_constant : llvalue -> bool = "llvm_is_global_constant" 510external set_global_constant : bool -> llvalue -> unit 511 = "llvm_set_global_constant" 512 513(*--... Operations on global variables .....................................--*) 514external declare_global : lltype -> string -> llmodule -> llvalue 515 = "llvm_declare_global" 516external declare_qualified_global : lltype -> string -> int -> llmodule -> 517 llvalue 518 = "llvm_declare_qualified_global" 519external define_global : string -> llvalue -> llmodule -> llvalue 520 = "llvm_define_global" 521external define_qualified_global : string -> llvalue -> int -> llmodule -> 522 llvalue 523 = "llvm_define_qualified_global" 524external lookup_global : string -> llmodule -> llvalue option 525 = "llvm_lookup_global" 526external delete_global : llvalue -> unit = "llvm_delete_global" 527external global_initializer : llvalue -> llvalue = "LLVMGetInitializer" 528external set_initializer : llvalue -> llvalue -> unit = "llvm_set_initializer" 529external remove_initializer : llvalue -> unit = "llvm_remove_initializer" 530external is_thread_local : llvalue -> bool = "llvm_is_thread_local" 531external set_thread_local : bool -> llvalue -> unit = "llvm_set_thread_local" 532external global_begin : llmodule -> (llmodule, llvalue) llpos 533 = "llvm_global_begin" 534external global_succ : llvalue -> (llmodule, llvalue) llpos 535 = "llvm_global_succ" 536external global_end : llmodule -> (llmodule, llvalue) llrev_pos 537 = "llvm_global_end" 538external global_pred : llvalue -> (llmodule, llvalue) llrev_pos 539 = "llvm_global_pred" 540 541let 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 549let iter_globals f m = 550 iter_global_range f (global_begin m) (At_end m) 551 552let 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 558let fold_left_globals f init m = 559 fold_left_global_range f init (global_begin m) (At_end m) 560 561let 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 569let rev_iter_globals f m = 570 rev_iter_global_range f (global_end m) (At_start m) 571 572let 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 578let fold_right_globals f m init = 579 fold_right_global_range f (global_end m) (At_start m) init 580 581(*--... Operations on aliases ..............................................--*) 582external add_alias : llmodule -> lltype -> llvalue -> string -> llvalue 583 = "llvm_add_alias" 584 585(*--... Operations on functions ............................................--*) 586external declare_function : string -> lltype -> llmodule -> llvalue 587 = "llvm_declare_function" 588external define_function : string -> lltype -> llmodule -> llvalue 589 = "llvm_define_function" 590external lookup_function : string -> llmodule -> llvalue option 591 = "llvm_lookup_function" 592external delete_function : llvalue -> unit = "llvm_delete_function" 593external is_intrinsic : llvalue -> bool = "llvm_is_intrinsic" 594external function_call_conv : llvalue -> int = "llvm_function_call_conv" 595external set_function_call_conv : int -> llvalue -> unit 596 = "llvm_set_function_call_conv" 597external gc : llvalue -> string option = "llvm_gc" 598external set_gc : string option -> llvalue -> unit = "llvm_set_gc" 599external function_begin : llmodule -> (llmodule, llvalue) llpos 600 = "llvm_function_begin" 601external function_succ : llvalue -> (llmodule, llvalue) llpos 602 = "llvm_function_succ" 603external function_end : llmodule -> (llmodule, llvalue) llrev_pos 604 = "llvm_function_end" 605external function_pred : llvalue -> (llmodule, llvalue) llrev_pos 606 = "llvm_function_pred" 607 608let 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 616let iter_functions f m = 617 iter_function_range f (function_begin m) (At_end m) 618 619let 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 625let fold_left_functions f init m = 626 fold_left_function_range f init (function_begin m) (At_end m) 627 628let 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 636let rev_iter_functions f m = 637 rev_iter_function_range f (function_end m) (At_start m) 638 639let 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 645let fold_right_functions f m init = 646 fold_right_function_range f (function_end m) (At_start m) init 647 648external llvm_add_function_attr : llvalue -> int32 -> unit 649 = "llvm_add_function_attr" 650external llvm_remove_function_attr : llvalue -> int32 -> unit 651 = "llvm_remove_function_attr" 652external llvm_function_attr : llvalue -> int32 = "llvm_function_attr" 653 654let 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 683let 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 724let add_function_attr llval attr = 725 llvm_add_function_attr llval (pack_attr attr) 726 727let remove_function_attr llval attr = 728 llvm_remove_function_attr llval (pack_attr attr) 729 730let function_attr f = unpack_attr (llvm_function_attr f) 731 732(*--... Operations on params ...............................................--*) 733external params : llvalue -> llvalue array = "llvm_params" 734external param : llvalue -> int -> llvalue = "llvm_param" 735external llvm_param_attr : llvalue -> int32 = "llvm_param_attr" 736let param_attr p = unpack_attr (llvm_param_attr p) 737external param_parent : llvalue -> llvalue = "LLVMGetParamParent" 738external param_begin : llvalue -> (llvalue, llvalue) llpos = "llvm_param_begin" 739external param_succ : llvalue -> (llvalue, llvalue) llpos = "llvm_param_succ" 740external param_end : llvalue -> (llvalue, llvalue) llrev_pos = "llvm_param_end" 741external param_pred : llvalue -> (llvalue, llvalue) llrev_pos ="llvm_param_pred" 742 743let 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 751let iter_params f fn = 752 iter_param_range f (param_begin fn) (At_end fn) 753 754let 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 760let fold_left_params f init fn = 761 fold_left_param_range f init (param_begin fn) (At_end fn) 762 763let 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 771let rev_iter_params f fn = 772 rev_iter_param_range f (param_end fn) (At_start fn) 773 774let 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 780let fold_right_params f fn init = 781 fold_right_param_range f init (param_end fn) (At_start fn) 782 783external llvm_add_param_attr : llvalue -> int32 -> unit 784 = "llvm_add_param_attr" 785external llvm_remove_param_attr : llvalue -> int32 -> unit 786 = "llvm_remove_param_attr" 787 788let add_param_attr llval attr = 789 llvm_add_param_attr llval (pack_attr attr) 790 791let remove_param_attr llval attr = 792 llvm_remove_param_attr llval (pack_attr attr) 793 794external set_param_alignment : llvalue -> int -> unit 795 = "llvm_set_param_alignment" 796 797(*--... Operations on basic blocks .........................................--*) 798external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue" 799external value_is_block : llvalue -> bool = "llvm_value_is_block" 800external block_of_value : llvalue -> llbasicblock = "LLVMValueAsBasicBlock" 801external block_parent : llbasicblock -> llvalue = "LLVMGetBasicBlockParent" 802external basic_blocks : llvalue -> llbasicblock array = "llvm_basic_blocks" 803external entry_block : llvalue -> llbasicblock = "LLVMGetEntryBasicBlock" 804external delete_block : llbasicblock -> unit = "llvm_delete_block" 805external append_block : llcontext -> string -> llvalue -> llbasicblock 806 = "llvm_append_block" 807external insert_block : llcontext -> string -> llbasicblock -> llbasicblock 808 = "llvm_insert_block" 809external block_begin : llvalue -> (llvalue, llbasicblock) llpos 810 = "llvm_block_begin" 811external block_succ : llbasicblock -> (llvalue, llbasicblock) llpos 812 = "llvm_block_succ" 813external block_end : llvalue -> (llvalue, llbasicblock) llrev_pos 814 = "llvm_block_end" 815external block_pred : llbasicblock -> (llvalue, llbasicblock) llrev_pos 816 = "llvm_block_pred" 817external block_terminator : llbasicblock -> llvalue option = 818 "llvm_block_terminator" 819 820let 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 828let iter_blocks f fn = 829 iter_block_range f (block_begin fn) (At_end fn) 830 831let 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 837let fold_left_blocks f init fn = 838 fold_left_block_range f init (block_begin fn) (At_end fn) 839 840let 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 848let rev_iter_blocks f fn = 849 rev_iter_block_range f (block_end fn) (At_start fn) 850 851let 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 857let fold_right_blocks f fn init = 858 fold_right_block_range f init (block_end fn) (At_start fn) 859 860(*--... Operations on instructions .........................................--*) 861external instr_parent : llvalue -> llbasicblock = "LLVMGetInstructionParent" 862external instr_begin : llbasicblock -> (llbasicblock, llvalue) llpos 863 = "llvm_instr_begin" 864external instr_succ : llvalue -> (llbasicblock, llvalue) llpos 865 = "llvm_instr_succ" 866external instr_end : llbasicblock -> (llbasicblock, llvalue) llrev_pos 867 = "llvm_instr_end" 868external instr_pred : llvalue -> (llbasicblock, llvalue) llrev_pos 869 = "llvm_instr_pred" 870 871external instr_opcode : llvalue -> Opcode.t = "llvm_instr_get_opcode" 872external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate" 873 874external icmp_predicate : llvalue -> Icmp.t option = "llvm_instr_icmp_predicate" 875 876let 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 884let iter_instrs f bb = 885 iter_instrs_range f (instr_begin bb) (At_end bb) 886 887let 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 893let fold_left_instrs f init bb = 894 fold_left_instrs_range f init (instr_begin bb) (At_end bb) 895 896let 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 904let rev_iter_instrs f bb = 905 rev_iter_instrs_range f (instr_end bb) (At_start bb) 906 907let 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 913let 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 ...........................................--*) 918external instruction_call_conv: llvalue -> int 919 = "llvm_instruction_call_conv" 920external set_instruction_call_conv: int -> llvalue -> unit 921 = "llvm_set_instruction_call_conv" 922 923external llvm_add_instruction_param_attr : llvalue -> int -> int32 -> unit 924 = "llvm_add_instruction_param_attr" 925external llvm_remove_instruction_param_attr : llvalue -> int -> int32 -> unit 926 = "llvm_remove_instruction_param_attr" 927 928let add_instruction_param_attr llval i attr = 929 llvm_add_instruction_param_attr llval i (pack_attr attr) 930 931let 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) .............................--*) 935external is_tail_call : llvalue -> bool = "llvm_is_tail_call" 936external set_tail_call : bool -> llvalue -> unit = "llvm_set_tail_call" 937 938(*--... Operations on phi nodes ............................................--*) 939external add_incoming : (llvalue * llbasicblock) -> llvalue -> unit 940 = "llvm_add_incoming" 941external incoming : llvalue -> (llvalue * llbasicblock) list = "llvm_incoming" 942 943external delete_instruction : llvalue -> unit = "llvm_delete_instruction" 944 945(*===-- Instruction builders ----------------------------------------------===*) 946external builder : llcontext -> llbuilder = "llvm_builder" 947external position_builder : (llbasicblock, llvalue) llpos -> llbuilder -> unit 948 = "llvm_position_builder" 949external insertion_block : llbuilder -> llbasicblock = "llvm_insertion_block" 950external insert_into_builder : llvalue -> string -> llbuilder -> unit 951 = "llvm_insert_into_builder" 952 953let builder_at context ip = 954 let b = builder context in 955 position_builder ip b; 956 b 957 958let builder_before context i = builder_at context (Before i) 959let builder_at_end context bb = builder_at context (At_end bb) 960 961let position_before i = position_builder (Before i) 962let position_at_end bb = position_builder (At_end bb) 963 964 965(*--... Metadata ...........................................................--*) 966external set_current_debug_location : llbuilder -> llvalue -> unit 967 = "llvm_set_current_debug_location" 968external clear_current_debug_location : llbuilder -> unit 969 = "llvm_clear_current_debug_location" 970external current_debug_location : llbuilder -> llvalue option 971 = "llvm_current_debug_location" 972external set_inst_debug_location : llbuilder -> llvalue -> unit 973 = "llvm_set_inst_debug_location" 974 975 976(*--... Terminators ........................................................--*) 977external build_ret_void : llbuilder -> llvalue = "llvm_build_ret_void" 978external build_ret : llvalue -> llbuilder -> llvalue = "llvm_build_ret" 979external build_aggregate_ret : llvalue array -> llbuilder -> llvalue 980 = "llvm_build_aggregate_ret" 981external build_br : llbasicblock -> llbuilder -> llvalue = "llvm_build_br" 982external build_cond_br : llvalue -> llbasicblock -> llbasicblock -> llbuilder -> 983 llvalue = "llvm_build_cond_br" 984external build_switch : llvalue -> llbasicblock -> int -> llbuilder -> llvalue 985 = "llvm_build_switch" 986external build_malloc : lltype -> string -> llbuilder -> llvalue = 987 "llvm_build_malloc" 988external build_array_malloc : lltype -> llvalue -> string -> llbuilder -> 989 llvalue = "llvm_build_array_malloc" 990external build_free : llvalue -> llbuilder -> llvalue = "llvm_build_free" 991external add_case : llvalue -> llvalue -> llbasicblock -> unit 992 = "llvm_add_case" 993external switch_default_dest : llvalue -> llbasicblock = 994 "LLVMGetSwitchDefaultDest" 995external build_indirect_br : llvalue -> int -> llbuilder -> llvalue 996 = "llvm_build_indirect_br" 997external add_destination : llvalue -> llbasicblock -> unit 998 = "llvm_add_destination" 999external build_invoke : llvalue -> llvalue array -> llbasicblock -> 1000 llbasicblock -> string -> llbuilder -> llvalue 1001 = "llvm_build_invoke_bc" "llvm_build_invoke_nat" 1002external build_landingpad : lltype -> llvalue -> int -> string -> llbuilder -> 1003 llvalue = "llvm_build_landingpad" 1004external set_cleanup : llvalue -> bool -> unit = "llvm_set_cleanup" 1005external add_clause : llvalue -> llvalue -> unit = "llvm_add_clause" 1006external build_resume : llvalue -> llbuilder -> llvalue = "llvm_build_resume" 1007external build_unreachable : llbuilder -> llvalue = "llvm_build_unreachable" 1008 1009(*--... Arithmetic .........................................................--*) 1010external build_add : llvalue -> llvalue -> string -> llbuilder -> llvalue 1011 = "llvm_build_add" 1012external build_nsw_add : llvalue -> llvalue -> string -> llbuilder -> llvalue 1013 = "llvm_build_nsw_add" 1014external build_nuw_add : llvalue -> llvalue -> string -> llbuilder -> llvalue 1015 = "llvm_build_nuw_add" 1016external build_fadd : llvalue -> llvalue -> string -> llbuilder -> llvalue 1017 = "llvm_build_fadd" 1018external build_sub : llvalue -> llvalue -> string -> llbuilder -> llvalue 1019 = "llvm_build_sub" 1020external build_nsw_sub : llvalue -> llvalue -> string -> llbuilder -> llvalue 1021 = "llvm_build_nsw_sub" 1022external build_nuw_sub : llvalue -> llvalue -> string -> llbuilder -> llvalue 1023 = "llvm_build_nuw_sub" 1024external build_fsub : llvalue -> llvalue -> string -> llbuilder -> llvalue 1025 = "llvm_build_fsub" 1026external build_mul : llvalue -> llvalue -> string -> llbuilder -> llvalue 1027 = "llvm_build_mul" 1028external build_nsw_mul : llvalue -> llvalue -> string -> llbuilder -> llvalue 1029 = "llvm_build_nsw_mul" 1030external build_nuw_mul : llvalue -> llvalue -> string -> llbuilder -> llvalue 1031 = "llvm_build_nuw_mul" 1032external build_fmul : llvalue -> llvalue -> string -> llbuilder -> llvalue 1033 = "llvm_build_fmul" 1034external build_udiv : llvalue -> llvalue -> string -> llbuilder -> llvalue 1035 = "llvm_build_udiv" 1036external build_sdiv : llvalue -> llvalue -> string -> llbuilder -> llvalue 1037 = "llvm_build_sdiv" 1038external build_exact_sdiv : llvalue -> llvalue -> string -> llbuilder -> llvalue 1039 = "llvm_build_exact_sdiv" 1040external build_fdiv : llvalue -> llvalue -> string -> llbuilder -> llvalue 1041 = "llvm_build_fdiv" 1042external build_urem : llvalue -> llvalue -> string -> llbuilder -> llvalue 1043 = "llvm_build_urem" 1044external build_srem : llvalue -> llvalue -> string -> llbuilder -> llvalue 1045 = "llvm_build_srem" 1046external build_frem : llvalue -> llvalue -> string -> llbuilder -> llvalue 1047 = "llvm_build_frem" 1048external build_shl : llvalue -> llvalue -> string -> llbuilder -> llvalue 1049 = "llvm_build_shl" 1050external build_lshr : llvalue -> llvalue -> string -> llbuilder -> llvalue 1051 = "llvm_build_lshr" 1052external build_ashr : llvalue -> llvalue -> string -> llbuilder -> llvalue 1053 = "llvm_build_ashr" 1054external build_and : llvalue -> llvalue -> string -> llbuilder -> llvalue 1055 = "llvm_build_and" 1056external build_or : llvalue -> llvalue -> string -> llbuilder -> llvalue 1057 = "llvm_build_or" 1058external build_xor : llvalue -> llvalue -> string -> llbuilder -> llvalue 1059 = "llvm_build_xor" 1060external build_neg : llvalue -> string -> llbuilder -> llvalue 1061 = "llvm_build_neg" 1062external build_nsw_neg : llvalue -> string -> llbuilder -> llvalue 1063 = "llvm_build_nsw_neg" 1064external build_nuw_neg : llvalue -> string -> llbuilder -> llvalue 1065 = "llvm_build_nuw_neg" 1066external build_fneg : llvalue -> string -> llbuilder -> llvalue 1067 = "llvm_build_fneg" 1068external build_not : llvalue -> string -> llbuilder -> llvalue 1069 = "llvm_build_not" 1070 1071(*--... Memory .............................................................--*) 1072external build_alloca : lltype -> string -> llbuilder -> llvalue 1073 = "llvm_build_alloca" 1074external build_array_alloca : lltype -> llvalue -> string -> llbuilder -> 1075 llvalue = "llvm_build_array_alloca" 1076external build_load : llvalue -> string -> llbuilder -> llvalue 1077 = "llvm_build_load" 1078external build_store : llvalue -> llvalue -> llbuilder -> llvalue 1079 = "llvm_build_store" 1080external build_gep : llvalue -> llvalue array -> string -> llbuilder -> llvalue 1081 = "llvm_build_gep" 1082external build_in_bounds_gep : llvalue -> llvalue array -> string -> 1083 llbuilder -> llvalue = "llvm_build_in_bounds_gep" 1084external build_struct_gep : llvalue -> int -> string -> llbuilder -> llvalue 1085 = "llvm_build_struct_gep" 1086 1087external build_global_string : string -> string -> llbuilder -> llvalue 1088 = "llvm_build_global_string" 1089external build_global_stringptr : string -> string -> llbuilder -> llvalue 1090 = "llvm_build_global_stringptr" 1091 1092(*--... Casts ..............................................................--*) 1093external build_trunc : llvalue -> lltype -> string -> llbuilder -> llvalue 1094 = "llvm_build_trunc" 1095external build_zext : llvalue -> lltype -> string -> llbuilder -> llvalue 1096 = "llvm_build_zext" 1097external build_sext : llvalue -> lltype -> string -> llbuilder -> llvalue 1098 = "llvm_build_sext" 1099external build_fptoui : llvalue -> lltype -> string -> llbuilder -> llvalue 1100 = "llvm_build_fptoui" 1101external build_fptosi : llvalue -> lltype -> string -> llbuilder -> llvalue 1102 = "llvm_build_fptosi" 1103external build_uitofp : llvalue -> lltype -> string -> llbuilder -> llvalue 1104 = "llvm_build_uitofp" 1105external build_sitofp : llvalue -> lltype -> string -> llbuilder -> llvalue 1106 = "llvm_build_sitofp" 1107external build_fptrunc : llvalue -> lltype -> string -> llbuilder -> llvalue 1108 = "llvm_build_fptrunc" 1109external build_fpext : llvalue -> lltype -> string -> llbuilder -> llvalue 1110 = "llvm_build_fpext" 1111external build_ptrtoint : llvalue -> lltype -> string -> llbuilder -> llvalue 1112 = "llvm_build_prttoint" 1113external build_inttoptr : llvalue -> lltype -> string -> llbuilder -> llvalue 1114 = "llvm_build_inttoptr" 1115external build_bitcast : llvalue -> lltype -> string -> llbuilder -> llvalue 1116 = "llvm_build_bitcast" 1117external build_zext_or_bitcast : llvalue -> lltype -> string -> llbuilder -> 1118 llvalue = "llvm_build_zext_or_bitcast" 1119external build_sext_or_bitcast : llvalue -> lltype -> string -> llbuilder -> 1120 llvalue = "llvm_build_sext_or_bitcast" 1121external build_trunc_or_bitcast : llvalue -> lltype -> string -> llbuilder -> 1122 llvalue = "llvm_build_trunc_or_bitcast" 1123external build_pointercast : llvalue -> lltype -> string -> llbuilder -> llvalue 1124 = "llvm_build_pointercast" 1125external build_intcast : llvalue -> lltype -> string -> llbuilder -> llvalue 1126 = "llvm_build_intcast" 1127external build_fpcast : llvalue -> lltype -> string -> llbuilder -> llvalue 1128 = "llvm_build_fpcast" 1129 1130(*--... Comparisons ........................................................--*) 1131external build_icmp : Icmp.t -> llvalue -> llvalue -> string -> 1132 llbuilder -> llvalue = "llvm_build_icmp" 1133external build_fcmp : Fcmp.t -> llvalue -> llvalue -> string -> 1134 llbuilder -> llvalue = "llvm_build_fcmp" 1135 1136(*--... Miscellaneous instructions .........................................--*) 1137external build_phi : (llvalue * llbasicblock) list -> string -> llbuilder -> 1138 llvalue = "llvm_build_phi" 1139external build_call : llvalue -> llvalue array -> string -> llbuilder -> llvalue 1140 = "llvm_build_call" 1141external build_select : llvalue -> llvalue -> llvalue -> string -> llbuilder -> 1142 llvalue = "llvm_build_select" 1143external build_va_arg : llvalue -> lltype -> string -> llbuilder -> llvalue 1144 = "llvm_build_va_arg" 1145external build_extractelement : llvalue -> llvalue -> string -> llbuilder -> 1146 llvalue = "llvm_build_extractelement" 1147external build_insertelement : llvalue -> llvalue -> llvalue -> string -> 1148 llbuilder -> llvalue = "llvm_build_insertelement" 1149external build_shufflevector : llvalue -> llvalue -> llvalue -> string -> 1150 llbuilder -> llvalue = "llvm_build_shufflevector" 1151external build_extractvalue : llvalue -> int -> string -> llbuilder -> llvalue 1152 = "llvm_build_extractvalue" 1153external build_insertvalue : llvalue -> llvalue -> int -> string -> llbuilder -> 1154 llvalue = "llvm_build_insertvalue" 1155 1156external build_is_null : llvalue -> string -> llbuilder -> llvalue 1157 = "llvm_build_is_null" 1158external build_is_not_null : llvalue -> string -> llbuilder -> llvalue 1159 = "llvm_build_is_not_null" 1160external build_ptrdiff : llvalue -> llvalue -> string -> llbuilder -> llvalue 1161 = "llvm_build_ptrdiff" 1162 1163 1164(*===-- Memory buffers ----------------------------------------------------===*) 1165 1166module 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" 1170end 1171 1172 1173(*===-- Pass Manager ------------------------------------------------------===*) 1174 1175module 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" 1188end 1189 1190 1191(*===-- Non-Externs -------------------------------------------------------===*) 1192(* These functions are built using the externals, so must be declared late. *) 1193 1194let 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 1204let 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