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