llvm.org GIT mirror llvm / b6703ff
[OCaml] Add Target and TargetMachine bindings to Llvm_target git-svn-id: https://llvm.org/svn/llvm-project/llvm/trunk@194774 91177308-0d34-0410-b5e6-96231b3b80d8 Peter Zotov 7 years ago
4 changed file(s) with 516 addition(s) and 3 deletion(s). Raw diff Collapse all Expand all
1111 | Big
1212 | Little
1313 end
14
15 module CodeGenOptLevel = struct
16 type t =
17 | None
18 | Less
19 | Default
20 | Aggressive
21 end
22
23 module RelocMode = struct
24 type t =
25 | Default
26 | Static
27 | PIC
28 | DynamicNoPIC
29 end
30
31 module CodeModel = struct
32 type t =
33 | Default
34 | JITDefault
35 | Small
36 | Kernel
37 | Medium
38 | Large
39 end
40
41 module CodeGenFileType = struct
42 type t =
43 | AssemblyFile
44 | ObjectFile
45 end
46
47 exception Error of string
48
49 external register_exns : exn -> unit = "llvm_register_target_exns"
50 let _ = register_exns (Error "")
1451
1552 module DataLayout = struct
1653 type t
4885 = "llvm_datalayout_offset_of_element"
4986 end
5087
88 module Target = struct
89 type t
90
91 external default_triple : unit -> string = "llvm_target_default_triple"
92 external first : unit -> t option = "llvm_target_first"
93 external succ : t -> t option = "llvm_target_succ"
94 external by_name : string -> t option = "llvm_target_by_name"
95 external by_triple : string -> t = "llvm_target_by_triple"
96 external name : t -> string = "llvm_target_name"
97 external description : t -> string = "llvm_target_description"
98 external has_jit : t -> bool = "llvm_target_has_jit"
99 external has_target_machine : t -> bool = "llvm_target_has_target_machine"
100 external has_asm_backend : t -> bool = "llvm_target_has_asm_backend"
101
102 let all () =
103 let rec step elem lst =
104 match elem with
105 | Some target -> step (succ target) (target :: lst)
106 | None -> lst
107 in
108 step (first ()) []
109 end
110
111 module TargetMachine = struct
112 type t
113
114 external create : triple:string -> ?cpu:string -> ?features:string ->
115 ?level:CodeGenOptLevel.t -> ?reloc_mode:RelocMode.t ->
116 ?code_model:CodeModel.t -> Target.t -> t
117 = "llvm_create_targetmachine_bytecode"
118 "llvm_create_targetmachine_native"
119 external target : t -> Target.t
120 = "llvm_targetmachine_target"
121 external triple : t -> string
122 = "llvm_targetmachine_triple"
123 external cpu : t -> string
124 = "llvm_targetmachine_cpu"
125 external features : t -> string
126 = "llvm_targetmachine_features"
127 external data_layout : t -> DataLayout.t
128 = "llvm_targetmachine_data_layout"
129 external set_verbose_asm : bool -> t -> unit
130 = "llvm_targetmachine_set_verbose_asm"
131 external emit_to_file : Llvm.llmodule -> CodeGenFileType.t -> string ->
132 t -> unit
133 = "llvm_targetmachine_emit_to_file"
134 external emit_to_memory_buffer : Llvm.llmodule -> CodeGenFileType.t ->
135 t -> Llvm.llmemorybuffer
136 = "llvm_targetmachine_emit_to_memory_buffer"
137 end
1717 | Little
1818 end
1919
20 module CodeGenOptLevel : sig
21 type t =
22 | None
23 | Less
24 | Default
25 | Aggressive
26 end
27
28 module RelocMode : sig
29 type t =
30 | Default
31 | Static
32 | PIC
33 | DynamicNoPIC
34 end
35
36 module CodeModel : sig
37 type t =
38 | Default
39 | JITDefault
40 | Small
41 | Kernel
42 | Medium
43 | Large
44 end
45
46 module CodeGenFileType : sig
47 type t =
48 | AssemblyFile
49 | ObjectFile
50 end
51
52 (** {6 Exceptions} *)
53
54 exception Error of string
55
56 (** {6 Data Layout} *)
57
2058 module DataLayout : sig
2159 type t
2260
92130 See the method [llvm::StructLayout::getElementContainingOffset]. *)
93131 val offset_of_element : Llvm.lltype -> int -> t -> Int64.t
94132 end
133
134 (** {6 Target} *)
135
136 module Target : sig
137 type t
138
139 (** [default_triple ()] returns the default target triple for current
140 platform. *)
141 val default_triple : unit -> string
142
143 (** [first ()] returns the first target in the registered targets
144 list, or [None]. *)
145 val first : unit -> t option
146
147 (** [succ t] returns the next target after [t], or [None]
148 if [t] was the last target. *)
149 val succ : t -> t option
150
151 (** [all ()] returns a list of known targets. *)
152 val all : unit -> t list
153
154 (** [by_name name] returns [Some t] if a target [t] named [name] is
155 registered, or [None] otherwise. *)
156 val by_name : string -> t option
157
158 (** [by_triple triple] returns a target for a triple [triple], or raises
159 [Error] if [triple] does not correspond to a registered target. *)
160 val by_triple : string -> t
161
162 (** Returns the name of a target. See [llvm::Target::getName]. *)
163 val name : t -> string
164
165 (** Returns the description of a target.
166 See [llvm::Target::getDescription]. *)
167 val description : t -> string
168
169 (** Returns [true] if the target has a JIT. *)
170 val has_jit : t -> bool
171
172 (** Returns [true] if the target has a target machine associated. *)
173 val has_target_machine : t -> bool
174
175 (** Returns [true] if the target has an ASM backend (required for
176 emitting output). *)
177 val has_asm_backend : t -> bool
178 end
179
180 (** {6 Target Machine} *)
181
182 module TargetMachine : sig
183 type t
184
185 (** Creates a new target machine.
186 See [llvm::Target::createTargetMachine]. *)
187 val create : triple:string -> ?cpu:string -> ?features:string ->
188 ?level:CodeGenOptLevel.t -> ?reloc_mode:RelocMode.t ->
189 ?code_model:CodeModel.t -> Target.t -> t
190
191 (** Returns the Target used in a TargetMachine *)
192 val target : t -> Target.t
193
194 (** Returns the triple used while creating this target machine. See
195 [llvm::TargetMachine::getTriple]. *)
196 val triple : t -> string
197
198 (** Returns the CPU used while creating this target machine. See
199 [llvm::TargetMachine::getCPU]. *)
200 val cpu : t -> string
201
202 (** Returns the feature string used while creating this target machine. See
203 [llvm::TargetMachine::getFeatureString]. *)
204 val features : t -> string
205
206 (** Returns the data layout of this target machine. *)
207 val data_layout : t -> DataLayout.t
208
209 (** Sets the assembly verbosity of this target machine.
210 See [llvm::TargetMachine::setAsmVerbosity]. *)
211 val set_verbose_asm : bool -> t -> unit
212
213 (** Emits assembly or object data for the given module to the given
214 file or raise [Error]. *)
215 val emit_to_file : Llvm.llmodule -> CodeGenFileType.t -> string -> t -> unit
216
217 (** Emits assembly or object data for the given module to a fresh memory
218 buffer or raise [Error]. *)
219 val emit_to_memory_buffer : Llvm.llmodule -> CodeGenFileType.t -> t ->
220 Llvm.llmemorybuffer
221 end
1515 \*===----------------------------------------------------------------------===*/
1616
1717 #include "llvm-c/Target.h"
18 #include "llvm-c/TargetMachine.h"
1819 #include "caml/alloc.h"
20 #include "caml/fail.h"
21 #include "caml/memory.h"
1922 #include "caml/custom.h"
23
24 /*===---- Exceptions ------------------------------------------------------===*/
25
26 static value llvm_target_error_exn;
27
28 CAMLprim value llvm_register_target_exns(value Error) {
29 llvm_target_error_exn = Field(Error, 0);
30 register_global_root(&llvm_target_error_exn);
31 return Val_unit;
32 }
33
34 static void llvm_raise(value Prototype, char *Message) {
35 CAMLparam1(Prototype);
36 CAMLlocal1(CamlMessage);
37
38 CamlMessage = copy_string(Message);
39 LLVMDisposeMessage(Message);
40
41 raise_with_arg(Prototype, CamlMessage);
42 abort(); /* NOTREACHED */
43 #ifdef CAMLnoreturn
44 CAMLnoreturn; /* Silences warnings, but is missing in some versions. */
45 #endif
46 }
47
48 static value llvm_string_of_message(char* Message) {
49 value String = caml_copy_string(Message);
50 LLVMDisposeMessage(Message);
51
52 return String;
53 }
54
55 /*===---- Data Layout -----------------------------------------------------===*/
2056
2157 #define DataLayout_val(v) (*(LLVMTargetDataRef *)(Data_custom_val(v)))
2258
3773 };
3874
3975 value llvm_alloc_data_layout(LLVMTargetDataRef DataLayout) {
40 value V = alloc_custom(&llvm_data_layout_ops, sizeof(LLVMTargetDataRef), 0, 1);
76 value V = alloc_custom(&llvm_data_layout_ops, sizeof(LLVMTargetDataRef),
77 0, 1);
4178 DataLayout_val(V) = DataLayout;
4279 return V;
4380 }
138175 return caml_copy_int64(LLVMOffsetOfElement(DataLayout_val(DL), Ty,
139176 Int_val(Index)));
140177 }
178
179 /*===---- Target ----------------------------------------------------------===*/
180
181 static value llvm_target_option(LLVMTargetRef Target) {
182 if(Target != NULL) {
183 value Result = caml_alloc_small(1, 0);
184 Store_field(Result, 0, (value) Target);
185 return Result;
186 }
187
188 return Val_int(0);
189 }
190
191 /* unit -> string */
192 CAMLprim value llvm_target_default_triple(value Unit) {
193 char *TripleCStr = LLVMGetDefaultTargetTriple();
194 value TripleStr = caml_copy_string(TripleCStr);
195 LLVMDisposeMessage(TripleCStr);
196
197 return TripleStr;
198 }
199
200 /* unit -> Target.t option */
201 CAMLprim value llvm_target_first(value Unit) {
202 return llvm_target_option(LLVMGetFirstTarget());
203 }
204
205 /* Target.t -> Target.t option */
206 CAMLprim value llvm_target_succ(LLVMTargetRef Target) {
207 return llvm_target_option(LLVMGetNextTarget(Target));
208 }
209
210 /* string -> Target.t option */
211 CAMLprim value llvm_target_by_name(value Name) {
212 return llvm_target_option(LLVMGetTargetFromName(String_val(Name)));
213 }
214
215 /* string -> Target.t */
216 CAMLprim LLVMTargetRef llvm_target_by_triple(value Triple) {
217 LLVMTargetRef T;
218 char *Error;
219
220 if(LLVMGetTargetFromTriple(String_val(Triple), &T, &Error))
221 llvm_raise(llvm_target_error_exn, Error);
222
223 return T;
224 }
225
226 /* Target.t -> string */
227 CAMLprim value llvm_target_name(LLVMTargetRef Target) {
228 return caml_copy_string(LLVMGetTargetName(Target));
229 }
230
231 /* Target.t -> string */
232 CAMLprim value llvm_target_description(LLVMTargetRef Target) {
233 return caml_copy_string(LLVMGetTargetDescription(Target));
234 }
235
236 /* Target.t -> bool */
237 CAMLprim value llvm_target_has_jit(LLVMTargetRef Target) {
238 return Val_bool(LLVMTargetHasJIT(Target));
239 }
240
241 /* Target.t -> bool */
242 CAMLprim value llvm_target_has_target_machine(LLVMTargetRef Target) {
243 return Val_bool(LLVMTargetHasTargetMachine(Target));
244 }
245
246 /* Target.t -> bool */
247 CAMLprim value llvm_target_has_asm_backend(LLVMTargetRef Target) {
248 return Val_bool(LLVMTargetHasAsmBackend(Target));
249 }
250
251 /*===---- Target Machine --------------------------------------------------===*/
252
253 #define TargetMachine_val(v) (*(LLVMTargetMachineRef *)(Data_custom_val(v)))
254
255 static void llvm_finalize_target_machine(value Machine) {
256 LLVMDisposeTargetMachine(TargetMachine_val(Machine));
257 }
258
259 static struct custom_operations llvm_target_machine_ops = {
260 (char *) "LLVMTargetMachine",
261 llvm_finalize_target_machine,
262 custom_compare_default,
263 custom_hash_default,
264 custom_serialize_default,
265 custom_deserialize_default
266 #ifdef custom_compare_ext_default
267 , custom_compare_ext_default
268 #endif
269 };
270
271 static value llvm_alloc_targetmachine(LLVMTargetMachineRef Machine) {
272 value V = alloc_custom(&llvm_target_machine_ops, sizeof(LLVMTargetMachineRef),
273 0, 1);
274 TargetMachine_val(V) = Machine;
275 return V;
276 }
277
278 /* triple:string -> ?cpu:string -> ?features:string
279 ?level:CodeGenOptLevel.t -> ?reloc_mode:RelocMode.t
280 ?code_model:CodeModel.t -> Target.t -> TargetMachine.t */
281 CAMLprim value llvm_create_targetmachine_native(value Triple, value CPU,
282 value Features, value OptLevel, value RelocMode,
283 value CodeModel, LLVMTargetRef Target) {
284 LLVMTargetMachineRef Machine;
285 const char *CPUStr = "", *FeaturesStr = "";
286 LLVMCodeGenOptLevel OptLevelEnum = LLVMCodeGenLevelDefault;
287 LLVMRelocMode RelocModeEnum = LLVMRelocDefault;
288 LLVMCodeModel CodeModelEnum = LLVMCodeModelDefault;
289
290 if(CPU != Val_int(0))
291 CPUStr = String_val(Field(CPU, 0));
292 if(Features != Val_int(0))
293 FeaturesStr = String_val(Field(Features, 0));
294 if(OptLevel != Val_int(0))
295 OptLevelEnum = Int_val(Field(OptLevel, 0));
296 if(RelocMode != Val_int(0))
297 RelocModeEnum = Int_val(Field(RelocMode, 0));
298 if(CodeModel != Val_int(0))
299 CodeModelEnum = Int_val(Field(CodeModel, 0));
300
301 Machine = LLVMCreateTargetMachine(Target, String_val(Triple), CPUStr,
302 FeaturesStr, OptLevelEnum, RelocModeEnum, CodeModelEnum);
303
304 return llvm_alloc_targetmachine(Machine);
305 }
306
307 CAMLprim value llvm_create_targetmachine_bytecode(value *argv, int argn) {
308 return llvm_create_targetmachine_native(argv[0], argv[1], argv[2], argv[3],
309 argv[4], argv[5], (LLVMTargetRef) argv[6]);
310 }
311
312 /* TargetMachine.t -> Target.t */
313 CAMLprim LLVMTargetRef llvm_targetmachine_target(value Machine) {
314 return LLVMGetTargetMachineTarget(TargetMachine_val(Machine));
315 }
316
317 /* TargetMachine.t -> string */
318 CAMLprim value llvm_targetmachine_triple(value Machine) {
319 return llvm_string_of_message(LLVMGetTargetMachineTriple(
320 TargetMachine_val(Machine)));
321 }
322
323 /* TargetMachine.t -> string */
324 CAMLprim value llvm_targetmachine_cpu(value Machine) {
325 return llvm_string_of_message(LLVMGetTargetMachineCPU(
326 TargetMachine_val(Machine)));
327 }
328
329 /* TargetMachine.t -> string */
330 CAMLprim value llvm_targetmachine_features(value Machine) {
331 return llvm_string_of_message(LLVMGetTargetMachineFeatureString(
332 TargetMachine_val(Machine)));
333 }
334
335 /* TargetMachine.t -> DataLayout.t */
336 CAMLprim value llvm_targetmachine_data_layout(value Machine) {
337 CAMLparam1(Machine);
338 CAMLlocal1(DataLayout);
339
340 /* LLVMGetTargetMachineData returns a pointer owned by the TargetMachine,
341 so it is impossible to wrap it with llvm_alloc_target_data, which assumes
342 that OCaml owns the pointer. */
343 LLVMTargetDataRef OrigDataLayout;
344 OrigDataLayout = LLVMGetTargetMachineData(TargetMachine_val(Machine));
345
346 char* TargetDataCStr;
347 TargetDataCStr = LLVMCopyStringRepOfTargetData(OrigDataLayout);
348 DataLayout = llvm_alloc_data_layout(LLVMCreateTargetData(TargetDataCStr));
349 LLVMDisposeMessage(TargetDataCStr);
350
351 CAMLreturn(DataLayout);
352 }
353
354 /* TargetMachine.t -> bool -> unit */
355 CAMLprim value llvm_targetmachine_set_verbose_asm(value Machine, value Verb) {
356 LLVMSetTargetMachineAsmVerbosity(TargetMachine_val(Machine), Bool_val(Verb));
357 return Val_unit;
358 }
359
360 /* Llvm.llmodule -> CodeGenFileType.t -> string -> TargetMachine.t -> unit */
361 CAMLprim value llvm_targetmachine_emit_to_file(LLVMModuleRef Module,
362 value FileType, value FileName, value Machine) {
363 char* ErrorMessage;
364
365 if(LLVMTargetMachineEmitToFile(TargetMachine_val(Machine), Module,
366 String_val(FileName), Int_val(FileType),
367 &ErrorMessage)) {
368 llvm_raise(llvm_target_error_exn, ErrorMessage);
369 }
370
371 return Val_unit;
372 }
373
374 /* Llvm.llmodule -> CodeGenFileType.t -> TargetMachine.t ->
375 Llvm.llmemorybuffer */
376 CAMLprim LLVMMemoryBufferRef llvm_targetmachine_emit_to_memory_buffer(
377 LLVMModuleRef Module, value FileType,
378 value Machine) {
379 char* ErrorMessage;
380 LLVMMemoryBufferRef Buffer;
381
382 if(LLVMTargetMachineEmitToMemoryBuffer(TargetMachine_val(Machine), Module,
383 Int_val(FileType), &ErrorMessage,
384 &Buffer)) {
385 llvm_raise(llvm_target_error_exn, ErrorMessage);
386 }
387
388 return Buffer;
389 }
0 (* RUN: rm -rf %t.builddir
11 * RUN: mkdir -p %t.builddir
22 * RUN: cp %s %t.builddir
3 * RUN: %ocamlopt -g -warn-error A llvm.cmxa llvm_target.cmxa %t.builddir/target.ml -o %t
3 * RUN: %ocamlopt -g -warn-error A llvm.cmxa llvm_target.cmxa llvm_X86.cmxa %t.builddir/target.ml -o %t
44 * RUN: %t %t.bc
55 * XFAIL: vg_leak
66 *)
1212 open Llvm
1313 open Llvm_target
1414
15 let _ = Llvm_X86.initialize ()
1516
1617 let context = global_context ()
1718 let i32_type = Llvm.i32_type context
3233 let filename = Sys.argv.(1)
3334 let m = create_module context filename
3435
36 let target =
37 match Target.by_name "x86" with
38 | Some t -> t
39 | None -> failwith "need a target"
3540
36 (*===-- Target Data -------------------------------------------------------===*)
41 let machine =
42 TargetMachine.create ~triple:"i686-linux-gnu" ~cpu:"core2" target
43
44 (*===-- Data Layout -------------------------------------------------------===*)
3745
3846 let test_target_data () =
3947 let module DL = DataLayout in
6270 ignore (DL.add_to_pass_manager pm dl)
6371
6472
73 (*===-- Target ------------------------------------------------------------===*)
74
75 let test_target () =
76 let module T = Target in
77 ignore (T.succ target);
78 assert_equal (T.name target) "x86";
79 assert_equal (T.description target) "32-bit X86: Pentium-Pro and above";
80 assert_equal (T.has_jit target) true;
81 assert_equal (T.has_target_machine target) true;
82 assert_equal (T.has_asm_backend target) true
83
84
85 (*===-- Target Machine ----------------------------------------------------===*)
86
87 let test_target_machine () =
88 let module TM = TargetMachine in
89 assert_equal (TM.target machine) target;
90 assert_equal (TM.triple machine) "i686-linux-gnu";
91 assert_equal (TM.cpu machine) "core2";
92 assert_equal (TM.features machine) "";
93 ignore (TM.data_layout machine)
94
95
96 (*===-- Code Emission -----------------------------------------------------===*)
97
98 let test_code_emission () =
99 TargetMachine.emit_to_file m CodeGenFileType.ObjectFile filename machine;
100 try
101 TargetMachine.emit_to_file m CodeGenFileType.ObjectFile
102 "/nonexistent/file" machine;
103 failwith "must raise"
104 with Llvm_target.Error _ ->
105 ();
106
107 let buf = TargetMachine.emit_to_memory_buffer m CodeGenFileType.ObjectFile
108 machine in
109 Llvm.MemoryBuffer.dispose buf
110
111
65112 (*===-- Driver ------------------------------------------------------------===*)
66113
67114 let _ =
68115 test_target_data ();
116 test_target ();
117 test_target_machine ();
118 (* test_code_emission (); *) (* broken without AsmParser support *)
69119 dispose_module m