1 /*===-- executionengine_ocaml.c - LLVM OCaml Glue ---------------*- C++ -*-===*\
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 |* This file glues LLVM's OCaml interface to its C interface. These functions *|
11 |* are by and large transparent wrappers to the corresponding C functions.    *|
12 |*                                                                            *|
13 |* Note that these functions intentionally take liberties with the CAMLparamX *|
14 |* macros, since most of the parameters are not GC heap objects.              *|
15 |*                                                                            *|
16 \*===----------------------------------------------------------------------===*/
17 
18 #include "llvm-c/ExecutionEngine.h"
19 #include "llvm-c/Target.h"
20 #include "caml/alloc.h"
21 #include "caml/custom.h"
22 #include "caml/fail.h"
23 #include "caml/memory.h"
24 #include <string.h>
25 #include <assert.h>
26 
27 /* Force the LLVM interpreter and JIT to be linked in. */
28 void llvm_initialize(void) {
29   LLVMLinkInInterpreter();
30   LLVMLinkInMCJIT();
31 }
32 
33 /* unit -> bool */
34 CAMLprim value llvm_initialize_native_target(value Unit) {
35   return Val_bool(!LLVMInitializeNativeTarget() &&
36                   !LLVMInitializeNativeAsmParser() &&
37                   !LLVMInitializeNativeAsmPrinter());
38 }
39 
40 /* Can't use the recommended caml_named_value mechanism for backwards
41    compatibility reasons. This is largely equivalent. */
42 static value llvm_ee_error_exn;
43 
44 CAMLprim value llvm_register_ee_exns(value Error) {
45   llvm_ee_error_exn = Field(Error, 0);
46   register_global_root(&llvm_ee_error_exn);
47   return Val_unit;
48 }
49 
50 static void llvm_raise(value Prototype, char *Message) {
51   CAMLparam1(Prototype);
52   CAMLlocal1(CamlMessage);
53 
54   CamlMessage = copy_string(Message);
55   LLVMDisposeMessage(Message);
56 
57   raise_with_arg(Prototype, CamlMessage);
58   abort(); /* NOTREACHED */
59 #ifdef CAMLnoreturn
60   CAMLnoreturn; /* Silences warnings, but is missing in some versions. */
61 #endif
62 }
63 
64 
65 /*--... Operations on generic values .......................................--*/
66 
67 #define Genericvalue_val(v)  (*(LLVMGenericValueRef *)(Data_custom_val(v)))
68 
69 static void llvm_finalize_generic_value(value GenVal) {
70   LLVMDisposeGenericValue(Genericvalue_val(GenVal));
71 }
72 
73 static struct custom_operations generic_value_ops = {
74   (char *) "LLVMGenericValue",
75   llvm_finalize_generic_value,
76   custom_compare_default,
77   custom_hash_default,
78   custom_serialize_default,
79   custom_deserialize_default
80 #ifdef custom_compare_ext_default
81   , custom_compare_ext_default
82 #endif
83 };
84 
85 static value alloc_generic_value(LLVMGenericValueRef Ref) {
86   value Val = alloc_custom(&generic_value_ops, sizeof(LLVMGenericValueRef), 0, 1);
87   Genericvalue_val(Val) = Ref;
88   return Val;
89 }
90 
91 /* Llvm.lltype -> float -> t */
92 CAMLprim value llvm_genericvalue_of_float(LLVMTypeRef Ty, value N) {
93   CAMLparam1(N);
94   CAMLreturn(alloc_generic_value(
95     LLVMCreateGenericValueOfFloat(Ty, Double_val(N))));
96 }
97 
98 /* 'a -> t */
99 CAMLprim value llvm_genericvalue_of_pointer(value V) {
100   CAMLparam1(V);
101   CAMLreturn(alloc_generic_value(LLVMCreateGenericValueOfPointer(Op_val(V))));
102 }
103 
104 /* Llvm.lltype -> int -> t */
105 CAMLprim value llvm_genericvalue_of_int(LLVMTypeRef Ty, value Int) {
106   return alloc_generic_value(LLVMCreateGenericValueOfInt(Ty, Int_val(Int), 1));
107 }
108 
109 /* Llvm.lltype -> int32 -> t */
110 CAMLprim value llvm_genericvalue_of_int32(LLVMTypeRef Ty, value Int32) {
111   CAMLparam1(Int32);
112   CAMLreturn(alloc_generic_value(
113     LLVMCreateGenericValueOfInt(Ty, Int32_val(Int32), 1)));
114 }
115 
116 /* Llvm.lltype -> nativeint -> t */
117 CAMLprim value llvm_genericvalue_of_nativeint(LLVMTypeRef Ty, value NatInt) {
118   CAMLparam1(NatInt);
119   CAMLreturn(alloc_generic_value(
120     LLVMCreateGenericValueOfInt(Ty, Nativeint_val(NatInt), 1)));
121 }
122 
123 /* Llvm.lltype -> int64 -> t */
124 CAMLprim value llvm_genericvalue_of_int64(LLVMTypeRef Ty, value Int64) {
125   CAMLparam1(Int64);
126   CAMLreturn(alloc_generic_value(
127     LLVMCreateGenericValueOfInt(Ty, Int64_val(Int64), 1)));
128 }
129 
130 /* Llvm.lltype -> t -> float */
131 CAMLprim value llvm_genericvalue_as_float(LLVMTypeRef Ty, value GenVal) {
132   CAMLparam1(GenVal);
133   CAMLreturn(copy_double(
134     LLVMGenericValueToFloat(Ty, Genericvalue_val(GenVal))));
135 }
136 
137 /* t -> 'a */
138 CAMLprim value llvm_genericvalue_as_pointer(value GenVal) {
139   return Val_op(LLVMGenericValueToPointer(Genericvalue_val(GenVal)));
140 }
141 
142 /* t -> int */
143 CAMLprim value llvm_genericvalue_as_int(value GenVal) {
144   assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 8 * sizeof(value)
145          && "Generic value too wide to treat as an int!");
146   return Val_int(LLVMGenericValueToInt(Genericvalue_val(GenVal), 1));
147 }
148 
149 /* t -> int32 */
150 CAMLprim value llvm_genericvalue_as_int32(value GenVal) {
151   CAMLparam1(GenVal);
152   assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 32
153          && "Generic value too wide to treat as an int32!");
154   CAMLreturn(copy_int32(LLVMGenericValueToInt(Genericvalue_val(GenVal), 1)));
155 }
156 
157 /* t -> int64 */
158 CAMLprim value llvm_genericvalue_as_int64(value GenVal) {
159   CAMLparam1(GenVal);
160   assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 64
161          && "Generic value too wide to treat as an int64!");
162   CAMLreturn(copy_int64(LLVMGenericValueToInt(Genericvalue_val(GenVal), 1)));
163 }
164 
165 /* t -> nativeint */
166 CAMLprim value llvm_genericvalue_as_nativeint(value GenVal) {
167   CAMLparam1(GenVal);
168   assert(LLVMGenericValueIntWidth(Genericvalue_val(GenVal)) <= 8 * sizeof(value)
169          && "Generic value too wide to treat as a nativeint!");
170   CAMLreturn(copy_nativeint(LLVMGenericValueToInt(Genericvalue_val(GenVal),1)));
171 }
172 
173 
174 /*--... Operations on execution engines ....................................--*/
175 
176 /* llmodule -> ExecutionEngine.t */
177 CAMLprim LLVMExecutionEngineRef llvm_ee_create(LLVMModuleRef M) {
178   LLVMExecutionEngineRef Interp;
179   char *Error;
180   if (LLVMCreateExecutionEngineForModule(&Interp, M, &Error))
181     llvm_raise(llvm_ee_error_exn, Error);
182   return Interp;
183 }
184 
185 /* llmodule -> ExecutionEngine.t */
186 CAMLprim LLVMExecutionEngineRef
187 llvm_ee_create_interpreter(LLVMModuleRef M) {
188   LLVMExecutionEngineRef Interp;
189   char *Error;
190   if (LLVMCreateInterpreterForModule(&Interp, M, &Error))
191     llvm_raise(llvm_ee_error_exn, Error);
192   return Interp;
193 }
194 
195 /* llmodule -> int -> ExecutionEngine.t */
196 CAMLprim LLVMExecutionEngineRef
197 llvm_ee_create_jit(LLVMModuleRef M, value OptLevel) {
198   LLVMExecutionEngineRef JIT;
199   char *Error;
200   if (LLVMCreateJITCompilerForModule(&JIT, M, Int_val(OptLevel), &Error))
201     llvm_raise(llvm_ee_error_exn, Error);
202   return JIT;
203 }
204 
205 /* llmodule -> llcompileroption -> ExecutionEngine.t */
206 CAMLprim LLVMExecutionEngineRef
207 llvm_ee_create_mcjit(LLVMModuleRef M, value OptRecord) {
208   LLVMExecutionEngineRef MCJIT;
209   char *Error;
210   struct LLVMMCJITCompilerOptions Options = {
211          .OptLevel = Int_val(Field(OptRecord, 0)),
212          .CodeModel = Int_val(Field(OptRecord, 1)),
213          .NoFramePointerElim = Int_val(Field(OptRecord, 2)),
214          .EnableFastISel = Int_val(Field(OptRecord, 3)),
215          .MCJMM = NULL
216   };
217   if (LLVMCreateMCJITCompilerForModule(&MCJIT, M, &Options,
218                                       sizeof(Options), &Error))
219     llvm_raise(llvm_ee_error_exn, Error);
220   return MCJIT;
221 }
222 
223 /* ExecutionEngine.t -> unit */
224 CAMLprim value llvm_ee_dispose(LLVMExecutionEngineRef EE) {
225   LLVMDisposeExecutionEngine(EE);
226   return Val_unit;
227 }
228 
229 /* llmodule -> ExecutionEngine.t -> unit */
230 CAMLprim value llvm_ee_add_module(LLVMModuleRef M, LLVMExecutionEngineRef EE) {
231   LLVMAddModule(EE, M);
232   return Val_unit;
233 }
234 
235 /* llmodule -> ExecutionEngine.t -> llmodule */
236 CAMLprim LLVMModuleRef llvm_ee_remove_module(LLVMModuleRef M,
237                                              LLVMExecutionEngineRef EE) {
238   LLVMModuleRef RemovedModule;
239   char *Error;
240   if (LLVMRemoveModule(EE, M, &RemovedModule, &Error))
241     llvm_raise(llvm_ee_error_exn, Error);
242   return RemovedModule;
243 }
244 
245 /* string -> ExecutionEngine.t -> llvalue option */
246 CAMLprim value llvm_ee_find_function(value Name, LLVMExecutionEngineRef EE) {
247   CAMLparam1(Name);
248   CAMLlocal1(Option);
249   LLVMValueRef Found;
250   if (LLVMFindFunction(EE, String_val(Name), &Found))
251     CAMLreturn(Val_unit);
252   Option = alloc(1, 0);
253   Field(Option, 0) = Val_op(Found);
254   CAMLreturn(Option);
255 }
256 
257 /* llvalue -> GenericValue.t array -> ExecutionEngine.t -> GenericValue.t */
258 CAMLprim value llvm_ee_run_function(LLVMValueRef F, value Args,
259                                     LLVMExecutionEngineRef EE) {
260   unsigned NumArgs;
261   LLVMGenericValueRef Result, *GVArgs;
262   unsigned I;
263 
264   NumArgs = Wosize_val(Args);
265   GVArgs = (LLVMGenericValueRef*) malloc(NumArgs * sizeof(LLVMGenericValueRef));
266   for (I = 0; I != NumArgs; ++I)
267     GVArgs[I] = Genericvalue_val(Field(Args, I));
268 
269   Result = LLVMRunFunction(EE, F, NumArgs, GVArgs);
270 
271   free(GVArgs);
272   return alloc_generic_value(Result);
273 }
274 
275 /* ExecutionEngine.t -> unit */
276 CAMLprim value llvm_ee_run_static_ctors(LLVMExecutionEngineRef EE) {
277   LLVMRunStaticConstructors(EE);
278   return Val_unit;
279 }
280 
281 /* ExecutionEngine.t -> unit */
282 CAMLprim value llvm_ee_run_static_dtors(LLVMExecutionEngineRef EE) {
283   LLVMRunStaticDestructors(EE);
284   return Val_unit;
285 }
286 
287 /* llvalue -> string array -> (string * string) array -> ExecutionEngine.t ->
288    int */
289 CAMLprim value llvm_ee_run_function_as_main(LLVMValueRef F,
290                                             value Args, value Env,
291                                             LLVMExecutionEngineRef EE) {
292   CAMLparam2(Args, Env);
293   int I, NumArgs, NumEnv, EnvSize, Result;
294   const char **CArgs, **CEnv;
295   char *CEnvBuf, *Pos;
296 
297   NumArgs = Wosize_val(Args);
298   NumEnv = Wosize_val(Env);
299 
300   /* Build the environment. */
301   CArgs = (const char **) malloc(NumArgs * sizeof(char*));
302   for (I = 0; I != NumArgs; ++I)
303     CArgs[I] = String_val(Field(Args, I));
304 
305   /* Compute the size of the environment string buffer. */
306   for (I = 0, EnvSize = 0; I != NumEnv; ++I) {
307     EnvSize += strlen(String_val(Field(Field(Env, I), 0))) + 1;
308     EnvSize += strlen(String_val(Field(Field(Env, I), 1))) + 1;
309   }
310 
311   /* Build the environment. */
312   CEnv = (const char **) malloc((NumEnv + 1) * sizeof(char*));
313   CEnvBuf = (char*) malloc(EnvSize);
314   Pos = CEnvBuf;
315   for (I = 0; I != NumEnv; ++I) {
316     char *Name  = String_val(Field(Field(Env, I), 0)),
317          *Value = String_val(Field(Field(Env, I), 1));
318     int NameLen  = strlen(Name),
319         ValueLen = strlen(Value);
320 
321     CEnv[I] = Pos;
322     memcpy(Pos, Name, NameLen);
323     Pos += NameLen;
324     *Pos++ = '=';
325     memcpy(Pos, Value, ValueLen);
326     Pos += ValueLen;
327     *Pos++ = '\0';
328   }
329   CEnv[NumEnv] = NULL;
330 
331   Result = LLVMRunFunctionAsMain(EE, F, NumArgs, CArgs, CEnv);
332 
333   free(CArgs);
334   free(CEnv);
335   free(CEnvBuf);
336 
337   CAMLreturn(Val_int(Result));
338 }
339 
340 /* llvalue -> ExecutionEngine.t -> unit */
341 CAMLprim value llvm_ee_free_machine_code(LLVMValueRef F,
342                                          LLVMExecutionEngineRef EE) {
343   LLVMFreeMachineCodeForFunction(EE, F);
344   return Val_unit;
345 }
346 
347 extern value llvm_alloc_data_layout(LLVMTargetDataRef TargetData);
348 
349 /* ExecutionEngine.t -> Llvm_target.DataLayout.t */
350 CAMLprim value llvm_ee_get_data_layout(LLVMExecutionEngineRef EE) {
351   value DataLayout;
352   LLVMTargetDataRef OrigDataLayout;
353   OrigDataLayout = LLVMGetExecutionEngineTargetData(EE);
354 
355   char* TargetDataCStr;
356   TargetDataCStr = LLVMCopyStringRepOfTargetData(OrigDataLayout);
357   DataLayout = llvm_alloc_data_layout(LLVMCreateTargetData(TargetDataCStr));
358   LLVMDisposeMessage(TargetDataCStr);
359 
360   return DataLayout;
361 }
362