llvm.org GIT mirror llvm / 5371aa2
Allow passing around LLVMContext in ocaml. git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@79410 91177308-0d34-0410-b5e6-96231b3b80d8 Erick Tryzelaar 11 years ago
13 changed file(s) with 212 addition(s) and 143 deletion(s). Raw diff Collapse all Expand all
4444
4545 /*===-- Modules -----------------------------------------------------------===*/
4646
47 /* Llvm.llmemorybuffer -> Llvm.module */
48 CAMLprim value llvm_get_module_provider(LLVMMemoryBufferRef MemBuf) {
47 /* Llvm.llcontext -> Llvm.llmemorybuffer -> Llvm.llmodule */
48 CAMLprim value llvm_get_module_provider(LLVMContextRef C,
49 LLVMMemoryBufferRef MemBuf) {
4950 CAMLparam0();
5051 CAMLlocal2(Variant, MessageVal);
5152 char *Message;
5253
5354 LLVMModuleProviderRef MP;
54 if (LLVMGetBitcodeModuleProvider(MemBuf, &MP, &Message))
55 if (LLVMGetBitcodeModuleProviderInContext(C, MemBuf, &MP, &Message))
5556 llvm_raise(llvm_bitreader_error_exn, Message);
5657
5758 CAMLreturn((value) MemBuf);
5859 }
5960
60 /* Llvm.llmemorybuffer -> Llvm.llmodule */
61 CAMLprim value llvm_parse_bitcode(LLVMMemoryBufferRef MemBuf) {
61 /* Llvm.llcontext -> Llvm.llmemorybuffer -> Llvm.llmodule */
62 CAMLprim value llvm_parse_bitcode(LLVMContextRef C,
63 LLVMMemoryBufferRef MemBuf) {
6264 CAMLparam0();
6365 CAMLlocal2(Variant, MessageVal);
6466 LLVMModuleRef M;
6567 char *Message;
6668
67 if (LLVMParseBitcode(MemBuf, &M, &Message))
69 if (LLVMParseBitcodeInContext(C, MemBuf, &M, &Message))
6870 llvm_raise(llvm_bitreader_error_exn, Message);
6971
7072 CAMLreturn((value) M);
1212 external register_exns : exn -> unit = "llvm_register_bitreader_exns"
1313 let _ = register_exns (Error "")
1414
15 external get_module_provider : Llvm.llmemorybuffer -> Llvm.llmoduleprovider
15 external get_module_provider : Llvm.llcontext -> Llvm.llmemorybuffer ->
16 Llvm.llmoduleprovider
1617 = "llvm_get_module_provider"
17 external parse_bitcode : Llvm.llmemorybuffer -> Llvm.llmodule
18
19 external parse_bitcode : Llvm.llcontext -> Llvm.llmemorybuffer -> Llvm.llmodule
1820 = "llvm_parse_bitcode"
1313
1414 exception Error of string
1515
16 (** [read_bitcode_file path] reads the bitcode for a new module [m] from the
17 file at [path]. Returns [Success m] if successful, and [Failure msg]
18 otherwise, where [msg] is a description of the error encountered.
19 See the function [llvm::getBitcodeModuleProvider]. *)
20 external get_module_provider : Llvm.llmemorybuffer -> Llvm.llmoduleprovider
16 (** [get_module_provider context mb] reads the bitcode for a new
17 module provider [m] from the memory buffer [mb] in the context [context].
18 Returns [m] if successful, or raises [Error msg] otherwise, where [msg] is a
19 description of the error encountered. See the function
20 [llvm::getBitcodeModuleProvider]. *)
21 external get_module_provider : Llvm.llcontext -> Llvm.llmemorybuffer ->
22 Llvm.llmoduleprovider
2123 = "llvm_get_module_provider"
2224
23 (** [parse_bitcode mb] parses the bitcode for a new module [m] from the memory
24 buffer [mb]. Returns [Success m] if successful, and [Failure msg] otherwise,
25 where [msg] is a description of the error encountered.
26 See the function [llvm::ParseBitcodeFile]. *)
27 external parse_bitcode : Llvm.llmemorybuffer -> Llvm.llmodule
25 (** [parse_bitcode context mb] parses the bitcode for a new module [m] from the
26 memory buffer [mb] in the context [context]. Returns [m] if successful, or
27 raises [Error msg] otherwise, where [msg] is a description of the error
28 encountered. See the function [llvm::ParseBitcodeFile]. *)
29 external parse_bitcode : Llvm.llcontext -> Llvm.llmemorybuffer -> Llvm.llmodule
2830 = "llvm_parse_bitcode"
77 *===----------------------------------------------------------------------===*)
88
99
10 type llcontext
1011 type llmodule
1112 type lltype
1213 type lltypehandle
126127 | At_start of 'a
127128 | After of 'b
128129
130 (*===-- Contexts ----------------------------------------------------------===*)
131 external create_context : unit -> llcontext = "llvm_create_context"
132 external dispose_context : unit -> llcontext = "llvm_dispose_context"
133 external global_context : unit -> llcontext = "llvm_global_context"
129134
130135 (*===-- Modules -----------------------------------------------------------===*)
131
132 external create_module : string -> llmodule = "llvm_create_module"
136 external create_module : llcontext -> string -> llmodule = "llvm_create_module"
133137 external dispose_module : llmodule -> unit = "llvm_dispose_module"
134138 external target_triple: llmodule -> string
135139 = "llvm_target_triple"
146150 external dump_module : llmodule -> unit = "llvm_dump_module"
147151
148152 (*===-- Types -------------------------------------------------------------===*)
149
150153 external classify_type : lltype -> TypeKind.t = "llvm_classify_type"
154 external type_context : lltype -> llcontext = "llvm_type_context"
151155
152156 (*--... Operations on integer types ........................................--*)
153157 external _i1_type : unit -> lltype = "llvm_i1_type"
187191 external param_types : lltype -> lltype array = "llvm_param_types"
188192
189193 (*--... Operations on struct types .........................................--*)
190 external struct_type : lltype array -> lltype = "llvm_struct_type"
191 external packed_struct_type : lltype array -> lltype = "llvm_packed_struct_type"
194 external struct_type : llcontext -> lltype array -> lltype = "llvm_struct_type"
195 external packed_struct_type : llcontext -> lltype array -> lltype
196 = "llvm_packed_struct_type"
192197 external element_types : lltype -> lltype array = "llvm_element_types"
193198 external is_packed : lltype -> bool = "llvm_is_packed"
194199
246251 external const_string : string -> llvalue = "llvm_const_string"
247252 external const_stringz : string -> llvalue = "llvm_const_stringz"
248253 external const_array : lltype -> llvalue array -> llvalue = "llvm_const_array"
249 external const_struct : llvalue array -> llvalue = "llvm_const_struct"
250 external const_packed_struct : llvalue array -> llvalue
254 external const_struct : llcontext -> llvalue array -> llvalue
255 = "llvm_const_struct"
256 external const_packed_struct : llcontext -> llvalue array -> llvalue
251257 = "llvm_const_packed_struct"
252258 external const_vector : llvalue array -> llvalue = "llvm_const_vector"
253259
653659
654660
655661 (*===-- Instruction builders ----------------------------------------------===*)
656 external builder : unit -> llbuilder = "llvm_builder"
662 external builder : llcontext -> llbuilder = "llvm_builder"
657663 external position_builder : (llbasicblock, llvalue) llpos -> llbuilder -> unit
658664 = "llvm_position_builder"
659665 external insertion_block : llbuilder -> llbasicblock = "llvm_insertion_block"
660666 external insert_into_builder : llvalue -> string -> llbuilder -> unit
661667 = "llvm_insert_into_builder"
662668
663 let builder_at ip =
664 let b = builder () in
669 let builder_at context ip =
670 let b = builder context in
665671 position_builder ip b;
666672 b
667673
668 let builder_before i = builder_at (Before i)
669 let builder_at_end bb = builder_at (At_end bb)
674 let builder_before context i = builder_at context (Before i)
675 let builder_at_end context bb = builder_at context (At_end bb)
670676
671677 let position_before i = position_builder (Before i)
672678 let position_at_end bb = position_builder (At_end bb)
1515 (** {6 Abstract types}
1616
1717 These abstract types correlate directly to the LLVM VMCore classes. *)
18
19 (** The top-level container for all LLVM global data. See the
20 [llvm::LLVMContext] class. *)
21 type llcontext
1822
1923 (** The top-level container for all other LLVM Intermediate Representation (IR)
2024 objects. See the [llvm::Module] class. *)
187191 exception IoError of string
188192
189193
194 (** {6 Contexts} *)
195
196 (** [create_context ()] creates a context for storing the "global" state in
197 LLVM. See the constructor [llvm::LLVMContext]. *)
198 external create_context : unit -> llcontext = "llvm_create_context"
199
200 (** [destroy_context ()] destroys a context. See the destructor
201 [llvm::LLVMContext::~LLVMContext]. *)
202 external dispose_context : unit -> llcontext = "llvm_dispose_context"
203
204 (** See the function [llvm::getGlobalContext]. *)
205 external global_context : unit -> llcontext = "llvm_global_context"
206
207
190208 (** {6 Modules} *)
191209
192 (** [create_module id] creates a module with the supplied module ID. Modules are
193 not garbage collected; it is mandatory to call {!dispose_module} to free
194 memory. See the constructor [llvm::Module::Module]. *)
195 external create_module : string -> llmodule = "llvm_create_module"
210 (** [create_module context id] creates a module with the supplied module ID in
211 the context [context]. Modules are not garbage collected; it is mandatory
212 to call {!dispose_module} to free memory. See the constructor
213 [llvm::Module::Module]. *)
214 external create_module : llcontext -> string -> llmodule = "llvm_create_module"
196215
197216 (** [dispose_module m] destroys a module [m] and all of the IR objects it
198217 contained. All references to subordinate objects are invalidated;
244263 See the method [llvm::Type::getTypeID]. *)
245264 external classify_type : lltype -> TypeKind.t = "llvm_classify_type"
246265
266 (** [type_context ty] returns the {!llcontext} corresponding to the type [ty].
267 See the method [llvm::Type::getContext]. *)
268 external type_context : lltype -> llcontext = "llvm_type_context"
269
247270 (** [string_of_lltype ty] returns a string describing the type [ty]. *)
248271 val string_of_lltype : lltype -> string
249272
320343
321344 (** {7 Operations on struct types} *)
322345
323 (** [struct_type tys] returns the structure type containing in the types in the
324 array [tys]. See the method [llvm::StructType::get]. *)
325 external struct_type : lltype array -> lltype = "llvm_struct_type"
326
327 (** [packed_struct_type tys] returns the packed structure type containing in the
328 types in the array [tys]. See the method [llvm::StructType::get]. *)
329 external packed_struct_type : lltype array -> lltype = "llvm_packed_struct_type"
346 (** [struct_type context tys] returns the structure type in the context
347 [context] containing in the types in the array [tys]. See the method
348 [llvm::StructType::get]. *)
349 external struct_type : llcontext -> lltype array -> lltype
350 = "llvm_struct_type"
351
352 (** [packed_struct_type context ys] returns the packed structure type in the
353 context [context] containing in the types in the array [tys]. See the method
354 [llvm::StructType::get]. *)
355 external packed_struct_type : llcontext -> lltype array -> lltype
356 = "llvm_packed_struct_type"
330357
331358 (** [element_types sty] returns the constituent types of the struct type [sty].
332359 See the method [llvm::StructType::getElementType]. *)
503530 See the method [llvm::ConstantArray::get]. *)
504531 external const_array : lltype -> llvalue array -> llvalue = "llvm_const_array"
505532
506 (** [const_struct elts] returns the structured constant of type
507 [struct_type (Array.map type_of elts)] and containing the values [elts].
508 This value can in turn be used as the initializer for a global variable.
509 See the method [llvm::ConstantStruct::get]. *)
510 external const_struct : llvalue array -> llvalue = "llvm_const_struct"
511
512 (** [const_packed_struct elts] returns the structured constant of type
513 {!packed_struct_type} [(Array.map type_of elts)] and containing the values
514 [elts]. This value can in turn be used as the initializer for a global
515 variable. See the method [llvm::ConstantStruct::get]. *)
516 external const_packed_struct : llvalue array -> llvalue
533 (** [const_struct context elts] returns the structured constant of type
534 [struct_type (Array.map type_of elts)] and containing the values [elts]
535 in the context [context]. This value can in turn be used as the initializer
536 for a global variable. See the method [llvm::ConstantStruct::get]. *)
537 external const_struct : llcontext -> llvalue array -> llvalue
538 = "llvm_const_struct"
539
540 (** [const_packed_struct context elts] returns the structured constant of
541 type {!packed_struct_type} [(Array.map type_of elts)] and containing the
542 values [elts] in the context [context]. This value can in turn be used as
543 the initializer for a global variable. See the method
544 [llvm::ConstantStruct::get]. *)
545 external const_packed_struct : llcontext -> llvalue array -> llvalue
517546 = "llvm_const_packed_struct"
518547
519548 (** [const_vector elts] returns the vector constant of type
589618
590619 (** [const_exact_sdiv c1 c2] returns the constant quotient [c1 / c2] of two
591620 signed integer constants. The result is undefined if the result is rounded
592 or overflows. See the method [llvm::ConstantExpr::getExactSDiv]. *)
621 or overflows. See the method [llvm::ConstantExpr::getExactSDiv]. *)
593622 external const_exact_sdiv : llvalue -> llvalue -> llvalue = "LLVMConstExactSDiv"
594623
595624 (** [const_fdiv c1 c2] returns the constant quotient [c1 / c2] of two floating
756785 = "LLVMConstIntCast"
757786
758787 (** [const_fpcast c ty] returns a constant fpext, bitcast, or fptrunc for fp ->
759 fp casts of constant [c] to type [ty].
788 fp casts of constant [c] to type [ty].
760789 See the method [llvm::ConstantExpr::getFPCast]. *)
761790 external const_fpcast : llvalue -> lltype -> llvalue
762791 = "LLVMConstFPCast"
12961325
12971326 (** {6 Instruction builders} *)
12981327
1299 (** [builder ()] creates an instruction builder with no position. It is invalid
1300 to use this builder until its position is set with {!position_before} or
1301 {!position_at_end}. See the constructor for [llvm::LLVMBuilder]. *)
1302 external builder : unit -> llbuilder = "llvm_builder"
1328 (** [builder context] creates an instruction builder with no position in
1329 the context [context]. It is invalid to use this builder until its position
1330 is set with {!position_before} or {!position_at_end}. See the constructor
1331 for [llvm::LLVMBuilder]. *)
1332 external builder : llcontext -> llbuilder = "llvm_builder"
13031333
13041334 (** [builder_at ip] creates an instruction builder positioned at [ip].
13051335 See the constructor for [llvm::LLVMBuilder]. *)
1306 val builder_at : (llbasicblock, llvalue) llpos -> llbuilder
1336 val builder_at : llcontext -> (llbasicblock, llvalue) llpos -> llbuilder
13071337
13081338 (** [builder_before ins] creates an instruction builder positioned before the
13091339 instruction [isn]. See the constructor for [llvm::LLVMBuilder]. *)
1310 val builder_before : llvalue -> llbuilder
1340 val builder_before : llcontext -> llvalue -> llbuilder
13111341
13121342 (** [builder_at_end bb] creates an instruction builder positioned at the end of
13131343 the basic block [bb]. See the constructor for [llvm::LLVMBuilder]. *)
1314 val builder_at_end : llbasicblock -> llbuilder
1344 val builder_at_end : llcontext -> llbasicblock -> llbuilder
13151345
13161346 (** [position_builder ip bb] moves the instruction builder [bb] to the position
13171347 [ip].
16471677
16481678 (** [build_global_stringptr str name b] creates a series of instructions that
16491679 adds a global string pointer at the position specified by the instruction
1650 builder [b].
1680 builder [b].
16511681 See the method [llvm::LLVMBuilder::CreateGlobalStringPtr]. *)
16521682 external build_global_stringptr : string -> string -> llbuilder -> llvalue
16531683 = "llvm_build_global_stringptr"
18751905
18761906 (** [build_ptrdiff lhs rhs name b] creates a series of instructions that measure
18771907 the difference between two pointer values at the position specified by the
1878 instruction builder [b].
1908 instruction builder [b].
18791909 See the method [llvm::LLVMBuilder::CreatePtrDiff]. *)
18801910 external build_ptrdiff : llvalue -> llvalue -> string -> llbuilder -> llvalue
18811911 = "llvm_build_ptrdiff"
9191 }
9292
9393
94 /*===-- Contexts ----------------------------------------------------------===*/
95
96 /* unit -> llcontext */
97 CAMLprim LLVMContextRef llvm_create_context(value Unit) {
98 return LLVMContextCreate();
99 }
100
101 /* llcontext -> unit */
102 CAMLprim value llvm_dispose_context(LLVMContextRef C) {
103 LLVMContextDispose(C);
104 return Val_unit;
105 }
106
107 /* unit -> llcontext */
108 CAMLprim LLVMContextRef llvm_global_context(value Unit) {
109 return LLVMGetGlobalContext();
110 }
111
94112 /*===-- Modules -----------------------------------------------------------===*/
95113
96114 /* string -> llmodule */
150168 /* lltype -> TypeKind.t */
151169 CAMLprim value llvm_classify_type(LLVMTypeRef Ty) {
152170 return Val_int(LLVMGetTypeKind(Ty));
171 }
172
173 /* lltype -> llcontext */
174 CAMLprim LLVMContextRef llvm_type_context(LLVMTypeRef Ty) {
175 return LLVMGetTypeContext(Ty);
153176 }
154177
155178 /*--... Operations on integer types ........................................--*/
227250
228251 /*--... Operations on struct types .........................................--*/
229252
230 /* lltype array -> lltype */
231 CAMLprim LLVMTypeRef llvm_struct_type(value ElementTypes) {
232 return LLVMStructType((LLVMTypeRef *) ElementTypes,
233 Wosize_val(ElementTypes), 0);
234 }
235
236 /* lltype array -> lltype */
237 CAMLprim LLVMTypeRef llvm_packed_struct_type(value ElementTypes) {
238 return LLVMStructType((LLVMTypeRef *) ElementTypes,
239 Wosize_val(ElementTypes), 1);
253 /* llcontext -> lltype array -> lltype */
254 CAMLprim LLVMTypeRef llvm_struct_type(LLVMContextRef C, value ElementTypes) {
255 return LLVMStructTypeInContext(C, (LLVMTypeRef *) ElementTypes,
256 Wosize_val(ElementTypes), 0);
257 }
258
259 /* llcontext -> lltype array -> lltype */
260 CAMLprim LLVMTypeRef llvm_packed_struct_type(LLVMContextRef C,
261 value ElementTypes) {
262 return LLVMStructTypeInContext(C, (LLVMTypeRef *) ElementTypes,
263 Wosize_val(ElementTypes), 1);
240264 }
241265
242266 /* lltype -> lltype array */
424448 Wosize_val(ElementVals));
425449 }
426450
427 /* llvalue array -> llvalue */
428 CAMLprim LLVMValueRef llvm_const_struct(value ElementVals) {
429 return LLVMConstStruct((LLVMValueRef *) Op_val(ElementVals),
430 Wosize_val(ElementVals), 0);
431 }
432
433 /* llvalue array -> llvalue */
434 CAMLprim LLVMValueRef llvm_const_packed_struct(value ElementVals) {
435 return LLVMConstStruct((LLVMValueRef *) Op_val(ElementVals),
436 Wosize_val(ElementVals), 1);
451 /* llcontext -> llvalue array -> llvalue */
452 CAMLprim LLVMValueRef llvm_const_struct(LLVMContextRef C, value ElementVals) {
453 return LLVMConstStructInContext(C, (LLVMValueRef *) Op_val(ElementVals),
454 Wosize_val(ElementVals), 0);
455 }
456
457 /* llcontext -> llvalue array -> llvalue */
458 CAMLprim LLVMValueRef llvm_const_packed_struct(LLVMContextRef C,
459 value ElementVals) {
460 return LLVMConstStructInContext(C, (LLVMValueRef *) Op_val(ElementVals),
461 Wosize_val(ElementVals), 1);
437462 }
438463
439464 /* llvalue array -> llvalue */
904929 return V;
905930 }
906931
907 /* unit-> llbuilder */
908 CAMLprim value llvm_builder(value Unit) {
909 return alloc_builder(LLVMCreateBuilder());
932 /* llcontext -> llbuilder */
933 CAMLprim value llvm_builder(LLVMContextRef C) {
934 return alloc_builder(LLVMCreateBuilderInContext(C));
910935 }
911936
912937 /* (llbasicblock, llvalue) llpos -> llbuilder -> unit */
1515
1616 let _ =
1717 let fty = function_type void_type [| |] in
18 let m = create_module "valid_m" in
18 let m = create_module (global_context ()) "valid_m" in
1919 let fn = define_function "valid_fn" fty m in
20 let at_entry = builder_at_end (entry_block fn) in
20 let at_entry = builder_at_end (global_context ()) (entry_block fn) in
2121 ignore (build_ret_void at_entry);
2222
2323
55 (* Note that this takes a moment to link, so it's best to keep the number of
66 individual tests low. *)
77
8 let context = Llvm.global_context ()
9
810 let test x = if not x then exit 1 else ()
911
1012 let _ =
1113 let fn = Sys.argv.(1) in
12 let m = Llvm.create_module "ocaml_test_module" in
14 let m = Llvm.create_module context "ocaml_test_module" in
1315
1416 ignore (Llvm.define_type_name "caml_int_ty" Llvm.i32_type m);
1517
2123 begin
2224 let mb = Llvm.MemoryBuffer.of_file fn in
2325 begin try
24 let m = Llvm_bitreader.parse_bitcode mb in
26 let m = Llvm_bitreader.parse_bitcode context mb in
2527 Llvm.dispose_module m
2628 with x ->
2729 Llvm.MemoryBuffer.dispose mb;
4244 begin
4345 let mb = Llvm.MemoryBuffer.of_file fn in
4446 let mp = begin try
45 Llvm_bitreader.get_module_provider mb
47 Llvm_bitreader.get_module_provider context mb
4648 with x ->
4749 Llvm.MemoryBuffer.dispose mb;
4850 raise x
6264 try
6365 let mb = Llvm.MemoryBuffer.of_file fn in
6466 let mp = begin try
65 Llvm_bitreader.get_module_provider mb
67 Llvm_bitreader.get_module_provider context mb
6668 with x ->
6769 Llvm.MemoryBuffer.dispose mb;
6870 raise x
88 let test x = if not x then exit 1 else ()
99
1010 let _ =
11 let m = Llvm.create_module "ocaml_test_module" in
11 let m = Llvm.create_module (Llvm.global_context ()) "ocaml_test_module" in
1212
1313 ignore (Llvm.define_type_name "caml_int_ty" Llvm.i32_type m);
1414
1818 define_function "main" (function_type i32_type [| i32_type;
1919 str_arr_type;
2020 str_arr_type |]) m in
21 let b = builder_at_end (entry_block fn) in
21 let b = builder_at_end (global_context ()) (entry_block fn) in
2222 ignore (build_ret (const_int i32_type retval) b);
2323 fn
2424
2525 let define_plus m =
2626 let fn = define_function "plus" (function_type i32_type [| i32_type;
2727 i32_type |]) m in
28 let b = builder_at_end (entry_block fn) in
28 let b = builder_at_end (global_context ()) (entry_block fn) in
2929 let add = build_add (param fn 0) (param fn 1) "sum" b in
3030 ignore (build_ret add b)
3131
5151
5252 let test_executionengine () =
5353 (* create *)
54 let m = create_module "test_module" in
54 let m = create_module (global_context ()) "test_module" in
5555 let main = define_main_fn m 42 in
5656
57 let m2 = create_module "test_module2" in
57 let m2 = create_module (global_context ()) "test_module2" in
5858 define_plus m2;
5959
6060 let ee = ExecutionEngine.create (ModuleProvider.create m) in
1818 (*===-- Fixture -----------------------------------------------------------===*)
1919
2020 let filename = Sys.argv.(1)
21 let m = create_module filename
21 let m = create_module (global_context ()) filename
2222 let mp = ModuleProvider.create m
2323
2424
2929
3030 let fty = function_type void_type [| |] in
3131 let fn = define_function "fn" fty m in
32 ignore (build_ret_void (builder_at_end (entry_block fn)));
32 ignore (build_ret_void (builder_at_end (global_context ()) (entry_block fn)));
3333
3434 let td = TargetData.create (target_triple m) in
3535
77 open Llvm
88 open Llvm_target
99
10
1110 (* Tiny unit test framework - really just to help find which line is busted *)
1211 let suite name f =
1312 prerr_endline (name ^ ":");
1716 (*===-- Fixture -----------------------------------------------------------===*)
1817
1918 let filename = Sys.argv.(1)
20 let m = create_module filename
19 let m = create_module (global_context ()) filename
2120
2221
2322 (*===-- Target Data -------------------------------------------------------===*)
2423
2524 let test_target_data () =
2625 let td = TargetData.create (target_triple m) in
27 let sty = struct_type [| i32_type; i64_type |] in
26 let sty = struct_type (global_context ()) [| i32_type; i64_type |] in
2827
2928 ignore (TargetData.as_string td);
3029 ignore (TargetData.invalidate_struct_layout td sty);
1616 let group_name = ref ""
1717 let case_num = ref 0
1818 let print_checkpoints = false
19 let context = global_context ()
1920
2021 let group name =
2122 group_name := !suite_name ^ "/" ^ name;
4647 (*===-- Fixture -----------------------------------------------------------===*)
4748
4849 let filename = Sys.argv.(1)
49 let m = create_module filename
50 let m = create_module context filename
5051 let mp = ModuleProvider.create m
5152
5253
269270 one; two; one; two |] in
270271 ignore (define_global "Const08" c m);
271272 insist ((vector_type i16_type 8) = (type_of c));
272
273
273274 (* RUN: grep {Const09.*.i16 1, i16 2, i32 3, i32 4} < %t.ll
274275 *)
275276 group "structure";
276 let c = const_struct [| one; two; three; four |] in
277 let c = const_struct context [| one; two; three; four |] in
277278 ignore (define_global "Const09" c m);
278 insist ((struct_type [| i16_type; i16_type; i32_type; i32_type |])
279 insist ((struct_type context [| i16_type; i16_type; i32_type; i32_type |])
279280 = (type_of c));
280281
281282 (* RUN: grep {Const10.*zeroinit} < %t.ll
282283 *)
283284 group "null";
284 let c = const_null (packed_struct_type [| i1_type; i8_type;
285 i64_type; double_type |]) in
285 let c = const_null (packed_struct_type context [| i1_type; i8_type; i64_type;
286 double_type |]) in
286287 ignore (define_global "Const10" c m);
287288
288289 (* RUN: grep {Const11.*-1} < %t.ll
495496 insist (is_global_constant g);
496497
497498 begin group "iteration";
498 let m = create_module "temp" in
499 let m = create_module context "temp" in
499500
500501 insist (At_end m = global_begin m);
501502 insist (At_start m = global_end m);
555556 let fn = define_function "Fn3" ty m in
556557 insist (not (is_declaration fn));
557558 insist (1 = Array.length (basic_blocks fn));
558 ignore (build_unreachable (builder_at_end (entry_block fn)));
559 ignore (build_unreachable (builder_at_end context (entry_block fn)));
559560
560561 (* RUN: grep {define.*Fn4.*Param1.*Param2} < %t.ll
561562 *)
569570 insist (i64_type = type_of params.(1));
570571 set_value_name "Param1" params.(0);
571572 set_value_name "Param2" params.(1);
572 ignore (build_unreachable (builder_at_end (entry_block fn)));
573 ignore (build_unreachable (builder_at_end context (entry_block fn)));
573574
574575 (* RUN: grep {fastcc.*Fn5} < %t.ll
575576 *)
578579 insist (CallConv.c = function_call_conv fn);
579580 set_function_call_conv CallConv.fast fn;
580581 insist (CallConv.fast = function_call_conv fn);
581 ignore (build_unreachable (builder_at_end (entry_block fn)));
582 ignore (build_unreachable (builder_at_end context (entry_block fn)));
582583
583584 begin group "gc";
584585 (* RUN: grep {Fn6.*gc.*shadowstack} < %t.ll
590591 set_gc None fn;
591592 insist (None = gc fn);
592593 set_gc (Some "shadowstack") fn;
593 ignore (build_unreachable (builder_at_end (entry_block fn)));
594 ignore (build_unreachable (builder_at_end context (entry_block fn)));
594595 end;
595596
596597 begin group "iteration";
597 let m = create_module "temp" in
598 let m = create_module context "temp" in
598599
599600 insist (At_end m = function_begin m);
600601 insist (At_start m = function_end m);
624625
625626 let test_params () =
626627 begin group "iteration";
627 let m = create_module "temp" in
628 let m = create_module context "temp" in
628629
629630 let vf = define_function "void" (function_type void_type [| |]) m in
630631
673674 let fn = declare_function "X" ty m in
674675 let bb = append_block "Bb1" fn in
675676 insist (bb = entry_block fn);
676 ignore (build_unreachable (builder_at_end bb));
677 ignore (build_unreachable (builder_at_end context bb));
677678
678679 (* RUN: grep -v Bb2 < %t.ll
679680 *)
687688 let bbb = append_block "b" fn in
688689 let bba = insert_block "a" bbb in
689690 insist ([| bba; bbb |] = basic_blocks fn);
690 ignore (build_unreachable (builder_at_end bba));
691 ignore (build_unreachable (builder_at_end bbb));
691 ignore (build_unreachable (builder_at_end context bba));
692 ignore (build_unreachable (builder_at_end context bbb));
692693
693694 (* RUN: grep Bb3 < %t.ll
694695 *)
695696 group "name/value";
696697 let fn = define_function "X4" ty m in
697698 let bb = entry_block fn in
698 ignore (build_unreachable (builder_at_end bb));
699 ignore (build_unreachable (builder_at_end context bb));
699700 let bbv = value_of_block bb in
700701 set_value_name "Bb3" bbv;
701702 insist ("Bb3" = value_name bbv);
703704 group "casts";
704705 let fn = define_function "X5" ty m in
705706 let bb = entry_block fn in
706 ignore (build_unreachable (builder_at_end bb));
707 ignore (build_unreachable (builder_at_end context bb));
707708 insist (bb = block_of_value (value_of_block bb));
708709 insist (value_is_block (value_of_block bb));
709710 insist (not (value_is_block (const_null i32_type)));
710711
711712 begin group "iteration";
712 let m = create_module "temp" in
713 let m = create_module context "temp" in
713714 let f = declare_function "Temp" (function_type i32_type [| |]) m in
714715
715716 insist (At_end f = block_begin f);
740741
741742 let test_instructions () =
742743 begin group "iteration";
743 let m = create_module "temp" in
744 let m = create_module context "temp" in
744745 let fty = function_type void_type [| i32_type; i32_type |] in
745746 let f = define_function "f" fty m in
746747 let bb = entry_block f in
747 let b = builder_at (At_end bb) in
748 let b = builder_at context (At_end bb) in
748749
749750 insist (At_end bb = instr_begin bb);
750751 insist (At_start bb = instr_end bb);
777778
778779 begin group "parent";
779780 insist (try
780 ignore (insertion_block (builder ()));
781 ignore (insertion_block (builder context));
781782 false
782783 with Not_found ->
783784 true);
785786 let fty = function_type void_type [| i32_type |] in
786787 let fn = define_function "BuilderParent" fty m in
787788 let bb = entry_block fn in
788 let b = builder_at_end bb in
789 let b = builder_at_end context bb in
789790 let p = param fn 0 in
790791 let sum = build_add p p "sum" b in
791792 ignore (build_ret_void b);
802803 *)
803804 let fty = function_type void_type [| |] in
804805 let fn = declare_function "X6" fty m in
805 let b = builder_at_end (append_block "Bb01" fn) in
806 let b = builder_at_end context (append_block "Bb01" fn) in
806807 ignore (build_ret_void b)
807808 end;
808809
809810 (* The rest of the tests will use one big function. *)
810811 let fty = function_type i32_type [| i32_type; i32_type |] in
811812 let fn = define_function "X7" fty m in
812 let atentry = builder_at_end (entry_block fn) in
813 let atentry = builder_at_end context (entry_block fn) in
813814 let p1 = param fn 0 ++ set_value_name "P1" in
814815 let p2 = param fn 1 ++ set_value_name "P2" in
815816 let f1 = build_uitofp p1 float_type "F1" atentry in
816817 let f2 = build_uitofp p2 float_type "F2" atentry in
817818
818819 let bb00 = append_block "Bb00" fn in
819 ignore (build_unreachable (builder_at_end bb00));
820 ignore (build_unreachable (builder_at_end context bb00));
820821
821822 group "ret"; begin
822823 (* RUN: grep {ret.*P1} < %t.ll
829830 (* RUN: grep {br.*Bb02} < %t.ll
830831 *)
831832 let bb02 = append_block "Bb02" fn in
832 let b = builder_at_end bb02 in
833 let b = builder_at_end context bb02 in
833834 ignore (build_br bb02 b)
834835 end;
835836
837838 (* RUN: grep {br.*Inst01.*Bb03.*Bb00} < %t.ll
838839 *)
839840 let bb03 = append_block "Bb03" fn in
840 let b = builder_at_end bb03 in
841 let b = builder_at_end context bb03 in
841842 let cond = build_trunc p1 i1_type "Inst01" b in
842843 ignore (build_cond_br cond bb03 bb00 b)
843844 end;
848849 *)
849850 let bb1 = append_block "SwiBlock1" fn in
850851 let bb2 = append_block "SwiBlock2" fn in
851 ignore (build_unreachable (builder_at_end bb2));
852 ignore (build_unreachable (builder_at_end context bb2));
852853 let bb3 = append_block "SwiBlock3" fn in
853 ignore (build_unreachable (builder_at_end bb3));
854 let si = build_switch p1 bb3 1 (builder_at_end bb1) in
854 ignore (build_unreachable (builder_at_end context bb3));
855 let si = build_switch p1 bb3 1 (builder_at_end context bb1) in
855856 ignore (add_case si (const_int i32_type 2) bb2)
856857 end;
857858
860861 * RUN: grep {to.*Bb04.*unwind.*Bb00} < %t.ll
861862 *)
862863 let bb04 = append_block "Bb04" fn in
863 let b = builder_at_end bb04 in
864 let b = builder_at_end context bb04 in
864865 ignore (build_invoke fn [| p1; p2 |] bb04 bb00 "Inst02" b)
865866 end;
866867
868869 (* RUN: grep {unwind} < %t.ll
869870 *)
870871 let bb05 = append_block "Bb05" fn in
871 let b = builder_at_end bb05 in
872 let b = builder_at_end context bb05 in
872873 ignore (build_unwind b)
873874 end;
874875
876877 (* RUN: grep {unreachable} < %t.ll
877878 *)
878879 let bb06 = append_block "Bb06" fn in
879 let b = builder_at_end bb06 in
880 let b = builder_at_end context bb06 in
880881 ignore (build_unreachable b)
881882 end;
882883
883884 group "arithmetic"; begin
884885 let bb07 = append_block "Bb07" fn in
885 let b = builder_at_end bb07 in
886 let b = builder_at_end context bb07 in
886887
887888 (* RUN: grep {Inst03.*add.*P1.*P2} < %t.ll
888889 * RUN: grep {Inst04.*sub.*P1.*Inst03} < %t.ll
924925
925926 group "memory"; begin
926927 let bb08 = append_block "Bb08" fn in
927 let b = builder_at_end bb08 in
928 let b = builder_at_end context bb08 in
928929
929930 (* RUN: grep {Inst20.*malloc.*i8 } < %t.ll
930931 * RUN: grep {Inst21.*malloc.*i8.*P1} < %t.ll
10361037 let b2 = append_block "PhiBlock2" fn in
10371038
10381039 let jb = append_block "PhiJoinBlock" fn in
1039 ignore (build_br jb (builder_at_end b1));
1040 ignore (build_br jb (builder_at_end b2));
1041 let at_jb = builder_at_end jb in
1040 ignore (build_br jb (builder_at_end context b1));
1041 ignore (build_br jb (builder_at_end context b2));
1042 let at_jb = builder_at_end context jb in
10421043
10431044 let phi = build_phi [(p1, b1)] "PhiNode" at_jb in
10441045 insist ([(p1, b1)] = incoming phi);
10531054 (*===-- Module Provider ---------------------------------------------------===*)
10541055
10551056 let test_module_provider () =
1056 let m = create_module "test" in
1057 let m = create_module context "test" in
10571058 let mp = ModuleProvider.create m in
10581059 ModuleProvider.dispose mp
10591060
10721073 begin group "function pass manager";
10731074 let fty = function_type void_type [| |] in
10741075 let fn = define_function "FunctionPassManager" fty m in
1075 ignore (build_ret_void (builder_at_end (entry_block fn)));
1076 ignore (build_ret_void (builder_at_end context (entry_block fn)));
10761077
10771078 ignore (PassManager.create_function mp
10781079 ++ PassManager.initialize