Mercurial > hg > CbC > CbC_llvm

comparison bindings/ocaml/llvm/llvm.ml @ 120:1172e4bd9c6f

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
update 4.0.0
author mir3636
date Fri, 25 Nov 2016 19:14:25 +0900
parents 7d135dc70f03
children 803732b1fca8
comparison
equal deleted inserted replaced
101:34baf5011add 120:1172e4bd9c6f
13 type lltype 13 type lltype
14 type llvalue 14 type llvalue
15 type lluse 15 type lluse
16 type llbasicblock 16 type llbasicblock
17 type llbuilder 17 type llbuilder
18 type llattrkind
19 type llattribute
18 type llmemorybuffer 20 type llmemorybuffer
19 type llmdkind 21 type llmdkind
20 22
21 module TypeKind = struct 23 module TypeKind = struct
22 type t = 24 type t =
77 let c = 0 79 let c = 0
78 let fast = 8 80 let fast = 8
79 let cold = 9 81 let cold = 9
80 let x86_stdcall = 64 82 let x86_stdcall = 64
81 let x86_fastcall = 65 83 let x86_fastcall = 65
84 end
85
86 module AttrRepr = struct
87 type t =
88 | Enum of llattrkind * int64
89 | String of string * string
90 end
91
92 module AttrIndex = struct
93 type t =
94 | Function
95 | Return
96 | Param of int
97
98 let to_int index =
99 match index with
100 | Function -> -1
101 | Return -> 0
102 | Param(n) -> 1 + n
82 end 103 end
83 104
84 module Attribute = struct 105 module Attribute = struct
85 type t = 106 type t =
86 | Zext 107 | Zext
281 | GlobalVariable 302 | GlobalVariable
282 | UndefValue 303 | UndefValue
283 | Instruction of Opcode.t 304 | Instruction of Opcode.t
284 end 305 end
285 306
307 module DiagnosticSeverity = struct
308 type t =
309 | Error
310 | Warning
311 | Remark
312 | Note
313 end
314
286 exception IoError of string 315 exception IoError of string
287 316
288 let () = Callback.register_exception "Llvm.IoError" (IoError "") 317 let () = Callback.register_exception "Llvm.IoError" (IoError "")
289 318
290 external install_fatal_error_handler : (string -> unit) -> unit 319 external install_fatal_error_handler : (string -> unit) -> unit
302 331
303 type ('a, 'b) llrev_pos = 332 type ('a, 'b) llrev_pos =
304 | At_start of 'a 333 | At_start of 'a
305 | After of 'b 334 | After of 'b
306 335
336
337 (*===-- Context error handling --------------------------------------------===*)
338 module Diagnostic = struct
339 type t
340
341 external description : t -> string = "llvm_get_diagnostic_description"
342 external severity : t -> DiagnosticSeverity.t
343 = "llvm_get_diagnostic_severity"
344 end
345
346 external set_diagnostic_handler
347 : llcontext -> (Diagnostic.t -> unit) option -> unit
348 = "llvm_set_diagnostic_handler"
349
307 (*===-- Contexts ----------------------------------------------------------===*) 350 (*===-- Contexts ----------------------------------------------------------===*)
308 external create_context : unit -> llcontext = "llvm_create_context" 351 external create_context : unit -> llcontext = "llvm_create_context"
309 external dispose_context : llcontext -> unit = "llvm_dispose_context" 352 external dispose_context : llcontext -> unit = "llvm_dispose_context"
310 external global_context : unit -> llcontext = "llvm_global_context" 353 external global_context : unit -> llcontext = "llvm_global_context"
311 external mdkind_id : llcontext -> string -> llmdkind = "llvm_mdkind_id" 354 external mdkind_id : llcontext -> string -> llmdkind = "llvm_mdkind_id"
355
356 (*===-- Attributes --------------------------------------------------------===*)
357 exception UnknownAttribute of string
358
359 let () = Callback.register_exception "Llvm.UnknownAttribute"
360 (UnknownAttribute "")
361
362 external enum_attr_kind : string -> llattrkind = "llvm_enum_attr_kind"
363 external llvm_create_enum_attr : llcontext -> llattrkind -> int64 ->
364 llattribute
365 = "llvm_create_enum_attr_by_kind"
366 external is_enum_attr : llattribute -> bool = "llvm_is_enum_attr"
367 external get_enum_attr_kind : llattribute -> llattrkind
368 = "llvm_get_enum_attr_kind"
369 external get_enum_attr_value : llattribute -> int64
370 = "llvm_get_enum_attr_value"
371 external llvm_create_string_attr : llcontext -> string -> string ->
372 llattribute
373 = "llvm_create_string_attr"
374 external is_string_attr : llattribute -> bool = "llvm_is_string_attr"
375 external get_string_attr_kind : llattribute -> string
376 = "llvm_get_string_attr_kind"
377 external get_string_attr_value : llattribute -> string
378 = "llvm_get_string_attr_value"
379
380 let create_enum_attr context name value =
381 llvm_create_enum_attr context (enum_attr_kind name) value
382 let create_string_attr context kind value =
383 llvm_create_string_attr context kind value
384
385 let attr_of_repr context repr =
386 match repr with
387 | AttrRepr.Enum(kind, value) -> llvm_create_enum_attr context kind value
388 | AttrRepr.String(key, value) -> llvm_create_string_attr context key value
389
390 let repr_of_attr attr =
391 if is_enum_attr attr then
392 AttrRepr.Enum(get_enum_attr_kind attr, get_enum_attr_value attr)
393 else if is_string_attr attr then
394 AttrRepr.String(get_string_attr_kind attr, get_string_attr_value attr)
395 else assert false
312 396
313 (*===-- Modules -----------------------------------------------------------===*) 397 (*===-- Modules -----------------------------------------------------------===*)
314 external create_module : llcontext -> string -> llmodule = "llvm_create_module" 398 external create_module : llcontext -> string -> llmodule = "llvm_create_module"
315 external dispose_module : llmodule -> unit = "llvm_dispose_module" 399 external dispose_module : llmodule -> unit = "llvm_dispose_module"
316 external target_triple: llmodule -> string 400 external target_triple: llmodule -> string
459 (*--... Operations on metadata .......,.....................................--*) 543 (*--... Operations on metadata .......,.....................................--*)
460 external mdstring : llcontext -> string -> llvalue = "llvm_mdstring" 544 external mdstring : llcontext -> string -> llvalue = "llvm_mdstring"
461 external mdnode : llcontext -> llvalue array -> llvalue = "llvm_mdnode" 545 external mdnode : llcontext -> llvalue array -> llvalue = "llvm_mdnode"
462 external mdnull : llcontext -> llvalue = "llvm_mdnull" 546 external mdnull : llcontext -> llvalue = "llvm_mdnull"
463 external get_mdstring : llvalue -> string option = "llvm_get_mdstring" 547 external get_mdstring : llvalue -> string option = "llvm_get_mdstring"
548 external get_mdnode_operands : llvalue -> llvalue array
549 = "llvm_get_mdnode_operands"
464 external get_named_metadata : llmodule -> string -> llvalue array 550 external get_named_metadata : llmodule -> string -> llvalue array
465 = "llvm_get_namedmd" 551 = "llvm_get_namedmd"
466 external add_named_metadata_operand : llmodule -> string -> llvalue -> unit 552 external add_named_metadata_operand : llmodule -> string -> llvalue -> unit
467 = "llvm_append_namedmd" 553 = "llvm_append_namedmd"
468 554
734 | After fn -> fold_right_function_range f (function_pred fn) e (f fn init) 820 | After fn -> fold_right_function_range f (function_pred fn) e (f fn init)
735 821
736 let fold_right_functions f m init = 822 let fold_right_functions f m init =
737 fold_right_function_range f (function_end m) (At_start m) init 823 fold_right_function_range f (function_end m) (At_start m) init
738 824
739 external llvm_add_function_attr : llvalue -> int32 -> unit 825 external llvm_add_function_attr : llvalue -> llattribute -> int -> unit
740 = "llvm_add_function_attr" 826 = "llvm_add_function_attr"
741 external llvm_remove_function_attr : llvalue -> int32 -> unit 827 external llvm_function_attrs : llvalue -> int -> llattribute array
742 = "llvm_remove_function_attr" 828 = "llvm_function_attrs"
743 external llvm_function_attr : llvalue -> int32 = "llvm_function_attr" 829 external llvm_remove_enum_function_attr : llvalue -> llattrkind -> int -> unit
744 830 = "llvm_remove_enum_function_attr"
745 let pack_attr (attr:Attribute.t) : int32 = 831 external llvm_remove_string_function_attr : llvalue -> string -> int -> unit
746 match attr with 832 = "llvm_remove_string_function_attr"
747 Attribute.Zext -> Int32.shift_left 1l 0 833
748 | Attribute.Sext -> Int32.shift_left 1l 1 834 let add_function_attr f a i =
749 | Attribute.Noreturn -> Int32.shift_left 1l 2 835 llvm_add_function_attr f a (AttrIndex.to_int i)
750 | Attribute.Inreg -> Int32.shift_left 1l 3 836 let function_attrs f i =
751 | Attribute.Structret -> Int32.shift_left 1l 4 837 llvm_function_attrs f (AttrIndex.to_int i)
752 | Attribute.Nounwind -> Int32.shift_left 1l 5 838 let remove_enum_function_attr f k i =
753 | Attribute.Noalias -> Int32.shift_left 1l 6 839 llvm_remove_enum_function_attr f k (AttrIndex.to_int i)
754 | Attribute.Byval -> Int32.shift_left 1l 7 840 let remove_string_function_attr f k i =
755 | Attribute.Nest -> Int32.shift_left 1l 8 841 llvm_remove_string_function_attr f k (AttrIndex.to_int i)
756 | Attribute.Readnone -> Int32.shift_left 1l 9
757 | Attribute.Readonly -> Int32.shift_left 1l 10
758 | Attribute.Noinline -> Int32.shift_left 1l 11
759 | Attribute.Alwaysinline -> Int32.shift_left 1l 12
760 | Attribute.Optsize -> Int32.shift_left 1l 13
761 | Attribute.Ssp -> Int32.shift_left 1l 14
762 | Attribute.Sspreq -> Int32.shift_left 1l 15
763 | Attribute.Alignment n -> Int32.shift_left (Int32.of_int n) 16
764 | Attribute.Nocapture -> Int32.shift_left 1l 21
765 | Attribute.Noredzone -> Int32.shift_left 1l 22
766 | Attribute.Noimplicitfloat -> Int32.shift_left 1l 23
767 | Attribute.Naked -> Int32.shift_left 1l 24
768 | Attribute.Inlinehint -> Int32.shift_left 1l 25
769 | Attribute.Stackalignment n -> Int32.shift_left (Int32.of_int n) 26
770 | Attribute.ReturnsTwice -> Int32.shift_left 1l 29
771 | Attribute.UWTable -> Int32.shift_left 1l 30
772 | Attribute.NonLazyBind -> Int32.shift_left 1l 31
773
774 let unpack_attr (a : int32) : Attribute.t list =
775 let l = ref [] in
776 let check attr =
777 Int32.logand (pack_attr attr) a in
778 let checkattr attr =
779 if (check attr) <> 0l then begin
780 l := attr :: !l
781 end
782 in
783 checkattr Attribute.Zext;
784 checkattr Attribute.Sext;
785 checkattr Attribute.Noreturn;
786 checkattr Attribute.Inreg;
787 checkattr Attribute.Structret;
788 checkattr Attribute.Nounwind;
789 checkattr Attribute.Noalias;
790 checkattr Attribute.Byval;
791 checkattr Attribute.Nest;
792 checkattr Attribute.Readnone;
793 checkattr Attribute.Readonly;
794 checkattr Attribute.Noinline;
795 checkattr Attribute.Alwaysinline;
796 checkattr Attribute.Optsize;
797 checkattr Attribute.Ssp;
798 checkattr Attribute.Sspreq;
799 let align = Int32.logand (Int32.shift_right_logical a 16) 31l in
800 if align <> 0l then
801 l := Attribute.Alignment (Int32.to_int align) :: !l;
802 checkattr Attribute.Nocapture;
803 checkattr Attribute.Noredzone;
804 checkattr Attribute.Noimplicitfloat;
805 checkattr Attribute.Naked;
806 checkattr Attribute.Inlinehint;
807 let stackalign = Int32.logand (Int32.shift_right_logical a 26) 7l in
808 if stackalign <> 0l then
809 l := Attribute.Stackalignment (Int32.to_int stackalign) :: !l;
810 checkattr Attribute.ReturnsTwice;
811 checkattr Attribute.UWTable;
812 checkattr Attribute.NonLazyBind;
813 !l;;
814
815 let add_function_attr llval attr =
816 llvm_add_function_attr llval (pack_attr attr)
817
818 external add_target_dependent_function_attr
819 : llvalue -> string -> string -> unit
820 = "llvm_add_target_dependent_function_attr"
821
822 let remove_function_attr llval attr =
823 llvm_remove_function_attr llval (pack_attr attr)
824
825 let function_attr f = unpack_attr (llvm_function_attr f)
826 842
827 (*--... Operations on params ...............................................--*) 843 (*--... Operations on params ...............................................--*)
828 external params : llvalue -> llvalue array = "llvm_params" 844 external params : llvalue -> llvalue array = "llvm_params"
829 external param : llvalue -> int -> llvalue = "llvm_param" 845 external param : llvalue -> int -> llvalue = "llvm_param"
830 external llvm_param_attr : llvalue -> int32 = "llvm_param_attr"
831 let param_attr p = unpack_attr (llvm_param_attr p)
832 external param_parent : llvalue -> llvalue = "LLVMGetParamParent" 846 external param_parent : llvalue -> llvalue = "LLVMGetParamParent"
833 external param_begin : llvalue -> (llvalue, llvalue) llpos = "llvm_param_begin" 847 external param_begin : llvalue -> (llvalue, llvalue) llpos = "llvm_param_begin"
834 external param_succ : llvalue -> (llvalue, llvalue) llpos = "llvm_param_succ" 848 external param_succ : llvalue -> (llvalue, llvalue) llpos = "llvm_param_succ"
835 external param_end : llvalue -> (llvalue, llvalue) llrev_pos = "llvm_param_end" 849 external param_end : llvalue -> (llvalue, llvalue) llrev_pos = "llvm_param_end"
836 external param_pred : llvalue -> (llvalue, llvalue) llrev_pos ="llvm_param_pred" 850 external param_pred : llvalue -> (llvalue, llvalue) llrev_pos ="llvm_param_pred"
872 | At_start _ -> raise (Invalid_argument "Invalid parameter range.") 886 | At_start _ -> raise (Invalid_argument "Invalid parameter range.")
873 | After p -> fold_right_param_range f (f p init) (param_pred p) e 887 | After p -> fold_right_param_range f (f p init) (param_pred p) e
874 888
875 let fold_right_params f fn init = 889 let fold_right_params f fn init =
876 fold_right_param_range f init (param_end fn) (At_start fn) 890 fold_right_param_range f init (param_end fn) (At_start fn)
877
878 external llvm_add_param_attr : llvalue -> int32 -> unit
879 = "llvm_add_param_attr"
880 external llvm_remove_param_attr : llvalue -> int32 -> unit
881 = "llvm_remove_param_attr"
882
883 let add_param_attr llval attr =
884 llvm_add_param_attr llval (pack_attr attr)
885
886 let remove_param_attr llval attr =
887 llvm_remove_param_attr llval (pack_attr attr)
888
889 external set_param_alignment : llvalue -> int -> unit
890 = "llvm_set_param_alignment"
891 891
892 (*--... Operations on basic blocks .........................................--*) 892 (*--... Operations on basic blocks .........................................--*)
893 external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue" 893 external value_of_block : llbasicblock -> llvalue = "LLVMBasicBlockAsValue"
894 external value_is_block : llvalue -> bool = "llvm_value_is_block" 894 external value_is_block : llvalue -> bool = "llvm_value_is_block"
895 external block_of_value : llvalue -> llbasicblock = "LLVMValueAsBasicBlock" 895 external block_of_value : llvalue -> llbasicblock = "LLVMValueAsBasicBlock"
1018 external instruction_call_conv: llvalue -> int 1018 external instruction_call_conv: llvalue -> int
1019 = "llvm_instruction_call_conv" 1019 = "llvm_instruction_call_conv"
1020 external set_instruction_call_conv: int -> llvalue -> unit 1020 external set_instruction_call_conv: int -> llvalue -> unit
1021 = "llvm_set_instruction_call_conv" 1021 = "llvm_set_instruction_call_conv"
1022 1022
1023 external llvm_add_instruction_param_attr : llvalue -> int -> int32 -> unit 1023 external llvm_add_call_site_attr : llvalue -> llattribute -> int -> unit
1024 = "llvm_add_instruction_param_attr" 1024 = "llvm_add_call_site_attr"
1025 external llvm_remove_instruction_param_attr : llvalue -> int -> int32 -> unit 1025 external llvm_call_site_attrs : llvalue -> int -> llattribute array
1026 = "llvm_remove_instruction_param_attr" 1026 = "llvm_call_site_attrs"
1027 1027 external llvm_remove_enum_call_site_attr : llvalue -> llattrkind -> int -> unit
1028 let add_instruction_param_attr llval i attr = 1028 = "llvm_remove_enum_call_site_attr"
1029 llvm_add_instruction_param_attr llval i (pack_attr attr) 1029 external llvm_remove_string_call_site_attr : llvalue -> string -> int -> unit
1030 1030 = "llvm_remove_string_call_site_attr"
1031 let remove_instruction_param_attr llval i attr = 1031
1032 llvm_remove_instruction_param_attr llval i (pack_attr attr) 1032 let add_call_site_attr f a i =
1033 llvm_add_call_site_attr f a (AttrIndex.to_int i)
1034 let call_site_attrs f i =
1035 llvm_call_site_attrs f (AttrIndex.to_int i)
1036 let remove_enum_call_site_attr f k i =
1037 llvm_remove_enum_call_site_attr f k (AttrIndex.to_int i)
1038 let remove_string_call_site_attr f k i =
1039 llvm_remove_string_call_site_attr f k (AttrIndex.to_int i)
1033 1040
1034 (*--... Operations on call instructions (only) .............................--*) 1041 (*--... Operations on call instructions (only) .............................--*)
1035 external is_tail_call : llvalue -> bool = "llvm_is_tail_call" 1042 external is_tail_call : llvalue -> bool = "llvm_is_tail_call"
1036 external set_tail_call : bool -> llvalue -> unit = "llvm_set_tail_call" 1043 external set_tail_call : bool -> llvalue -> unit = "llvm_set_tail_call"
1037 1044