1 /* Compile Emacs Lisp into native code.
2 Copyright (C) 2019-2021 Free Software Foundation, Inc.
3
4 Author: Andrea Corallo <akrl@sdf.org>
5
6 This file is part of GNU Emacs.
7
8 GNU Emacs is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or (at
11 your option) any later version.
12
13 GNU Emacs is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
20
21 #include <config.h>
22
23 #include "lisp.h"
24
25 #ifdef HAVE_NATIVE_COMP
26
27 #include <setjmp.h>
28 #include <stdlib.h>
29 #include <stdio.h>
30 #include <signal.h>
31 #include <libgccjit.h>
32 #include <epaths.h>
33
34 #include "puresize.h"
35 #include "window.h"
36 #include "dynlib.h"
37 #include "buffer.h"
38 #include "blockinput.h"
39 #include "coding.h"
40 #include "md5.h"
41 #include "sysstdio.h"
42 #include "zlib.h"
43
44
45 /********************************/
46 /* Dynamic loading of libgccjit */
47 /********************************/
48
49 #ifdef WINDOWSNT
50 # include "w32common.h"
51
52 #undef gcc_jit_block_add_assignment
53 #undef gcc_jit_block_add_comment
54 #undef gcc_jit_block_add_eval
55 #undef gcc_jit_block_end_with_conditional
56 #undef gcc_jit_block_end_with_jump
57 #undef gcc_jit_block_end_with_return
58 #undef gcc_jit_block_end_with_void_return
59 #undef gcc_jit_context_acquire
60 #undef gcc_jit_context_add_command_line_option
61 #undef gcc_jit_context_add_driver_option
62 #undef gcc_jit_context_compile_to_file
63 #undef gcc_jit_context_dump_reproducer_to_file
64 #undef gcc_jit_context_dump_to_file
65 #undef gcc_jit_context_get_builtin_function
66 #undef gcc_jit_context_get_first_error
67 #undef gcc_jit_context_get_int_type
68 #undef gcc_jit_context_get_type
69 #undef gcc_jit_context_new_array_access
70 #undef gcc_jit_context_new_array_type
71 #undef gcc_jit_context_new_binary_op
72 #undef gcc_jit_context_new_call
73 #undef gcc_jit_context_new_call_through_ptr
74 #undef gcc_jit_context_new_cast
75 #undef gcc_jit_context_new_comparison
76 #undef gcc_jit_context_new_field
77 #undef gcc_jit_context_new_function
78 #undef gcc_jit_context_new_function_ptr_type
79 #undef gcc_jit_context_new_global
80 #undef gcc_jit_context_new_opaque_struct
81 #undef gcc_jit_context_new_param
82 #undef gcc_jit_context_new_rvalue_from_int
83 #undef gcc_jit_context_new_rvalue_from_long
84 #undef gcc_jit_context_new_rvalue_from_ptr
85 #undef gcc_jit_context_new_string_literal
86 #undef gcc_jit_context_new_struct_type
87 #undef gcc_jit_context_new_unary_op
88 #undef gcc_jit_context_new_union_type
89 #undef gcc_jit_context_release
90 #undef gcc_jit_context_set_bool_option
91 #undef gcc_jit_context_set_int_option
92 #undef gcc_jit_context_set_logfile
93 #undef gcc_jit_context_set_str_option
94 #undef gcc_jit_function_get_param
95 #undef gcc_jit_function_new_block
96 #undef gcc_jit_function_new_local
97 #undef gcc_jit_global_set_initializer
98 #undef gcc_jit_lvalue_access_field
99 #undef gcc_jit_lvalue_as_rvalue
100 #undef gcc_jit_lvalue_get_address
101 #undef gcc_jit_param_as_lvalue
102 #undef gcc_jit_param_as_rvalue
103 #undef gcc_jit_rvalue_access_field
104 #undef gcc_jit_rvalue_dereference
105 #undef gcc_jit_rvalue_dereference_field
106 #undef gcc_jit_rvalue_get_type
107 #undef gcc_jit_struct_as_type
108 #undef gcc_jit_struct_set_fields
109 #undef gcc_jit_type_get_const
110 #undef gcc_jit_type_get_pointer
111 #undef gcc_jit_version_major
112 #undef gcc_jit_version_minor
113 #undef gcc_jit_version_patchlevel
114
115 /* In alphabetical order */
116 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_int,
117 (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, int value));
118 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_as_rvalue,
119 (gcc_jit_lvalue *lvalue));
120 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_rvalue_access_field,
121 (gcc_jit_rvalue *struct_or_union, gcc_jit_location *loc,
122 gcc_jit_field *field));
123 DEF_DLL_FN (void, gcc_jit_block_add_comment,
124 (gcc_jit_block *block, gcc_jit_location *loc, const char *text));
125 DEF_DLL_FN (void, gcc_jit_context_release, (gcc_jit_context *ctxt));
126 DEF_DLL_FN (const char *, gcc_jit_context_get_first_error,
127 (gcc_jit_context *ctxt));
128 DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block,
129 (gcc_jit_function *func, const char *name));
130 DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void));
131 DEF_DLL_FN (void, gcc_jit_context_add_command_line_option,
132 (gcc_jit_context *ctxt, const char *optname));
133 DEF_DLL_FN (void, gcc_jit_context_add_driver_option,
134 (gcc_jit_context *ctxt, const char *optname));
135 DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field,
136 (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type,
137 const char *name));
138 DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_get_builtin_function,
139 (gcc_jit_context *ctxt, const char *name));
140 DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_new_function,
141 (gcc_jit_context *ctxt, gcc_jit_location *loc,
142 enum gcc_jit_function_kind kind, gcc_jit_type *return_type,
143 const char *name, int num_params, gcc_jit_param **params,
144 int is_variadic));
145 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_array_access,
146 (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_rvalue *ptr,
147 gcc_jit_rvalue *index));
148 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_global,
149 (gcc_jit_context *ctxt, gcc_jit_location *loc,
150 enum gcc_jit_global_kind kind, gcc_jit_type *type,
151 const char *name));
152 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_function_new_local,
153 (gcc_jit_function *func, gcc_jit_location *loc, gcc_jit_type *type,
154 const char *name));
155 #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer)
156 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_global_set_initializer,
157 (gcc_jit_lvalue *global, const void *blob, size_t num_bytes));
158 #endif
159 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_lvalue_access_field,
160 (gcc_jit_lvalue *struct_or_union, gcc_jit_location *loc,
161 gcc_jit_field *field));
162 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_param_as_lvalue, (gcc_jit_param *param));
163 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference,
164 (gcc_jit_rvalue *rvalue, gcc_jit_location *loc));
165 DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference_field,
166 (gcc_jit_rvalue *ptr, gcc_jit_location *loc, gcc_jit_field *field));
167 DEF_DLL_FN (gcc_jit_param *, gcc_jit_context_new_param,
168 (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type,
169 const char *name));
170 DEF_DLL_FN (gcc_jit_param *, gcc_jit_function_get_param,
171 (gcc_jit_function *func, int index));
172 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_binary_op,
173 (gcc_jit_context *ctxt, gcc_jit_location *loc,
174 enum gcc_jit_binary_op op, gcc_jit_type *result_type,
175 gcc_jit_rvalue *a, gcc_jit_rvalue *b));
176 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call,
177 (gcc_jit_context *ctxt, gcc_jit_location *loc,
178 gcc_jit_function *func, int numargs , gcc_jit_rvalue **args));
179 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call_through_ptr,
180 (gcc_jit_context *ctxt, gcc_jit_location *loc,
181 gcc_jit_rvalue *fn_ptr, int numargs, gcc_jit_rvalue **args));
182 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_cast,
183 (gcc_jit_context *ctxt, gcc_jit_location *loc,
184 gcc_jit_rvalue *rvalue, gcc_jit_type *type));
185 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_comparison,
186 (gcc_jit_context *ctxt, gcc_jit_location *loc,
187 enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b));
188 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long,
189 (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value));
190 #if LISP_WORDS_ARE_POINTERS
191 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr,
192 (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value));
193 #endif
194 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_string_literal,
195 (gcc_jit_context *ctxt, const char *value));
196 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op,
197 (gcc_jit_context *ctxt, gcc_jit_location *loc,
198 enum gcc_jit_unary_op op, gcc_jit_type *result_type,
199 gcc_jit_rvalue *rvalue));
200 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_get_address,
201 (gcc_jit_lvalue *lvalue, gcc_jit_location *loc));
202 DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_param_as_rvalue, (gcc_jit_param *param));
203 DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_opaque_struct,
204 (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name));
205 DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_struct_type,
206 (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name,
207 int num_fields, gcc_jit_field **fields));
208 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_int_type,
209 (gcc_jit_context *ctxt, int num_bytes, int is_signed));
210 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_type,
211 (gcc_jit_context *ctxt, enum gcc_jit_types type_));
212 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_array_type,
213 (gcc_jit_context *ctxt, gcc_jit_location *loc,
214 gcc_jit_type *element_type, int num_elements));
215 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_function_ptr_type,
216 (gcc_jit_context *ctxt, gcc_jit_location *loc,
217 gcc_jit_type *return_type, int num_params,
218 gcc_jit_type **param_types, int is_variadic));
219 DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_union_type,
220 (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name,
221 int num_fields, gcc_jit_field **fields));
222 DEF_DLL_FN (gcc_jit_type *, gcc_jit_rvalue_get_type, (gcc_jit_rvalue *rvalue));
223 DEF_DLL_FN (gcc_jit_type *, gcc_jit_struct_as_type,
224 (gcc_jit_struct *struct_type));
225 DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_const, (gcc_jit_type *type));
226 DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type));
227 DEF_DLL_FN (void, gcc_jit_block_add_assignment,
228 (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue,
229 gcc_jit_rvalue *rvalue));
230 DEF_DLL_FN (void, gcc_jit_block_add_eval,
231 (gcc_jit_block *block, gcc_jit_location *loc,
232 gcc_jit_rvalue *rvalue));
233 DEF_DLL_FN (void, gcc_jit_block_end_with_conditional,
234 (gcc_jit_block *block, gcc_jit_location *loc,
235 gcc_jit_rvalue *boolval, gcc_jit_block *on_true,
236 gcc_jit_block *on_false));
237 DEF_DLL_FN (void, gcc_jit_block_end_with_jump,
238 (gcc_jit_block *block, gcc_jit_location *loc,
239 gcc_jit_block *target));
240 DEF_DLL_FN (void, gcc_jit_block_end_with_return,
241 (gcc_jit_block *block, gcc_jit_location *loc,
242 gcc_jit_rvalue *rvalue));
243 DEF_DLL_FN (void, gcc_jit_block_end_with_void_return,
244 (gcc_jit_block *block, gcc_jit_location *loc));
245 DEF_DLL_FN (void, gcc_jit_context_compile_to_file,
246 (gcc_jit_context *ctxt, enum gcc_jit_output_kind output_kind,
247 const char *output_path));
248 DEF_DLL_FN (void, gcc_jit_context_dump_reproducer_to_file,
249 (gcc_jit_context *ctxt, const char *path));
250 DEF_DLL_FN (void, gcc_jit_context_dump_to_file,
251 (gcc_jit_context *ctxt, const char *path, int update_locations));
252 DEF_DLL_FN (void, gcc_jit_context_set_bool_option,
253 (gcc_jit_context *ctxt, enum gcc_jit_bool_option opt, int value));
254 DEF_DLL_FN (void, gcc_jit_context_set_int_option,
255 (gcc_jit_context *ctxt, enum gcc_jit_int_option opt, int value));
256 DEF_DLL_FN (void, gcc_jit_context_set_logfile,
257 (gcc_jit_context *ctxt, FILE *logfile, int flags, int verbosity));
258 DEF_DLL_FN (void, gcc_jit_context_set_str_option,
259 (gcc_jit_context *ctxt, enum gcc_jit_str_option opt,
260 const char *value));
261 DEF_DLL_FN (void, gcc_jit_struct_set_fields,
262 (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields,
263 gcc_jit_field **fields));
264 #if defined (LIBGCCJIT_HAVE_gcc_jit_version)
265 DEF_DLL_FN (int, gcc_jit_version_major, (void));
266 DEF_DLL_FN (int, gcc_jit_version_minor, (void));
267 DEF_DLL_FN (int, gcc_jit_version_patchlevel, (void));
268 #endif
269
270 static bool
init_gccjit_functions(void)271 init_gccjit_functions (void)
272 {
273 HMODULE library = w32_delayed_load (Qgccjit);
274
275 if (!library)
276 return false;
277
278 /* In alphabetical order */
279 LOAD_DLL_FN (library, gcc_jit_block_add_assignment);
280 LOAD_DLL_FN (library, gcc_jit_block_add_comment);
281 LOAD_DLL_FN (library, gcc_jit_block_add_eval);
282 LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional);
283 LOAD_DLL_FN (library, gcc_jit_block_end_with_jump);
284 LOAD_DLL_FN (library, gcc_jit_block_end_with_return);
285 LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return);
286 LOAD_DLL_FN (library, gcc_jit_context_acquire);
287 LOAD_DLL_FN (library, gcc_jit_context_compile_to_file);
288 LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file);
289 LOAD_DLL_FN (library, gcc_jit_context_dump_to_file);
290 LOAD_DLL_FN (library, gcc_jit_context_get_builtin_function);
291 LOAD_DLL_FN (library, gcc_jit_context_get_first_error);
292 LOAD_DLL_FN (library, gcc_jit_context_get_int_type);
293 LOAD_DLL_FN (library, gcc_jit_context_get_type);
294 LOAD_DLL_FN (library, gcc_jit_context_new_array_access);
295 LOAD_DLL_FN (library, gcc_jit_context_new_array_type);
296 LOAD_DLL_FN (library, gcc_jit_context_new_binary_op);
297 LOAD_DLL_FN (library, gcc_jit_context_new_call);
298 LOAD_DLL_FN (library, gcc_jit_context_new_call_through_ptr);
299 LOAD_DLL_FN (library, gcc_jit_context_new_cast);
300 LOAD_DLL_FN (library, gcc_jit_context_new_comparison);
301 LOAD_DLL_FN (library, gcc_jit_context_new_field);
302 LOAD_DLL_FN (library, gcc_jit_context_new_function);
303 LOAD_DLL_FN (library, gcc_jit_context_new_function_ptr_type);
304 LOAD_DLL_FN (library, gcc_jit_context_new_global);
305 LOAD_DLL_FN (library, gcc_jit_context_new_opaque_struct);
306 LOAD_DLL_FN (library, gcc_jit_context_new_param);
307 LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int);
308 LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long);
309 #if LISP_WORDS_ARE_POINTERS
310 LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr);
311 #endif
312 LOAD_DLL_FN (library, gcc_jit_context_new_string_literal);
313 LOAD_DLL_FN (library, gcc_jit_context_new_struct_type);
314 LOAD_DLL_FN (library, gcc_jit_context_new_unary_op);
315 LOAD_DLL_FN (library, gcc_jit_context_new_union_type);
316 LOAD_DLL_FN (library, gcc_jit_context_release);
317 LOAD_DLL_FN (library, gcc_jit_context_set_bool_option);
318 LOAD_DLL_FN (library, gcc_jit_context_set_int_option);
319 LOAD_DLL_FN (library, gcc_jit_context_set_logfile);
320 LOAD_DLL_FN (library, gcc_jit_context_set_str_option);
321 LOAD_DLL_FN (library, gcc_jit_function_get_param);
322 LOAD_DLL_FN (library, gcc_jit_function_new_block);
323 LOAD_DLL_FN (library, gcc_jit_function_new_local);
324 LOAD_DLL_FN (library, gcc_jit_lvalue_access_field);
325 LOAD_DLL_FN (library, gcc_jit_lvalue_as_rvalue);
326 LOAD_DLL_FN (library, gcc_jit_lvalue_get_address);
327 LOAD_DLL_FN (library, gcc_jit_param_as_lvalue);
328 LOAD_DLL_FN (library, gcc_jit_param_as_rvalue);
329 LOAD_DLL_FN (library, gcc_jit_rvalue_access_field);
330 LOAD_DLL_FN (library, gcc_jit_rvalue_dereference);
331 LOAD_DLL_FN (library, gcc_jit_rvalue_dereference_field);
332 LOAD_DLL_FN (library, gcc_jit_rvalue_get_type);
333 LOAD_DLL_FN (library, gcc_jit_struct_as_type);
334 LOAD_DLL_FN (library, gcc_jit_struct_set_fields);
335 LOAD_DLL_FN (library, gcc_jit_type_get_const);
336 LOAD_DLL_FN (library, gcc_jit_type_get_pointer);
337 LOAD_DLL_FN_OPT (library, gcc_jit_context_add_command_line_option);
338 LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option);
339 #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer)
340 LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer);
341 #endif
342 #if defined (LIBGCCJIT_HAVE_gcc_jit_version)
343 LOAD_DLL_FN_OPT (library, gcc_jit_version_major);
344 LOAD_DLL_FN_OPT (library, gcc_jit_version_minor);
345 LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel);
346 #endif
347
348 return true;
349 }
350
351 /* In alphabetical order */
352 #define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment
353 #define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment
354 #define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval
355 #define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional
356 #define gcc_jit_block_end_with_jump fn_gcc_jit_block_end_with_jump
357 #define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return
358 #define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return
359 #define gcc_jit_context_acquire fn_gcc_jit_context_acquire
360 #define gcc_jit_context_add_command_line_option fn_gcc_jit_context_add_command_line_option
361 #define gcc_jit_context_add_driver_option fn_gcc_jit_context_add_driver_option
362 #define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file
363 #define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file
364 #define gcc_jit_context_dump_to_file fn_gcc_jit_context_dump_to_file
365 #define gcc_jit_context_get_builtin_function fn_gcc_jit_context_get_builtin_function
366 #define gcc_jit_context_get_first_error fn_gcc_jit_context_get_first_error
367 #define gcc_jit_context_get_int_type fn_gcc_jit_context_get_int_type
368 #define gcc_jit_context_get_type fn_gcc_jit_context_get_type
369 #define gcc_jit_context_new_array_access fn_gcc_jit_context_new_array_access
370 #define gcc_jit_context_new_array_type fn_gcc_jit_context_new_array_type
371 #define gcc_jit_context_new_binary_op fn_gcc_jit_context_new_binary_op
372 #define gcc_jit_context_new_call fn_gcc_jit_context_new_call
373 #define gcc_jit_context_new_call_through_ptr fn_gcc_jit_context_new_call_through_ptr
374 #define gcc_jit_context_new_cast fn_gcc_jit_context_new_cast
375 #define gcc_jit_context_new_comparison fn_gcc_jit_context_new_comparison
376 #define gcc_jit_context_new_field fn_gcc_jit_context_new_field
377 #define gcc_jit_context_new_function fn_gcc_jit_context_new_function
378 #define gcc_jit_context_new_function_ptr_type fn_gcc_jit_context_new_function_ptr_type
379 #define gcc_jit_context_new_global fn_gcc_jit_context_new_global
380 #define gcc_jit_context_new_opaque_struct fn_gcc_jit_context_new_opaque_struct
381 #define gcc_jit_context_new_param fn_gcc_jit_context_new_param
382 #define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int
383 #define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long
384 #if LISP_WORDS_ARE_POINTERS
385 # define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr
386 #endif
387 #define gcc_jit_context_new_string_literal fn_gcc_jit_context_new_string_literal
388 #define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type
389 #define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op
390 #define gcc_jit_context_new_union_type fn_gcc_jit_context_new_union_type
391 #define gcc_jit_context_release fn_gcc_jit_context_release
392 #define gcc_jit_context_set_bool_option fn_gcc_jit_context_set_bool_option
393 #define gcc_jit_context_set_int_option fn_gcc_jit_context_set_int_option
394 #define gcc_jit_context_set_logfile fn_gcc_jit_context_set_logfile
395 #define gcc_jit_context_set_str_option fn_gcc_jit_context_set_str_option
396 #define gcc_jit_function_get_param fn_gcc_jit_function_get_param
397 #define gcc_jit_function_new_block fn_gcc_jit_function_new_block
398 #define gcc_jit_function_new_local fn_gcc_jit_function_new_local
399 #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer)
400 #define gcc_jit_global_set_initializer fn_gcc_jit_global_set_initializer
401 #endif
402 #define gcc_jit_lvalue_access_field fn_gcc_jit_lvalue_access_field
403 #define gcc_jit_lvalue_as_rvalue fn_gcc_jit_lvalue_as_rvalue
404 #define gcc_jit_lvalue_get_address fn_gcc_jit_lvalue_get_address
405 #define gcc_jit_param_as_lvalue fn_gcc_jit_param_as_lvalue
406 #define gcc_jit_param_as_rvalue fn_gcc_jit_param_as_rvalue
407 #define gcc_jit_rvalue_access_field fn_gcc_jit_rvalue_access_field
408 #define gcc_jit_rvalue_dereference fn_gcc_jit_rvalue_dereference
409 #define gcc_jit_rvalue_dereference_field fn_gcc_jit_rvalue_dereference_field
410 #define gcc_jit_rvalue_get_type fn_gcc_jit_rvalue_get_type
411 #define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type
412 #define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields
413 #define gcc_jit_type_get_const fn_gcc_jit_type_get_const
414 #define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer
415 #if defined (LIBGCCJIT_HAVE_gcc_jit_version)
416 #define gcc_jit_version_major fn_gcc_jit_version_major
417 #define gcc_jit_version_minor fn_gcc_jit_version_minor
418 #define gcc_jit_version_patchlevel fn_gcc_jit_version_patchlevel
419 #endif
420
421 #endif
422
423 static bool
load_gccjit_if_necessary(bool mandatory)424 load_gccjit_if_necessary (bool mandatory)
425 {
426 #ifdef WINDOWSNT
427 static bool tried_to_initialize_once;
428 static bool gccjit_initialized;
429
430 if (!tried_to_initialize_once)
431 {
432 tried_to_initialize_once = true;
433 Lisp_Object status;
434 gccjit_initialized = init_gccjit_functions ();
435 status = gccjit_initialized ? Qt : Qnil;
436 Vlibrary_cache = Fcons (Fcons (Qgccjit, status), Vlibrary_cache);
437 }
438
439 if (mandatory && !gccjit_initialized)
440 xsignal1 (Qnative_compiler_error, build_string ("libgccjit not found"));
441
442 return gccjit_initialized;
443 #else
444 return true;
445 #endif
446 }
447
448
449 /* Increase this number to force a new Vcomp_abi_hash to be generated. */
450 #define ABI_VERSION "4"
451
452 /* Length of the hashes used for eln file naming. */
453 #define HASH_LENGTH 8
454
455 /* C symbols emitted for the load relocation mechanism. */
456 #define CURRENT_THREAD_RELOC_SYM "current_thread_reloc"
457 #define PURE_RELOC_SYM "pure_reloc"
458 #define DATA_RELOC_SYM "d_reloc"
459 #define DATA_RELOC_IMPURE_SYM "d_reloc_imp"
460 #define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph"
461
462 #define FUNC_LINK_TABLE_SYM "freloc_link_table"
463 #define LINK_TABLE_HASH_SYM "freloc_hash"
464 #define COMP_UNIT_SYM "comp_unit"
465 #define TEXT_DATA_RELOC_SYM "text_data_reloc"
466 #define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp"
467 #define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph"
468
469 #define TEXT_OPTIM_QLY_SYM "text_optim_qly"
470 #define TEXT_FDOC_SYM "text_data_fdoc"
471
472 #define STR_VALUE(s) #s
473 #define STR(s) STR_VALUE (s)
474
475 #define FIRST(x) \
476 XCAR(x)
477 #define SECOND(x) \
478 XCAR (XCDR (x))
479 #define THIRD(x) \
480 XCAR (XCDR (XCDR (x)))
481
482 /* Like call1 but stringify and intern. */
483 #define CALL1I(fun, arg) \
484 CALLN (Ffuncall, intern_c_string (STR (fun)), arg)
485
486 /* Like call2 but stringify and intern. */
487 #define CALL2I(fun, arg1, arg2) \
488 CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2)
489
490 #define DECL_BLOCK(name, func) \
491 gcc_jit_block *(name) = \
492 gcc_jit_function_new_block ((func), STR (name))
493
494 #ifndef WINDOWSNT
495 # ifdef HAVE__SETJMP
496 # define SETJMP _setjmp
497 # else
498 # define SETJMP setjmp
499 # endif
500 #else
501 /* snippet from MINGW-64 setjmp.h */
502 # define SETJMP _setjmp
503 #endif
504 #define SETJMP_NAME SETJMP
505
506 /* Max number function importable by native compiled code. */
507 #define F_RELOC_MAX_SIZE 1500
508
509 typedef struct {
510 void *link_table[F_RELOC_MAX_SIZE];
511 ptrdiff_t size;
512 } f_reloc_t;
513
514 sigset_t saved_sigset;
515
516 static f_reloc_t freloc;
517
518 #define NUM_CAST_TYPES 15
519
520 typedef struct {
521 EMACS_INT len;
522 gcc_jit_rvalue *r_val;
523 } reloc_array_t;
524
525 /* C side of the compiler context. */
526
527 typedef struct {
528 EMACS_INT speed;
529 EMACS_INT debug;
530 Lisp_Object compiler_options;
531 Lisp_Object driver_options;
532 gcc_jit_context *ctxt;
533 gcc_jit_type *void_type;
534 gcc_jit_type *bool_type;
535 gcc_jit_type *char_type;
536 gcc_jit_type *int_type;
537 gcc_jit_type *unsigned_type;
538 gcc_jit_type *long_type;
539 gcc_jit_type *unsigned_long_type;
540 gcc_jit_type *long_long_type;
541 gcc_jit_type *unsigned_long_long_type;
542 gcc_jit_type *emacs_int_type;
543 gcc_jit_type *emacs_uint_type;
544 gcc_jit_type *void_ptr_type;
545 gcc_jit_type *char_ptr_type;
546 gcc_jit_type *ptrdiff_type;
547 gcc_jit_type *uintptr_type;
548 gcc_jit_type *size_t_type;
549 gcc_jit_type *lisp_word_type;
550 gcc_jit_type *lisp_word_tag_type;
551 #ifdef LISP_OBJECT_IS_STRUCT
552 gcc_jit_field *lisp_obj_i;
553 gcc_jit_struct *lisp_obj_s;
554 #endif
555 gcc_jit_type *lisp_obj_type;
556 gcc_jit_type *lisp_obj_ptr_type;
557 /* struct Lisp_Cons */
558 gcc_jit_struct *lisp_cons_s;
559 gcc_jit_field *lisp_cons_u;
560 gcc_jit_field *lisp_cons_u_s;
561 gcc_jit_field *lisp_cons_u_s_car;
562 gcc_jit_field *lisp_cons_u_s_u;
563 gcc_jit_field *lisp_cons_u_s_u_cdr;
564 gcc_jit_type *lisp_cons_type;
565 gcc_jit_type *lisp_cons_ptr_type;
566 /* struct jmp_buf. */
567 gcc_jit_struct *jmp_buf_s;
568 /* struct handler. */
569 gcc_jit_struct *handler_s;
570 gcc_jit_field *handler_jmp_field;
571 gcc_jit_field *handler_val_field;
572 gcc_jit_field *handler_next_field;
573 gcc_jit_type *handler_ptr_type;
574 gcc_jit_lvalue *loc_handler;
575 /* struct thread_state. */
576 gcc_jit_struct *thread_state_s;
577 gcc_jit_field *m_handlerlist;
578 gcc_jit_type *thread_state_ptr_type;
579 gcc_jit_rvalue *current_thread_ref;
580 /* Other globals. */
581 gcc_jit_rvalue *pure_ptr;
582 /* libgccjit has really limited support for casting therefore this union will
583 be used for the scope. */
584 gcc_jit_type *cast_union_type;
585 gcc_jit_function *cast_functions_from_to[NUM_CAST_TYPES][NUM_CAST_TYPES];
586 gcc_jit_function *cast_ptr_to_int;
587 gcc_jit_function *cast_int_to_ptr;
588 gcc_jit_type *cast_types[NUM_CAST_TYPES];
589 gcc_jit_function *func; /* Current function being compiled. */
590 bool func_has_non_local; /* From comp-func has-non-local slot. */
591 EMACS_INT func_speed; /* From comp-func speed slot. */
592 gcc_jit_block *block; /* Current basic block being compiled. */
593 gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */
594 ptrdiff_t frame_size; /* Size of the following array in elements. */
595 gcc_jit_lvalue **frame; /* Frame slot n -> gcc_jit_lvalue *. */
596 gcc_jit_rvalue *zero;
597 gcc_jit_rvalue *one;
598 gcc_jit_rvalue *inttypebits;
599 gcc_jit_rvalue *lisp_int0;
600 gcc_jit_function *pseudovectorp;
601 gcc_jit_function *bool_to_lisp_obj;
602 gcc_jit_function *add1;
603 gcc_jit_function *sub1;
604 gcc_jit_function *negate;
605 gcc_jit_function *car;
606 gcc_jit_function *cdr;
607 gcc_jit_function *setcar;
608 gcc_jit_function *setcdr;
609 gcc_jit_function *check_type;
610 gcc_jit_function *check_impure;
611 gcc_jit_function *maybe_gc_or_quit;
612 Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */
613 Lisp_Object exported_funcs_h; /* c-func-name -> gcc_jit_function *. */
614 Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */
615 Lisp_Object emitter_dispatcher;
616 /* Synthesized struct holding data relocs. */
617 reloc_array_t data_relocs;
618 /* Same as before but can't go in pure space. */
619 reloc_array_t data_relocs_impure;
620 /* Same as before but content does not survive load phase. */
621 reloc_array_t data_relocs_ephemeral;
622 /* Global structure holding function relocations. */
623 gcc_jit_lvalue *func_relocs;
624 gcc_jit_type *func_relocs_ptr_type;
625 /* Pointer to this structure local to each function. */
626 gcc_jit_lvalue *func_relocs_local;
627 gcc_jit_function *memcpy;
628 Lisp_Object d_default_idx;
629 Lisp_Object d_impure_idx;
630 Lisp_Object d_ephemeral_idx;
631 } comp_t;
632
633 static comp_t comp;
634
635 FILE *logfile = NULL;
636
637 /* This is used for serialized objects by the reload mechanism. */
638 typedef struct {
639 ptrdiff_t len;
640 char data[];
641 } static_obj_t;
642
643 typedef struct {
644 reloc_array_t array;
645 gcc_jit_rvalue *idx;
646 } imm_reloc_t;
647
648
649 /*
650 Helper functions called by the run-time.
651 */
652
653 void helper_unwind_protect (Lisp_Object handler);
654 Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x);
655 Lisp_Object helper_unbind_n (Lisp_Object n);
656 void helper_save_restriction (void);
657 bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code);
658
659 void *helper_link_table[] =
660 { wrong_type_argument,
661 helper_PSEUDOVECTOR_TYPEP_XUNTAG,
662 pure_write_error,
663 push_handler,
664 record_unwind_protect_excursion,
665 helper_unbind_n,
666 helper_save_restriction,
667 record_unwind_current_buffer,
668 set_internal,
669 helper_unwind_protect,
670 specbind,
671 maybe_gc,
672 maybe_quit };
673
674
675 static char * ATTRIBUTE_FORMAT_PRINTF (1, 2)
format_string(const char * format,...)676 format_string (const char *format, ...)
677 {
678 static char scratch_area[512];
679 va_list va;
680 va_start (va, format);
681 int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va);
682 if (res >= sizeof (scratch_area))
683 {
684 scratch_area[sizeof (scratch_area) - 4] = '.';
685 scratch_area[sizeof (scratch_area) - 3] = '.';
686 scratch_area[sizeof (scratch_area) - 2] = '.';
687 }
688 va_end (va);
689 return scratch_area;
690 }
691
692 static Lisp_Object
comp_hash_string(Lisp_Object string)693 comp_hash_string (Lisp_Object string)
694 {
695 Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2);
696 md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest));
697 hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE);
698
699 return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH));
700 }
701
702 static Lisp_Object
comp_hash_source_file(Lisp_Object filename)703 comp_hash_source_file (Lisp_Object filename)
704 {
705 /* Can't use Finsert_file_contents + Fbuffer_hash as this is called
706 by Fcomp_el_to_eln_filename too early during bootstrap. */
707 bool is_gz = suffix_p (filename, ".gz");
708 #ifndef HAVE_ZLIB
709 if (is_gz)
710 xsignal2 (Qfile_notify_error,
711 build_string ("Cannot natively compile compressed *.el files without zlib support"),
712 filename);
713 #endif
714 Lisp_Object encoded_filename = ENCODE_FILE (filename);
715 FILE *f = emacs_fopen (SSDATA (encoded_filename), is_gz ? "rb" : "r");
716
717 if (!f)
718 report_file_error ("Opening source file", filename);
719
720 Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2);
721
722 #ifdef HAVE_ZLIB
723 int res = is_gz
724 ? md5_gz_stream (f, SSDATA (digest))
725 : md5_stream (f, SSDATA (digest));
726 #else
727 int res = md5_stream (f, SSDATA (digest));
728 #endif
729 fclose (f);
730
731 if (res)
732 xsignal2 (Qfile_notify_error, build_string ("hashing failed"), filename);
733
734 hexbuf_digest (SSDATA (digest), SSDATA (digest), MD5_DIGEST_SIZE);
735
736 return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH));
737 }
738
739 DEFUN ("comp--subr-signature", Fcomp__subr_signature,
740 Scomp__subr_signature, 1, 1, 0,
741 doc: /* Support function to 'hash_native_abi'.
742 For internal use. */)
743 (Lisp_Object subr)
744 {
745 return concat2 (Fsubr_name (subr),
746 Fprin1_to_string (Fsubr_arity (subr), Qnil));
747 }
748
749 /* Produce a key hashing Vcomp_subr_list. */
750
751 void
hash_native_abi(void)752 hash_native_abi (void)
753 {
754 /* Check runs once. */
755 eassert (NILP (Vcomp_abi_hash));
756
757 Vcomp_abi_hash =
758 comp_hash_string (
759 concat3 (build_string (ABI_VERSION),
760 concat3 (Vemacs_version, Vsystem_configuration,
761 Vsystem_configuration_options),
762 Fmapconcat (intern_c_string ("comp--subr-signature"),
763 Vcomp_subr_list, build_string (""))));
764
765 Lisp_Object version = Vemacs_version;
766
767 #ifdef NS_SELF_CONTAINED
768 /* MacOS self contained app bundles do not like having dots in the
769 directory names under the Contents/Frameworks directory, so
770 convert them to underscores. */
771 version = STRING_MULTIBYTE (Vemacs_version)
772 ? make_uninit_multibyte_string (SCHARS (Vemacs_version),
773 SBYTES (Vemacs_version))
774 : make_uninit_string (SBYTES (Vemacs_version));
775
776 const unsigned char *from = SDATA (Vemacs_version);
777 unsigned char *to = SDATA (version);
778
779 while (from < SDATA (Vemacs_version) + SBYTES (Vemacs_version))
780 {
781 unsigned char c = *from++;
782
783 if (c == '.')
784 c = '_';
785
786 *to++ = c;
787 }
788 #endif
789
790 Vcomp_native_version_dir =
791 concat3 (version, build_string ("-"), Vcomp_abi_hash);
792 }
793
794 static void
freloc_check_fill(void)795 freloc_check_fill (void)
796 {
797 if (freloc.size)
798 return;
799
800 eassert (!NILP (Vcomp_subr_list));
801
802 if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE)
803 goto overflow;
804 memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table));
805 freloc.size = ARRAYELTS (helper_link_table);
806
807 Lisp_Object subr_l = Vcomp_subr_list;
808 FOR_EACH_TAIL (subr_l)
809 {
810 if (freloc.size == F_RELOC_MAX_SIZE)
811 goto overflow;
812 struct Lisp_Subr *subr = XSUBR (XCAR (subr_l));
813 freloc.link_table[freloc.size] = subr->function.a0;
814 freloc.size++;
815 }
816 return;
817
818 overflow:
819 fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE");
820 }
821
822 static void
bcall0(Lisp_Object f)823 bcall0 (Lisp_Object f)
824 {
825 Ffuncall (1, &f);
826 }
827
828 static gcc_jit_block *
retrive_block(Lisp_Object block_name)829 retrive_block (Lisp_Object block_name)
830 {
831 Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil);
832
833 if (NILP (value))
834 xsignal2 (Qnative_ice, build_string ("missing basic block"), block_name);
835
836 return (gcc_jit_block *) xmint_pointer (value);
837 }
838
839 static void
declare_block(Lisp_Object block_name)840 declare_block (Lisp_Object block_name)
841 {
842 char *name_str = SSDATA (SYMBOL_NAME (block_name));
843 gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str);
844 Lisp_Object value = make_mint_ptr (block);
845
846 if (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)))
847 xsignal1 (Qnative_ice, build_string ("double basic block declaration"));
848
849 Fputhash (block_name, value, comp.func_blocks_h);
850 }
851
852 static gcc_jit_lvalue *
emit_mvar_lval(Lisp_Object mvar)853 emit_mvar_lval (Lisp_Object mvar)
854 {
855 Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar);
856
857 if (EQ (mvar_slot, Qscratch))
858 {
859 if (!comp.scratch)
860 comp.scratch = gcc_jit_function_new_local (comp.func,
861 NULL,
862 comp.lisp_obj_type,
863 "scratch");
864 return comp.scratch;
865 }
866
867 EMACS_INT slot_n = XFIXNUM (mvar_slot);
868 eassert (slot_n < comp.frame_size);
869 return comp.frame[slot_n];
870 }
871
872 static void
register_emitter(Lisp_Object key,void * func)873 register_emitter (Lisp_Object key, void *func)
874 {
875 Lisp_Object value = make_mint_ptr (func);
876 Fputhash (key, value, comp.emitter_dispatcher);
877 }
878
879 static imm_reloc_t
obj_to_reloc(Lisp_Object obj)880 obj_to_reloc (Lisp_Object obj)
881 {
882 imm_reloc_t reloc;
883 Lisp_Object idx;
884
885 idx = Fgethash (obj, comp.d_default_idx, Qnil);
886 if (!NILP (idx)) {
887 reloc.array = comp.data_relocs;
888 goto found;
889 }
890
891 idx = Fgethash (obj, comp.d_impure_idx, Qnil);
892 if (!NILP (idx))
893 {
894 reloc.array = comp.data_relocs_impure;
895 goto found;
896 }
897
898 idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil);
899 if (!NILP (idx))
900 {
901 reloc.array = comp.data_relocs_ephemeral;
902 goto found;
903 }
904
905 xsignal1 (Qnative_ice,
906 build_string ("cant't find data in relocation containers"));
907 assume (false);
908
909 found:
910 eassert (XFIXNUM (idx) < reloc.array.len);
911 if (!FIXNUMP (idx))
912 xsignal1 (Qnative_ice,
913 build_string ("inconsistent data relocation container"));
914 reloc.idx = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
915 comp.ptrdiff_type,
916 XFIXNUM (idx));
917 return reloc;
918 }
919
920 static void
emit_comment(const char * str)921 emit_comment (const char *str)
922 {
923 if (comp.debug)
924 gcc_jit_block_add_comment (comp.block,
925 NULL,
926 str);
927 }
928
929 /*
930 Declare an imported function.
931 When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed.
932 When types is NULL args are assumed to be all Lisp_Objects.
933 */
934 static gcc_jit_field *
declare_imported_func(Lisp_Object subr_sym,gcc_jit_type * ret_type,int nargs,gcc_jit_type ** types)935 declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type,
936 int nargs, gcc_jit_type **types)
937 {
938 USE_SAFE_ALLOCA;
939 /* Don't want to declare the same function two times. */
940 if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)))
941 xsignal2 (Qnative_ice,
942 build_string ("unexpected double function declaration"),
943 subr_sym);
944
945 if (nargs == MANY)
946 {
947 nargs = 2;
948 types = SAFE_ALLOCA (nargs * sizeof (* types));
949 types[0] = comp.ptrdiff_type;
950 types[1] = comp.lisp_obj_ptr_type;
951 }
952 else if (nargs == UNEVALLED)
953 {
954 nargs = 1;
955 types = SAFE_ALLOCA (nargs * sizeof (* types));
956 types[0] = comp.lisp_obj_type;
957 }
958 else if (!types)
959 {
960 types = SAFE_ALLOCA (nargs * sizeof (* types));
961 for (ptrdiff_t i = 0; i < nargs; i++)
962 types[i] = comp.lisp_obj_type;
963 }
964
965 /* String containing the function ptr name. */
966 Lisp_Object f_ptr_name =
967 CALLN (Ffuncall, intern_c_string ("comp-c-func-name"),
968 subr_sym, make_string ("R", 1));
969
970 gcc_jit_type *f_ptr_type =
971 gcc_jit_type_get_const (
972 gcc_jit_context_new_function_ptr_type (comp.ctxt,
973 NULL,
974 ret_type,
975 nargs,
976 types,
977 0));
978 gcc_jit_field *field =
979 gcc_jit_context_new_field (comp.ctxt,
980 NULL,
981 f_ptr_type,
982 SSDATA (f_ptr_name));
983
984 Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h);
985 SAFE_FREE ();
986 return field;
987 }
988
989 /* Emit calls fetching from existing declarations. */
990
991 static gcc_jit_rvalue *
emit_call(Lisp_Object func,gcc_jit_type * ret_type,ptrdiff_t nargs,gcc_jit_rvalue ** args,bool direct)992 emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs,
993 gcc_jit_rvalue **args, bool direct)
994 {
995 Lisp_Object gcc_func =
996 Fgethash (func,
997 direct ? comp.exported_funcs_h : comp.imported_funcs_h,
998 Qnil);
999
1000 if (NILP (gcc_func))
1001 xsignal2 (Qnative_ice,
1002 build_string ("missing function declaration"),
1003 func);
1004
1005 if (direct)
1006 {
1007 emit_comment (format_string ("direct call to: %s",
1008 SSDATA (func)));
1009 return gcc_jit_context_new_call (comp.ctxt,
1010 NULL,
1011 xmint_pointer (gcc_func),
1012 nargs,
1013 args);
1014 }
1015 else
1016 {
1017 /* Inline functions so far don't have a local variable for
1018 function reloc table so we fall back to the global one. Even
1019 if this is not aesthetic calling into C from open-code is
1020 always a fallback and therefore not be performance critical.
1021 To fix this could think do the inline our-self without
1022 relying on GCC. */
1023 gcc_jit_lvalue *f_ptr =
1024 gcc_jit_rvalue_dereference_field (
1025 gcc_jit_lvalue_as_rvalue (comp.func_relocs_local
1026 ? comp.func_relocs_local
1027 : comp.func_relocs),
1028 NULL,
1029 (gcc_jit_field *) xmint_pointer (gcc_func));
1030
1031 if (!f_ptr)
1032 xsignal2 (Qnative_ice,
1033 build_string ("missing function relocation"),
1034 func);
1035 emit_comment (format_string ("calling subr: %s",
1036 SSDATA (SYMBOL_NAME (func))));
1037 return gcc_jit_context_new_call_through_ptr (comp.ctxt,
1038 NULL,
1039 gcc_jit_lvalue_as_rvalue (f_ptr),
1040 nargs,
1041 args);
1042 }
1043 }
1044
1045 static gcc_jit_rvalue *
emit_call_ref(Lisp_Object func,ptrdiff_t nargs,gcc_jit_lvalue * base_arg,bool direct)1046 emit_call_ref (Lisp_Object func, ptrdiff_t nargs,
1047 gcc_jit_lvalue *base_arg, bool direct)
1048 {
1049 gcc_jit_rvalue *args[] =
1050 { gcc_jit_context_new_rvalue_from_int (comp.ctxt,
1051 comp.ptrdiff_type,
1052 nargs),
1053 gcc_jit_lvalue_get_address (base_arg, NULL) };
1054 return emit_call (func, comp.lisp_obj_type, 2, args, direct);
1055 }
1056
1057 /* Close current basic block emitting a conditional. */
1058
1059 static void
emit_cond_jump(gcc_jit_rvalue * test,gcc_jit_block * then_target,gcc_jit_block * else_target)1060 emit_cond_jump (gcc_jit_rvalue *test,
1061 gcc_jit_block *then_target, gcc_jit_block *else_target)
1062 {
1063 if (gcc_jit_rvalue_get_type (test) == comp.bool_type)
1064 gcc_jit_block_end_with_conditional (comp.block,
1065 NULL,
1066 test,
1067 then_target,
1068 else_target);
1069 else
1070 /* In case test is not bool we do a logical negation to obtain a bool as
1071 result. */
1072 gcc_jit_block_end_with_conditional (
1073 comp.block,
1074 NULL,
1075 gcc_jit_context_new_unary_op (comp.ctxt,
1076 NULL,
1077 GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
1078 comp.bool_type,
1079 test),
1080 else_target,
1081 then_target);
1082
1083 }
1084
1085 static int
type_to_cast_index(gcc_jit_type * type)1086 type_to_cast_index (gcc_jit_type * type)
1087 {
1088 for (int i = 0; i < NUM_CAST_TYPES; ++i)
1089 if (type == comp.cast_types[i])
1090 return i;
1091
1092 xsignal1 (Qnative_ice, build_string ("unsupported cast"));
1093 }
1094
1095 static gcc_jit_rvalue *
emit_coerce(gcc_jit_type * new_type,gcc_jit_rvalue * obj)1096 emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj)
1097 {
1098 gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj);
1099
1100 if (new_type == old_type)
1101 return obj;
1102
1103 #ifdef LISP_OBJECT_IS_STRUCT
1104 if (old_type == comp.lisp_obj_type)
1105 {
1106 gcc_jit_rvalue *lwordobj =
1107 gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_i);
1108 return emit_coerce (new_type, lwordobj);
1109 }
1110
1111 if (new_type == comp.lisp_obj_type)
1112 {
1113 gcc_jit_rvalue *lwordobj =
1114 emit_coerce (comp.lisp_word_type, obj);
1115
1116 static ptrdiff_t i;
1117 gcc_jit_lvalue *tmp_s =
1118 gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type,
1119 format_string ("lisp_obj_%td", i++));
1120
1121 gcc_jit_block_add_assignment (
1122 comp.block, NULL,
1123 gcc_jit_lvalue_access_field (tmp_s, NULL,
1124 comp.lisp_obj_i),
1125 lwordobj);
1126 return gcc_jit_lvalue_as_rvalue (tmp_s);
1127 }
1128 #endif
1129
1130 int old_index = type_to_cast_index (old_type);
1131 int new_index = type_to_cast_index (new_type);
1132
1133 /* Lookup the appropriate cast function in the cast matrix. */
1134 return gcc_jit_context_new_call (comp.ctxt,
1135 NULL,
1136 comp.cast_functions_from_to[old_index][new_index],
1137 1, &obj);
1138 }
1139
1140 static gcc_jit_rvalue *
emit_binary_op(enum gcc_jit_binary_op op,gcc_jit_type * result_type,gcc_jit_rvalue * a,gcc_jit_rvalue * b)1141 emit_binary_op (enum gcc_jit_binary_op op,
1142 gcc_jit_type *result_type,
1143 gcc_jit_rvalue *a, gcc_jit_rvalue *b)
1144 {
1145 /* FIXME Check here for possible UB. */
1146 return gcc_jit_context_new_binary_op (comp.ctxt, NULL,
1147 op,
1148 result_type,
1149 emit_coerce (result_type, a),
1150 emit_coerce (result_type, b));
1151 }
1152
1153 /* Should come with libgccjit. */
1154
1155 static gcc_jit_rvalue *
emit_rvalue_from_long_long(gcc_jit_type * type,long long n)1156 emit_rvalue_from_long_long (gcc_jit_type *type, long long n)
1157 {
1158 emit_comment (format_string ("emit long long: %lld", n));
1159
1160 gcc_jit_rvalue *high =
1161 gcc_jit_context_new_rvalue_from_long (comp.ctxt,
1162 comp.unsigned_long_long_type,
1163 (unsigned long long)n >> 32);
1164 gcc_jit_rvalue *low =
1165 emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
1166 comp.unsigned_long_long_type,
1167 emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
1168 comp.unsigned_long_long_type,
1169 gcc_jit_context_new_rvalue_from_long (
1170 comp.ctxt,
1171 comp.unsigned_long_long_type,
1172 n),
1173 gcc_jit_context_new_rvalue_from_int (
1174 comp.ctxt,
1175 comp.unsigned_long_long_type,
1176 32)),
1177 gcc_jit_context_new_rvalue_from_int (
1178 comp.ctxt,
1179 comp.unsigned_long_long_type,
1180 32));
1181
1182 return
1183 emit_coerce (type,
1184 emit_binary_op (
1185 GCC_JIT_BINARY_OP_BITWISE_OR,
1186 comp.unsigned_long_long_type,
1187 emit_binary_op (
1188 GCC_JIT_BINARY_OP_LSHIFT,
1189 comp.unsigned_long_long_type,
1190 high,
1191 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
1192 comp.unsigned_long_long_type,
1193 32)),
1194 low));
1195 }
1196
1197 static gcc_jit_rvalue *
emit_rvalue_from_emacs_uint(EMACS_UINT val)1198 emit_rvalue_from_emacs_uint (EMACS_UINT val)
1199 {
1200 #ifdef WIDE_EMACS_INT
1201 if (val > ULONG_MAX)
1202 return emit_rvalue_from_long_long (comp.emacs_uint_type, val);
1203 #endif
1204 return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
1205 comp.emacs_uint_type,
1206 val);
1207 }
1208
1209 static gcc_jit_rvalue *
emit_rvalue_from_emacs_int(EMACS_INT val)1210 emit_rvalue_from_emacs_int (EMACS_INT val)
1211 {
1212 if (val > LONG_MAX || val < LONG_MIN)
1213 return emit_rvalue_from_long_long (comp.emacs_int_type, val);
1214 else
1215 return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
1216 comp.emacs_int_type, val);
1217 }
1218
1219 static gcc_jit_rvalue *
emit_rvalue_from_lisp_word_tag(Lisp_Word_tag val)1220 emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val)
1221 {
1222 #ifdef WIDE_EMACS_INT
1223 if (val > ULONG_MAX)
1224 return emit_rvalue_from_long_long (comp.lisp_word_tag_type, val);
1225 #endif
1226 return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
1227 comp.lisp_word_tag_type,
1228 val);
1229 }
1230
1231 static gcc_jit_rvalue *
emit_rvalue_from_lisp_word(Lisp_Word val)1232 emit_rvalue_from_lisp_word (Lisp_Word val)
1233 {
1234 #if LISP_WORDS_ARE_POINTERS
1235 return gcc_jit_context_new_rvalue_from_ptr (comp.ctxt,
1236 comp.lisp_word_type,
1237 val);
1238 #else
1239 if (val > LONG_MAX || val < LONG_MIN)
1240 return emit_rvalue_from_long_long (comp.lisp_word_type, val);
1241 else
1242 return gcc_jit_context_new_rvalue_from_long (comp.ctxt,
1243 comp.lisp_word_type,
1244 val);
1245 #endif
1246 }
1247
1248 static gcc_jit_rvalue *
emit_rvalue_from_lisp_obj(Lisp_Object obj)1249 emit_rvalue_from_lisp_obj (Lisp_Object obj)
1250 {
1251 #ifdef LISP_OBJECT_IS_STRUCT
1252 return emit_coerce (comp.lisp_obj_type,
1253 emit_rvalue_from_lisp_word (obj.i));
1254 #else
1255 return emit_rvalue_from_lisp_word (obj);
1256 #endif
1257 }
1258
1259 /*
1260 Emit the equivalent of:
1261 (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i)
1262 */
1263
1264 static gcc_jit_rvalue *
emit_ptr_arithmetic(gcc_jit_rvalue * ptr,gcc_jit_type * ptr_type,int size_of_ptr_ref,gcc_jit_rvalue * i)1265 emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type,
1266 int size_of_ptr_ref, gcc_jit_rvalue *i)
1267 {
1268 emit_comment ("ptr_arithmetic");
1269
1270 gcc_jit_rvalue *offset =
1271 emit_binary_op (
1272 GCC_JIT_BINARY_OP_MULT,
1273 comp.uintptr_type,
1274 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
1275 comp.uintptr_type,
1276 size_of_ptr_ref),
1277 i);
1278
1279 return
1280 emit_coerce (
1281 ptr_type,
1282 emit_binary_op (
1283 GCC_JIT_BINARY_OP_PLUS,
1284 comp.uintptr_type,
1285 ptr,
1286 offset));
1287 }
1288
1289 static gcc_jit_rvalue *
emit_XLI(gcc_jit_rvalue * obj)1290 emit_XLI (gcc_jit_rvalue *obj)
1291 {
1292 emit_comment ("XLI");
1293 return emit_coerce (comp.emacs_int_type, obj);
1294 }
1295
1296 static gcc_jit_rvalue *
emit_XLP(gcc_jit_rvalue * obj)1297 emit_XLP (gcc_jit_rvalue *obj)
1298 {
1299 emit_comment ("XLP");
1300
1301 return emit_coerce (comp.void_ptr_type, obj);
1302 }
1303
1304 static gcc_jit_rvalue *
emit_XUNTAG(gcc_jit_rvalue * a,gcc_jit_type * type,Lisp_Word_tag lisp_word_tag)1305 emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag)
1306 {
1307 /* #define XUNTAG(a, type, ctype) ((ctype *)
1308 ((char *) XLP (a) - LISP_WORD_TAG (type))) */
1309 emit_comment ("XUNTAG");
1310
1311 return emit_coerce (
1312 gcc_jit_type_get_pointer (type),
1313 emit_binary_op (
1314 GCC_JIT_BINARY_OP_MINUS,
1315 comp.uintptr_type,
1316 emit_XLP (a),
1317 emit_rvalue_from_lisp_word_tag (lisp_word_tag)));
1318 }
1319
1320 static gcc_jit_rvalue *
emit_XCONS(gcc_jit_rvalue * a)1321 emit_XCONS (gcc_jit_rvalue *a)
1322 {
1323 emit_comment ("XCONS");
1324
1325 return emit_XUNTAG (a,
1326 gcc_jit_struct_as_type (comp.lisp_cons_s),
1327 LISP_WORD_TAG (Lisp_Cons));
1328 }
1329
1330 static gcc_jit_rvalue *
emit_EQ(gcc_jit_rvalue * x,gcc_jit_rvalue * y)1331 emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y)
1332 {
1333 emit_comment ("EQ");
1334
1335 return gcc_jit_context_new_comparison (
1336 comp.ctxt,
1337 NULL,
1338 GCC_JIT_COMPARISON_EQ,
1339 emit_XLI (x),
1340 emit_XLI (y));
1341 }
1342
1343 static gcc_jit_rvalue *
emit_TAGGEDP(gcc_jit_rvalue * obj,Lisp_Word_tag tag)1344 emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag)
1345 {
1346 /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \
1347 - (unsigned) (tag)) \
1348 & ((1 << GCTYPEBITS) - 1))) */
1349 emit_comment ("TAGGEDP");
1350
1351 gcc_jit_rvalue *sh_res =
1352 emit_binary_op (
1353 GCC_JIT_BINARY_OP_RSHIFT,
1354 comp.emacs_int_type,
1355 emit_XLI (obj),
1356 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
1357 comp.emacs_int_type,
1358 (USE_LSB_TAG ? 0 : VALBITS)));
1359
1360 gcc_jit_rvalue *minus_res =
1361 emit_binary_op (
1362 GCC_JIT_BINARY_OP_MINUS,
1363 comp.unsigned_type,
1364 sh_res,
1365 gcc_jit_context_new_rvalue_from_int (
1366 comp.ctxt,
1367 comp.unsigned_type,
1368 tag));
1369
1370 gcc_jit_rvalue *res =
1371 gcc_jit_context_new_unary_op (
1372 comp.ctxt,
1373 NULL,
1374 GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
1375 comp.int_type,
1376 emit_binary_op (
1377 GCC_JIT_BINARY_OP_BITWISE_AND,
1378 comp.unsigned_type,
1379 minus_res,
1380 gcc_jit_context_new_rvalue_from_int (
1381 comp.ctxt,
1382 comp.unsigned_type,
1383 ((1 << GCTYPEBITS) - 1))));
1384
1385 return res;
1386 }
1387
1388 static gcc_jit_rvalue *
emit_VECTORLIKEP(gcc_jit_rvalue * obj)1389 emit_VECTORLIKEP (gcc_jit_rvalue *obj)
1390 {
1391 emit_comment ("VECTORLIKEP");
1392
1393 return emit_TAGGEDP (obj, Lisp_Vectorlike);
1394 }
1395
1396 static gcc_jit_rvalue *
emit_CONSP(gcc_jit_rvalue * obj)1397 emit_CONSP (gcc_jit_rvalue *obj)
1398 {
1399 emit_comment ("CONSP");
1400
1401 return emit_TAGGEDP (obj, Lisp_Cons);
1402 }
1403
1404 static gcc_jit_rvalue *
emit_FLOATP(gcc_jit_rvalue * obj)1405 emit_FLOATP (gcc_jit_rvalue *obj)
1406 {
1407 emit_comment ("FLOATP");
1408
1409 return emit_TAGGEDP (obj, Lisp_Float);
1410 }
1411
1412 static gcc_jit_rvalue *
emit_BIGNUMP(gcc_jit_rvalue * obj)1413 emit_BIGNUMP (gcc_jit_rvalue *obj)
1414 {
1415 /* PSEUDOVECTORP (x, PVEC_BIGNUM); */
1416 emit_comment ("BIGNUMP");
1417
1418 gcc_jit_rvalue *args[] =
1419 { obj,
1420 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
1421 comp.int_type,
1422 PVEC_BIGNUM) };
1423
1424 return gcc_jit_context_new_call (comp.ctxt,
1425 NULL,
1426 comp.pseudovectorp,
1427 2,
1428 args);
1429 }
1430
1431 static gcc_jit_rvalue *
emit_FIXNUMP(gcc_jit_rvalue * obj)1432 emit_FIXNUMP (gcc_jit_rvalue *obj)
1433 {
1434 /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS))
1435 - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG))
1436 & ((1 << INTTYPEBITS) - 1))) */
1437 emit_comment ("FIXNUMP");
1438
1439 gcc_jit_rvalue *sh_res =
1440 USE_LSB_TAG ? obj
1441 : emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
1442 comp.emacs_int_type,
1443 emit_XLI (obj),
1444 gcc_jit_context_new_rvalue_from_int (
1445 comp.ctxt,
1446 comp.emacs_int_type,
1447 FIXNUM_BITS));
1448
1449 gcc_jit_rvalue *minus_res =
1450 emit_binary_op (
1451 GCC_JIT_BINARY_OP_MINUS,
1452 comp.unsigned_type,
1453 sh_res,
1454 gcc_jit_context_new_rvalue_from_int (
1455 comp.ctxt,
1456 comp.unsigned_type,
1457 (Lisp_Int0 >> !USE_LSB_TAG)));
1458
1459 gcc_jit_rvalue *res =
1460 gcc_jit_context_new_unary_op (
1461 comp.ctxt,
1462 NULL,
1463 GCC_JIT_UNARY_OP_LOGICAL_NEGATE,
1464 comp.int_type,
1465 emit_binary_op (
1466 GCC_JIT_BINARY_OP_BITWISE_AND,
1467 comp.unsigned_type,
1468 minus_res,
1469 gcc_jit_context_new_rvalue_from_int (
1470 comp.ctxt,
1471 comp.unsigned_type,
1472 ((1 << INTTYPEBITS) - 1))));
1473
1474 return res;
1475 }
1476
1477 static gcc_jit_rvalue *
emit_XFIXNUM(gcc_jit_rvalue * obj)1478 emit_XFIXNUM (gcc_jit_rvalue *obj)
1479 {
1480 emit_comment ("XFIXNUM");
1481 gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj));
1482
1483 /* FIXME: Implementation dependent (both RSHIFT are arithmetic). */
1484
1485 if (!USE_LSB_TAG)
1486 {
1487 i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
1488 comp.emacs_uint_type,
1489 i,
1490 comp.inttypebits);
1491
1492 return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
1493 comp.emacs_int_type,
1494 i,
1495 comp.inttypebits);
1496 }
1497 else
1498 return emit_coerce (comp.emacs_int_type,
1499 emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
1500 comp.emacs_int_type,
1501 i,
1502 comp.inttypebits));
1503 }
1504
1505 static gcc_jit_rvalue *
emit_INTEGERP(gcc_jit_rvalue * obj)1506 emit_INTEGERP (gcc_jit_rvalue *obj)
1507 {
1508 emit_comment ("INTEGERP");
1509
1510 return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
1511 comp.bool_type,
1512 emit_FIXNUMP (obj),
1513 emit_BIGNUMP (obj));
1514 }
1515
1516 static gcc_jit_rvalue *
emit_NUMBERP(gcc_jit_rvalue * obj)1517 emit_NUMBERP (gcc_jit_rvalue *obj)
1518 {
1519 emit_comment ("NUMBERP");
1520
1521 return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
1522 comp.bool_type,
1523 emit_INTEGERP (obj),
1524 emit_FLOATP (obj));
1525 }
1526
1527 static gcc_jit_rvalue *
emit_make_fixnum_LSB_TAG(gcc_jit_rvalue * n)1528 emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n)
1529 {
1530 /*
1531 EMACS_UINT u = n;
1532 n = u << INTTYPEBITS;
1533 n += int0;
1534 */
1535
1536 gcc_jit_rvalue *tmp =
1537 emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
1538 comp.emacs_int_type,
1539 n, comp.inttypebits);
1540
1541 tmp = emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
1542 comp.emacs_int_type,
1543 tmp, comp.lisp_int0);
1544
1545 return emit_coerce (comp.lisp_obj_type, tmp);
1546 }
1547
1548 static gcc_jit_rvalue *
emit_make_fixnum_MSB_TAG(gcc_jit_rvalue * n)1549 emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n)
1550 {
1551 /*
1552 n &= INTMASK;
1553 n += (int0 << VALBITS);
1554 return XIL (n);
1555 */
1556
1557 gcc_jit_rvalue *intmask = emit_rvalue_from_emacs_uint (INTMASK);
1558
1559 n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND,
1560 comp.emacs_uint_type,
1561 intmask, n);
1562
1563 n =
1564 emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
1565 comp.emacs_uint_type,
1566 emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT,
1567 comp.emacs_uint_type,
1568 comp.lisp_int0,
1569 emit_rvalue_from_emacs_uint (VALBITS)),
1570 n);
1571
1572 return emit_coerce (comp.lisp_obj_type, n);
1573 }
1574
1575
1576 static gcc_jit_rvalue *
emit_make_fixnum(gcc_jit_rvalue * obj)1577 emit_make_fixnum (gcc_jit_rvalue *obj)
1578 {
1579 emit_comment ("make_fixnum");
1580 return USE_LSB_TAG
1581 ? emit_make_fixnum_LSB_TAG (obj)
1582 : emit_make_fixnum_MSB_TAG (obj);
1583 }
1584
1585 static gcc_jit_lvalue *
emit_lisp_obj_reloc_lval(Lisp_Object obj)1586 emit_lisp_obj_reloc_lval (Lisp_Object obj)
1587 {
1588 emit_comment (format_string ("l-value for lisp obj: %s",
1589 SSDATA (Fprin1_to_string (obj, Qnil))));
1590
1591 imm_reloc_t reloc = obj_to_reloc (obj);
1592 return gcc_jit_context_new_array_access (comp.ctxt,
1593 NULL,
1594 reloc.array.r_val,
1595 reloc.idx);
1596 }
1597
1598 static gcc_jit_rvalue *
emit_lisp_obj_rval(Lisp_Object obj)1599 emit_lisp_obj_rval (Lisp_Object obj)
1600 {
1601 emit_comment (format_string ("const lisp obj: %s",
1602 SSDATA (Fprin1_to_string (obj, Qnil))));
1603
1604 if (EQ (obj, Qnil))
1605 {
1606 gcc_jit_rvalue *n;
1607 n = emit_rvalue_from_lisp_word ((Lisp_Word) iQnil);
1608 return emit_coerce (comp.lisp_obj_type, n);
1609 }
1610
1611 return gcc_jit_lvalue_as_rvalue (emit_lisp_obj_reloc_lval (obj));
1612 }
1613
1614 static gcc_jit_rvalue *
emit_NILP(gcc_jit_rvalue * x)1615 emit_NILP (gcc_jit_rvalue *x)
1616 {
1617 emit_comment ("NILP");
1618 return emit_EQ (x, emit_lisp_obj_rval (Qnil));
1619 }
1620
1621 static gcc_jit_rvalue *
emit_XCAR(gcc_jit_rvalue * c)1622 emit_XCAR (gcc_jit_rvalue *c)
1623 {
1624 emit_comment ("XCAR");
1625
1626 /* XCONS (c)->u.s.car */
1627 return
1628 gcc_jit_rvalue_access_field (
1629 /* XCONS (c)->u.s */
1630 gcc_jit_rvalue_access_field (
1631 /* XCONS (c)->u */
1632 gcc_jit_lvalue_as_rvalue (
1633 gcc_jit_rvalue_dereference_field (
1634 emit_XCONS (c),
1635 NULL,
1636 comp.lisp_cons_u)),
1637 NULL,
1638 comp.lisp_cons_u_s),
1639 NULL,
1640 comp.lisp_cons_u_s_car);
1641 }
1642
1643 static gcc_jit_lvalue *
emit_lval_XCAR(gcc_jit_rvalue * c)1644 emit_lval_XCAR (gcc_jit_rvalue *c)
1645 {
1646 emit_comment ("lval_XCAR");
1647
1648 /* XCONS (c)->u.s.car */
1649 return
1650 gcc_jit_lvalue_access_field (
1651 /* XCONS (c)->u.s */
1652 gcc_jit_lvalue_access_field (
1653 /* XCONS (c)->u */
1654 gcc_jit_rvalue_dereference_field (
1655 emit_XCONS (c),
1656 NULL,
1657 comp.lisp_cons_u),
1658 NULL,
1659 comp.lisp_cons_u_s),
1660 NULL,
1661 comp.lisp_cons_u_s_car);
1662 }
1663
1664 static gcc_jit_rvalue *
emit_XCDR(gcc_jit_rvalue * c)1665 emit_XCDR (gcc_jit_rvalue *c)
1666 {
1667 emit_comment ("XCDR");
1668 /* XCONS (c)->u.s.u.cdr */
1669 return
1670 gcc_jit_rvalue_access_field (
1671 /* XCONS (c)->u.s.u */
1672 gcc_jit_rvalue_access_field (
1673 /* XCONS (c)->u.s */
1674 gcc_jit_rvalue_access_field (
1675 /* XCONS (c)->u */
1676 gcc_jit_lvalue_as_rvalue (
1677 gcc_jit_rvalue_dereference_field (
1678 emit_XCONS (c),
1679 NULL,
1680 comp.lisp_cons_u)),
1681 NULL,
1682 comp.lisp_cons_u_s),
1683 NULL,
1684 comp.lisp_cons_u_s_u),
1685 NULL,
1686 comp.lisp_cons_u_s_u_cdr);
1687 }
1688
1689 static gcc_jit_lvalue *
emit_lval_XCDR(gcc_jit_rvalue * c)1690 emit_lval_XCDR (gcc_jit_rvalue *c)
1691 {
1692 emit_comment ("lval_XCDR");
1693
1694 /* XCONS (c)->u.s.u.cdr */
1695 return
1696 gcc_jit_lvalue_access_field (
1697 /* XCONS (c)->u.s.u */
1698 gcc_jit_lvalue_access_field (
1699 /* XCONS (c)->u.s */
1700 gcc_jit_lvalue_access_field (
1701 /* XCONS (c)->u */
1702 gcc_jit_rvalue_dereference_field (
1703 emit_XCONS (c),
1704 NULL,
1705 comp.lisp_cons_u),
1706 NULL,
1707 comp.lisp_cons_u_s),
1708 NULL,
1709 comp.lisp_cons_u_s_u),
1710 NULL,
1711 comp.lisp_cons_u_s_u_cdr);
1712 }
1713
1714 static void
emit_CHECK_CONS(gcc_jit_rvalue * x)1715 emit_CHECK_CONS (gcc_jit_rvalue *x)
1716 {
1717 emit_comment ("CHECK_CONS");
1718
1719 gcc_jit_rvalue *args[] =
1720 { emit_CONSP (x),
1721 emit_lisp_obj_rval (Qconsp),
1722 x };
1723
1724 gcc_jit_block_add_eval (
1725 comp.block,
1726 NULL,
1727 gcc_jit_context_new_call (comp.ctxt,
1728 NULL,
1729 comp.check_type,
1730 3,
1731 args));
1732 }
1733
1734 static gcc_jit_rvalue *
emit_car_addr(gcc_jit_rvalue * c)1735 emit_car_addr (gcc_jit_rvalue *c)
1736 {
1737 emit_comment ("car_addr");
1738
1739 return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL);
1740 }
1741
1742 static gcc_jit_rvalue *
emit_cdr_addr(gcc_jit_rvalue * c)1743 emit_cdr_addr (gcc_jit_rvalue *c)
1744 {
1745 emit_comment ("cdr_addr");
1746
1747 return gcc_jit_lvalue_get_address (emit_lval_XCDR (c), NULL);
1748 }
1749
1750 static void
emit_XSETCAR(gcc_jit_rvalue * c,gcc_jit_rvalue * n)1751 emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
1752 {
1753 emit_comment ("XSETCAR");
1754
1755 gcc_jit_block_add_assignment (
1756 comp.block,
1757 NULL,
1758 gcc_jit_rvalue_dereference (
1759 emit_car_addr (c),
1760 NULL),
1761 n);
1762 }
1763
1764 static void
emit_XSETCDR(gcc_jit_rvalue * c,gcc_jit_rvalue * n)1765 emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n)
1766 {
1767 emit_comment ("XSETCDR");
1768
1769 gcc_jit_block_add_assignment (
1770 comp.block,
1771 NULL,
1772 gcc_jit_rvalue_dereference (
1773 emit_cdr_addr (c),
1774 NULL),
1775 n);
1776 }
1777
1778 static gcc_jit_rvalue *
emit_PURE_P(gcc_jit_rvalue * ptr)1779 emit_PURE_P (gcc_jit_rvalue *ptr)
1780 {
1781
1782 emit_comment ("PURE_P");
1783
1784 return
1785 gcc_jit_context_new_comparison (
1786 comp.ctxt,
1787 NULL,
1788 GCC_JIT_COMPARISON_LE,
1789 emit_binary_op (
1790 GCC_JIT_BINARY_OP_MINUS,
1791 comp.uintptr_type,
1792 ptr,
1793 comp.pure_ptr),
1794 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
1795 comp.uintptr_type,
1796 PURESIZE));
1797 }
1798
1799
1800 /*************************************/
1801 /* Code emitted by LIMPLE statemes. */
1802 /*************************************/
1803
1804 /* Emit an r-value from an mvar meta variable.
1805 In case this is a constant that was propagated return it otherwise load it
1806 from frame. */
1807
1808 static gcc_jit_rvalue *
emit_mvar_rval(Lisp_Object mvar)1809 emit_mvar_rval (Lisp_Object mvar)
1810 {
1811 Lisp_Object const_vld = CALL1I (comp-cstr-imm-vld-p, mvar);
1812
1813 if (!NILP (const_vld))
1814 {
1815 Lisp_Object value = CALL1I (comp-cstr-imm, mvar);
1816 if (comp.debug > 1)
1817 {
1818 Lisp_Object func =
1819 Fgethash (value,
1820 CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt),
1821 Qnil);
1822
1823 emit_comment (
1824 SSDATA (
1825 Fprin1_to_string (
1826 NILP (func) ? value : CALL1I (comp-func-c-name, func),
1827 Qnil)));
1828 }
1829 if (FIXNUMP (value))
1830 {
1831 /* We can still emit directly objects that are self-contained in a
1832 word (read fixnums). */
1833 return emit_rvalue_from_lisp_obj (value);
1834 }
1835 /* Other const objects are fetched from the reloc array. */
1836 return emit_lisp_obj_rval (value);
1837 }
1838
1839 return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar));
1840 }
1841
1842 static void
emit_frame_assignment(Lisp_Object dst_mvar,gcc_jit_rvalue * val)1843 emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val)
1844 {
1845
1846 gcc_jit_block_add_assignment (
1847 comp.block,
1848 NULL,
1849 emit_mvar_lval (dst_mvar),
1850 val);
1851 }
1852
1853 static gcc_jit_rvalue *
emit_set_internal(Lisp_Object args)1854 emit_set_internal (Lisp_Object args)
1855 {
1856 /*
1857 Ex: (set_internal #s(comp-mvar nil nil t comp-test-up-val nil nil)
1858 #s(comp-mvar 1 4 t nil symbol nil)).
1859 */
1860 /* TODO: Inline the most common case. */
1861 if (list_length (args) != 3)
1862 xsignal2 (Qnative_ice,
1863 build_string ("unexpected arg length for insns"),
1864 args);
1865
1866 args = XCDR (args);
1867 int i = 0;
1868 gcc_jit_rvalue *gcc_args[4];
1869 FOR_EACH_TAIL (args)
1870 gcc_args[i++] = emit_mvar_rval (XCAR (args));
1871 gcc_args[2] = emit_lisp_obj_rval (Qnil);
1872 gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt,
1873 comp.int_type,
1874 SET_INTERNAL_SET);
1875 return emit_call (intern_c_string ("set_internal"), comp.void_type , 4,
1876 gcc_args, false);
1877 }
1878
1879 /* This is for a regular function with arguments as m-var. */
1880
1881 static gcc_jit_rvalue *
emit_simple_limple_call(Lisp_Object args,gcc_jit_type * ret_type,bool direct)1882 emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct)
1883 {
1884 USE_SAFE_ALLOCA;
1885 int i = 0;
1886 Lisp_Object callee = FIRST (args);
1887 args = XCDR (args);
1888 ptrdiff_t nargs = list_length (args);
1889 gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args));
1890 FOR_EACH_TAIL (args)
1891 gcc_args[i++] = emit_mvar_rval (XCAR (args));
1892
1893 SAFE_FREE ();
1894 return emit_call (callee, ret_type, nargs, gcc_args, direct);
1895 }
1896
1897 static gcc_jit_rvalue *
emit_simple_limple_call_lisp_ret(Lisp_Object args)1898 emit_simple_limple_call_lisp_ret (Lisp_Object args)
1899 {
1900 /*
1901 Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)).
1902 */
1903 return emit_simple_limple_call (args, comp.lisp_obj_type, false);
1904 }
1905
1906 static gcc_jit_rvalue *
emit_simple_limple_call_void_ret(Lisp_Object args)1907 emit_simple_limple_call_void_ret (Lisp_Object args)
1908 {
1909 return emit_simple_limple_call (args, comp.void_type, false);
1910 }
1911
1912 /* Entry point to dispatch emitting (call fun ...). */
1913
1914 static gcc_jit_rvalue *
emit_limple_call(Lisp_Object insn)1915 emit_limple_call (Lisp_Object insn)
1916 {
1917 Lisp_Object callee_sym = FIRST (insn);
1918 Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil);
1919
1920 if (!NILP (emitter))
1921 {
1922 gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter);
1923 return emitter_ptr (insn);
1924 }
1925
1926 return emit_simple_limple_call_lisp_ret (insn);
1927 }
1928
1929 static gcc_jit_rvalue *
emit_limple_call_ref(Lisp_Object insn,bool direct)1930 emit_limple_call_ref (Lisp_Object insn, bool direct)
1931 {
1932 /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t)
1933 #s(comp-mvar 2 6 nil nil nil t)
1934 #s(comp-mvar 3 7 t 0 fixnum t)). */
1935 static int i = 0;
1936 Lisp_Object callee = FIRST (insn);
1937 EMACS_INT nargs = XFIXNUM (Flength (CDR (insn)));
1938
1939 if (!nargs)
1940 return emit_call_ref (callee, 0, comp.frame[0], direct);
1941
1942 if (comp.func_has_non_local || !comp.func_speed)
1943 {
1944 /* FIXME: See bug#42360. */
1945 Lisp_Object first_arg = SECOND (insn);
1946 EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg));
1947 return emit_call_ref (callee, nargs, comp.frame[first_slot], direct);
1948 }
1949
1950 gcc_jit_lvalue *tmp_arr =
1951 gcc_jit_function_new_local (
1952 comp.func,
1953 NULL,
1954 gcc_jit_context_new_array_type (comp.ctxt,
1955 NULL,
1956 comp.lisp_obj_type,
1957 nargs),
1958 format_string ("call_arr_%d", i++));
1959
1960 ptrdiff_t j = 0;
1961 Lisp_Object arg = CDR (insn);
1962 FOR_EACH_TAIL (arg)
1963 {
1964 gcc_jit_block_add_assignment (
1965 comp.block,
1966 NULL,
1967 gcc_jit_context_new_array_access (
1968 comp.ctxt,
1969 NULL,
1970 gcc_jit_lvalue_as_rvalue (tmp_arr),
1971 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
1972 comp.int_type,
1973 j)),
1974 emit_mvar_rval (XCAR (arg)));
1975 ++j;
1976 }
1977
1978 return emit_call_ref (
1979 callee,
1980 nargs,
1981 gcc_jit_context_new_array_access (comp.ctxt,
1982 NULL,
1983 gcc_jit_lvalue_as_rvalue (tmp_arr),
1984 comp.zero),
1985 direct);
1986 }
1987
1988 static gcc_jit_rvalue *
emit_setjmp(gcc_jit_rvalue * buf)1989 emit_setjmp (gcc_jit_rvalue *buf)
1990 {
1991 #ifndef WINDOWSNT
1992 gcc_jit_rvalue *args[] = {buf};
1993 gcc_jit_param *params[] =
1994 {
1995 gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"),
1996 };
1997 /* Don't call setjmp through a function pointer (Bug#46824) */
1998 gcc_jit_function *f =
1999 gcc_jit_context_new_function (comp.ctxt, NULL,
2000 GCC_JIT_FUNCTION_IMPORTED,
2001 comp.int_type, STR (SETJMP_NAME),
2002 ARRAYELTS (params), params,
2003 false);
2004
2005 return gcc_jit_context_new_call (comp.ctxt, NULL, f, 1, args);
2006 #else
2007 /* _setjmp (buf, __builtin_frame_address (0)) */
2008 gcc_jit_param *params[] =
2009 {
2010 gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"),
2011 gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "frame"),
2012 };
2013 gcc_jit_rvalue *args[2];
2014
2015 args[0] =
2016 gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0);
2017
2018 args[1] =
2019 gcc_jit_context_new_call (
2020 comp.ctxt,
2021 NULL,
2022 gcc_jit_context_get_builtin_function (comp.ctxt,
2023 "__builtin_frame_address"),
2024 1, args);
2025 args[0] = buf;
2026 gcc_jit_function *f =
2027 gcc_jit_context_new_function (comp.ctxt, NULL,
2028 GCC_JIT_FUNCTION_IMPORTED,
2029 comp.int_type, STR (SETJMP_NAME),
2030 ARRAYELTS (params), params,
2031 false);
2032
2033 return gcc_jit_context_new_call (comp.ctxt, NULL, f, 2, args);
2034 #endif
2035 }
2036
2037 /* Register an handler for a non local exit. */
2038
2039 static void
emit_limple_push_handler(gcc_jit_rvalue * handler,gcc_jit_rvalue * handler_type,gcc_jit_block * handler_bb,gcc_jit_block * guarded_bb,Lisp_Object clobbered_mvar)2040 emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type,
2041 gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb,
2042 Lisp_Object clobbered_mvar)
2043 {
2044 /* struct handler *c = push_handler (POP, type); */
2045
2046 gcc_jit_rvalue *args[] = { handler, handler_type };
2047 gcc_jit_block_add_assignment (
2048 comp.block,
2049 NULL,
2050 comp.loc_handler,
2051 emit_call (intern_c_string ("push_handler"),
2052 comp.handler_ptr_type, 2, args, false));
2053
2054 args[0] =
2055 gcc_jit_lvalue_get_address (
2056 gcc_jit_rvalue_dereference_field (
2057 gcc_jit_lvalue_as_rvalue (comp.loc_handler),
2058 NULL,
2059 comp.handler_jmp_field),
2060 NULL);
2061
2062 gcc_jit_rvalue *res;
2063 res = emit_setjmp (args[0]);
2064 emit_cond_jump (res, handler_bb, guarded_bb);
2065 }
2066
2067 static void
emit_limple_insn(Lisp_Object insn)2068 emit_limple_insn (Lisp_Object insn)
2069 {
2070 Lisp_Object op = XCAR (insn);
2071 Lisp_Object args = XCDR (insn);
2072 gcc_jit_rvalue *res;
2073 Lisp_Object arg[6];
2074
2075 Lisp_Object p = XCDR (insn);
2076 ptrdiff_t i = 0;
2077 FOR_EACH_TAIL (p)
2078 {
2079 if (i == sizeof (arg) / sizeof (Lisp_Object))
2080 break;
2081 arg[i++] = XCAR (p);
2082 }
2083
2084 if (EQ (op, Qjump))
2085 {
2086 /* Unconditional branch. */
2087 gcc_jit_block *target = retrive_block (arg[0]);
2088 gcc_jit_block_end_with_jump (comp.block, NULL, target);
2089 }
2090 else if (EQ (op, Qcond_jump))
2091 {
2092 /* Conditional branch. */
2093 gcc_jit_rvalue *a = emit_mvar_rval (arg[0]);
2094 gcc_jit_rvalue *b = emit_mvar_rval (arg[1]);
2095 gcc_jit_block *target1 = retrive_block (arg[2]);
2096 gcc_jit_block *target2 = retrive_block (arg[3]);
2097
2098 emit_cond_jump (emit_EQ (a, b), target1, target2);
2099 }
2100 else if (EQ (op, Qcond_jump_narg_leq))
2101 {
2102 /*
2103 Limple: (cond-jump-narg-less 2 entry_2 entry_fallback_2)
2104 C: if (nargs < 2) goto entry2_fallback; else goto entry_2;
2105 */
2106 gcc_jit_lvalue *nargs =
2107 gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0));
2108 eassert (XFIXNUM (arg[0]) < INT_MAX);
2109 gcc_jit_rvalue *n =
2110 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2111 comp.ptrdiff_type,
2112 XFIXNUM (arg[0]));
2113 gcc_jit_block *target1 = retrive_block (arg[1]);
2114 gcc_jit_block *target2 = retrive_block (arg[2]);
2115 gcc_jit_rvalue *test = gcc_jit_context_new_comparison (
2116 comp.ctxt,
2117 NULL,
2118 GCC_JIT_COMPARISON_LE,
2119 gcc_jit_lvalue_as_rvalue (nargs),
2120 n);
2121 emit_cond_jump (test, target1, target2);
2122 }
2123 else if (EQ (op, Qphi) || EQ (op, Qassume))
2124 {
2125 /* Nothing to do for phis or assumes in the backend. */
2126 }
2127 else if (EQ (op, Qpush_handler))
2128 {
2129 /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */
2130 int h_num UNINIT;
2131 Lisp_Object handler_spec = arg[0];
2132 gcc_jit_rvalue *handler = emit_mvar_rval (arg[1]);
2133 if (EQ (handler_spec, Qcatcher))
2134 h_num = CATCHER;
2135 else if (EQ (handler_spec, Qcondition_case))
2136 h_num = CONDITION_CASE;
2137 else
2138 xsignal2 (Qnative_ice, build_string ("incoherent insn"), insn);
2139 gcc_jit_rvalue *handler_type =
2140 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2141 comp.int_type,
2142 h_num);
2143 gcc_jit_block *handler_bb = retrive_block (arg[2]);
2144 gcc_jit_block *guarded_bb = retrive_block (arg[3]);
2145 emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb,
2146 arg[0]);
2147 }
2148 else if (EQ (op, Qpop_handler))
2149 {
2150 /*
2151 C: current_thread->m_handlerlist =
2152 current_thread->m_handlerlist->next;
2153 */
2154 gcc_jit_lvalue *m_handlerlist =
2155 gcc_jit_rvalue_dereference_field (
2156 gcc_jit_lvalue_as_rvalue (
2157 gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)),
2158 NULL,
2159 comp.m_handlerlist);
2160
2161 gcc_jit_block_add_assignment (
2162 comp.block,
2163 NULL,
2164 m_handlerlist,
2165 gcc_jit_lvalue_as_rvalue (
2166 gcc_jit_rvalue_dereference_field (
2167 gcc_jit_lvalue_as_rvalue (m_handlerlist),
2168 NULL,
2169 comp.handler_next_field)));
2170
2171 }
2172 else if (EQ (op, Qfetch_handler))
2173 {
2174 gcc_jit_lvalue *m_handlerlist =
2175 gcc_jit_rvalue_dereference_field (
2176 gcc_jit_lvalue_as_rvalue (
2177 gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)),
2178 NULL,
2179 comp.m_handlerlist);
2180 gcc_jit_block_add_assignment (comp.block,
2181 NULL,
2182 comp.loc_handler,
2183 gcc_jit_lvalue_as_rvalue (m_handlerlist));
2184
2185 gcc_jit_block_add_assignment (
2186 comp.block,
2187 NULL,
2188 m_handlerlist,
2189 gcc_jit_lvalue_as_rvalue (
2190 gcc_jit_rvalue_dereference_field (
2191 gcc_jit_lvalue_as_rvalue (comp.loc_handler),
2192 NULL,
2193 comp.handler_next_field)));
2194 emit_frame_assignment (
2195 arg[0],
2196 gcc_jit_lvalue_as_rvalue (
2197 gcc_jit_rvalue_dereference_field (
2198 gcc_jit_lvalue_as_rvalue (comp.loc_handler),
2199 NULL,
2200 comp.handler_val_field)));
2201 }
2202 else if (EQ (op, Qcall))
2203 {
2204 gcc_jit_block_add_eval (comp.block, NULL,
2205 emit_limple_call (args));
2206 }
2207 else if (EQ (op, Qcallref))
2208 {
2209 gcc_jit_block_add_eval (comp.block, NULL,
2210 emit_limple_call_ref (args, false));
2211 }
2212 else if (EQ (op, Qdirect_call))
2213 {
2214 gcc_jit_block_add_eval (
2215 comp.block, NULL,
2216 emit_simple_limple_call (XCDR (insn), comp.lisp_obj_type, true));
2217 }
2218 else if (EQ (op, Qdirect_callref))
2219 {
2220 gcc_jit_block_add_eval (comp.block, NULL,
2221 emit_limple_call_ref (XCDR (insn), true));
2222 }
2223 else if (EQ (op, Qset))
2224 {
2225 Lisp_Object arg1 = arg[1];
2226
2227 if (EQ (Ftype_of (arg1), Qcomp_mvar))
2228 res = emit_mvar_rval (arg1);
2229 else if (EQ (FIRST (arg1), Qcall))
2230 res = emit_limple_call (XCDR (arg1));
2231 else if (EQ (FIRST (arg1), Qcallref))
2232 res = emit_limple_call_ref (XCDR (arg1), false);
2233 else if (EQ (FIRST (arg1), Qdirect_call))
2234 res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true);
2235 else if (EQ (FIRST (arg1), Qdirect_callref))
2236 res = emit_limple_call_ref (XCDR (arg1), true);
2237 else
2238 xsignal2 (Qnative_ice,
2239 build_string ("LIMPLE inconsistent arg1 for insn"),
2240 insn);
2241
2242 if (!res)
2243 xsignal1 (Qnative_ice,
2244 build_string (gcc_jit_context_get_first_error (comp.ctxt)));
2245
2246 emit_frame_assignment (arg[0], res);
2247 }
2248 else if (EQ (op, Qset_par_to_local))
2249 {
2250 /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0). */
2251 EMACS_INT param_n = XFIXNUM (arg[1]);
2252 eassert (param_n < INT_MAX);
2253 gcc_jit_rvalue *param =
2254 gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func,
2255 param_n));
2256 emit_frame_assignment (arg[0], param);
2257 }
2258 else if (EQ (op, Qset_args_to_local))
2259 {
2260 /*
2261 Ex: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil))
2262 C: local[1] = *args;
2263 */
2264 gcc_jit_rvalue *gcc_args =
2265 gcc_jit_lvalue_as_rvalue (
2266 gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)));
2267
2268 gcc_jit_rvalue *res =
2269 gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL));
2270
2271 emit_frame_assignment (arg[0], res);
2272 }
2273 else if (EQ (op, Qset_rest_args_to_local))
2274 {
2275 /*
2276 Ex: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil))
2277 C: local[2] = list (nargs - 2, args);
2278 */
2279
2280 EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0]));
2281 eassert (slot_n < INT_MAX);
2282 gcc_jit_rvalue *n =
2283 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2284 comp.ptrdiff_type,
2285 slot_n);
2286 gcc_jit_lvalue *nargs =
2287 gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0));
2288 gcc_jit_lvalue *args =
2289 gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1));
2290
2291 gcc_jit_rvalue *list_args[] =
2292 { emit_binary_op (GCC_JIT_BINARY_OP_MINUS,
2293 comp.ptrdiff_type,
2294 gcc_jit_lvalue_as_rvalue (nargs),
2295 n),
2296 gcc_jit_lvalue_as_rvalue (args) };
2297
2298 res = emit_call (Qlist, comp.lisp_obj_type, 2,
2299 list_args, false);
2300
2301 emit_frame_assignment (arg[0], res);
2302 }
2303 else if (EQ (op, Qinc_args))
2304 {
2305 /*
2306 Ex: (inc-args)
2307 C: ++args;
2308 */
2309 gcc_jit_lvalue *args =
2310 gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1));
2311
2312 gcc_jit_block_add_assignment (comp.block,
2313 NULL,
2314 args,
2315 emit_ptr_arithmetic (
2316 gcc_jit_lvalue_as_rvalue (args),
2317 comp.lisp_obj_ptr_type,
2318 sizeof (Lisp_Object),
2319 comp.one));
2320 }
2321 else if (EQ (op, Qsetimm))
2322 {
2323 /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) a). */
2324 emit_comment (SSDATA (Fprin1_to_string (arg[1], Qnil)));
2325 imm_reloc_t reloc = obj_to_reloc (arg[1]);
2326 emit_frame_assignment (
2327 arg[0],
2328 gcc_jit_lvalue_as_rvalue (
2329 gcc_jit_context_new_array_access (comp.ctxt,
2330 NULL,
2331 reloc.array.r_val,
2332 reloc.idx)));
2333 }
2334 else if (EQ (op, Qcomment))
2335 {
2336 /* Ex: (comment "Function: foo"). */
2337 emit_comment (SSDATA (arg[0]));
2338 }
2339 else if (EQ (op, Qreturn))
2340 {
2341 gcc_jit_block_end_with_return (comp.block,
2342 NULL,
2343 emit_mvar_rval (arg[0]));
2344 }
2345 else if (EQ (op, Qunreachable))
2346 {
2347 /* Libgccjit has no __builtin_unreachable. */
2348 gcc_jit_block_end_with_return (comp.block,
2349 NULL,
2350 emit_lisp_obj_rval (Qnil));
2351 }
2352 else
2353 {
2354 xsignal2 (Qnative_ice,
2355 build_string ("LIMPLE op inconsistent"),
2356 op);
2357 }
2358 }
2359
2360
2361 /**************/
2362 /* Inliners. */
2363 /**************/
2364
2365 static gcc_jit_rvalue *
emit_call_with_type_hint(gcc_jit_function * func,Lisp_Object insn,Lisp_Object type)2366 emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
2367 Lisp_Object type)
2368 {
2369 bool hint_match =
2370 !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
2371 gcc_jit_rvalue *args[] =
2372 { emit_mvar_rval (SECOND (insn)),
2373 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2374 comp.bool_type,
2375 hint_match) };
2376
2377 return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args);
2378 }
2379
2380 /* Same as before but with two args. The type hint is on the 2th. */
2381 static gcc_jit_rvalue *
emit_call2_with_type_hint(gcc_jit_function * func,Lisp_Object insn,Lisp_Object type)2382 emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn,
2383 Lisp_Object type)
2384 {
2385 bool hint_match =
2386 !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type));
2387 gcc_jit_rvalue *args[] =
2388 { emit_mvar_rval (SECOND (insn)),
2389 emit_mvar_rval (THIRD (insn)),
2390 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2391 comp.bool_type,
2392 hint_match) };
2393
2394 return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args);
2395 }
2396
2397
2398 static gcc_jit_rvalue *
emit_add1(Lisp_Object insn)2399 emit_add1 (Lisp_Object insn)
2400 {
2401 return emit_call_with_type_hint (comp.add1, insn, Qfixnum);
2402 }
2403
2404 static gcc_jit_rvalue *
emit_sub1(Lisp_Object insn)2405 emit_sub1 (Lisp_Object insn)
2406 {
2407 return emit_call_with_type_hint (comp.sub1, insn, Qfixnum);
2408 }
2409
2410 static gcc_jit_rvalue *
emit_negate(Lisp_Object insn)2411 emit_negate (Lisp_Object insn)
2412 {
2413 return emit_call_with_type_hint (comp.negate, insn, Qfixnum);
2414 }
2415
2416 static gcc_jit_rvalue *
emit_consp(Lisp_Object insn)2417 emit_consp (Lisp_Object insn)
2418 {
2419 gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
2420 gcc_jit_rvalue *res = emit_coerce (comp.bool_type,
2421 emit_CONSP (x));
2422 return gcc_jit_context_new_call (comp.ctxt,
2423 NULL,
2424 comp.bool_to_lisp_obj,
2425 1, &res);
2426 }
2427
2428 static gcc_jit_rvalue *
emit_car(Lisp_Object insn)2429 emit_car (Lisp_Object insn)
2430 {
2431 return emit_call_with_type_hint (comp.car, insn, Qcons);
2432 }
2433
2434 static gcc_jit_rvalue *
emit_cdr(Lisp_Object insn)2435 emit_cdr (Lisp_Object insn)
2436 {
2437 return emit_call_with_type_hint (comp.cdr, insn, Qcons);
2438 }
2439
2440 static gcc_jit_rvalue *
emit_setcar(Lisp_Object insn)2441 emit_setcar (Lisp_Object insn)
2442 {
2443 return emit_call2_with_type_hint (comp.setcar, insn, Qcons);
2444 }
2445
2446 static gcc_jit_rvalue *
emit_setcdr(Lisp_Object insn)2447 emit_setcdr (Lisp_Object insn)
2448 {
2449 return emit_call2_with_type_hint (comp.setcdr, insn, Qcons);
2450 }
2451
2452 static gcc_jit_rvalue *
emit_numperp(Lisp_Object insn)2453 emit_numperp (Lisp_Object insn)
2454 {
2455 gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
2456 gcc_jit_rvalue *res = emit_NUMBERP (x);
2457 return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1,
2458 &res);
2459 }
2460
2461 static gcc_jit_rvalue *
emit_integerp(Lisp_Object insn)2462 emit_integerp (Lisp_Object insn)
2463 {
2464 gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn));
2465 gcc_jit_rvalue *res = emit_INTEGERP (x);
2466 return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1,
2467 &res);
2468 }
2469
2470 static gcc_jit_rvalue *
emit_maybe_gc_or_quit(Lisp_Object insn)2471 emit_maybe_gc_or_quit (Lisp_Object insn)
2472 {
2473 return gcc_jit_context_new_call (comp.ctxt, NULL, comp.maybe_gc_or_quit, 0,
2474 NULL);
2475 }
2476
2477 /* This is in charge of serializing an object and export a function to
2478 retrieve it at load time. */
2479 #pragma GCC diagnostic ignored "-Waddress"
2480 static void
emit_static_object(const char * name,Lisp_Object obj)2481 emit_static_object (const char *name, Lisp_Object obj)
2482 {
2483 /* libgccjit has no support for initialized static data.
2484 The mechanism below is certainly not aesthetic but I assume the bottle neck
2485 in terms of performance at load time will still be the reader.
2486 NOTE: we can not rely on libgccjit even for valid NULL terminated C
2487 strings cause of this funny bug that will affect all pre gcc10 era gccs:
2488 https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */
2489
2490 ptrdiff_t count = SPECPDL_INDEX ();
2491 /* Preserve uninterned symbols, this is specifically necessary for
2492 CL macro expansion in dynamic scope code (bug#42088). See
2493 `byte-compile-output-file-form'. */
2494 specbind (intern_c_string ("print-escape-newlines"), Qt);
2495 specbind (intern_c_string ("print-length"), Qnil);
2496 specbind (intern_c_string ("print-level"), Qnil);
2497 specbind (intern_c_string ("print-quoted"), Qt);
2498 specbind (intern_c_string ("print-gensym"), Qt);
2499 specbind (intern_c_string ("print-circle"), Qt);
2500 Lisp_Object str = Fprin1_to_string (obj, Qnil);
2501 unbind_to (count, Qnil);
2502
2503 ptrdiff_t len = SBYTES (str);
2504 const char *p = SSDATA (str);
2505
2506 #if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer)
2507 if (gcc_jit_global_set_initializer)
2508 {
2509 ptrdiff_t str_size = len + 1;
2510 ptrdiff_t size = sizeof (static_obj_t) + str_size;
2511 static_obj_t *static_obj = xmalloc (size);
2512 static_obj->len = str_size;
2513 memcpy (static_obj->data, p, str_size);
2514 gcc_jit_lvalue *blob =
2515 gcc_jit_context_new_global (
2516 comp.ctxt,
2517 NULL,
2518 GCC_JIT_GLOBAL_EXPORTED,
2519 gcc_jit_context_new_array_type (comp.ctxt, NULL,
2520 comp.char_type,
2521 size),
2522 format_string ("%s_blob", name));
2523 gcc_jit_global_set_initializer (blob, static_obj, size);
2524 xfree (static_obj);
2525
2526 return;
2527 }
2528 #endif
2529
2530 gcc_jit_type *a_type =
2531 gcc_jit_context_new_array_type (comp.ctxt,
2532 NULL,
2533 comp.char_type,
2534 len + 1);
2535 gcc_jit_field *fields[] =
2536 { gcc_jit_context_new_field (comp.ctxt,
2537 NULL,
2538 comp.ptrdiff_type,
2539 "len"),
2540 gcc_jit_context_new_field (comp.ctxt,
2541 NULL,
2542 a_type,
2543 "data") };
2544
2545 gcc_jit_type *data_struct_t =
2546 gcc_jit_struct_as_type (
2547 gcc_jit_context_new_struct_type (comp.ctxt,
2548 NULL,
2549 format_string ("%s_struct", name),
2550 ARRAYELTS (fields), fields));
2551
2552 gcc_jit_lvalue *data_struct =
2553 gcc_jit_context_new_global (comp.ctxt,
2554 NULL,
2555 GCC_JIT_GLOBAL_INTERNAL,
2556 data_struct_t,
2557 format_string ("%s_s", name));
2558
2559 gcc_jit_function *f =
2560 gcc_jit_context_new_function (comp.ctxt, NULL,
2561 GCC_JIT_FUNCTION_EXPORTED,
2562 gcc_jit_type_get_pointer (data_struct_t),
2563 name,
2564 0, NULL, 0);
2565 DECL_BLOCK (block, f);
2566
2567 if (comp.debug > 1)
2568 {
2569 char *comment = memcpy (xmalloc (len), p, len);
2570 for (ptrdiff_t i = 0; i < len - 1; i++)
2571 if (!comment[i])
2572 comment[i] = '\n';
2573 gcc_jit_block_add_comment (block, NULL, comment);
2574 xfree (comment);
2575 }
2576
2577 gcc_jit_lvalue *arr =
2578 gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]);
2579
2580 gcc_jit_lvalue *ptrvar = gcc_jit_function_new_local (f, NULL,
2581 comp.char_ptr_type,
2582 "ptr");
2583
2584 gcc_jit_block_add_assignment (
2585 block,
2586 NULL,
2587 ptrvar,
2588 gcc_jit_lvalue_get_address (
2589 gcc_jit_context_new_array_access (
2590 comp.ctxt,
2591 NULL,
2592 gcc_jit_lvalue_as_rvalue (arr),
2593 gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, 0)),
2594 NULL));
2595
2596 /* We can't use always string literals longer that 200 bytes because
2597 they cause a crash in pre GCC 10 libgccjit.
2598 <https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html>.
2599
2600 Adjust if possible to reduce the number of function calls. */
2601 size_t chunck_size = NILP (Fcomp_libgccjit_version ()) ? 200 : 1024;
2602 char *buff = xmalloc (chunck_size);
2603 for (ptrdiff_t i = 0; i < len;)
2604 {
2605 strncpy (buff, p, chunck_size);
2606 buff[chunck_size - 1] = 0;
2607 uintptr_t l = strlen (buff);
2608
2609 if (l != 0)
2610 {
2611 p += l;
2612 i += l;
2613
2614 gcc_jit_rvalue *args[] =
2615 { gcc_jit_lvalue_as_rvalue (ptrvar),
2616 gcc_jit_context_new_string_literal (comp.ctxt, buff),
2617 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2618 comp.size_t_type,
2619 l) };
2620
2621 gcc_jit_block_add_eval (block, NULL,
2622 gcc_jit_context_new_call (comp.ctxt, NULL,
2623 comp.memcpy,
2624 ARRAYELTS (args),
2625 args));
2626 gcc_jit_block_add_assignment (block, NULL, ptrvar,
2627 gcc_jit_lvalue_get_address (
2628 gcc_jit_context_new_array_access (comp.ctxt, NULL,
2629 gcc_jit_lvalue_as_rvalue (ptrvar),
2630 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2631 comp.uintptr_type,
2632 l)),
2633 NULL));
2634 }
2635 else
2636 {
2637 /* If strlen returned 0 that means that the static object
2638 contains a NULL byte. In that case just move over to the
2639 next block. We can rely on the byte being zero because
2640 of the previous call to bzero and because the dynamic
2641 linker cleared it. */
2642 p++;
2643 i++;
2644 gcc_jit_block_add_assignment (
2645 block, NULL, ptrvar,
2646 gcc_jit_lvalue_get_address (
2647 gcc_jit_context_new_array_access (
2648 comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue (ptrvar),
2649 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2650 comp.uintptr_type, 1)),
2651 NULL));
2652 }
2653 }
2654 xfree (buff);
2655
2656 gcc_jit_block_add_assignment (
2657 block,
2658 NULL,
2659 gcc_jit_lvalue_access_field (data_struct, NULL, fields[0]),
2660 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
2661 comp.ptrdiff_type,
2662 len));
2663 gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL);
2664 gcc_jit_block_end_with_return (block, NULL, res);
2665 }
2666 #pragma GCC diagnostic pop
2667
2668 static reloc_array_t
declare_imported_data_relocs(Lisp_Object container,const char * code_symbol,const char * text_symbol)2669 declare_imported_data_relocs (Lisp_Object container, const char *code_symbol,
2670 const char *text_symbol)
2671 {
2672 /* Imported objects. */
2673 reloc_array_t res;
2674 res.len =
2675 XFIXNUM (CALL1I (hash-table-count,
2676 CALL1I (comp-data-container-idx, container)));
2677 Lisp_Object d_reloc = CALL1I (comp-data-container-l, container);
2678 d_reloc = Fvconcat (1, &d_reloc);
2679
2680 res.r_val =
2681 gcc_jit_lvalue_as_rvalue (
2682 gcc_jit_context_new_global (
2683 comp.ctxt,
2684 NULL,
2685 GCC_JIT_GLOBAL_EXPORTED,
2686 gcc_jit_context_new_array_type (comp.ctxt,
2687 NULL,
2688 comp.lisp_obj_type,
2689 res.len),
2690 code_symbol));
2691
2692 emit_static_object (text_symbol, d_reloc);
2693
2694 return res;
2695 }
2696
2697 static void
declare_imported_data(void)2698 declare_imported_data (void)
2699 {
2700 /* Imported objects. */
2701 comp.data_relocs =
2702 declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt),
2703 DATA_RELOC_SYM,
2704 TEXT_DATA_RELOC_SYM);
2705 comp.data_relocs_impure =
2706 declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt),
2707 DATA_RELOC_IMPURE_SYM,
2708 TEXT_DATA_RELOC_IMPURE_SYM);
2709 comp.data_relocs_ephemeral =
2710 declare_imported_data_relocs (CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt),
2711 DATA_RELOC_EPHEMERAL_SYM,
2712 TEXT_DATA_RELOC_EPHEMERAL_SYM);
2713 }
2714
2715 /*
2716 Declare as imported all the functions that are requested from the runtime.
2717 These are either subrs or not.
2718 */
2719 static Lisp_Object
declare_runtime_imported_funcs(void)2720 declare_runtime_imported_funcs (void)
2721 {
2722 Lisp_Object field_list = Qnil;
2723
2724 #define ADD_IMPORTED(f_name, ret_type, nargs, args) \
2725 do { \
2726 Lisp_Object name = intern_c_string (STR (f_name)); \
2727 Lisp_Object field = \
2728 make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \
2729 Lisp_Object el = Fcons (name, field); \
2730 field_list = Fcons (el, field_list); \
2731 } while (0)
2732
2733 gcc_jit_type *args[4];
2734
2735 ADD_IMPORTED (wrong_type_argument, comp.void_type, 2, NULL);
2736
2737 args[0] = comp.lisp_obj_type;
2738 args[1] = comp.int_type;
2739 ADD_IMPORTED (helper_PSEUDOVECTOR_TYPEP_XUNTAG, comp.bool_type, 2, args);
2740
2741 ADD_IMPORTED (pure_write_error, comp.void_type, 1, NULL);
2742
2743 args[0] = comp.lisp_obj_type;
2744 args[1] = comp.int_type;
2745 ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args);
2746
2747 ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL);
2748
2749 args[0] = comp.lisp_obj_type;
2750 ADD_IMPORTED (helper_unbind_n, comp.lisp_obj_type, 1, args);
2751
2752 ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL);
2753
2754 ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL);
2755
2756 args[0] = args[1] = args[2] = comp.lisp_obj_type;
2757 args[3] = comp.int_type;
2758 ADD_IMPORTED (set_internal, comp.void_type, 4, args);
2759
2760 args[0] = comp.lisp_obj_type;
2761 ADD_IMPORTED (helper_unwind_protect, comp.void_type, 1, args);
2762
2763 args[0] = args[1] = comp.lisp_obj_type;
2764 ADD_IMPORTED (specbind, comp.void_type, 2, args);
2765
2766 ADD_IMPORTED (maybe_gc, comp.void_type, 0, NULL);
2767
2768 ADD_IMPORTED (maybe_quit, comp.void_type, 0, NULL);
2769
2770 #undef ADD_IMPORTED
2771
2772 return Freverse (field_list);
2773 }
2774
2775 /*
2776 This emit the code needed by every compilation unit to be loaded.
2777 */
2778 static void
emit_ctxt_code(void)2779 emit_ctxt_code (void)
2780 {
2781 /* Emit optimize qualities. */
2782 Lisp_Object opt_qly[] =
2783 { Fcons (Qnative_comp_speed, make_fixnum (comp.speed)),
2784 Fcons (Qnative_comp_debug, make_fixnum (comp.debug)),
2785 Fcons (Qgccjit,
2786 Fcomp_libgccjit_version ()) };
2787 emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (ARRAYELTS (opt_qly), opt_qly));
2788
2789 emit_static_object (TEXT_FDOC_SYM,
2790 CALL1I (comp-ctxt-function-docs, Vcomp_ctxt));
2791
2792 comp.current_thread_ref =
2793 gcc_jit_lvalue_as_rvalue (
2794 gcc_jit_context_new_global (
2795 comp.ctxt,
2796 NULL,
2797 GCC_JIT_GLOBAL_EXPORTED,
2798 gcc_jit_type_get_pointer (comp.thread_state_ptr_type),
2799 CURRENT_THREAD_RELOC_SYM));
2800
2801 comp.pure_ptr =
2802 gcc_jit_lvalue_as_rvalue (
2803 gcc_jit_context_new_global (
2804 comp.ctxt,
2805 NULL,
2806 GCC_JIT_GLOBAL_EXPORTED,
2807 comp.void_ptr_type,
2808 PURE_RELOC_SYM));
2809
2810 gcc_jit_context_new_global (
2811 comp.ctxt,
2812 NULL,
2813 GCC_JIT_GLOBAL_EXPORTED,
2814 comp.lisp_obj_type,
2815 COMP_UNIT_SYM);
2816
2817 declare_imported_data ();
2818
2819 /* Functions imported from Lisp code. */
2820 freloc_check_fill ();
2821 gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields));
2822 ptrdiff_t n_frelocs = 0;
2823 Lisp_Object f_runtime = declare_runtime_imported_funcs ();
2824 FOR_EACH_TAIL (f_runtime)
2825 {
2826 Lisp_Object el = XCAR (f_runtime);
2827 eassert (n_frelocs < freloc.size);
2828 fields[n_frelocs++] = xmint_pointer (XCDR (el));
2829 }
2830
2831 /* Sign the .eln for the exposed ABI it expects at load. */
2832 eassert (!NILP (Vcomp_abi_hash));
2833 emit_static_object (LINK_TABLE_HASH_SYM, Vcomp_abi_hash);
2834
2835 Lisp_Object subr_l = Vcomp_subr_list;
2836 FOR_EACH_TAIL (subr_l)
2837 {
2838 struct Lisp_Subr *subr = XSUBR (XCAR (subr_l));
2839 Lisp_Object subr_sym = intern_c_string (subr->symbol_name);
2840 eassert (n_frelocs < freloc.size);
2841 fields[n_frelocs++] = declare_imported_func (subr_sym, comp.lisp_obj_type,
2842 subr->max_args, NULL);
2843 }
2844
2845 gcc_jit_struct *f_reloc_struct =
2846 gcc_jit_context_new_struct_type (comp.ctxt,
2847 NULL,
2848 "freloc_link_table",
2849 n_frelocs, fields);
2850 comp.func_relocs_ptr_type =
2851 gcc_jit_type_get_pointer (
2852 gcc_jit_struct_as_type (f_reloc_struct));
2853
2854 comp.func_relocs =
2855 gcc_jit_context_new_global (comp.ctxt,
2856 NULL,
2857 GCC_JIT_GLOBAL_EXPORTED,
2858 comp.func_relocs_ptr_type,
2859 FUNC_LINK_TABLE_SYM);
2860
2861 xfree (fields);
2862 }
2863
2864
2865 /****************************************************************/
2866 /* Inline function definition and lisp data structure follows. */
2867 /****************************************************************/
2868
2869 /* struct Lisp_Cons definition. */
2870
2871 static void
define_lisp_cons(void)2872 define_lisp_cons (void)
2873 {
2874 /*
2875 union cdr_u
2876 {
2877 Lisp_Object cdr;
2878 struct Lisp_Cons *chain;
2879 };
2880
2881 struct cons_s
2882 {
2883 Lisp_Object car;
2884 union cdr_u u;
2885 };
2886
2887 union cons_u
2888 {
2889 struct cons_s s;
2890 char align_pad[sizeof (struct Lisp_Cons)];
2891 };
2892
2893 struct Lisp_Cons
2894 {
2895 union cons_u u;
2896 };
2897 */
2898
2899 comp.lisp_cons_s =
2900 gcc_jit_context_new_opaque_struct (comp.ctxt,
2901 NULL,
2902 "comp_Lisp_Cons");
2903 comp.lisp_cons_type =
2904 gcc_jit_struct_as_type (comp.lisp_cons_s);
2905 comp.lisp_cons_ptr_type =
2906 gcc_jit_type_get_pointer (comp.lisp_cons_type);
2907
2908 comp.lisp_cons_u_s_u_cdr =
2909 gcc_jit_context_new_field (comp.ctxt,
2910 NULL,
2911 comp.lisp_obj_type,
2912 "cdr");
2913
2914 gcc_jit_field *cdr_u_fields[] =
2915 { comp.lisp_cons_u_s_u_cdr,
2916 gcc_jit_context_new_field (comp.ctxt,
2917 NULL,
2918 comp.lisp_cons_ptr_type,
2919 "chain") };
2920
2921 gcc_jit_type *cdr_u =
2922 gcc_jit_context_new_union_type (comp.ctxt,
2923 NULL,
2924 "comp_cdr_u",
2925 ARRAYELTS (cdr_u_fields),
2926 cdr_u_fields);
2927
2928 comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt,
2929 NULL,
2930 comp.lisp_obj_type,
2931 "car");
2932 comp.lisp_cons_u_s_u = gcc_jit_context_new_field (comp.ctxt,
2933 NULL,
2934 cdr_u,
2935 "u");
2936 gcc_jit_field *cons_s_fields[] =
2937 { comp.lisp_cons_u_s_car,
2938 comp.lisp_cons_u_s_u };
2939
2940 gcc_jit_struct *cons_s =
2941 gcc_jit_context_new_struct_type (comp.ctxt,
2942 NULL,
2943 "comp_cons_s",
2944 ARRAYELTS (cons_s_fields),
2945 cons_s_fields);
2946
2947 comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt,
2948 NULL,
2949 gcc_jit_struct_as_type (cons_s),
2950 "s");
2951
2952 gcc_jit_field *cons_u_fields[] =
2953 { comp.lisp_cons_u_s,
2954 gcc_jit_context_new_field (
2955 comp.ctxt,
2956 NULL,
2957 gcc_jit_context_new_array_type (comp.ctxt,
2958 NULL,
2959 comp.char_type,
2960 sizeof (struct Lisp_Cons)),
2961 "align_pad") };
2962
2963 gcc_jit_type *lisp_cons_u_type =
2964 gcc_jit_context_new_union_type (comp.ctxt,
2965 NULL,
2966 "comp_cons_u",
2967 ARRAYELTS (cons_u_fields),
2968 cons_u_fields);
2969
2970 comp.lisp_cons_u =
2971 gcc_jit_context_new_field (comp.ctxt,
2972 NULL,
2973 lisp_cons_u_type,
2974 "u");
2975 gcc_jit_struct_set_fields (comp.lisp_cons_s,
2976 NULL, 1, &comp.lisp_cons_u);
2977
2978 }
2979
2980 /* Opaque jmp_buf definition. */
2981
2982 static void
define_jmp_buf(void)2983 define_jmp_buf (void)
2984 {
2985 gcc_jit_field *field =
2986 gcc_jit_context_new_field (
2987 comp.ctxt,
2988 NULL,
2989 gcc_jit_context_new_array_type (comp.ctxt,
2990 NULL,
2991 comp.char_type,
2992 sizeof (sys_jmp_buf)),
2993 "stuff");
2994 comp.jmp_buf_s =
2995 gcc_jit_context_new_struct_type (comp.ctxt,
2996 NULL,
2997 "comp_jmp_buf",
2998 1, &field);
2999 }
3000
3001 static void
define_memcpy(void)3002 define_memcpy (void)
3003 {
3004
3005 gcc_jit_param *params[] =
3006 { gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "dest"),
3007 gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "src"),
3008 gcc_jit_context_new_param (comp.ctxt, NULL, comp.size_t_type, "n") };
3009
3010 comp.memcpy =
3011 gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED,
3012 comp.void_ptr_type, "memcpy",
3013 ARRAYELTS (params), params, false);
3014 }
3015
3016 /* struct handler definition */
3017
3018 static void
define_handler_struct(void)3019 define_handler_struct (void)
3020 {
3021 comp.handler_s =
3022 gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler");
3023 comp.handler_ptr_type =
3024 gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler_s));
3025
3026 comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt,
3027 NULL,
3028 gcc_jit_struct_as_type (
3029 comp.jmp_buf_s),
3030 "jmp");
3031 comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt,
3032 NULL,
3033 comp.lisp_obj_type,
3034 "val");
3035 comp.handler_next_field = gcc_jit_context_new_field (comp.ctxt,
3036 NULL,
3037 comp.handler_ptr_type,
3038 "next");
3039 gcc_jit_field *fields[] =
3040 { gcc_jit_context_new_field (
3041 comp.ctxt,
3042 NULL,
3043 gcc_jit_context_new_array_type (comp.ctxt,
3044 NULL,
3045 comp.char_type,
3046 offsetof (struct handler, val)),
3047 "pad0"),
3048 comp.handler_val_field,
3049 comp.handler_next_field,
3050 gcc_jit_context_new_field (
3051 comp.ctxt,
3052 NULL,
3053 gcc_jit_context_new_array_type (comp.ctxt,
3054 NULL,
3055 comp.char_type,
3056 offsetof (struct handler, jmp)
3057 - offsetof (struct handler, next)
3058 - sizeof (((struct handler *) 0)->next)),
3059 "pad1"),
3060 comp.handler_jmp_field,
3061 gcc_jit_context_new_field (
3062 comp.ctxt,
3063 NULL,
3064 gcc_jit_context_new_array_type (comp.ctxt,
3065 NULL,
3066 comp.char_type,
3067 sizeof (struct handler)
3068 - offsetof (struct handler, jmp)
3069 - sizeof (((struct handler *) 0)->jmp)),
3070 "pad2") };
3071 gcc_jit_struct_set_fields (comp.handler_s,
3072 NULL,
3073 ARRAYELTS (fields),
3074 fields);
3075
3076 }
3077
3078 static void
define_thread_state_struct(void)3079 define_thread_state_struct (void)
3080 {
3081 /* Partially opaque definition for `thread_state'.
3082 Because we need to access just m_handlerlist hopefully this is requires
3083 less manutention then the full deifnition. */
3084
3085 comp.m_handlerlist = gcc_jit_context_new_field (comp.ctxt,
3086 NULL,
3087 comp.handler_ptr_type,
3088 "m_handlerlist");
3089 gcc_jit_field *fields[] =
3090 { gcc_jit_context_new_field (
3091 comp.ctxt,
3092 NULL,
3093 gcc_jit_context_new_array_type (comp.ctxt,
3094 NULL,
3095 comp.char_type,
3096 offsetof (struct thread_state,
3097 m_handlerlist)),
3098 "pad0"),
3099 comp.m_handlerlist,
3100 gcc_jit_context_new_field (
3101 comp.ctxt,
3102 NULL,
3103 gcc_jit_context_new_array_type (
3104 comp.ctxt,
3105 NULL,
3106 comp.char_type,
3107 sizeof (struct thread_state)
3108 - offsetof (struct thread_state,
3109 m_handlerlist)
3110 - sizeof (((struct thread_state *) 0)->m_handlerlist)),
3111 "pad1") };
3112
3113 comp.thread_state_s =
3114 gcc_jit_context_new_struct_type (comp.ctxt,
3115 NULL,
3116 "comp_thread_state",
3117 ARRAYELTS (fields),
3118 fields);
3119 comp.thread_state_ptr_type =
3120 gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s));
3121 }
3122
3123 static gcc_jit_function *
define_type_punning(const char * name,gcc_jit_type * from,gcc_jit_field * from_field,gcc_jit_type * to,gcc_jit_field * to_field)3124 define_type_punning (const char *name,
3125 gcc_jit_type *from, gcc_jit_field *from_field,
3126 gcc_jit_type *to, gcc_jit_field *to_field)
3127 {
3128 gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL,
3129 from, "arg");
3130 gcc_jit_function *result = gcc_jit_context_new_function (comp.ctxt,
3131 NULL,
3132 GCC_JIT_FUNCTION_INTERNAL,
3133 to,
3134 name,
3135 1,
3136 ¶m,
3137 0);
3138
3139 DECL_BLOCK (entry_block, result);
3140
3141 gcc_jit_lvalue *tmp_union
3142 = gcc_jit_function_new_local (result,
3143 NULL,
3144 comp.cast_union_type,
3145 "union_cast");
3146
3147 gcc_jit_block_add_assignment (entry_block, NULL,
3148 gcc_jit_lvalue_access_field (tmp_union, NULL,
3149 from_field),
3150 gcc_jit_param_as_rvalue (param));
3151
3152 gcc_jit_block_end_with_return (entry_block,
3153 NULL,
3154 gcc_jit_rvalue_access_field (
3155 gcc_jit_lvalue_as_rvalue (tmp_union),
3156 NULL, to_field));
3157
3158 return result;
3159 }
3160
3161 struct cast_type
3162 {
3163 gcc_jit_type *type;
3164 const char *name;
3165 bool is_ptr;
3166 };
3167
3168 static gcc_jit_function *
define_cast_from_to(struct cast_type from,struct cast_type to)3169 define_cast_from_to (struct cast_type from, struct cast_type to)
3170 {
3171 char *name = format_string ("cast_from_%s_to_%s", from.name, to.name);
3172 gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL,
3173 from.type, "arg");
3174 gcc_jit_function *result
3175 = gcc_jit_context_new_function (comp.ctxt,
3176 NULL,
3177 GCC_JIT_FUNCTION_INTERNAL,
3178 to.type, name,
3179 1, ¶m, 0);
3180 DECL_BLOCK (entry_block, result);
3181
3182 gcc_jit_rvalue *tmp = gcc_jit_param_as_rvalue (param);
3183 if (from.is_ptr != to.is_ptr)
3184 {
3185 if (from.is_ptr)
3186 {
3187 tmp = gcc_jit_context_new_cast (comp.ctxt, NULL,
3188 tmp, comp.void_ptr_type);
3189 tmp = gcc_jit_context_new_call (comp.ctxt, NULL,
3190 comp.cast_ptr_to_int, 1, &tmp);
3191 }
3192 else
3193 {
3194 tmp = gcc_jit_context_new_cast (comp.ctxt, NULL,
3195 tmp, comp.uintptr_type);
3196 tmp = gcc_jit_context_new_call (comp.ctxt, NULL,
3197 comp.cast_int_to_ptr, 1, &tmp);
3198 }
3199 }
3200
3201 tmp = gcc_jit_context_new_cast (comp.ctxt, NULL, tmp, to.type);
3202
3203 gcc_jit_block_end_with_return (entry_block, NULL, tmp);
3204
3205 return result;
3206 }
3207
3208 static void
define_cast_functions(void)3209 define_cast_functions (void)
3210 {
3211 struct cast_type cast_types[NUM_CAST_TYPES]
3212 = { { comp.bool_type, "bool", false },
3213 { comp.char_ptr_type, "char_ptr", true },
3214 { comp.int_type, "int", false },
3215 { comp.lisp_cons_ptr_type, "lisp_cons_ptr", true },
3216 { comp.lisp_obj_ptr_type, "lisp_obj_ptr", true },
3217 { comp.lisp_word_tag_type, "lisp_word_tag", false },
3218 { comp.lisp_word_type, "lisp_word", LISP_WORDS_ARE_POINTERS },
3219 { comp.long_long_type, "long_long", false },
3220 { comp.long_type, "long", false },
3221 { comp.ptrdiff_type, "ptrdiff", false },
3222 { comp.uintptr_type, "uintptr", false },
3223 { comp.unsigned_long_long_type, "unsigned_long_long", false },
3224 { comp.unsigned_long_type, "unsigned_long", false },
3225 { comp.unsigned_type, "unsigned", false },
3226 { comp.void_ptr_type, "void_ptr", true } };
3227 gcc_jit_field *cast_union_fields[2];
3228
3229 /* Define the union used for type punning. */
3230 cast_union_fields[0] = gcc_jit_context_new_field (comp.ctxt,
3231 NULL,
3232 comp.void_ptr_type,
3233 "void_ptr");
3234 cast_union_fields[1] = gcc_jit_context_new_field (comp.ctxt,
3235 NULL,
3236 comp.uintptr_type,
3237 "uintptr");
3238
3239 comp.cast_union_type
3240 = gcc_jit_context_new_union_type (comp.ctxt,
3241 NULL,
3242 "cast_union",
3243 2, cast_union_fields);
3244
3245 comp.cast_ptr_to_int = define_type_punning ("cast_pointer_to_uintptr_t",
3246 comp.void_ptr_type,
3247 cast_union_fields[0],
3248 comp.uintptr_type,
3249 cast_union_fields[1]);
3250 comp.cast_int_to_ptr = define_type_punning ("cast_uintptr_t_to_pointer",
3251 comp.uintptr_type,
3252 cast_union_fields[1],
3253 comp.void_ptr_type,
3254 cast_union_fields[0]);
3255
3256 for (int i = 0; i < NUM_CAST_TYPES; ++i)
3257 comp.cast_types[i] = cast_types[i].type;
3258
3259 /* Define the cast functions using a matrix. */
3260 for (int i = 0; i < NUM_CAST_TYPES; ++i)
3261 for (int j = 0; j < NUM_CAST_TYPES; ++j)
3262 comp.cast_functions_from_to[i][j] =
3263 define_cast_from_to (cast_types[i], cast_types[j]);
3264 }
3265
3266 static void
define_CHECK_TYPE(void)3267 define_CHECK_TYPE (void)
3268 {
3269 gcc_jit_param *param[] =
3270 { gcc_jit_context_new_param (comp.ctxt,
3271 NULL,
3272 comp.int_type,
3273 "ok"),
3274 gcc_jit_context_new_param (comp.ctxt,
3275 NULL,
3276 comp.lisp_obj_type,
3277 "predicate"),
3278 gcc_jit_context_new_param (comp.ctxt,
3279 NULL,
3280 comp.lisp_obj_type,
3281 "x") };
3282 comp.check_type =
3283 gcc_jit_context_new_function (comp.ctxt, NULL,
3284 GCC_JIT_FUNCTION_INTERNAL,
3285 comp.void_type,
3286 "CHECK_TYPE",
3287 3,
3288 param,
3289 0);
3290 gcc_jit_rvalue *ok = gcc_jit_param_as_rvalue (param[0]);
3291 gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]);
3292 gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]);
3293
3294 DECL_BLOCK (entry_block, comp.check_type);
3295 DECL_BLOCK (ok_block, comp.check_type);
3296 DECL_BLOCK (not_ok_block, comp.check_type);
3297
3298 comp.block = entry_block;
3299 comp.func = comp.check_type;
3300
3301 emit_cond_jump (ok, ok_block, not_ok_block);
3302
3303 gcc_jit_block_end_with_void_return (ok_block, NULL);
3304
3305 comp.block = not_ok_block;
3306
3307 gcc_jit_rvalue *wrong_type_args[] = { predicate, x };
3308
3309 gcc_jit_block_add_eval (comp.block,
3310 NULL,
3311 emit_call (intern_c_string ("wrong_type_argument"),
3312 comp.void_type, 2, wrong_type_args,
3313 false));
3314
3315 gcc_jit_block_end_with_void_return (not_ok_block, NULL);
3316 }
3317
3318 /* Define a substitute for CAR as always inlined function. */
3319
3320 static void
define_CAR_CDR(void)3321 define_CAR_CDR (void)
3322 {
3323 gcc_jit_function *func[2];
3324 char const *f_name[] = { "CAR", "CDR" };
3325 for (int i = 0; i < 2; i++)
3326 {
3327 gcc_jit_param *param[] =
3328 { gcc_jit_context_new_param (comp.ctxt,
3329 NULL,
3330 comp.lisp_obj_type,
3331 "c"),
3332 gcc_jit_context_new_param (comp.ctxt,
3333 NULL,
3334 comp.bool_type,
3335 "cert_cons") };
3336 /* TODO: understand why after ipa-prop pass gcc is less keen on inlining
3337 and as consequence can refuse to compile these. (see dhrystone.el)
3338 Flag this and all the one involved in ipa-prop as
3339 GCC_JIT_FUNCTION_INTERNAL not to fail compilation in case.
3340 This seems at least to have no perf downside. */
3341 func[i] =
3342 gcc_jit_context_new_function (comp.ctxt, NULL,
3343 GCC_JIT_FUNCTION_INTERNAL,
3344 comp.lisp_obj_type,
3345 f_name[i],
3346 2, param, 0);
3347
3348 gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]);
3349 DECL_BLOCK (entry_block, func[i]);
3350 DECL_BLOCK (is_cons_b, func[i]);
3351 DECL_BLOCK (not_a_cons_b, func[i]);
3352 comp.block = entry_block;
3353 comp.func = func[i];
3354 emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
3355 comp.bool_type,
3356 gcc_jit_param_as_rvalue (param[1]),
3357 emit_CONSP (c)),
3358 is_cons_b,
3359 not_a_cons_b);
3360 comp.block = is_cons_b;
3361 if (i == 0)
3362 gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c));
3363 else
3364 gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c));
3365
3366 comp.block = not_a_cons_b;
3367
3368 DECL_BLOCK (is_nil_b, func[i]);
3369 DECL_BLOCK (not_nil_b, func[i]);
3370
3371 emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b);
3372
3373 comp.block = is_nil_b;
3374 gcc_jit_block_end_with_return (comp.block,
3375 NULL,
3376 emit_lisp_obj_rval (Qnil));
3377
3378 comp.block = not_nil_b;
3379 gcc_jit_rvalue *wrong_type_args[] =
3380 { emit_lisp_obj_rval (Qlistp), c };
3381
3382 gcc_jit_block_add_eval (comp.block,
3383 NULL,
3384 emit_call (intern_c_string ("wrong_type_argument"),
3385 comp.void_type, 2, wrong_type_args,
3386 false));
3387 gcc_jit_block_end_with_return (comp.block,
3388 NULL,
3389 emit_lisp_obj_rval (Qnil));
3390 }
3391 comp.car = func[0];
3392 comp.cdr = func[1];
3393 }
3394
3395 static void
define_setcar_setcdr(void)3396 define_setcar_setcdr (void)
3397 {
3398 char const *f_name[] = { "setcar", "setcdr" };
3399 char const *par_name[] = { "new_car", "new_cdr" };
3400
3401 for (int i = 0; i < 2; i++)
3402 {
3403 gcc_jit_param *cell =
3404 gcc_jit_context_new_param (comp.ctxt,
3405 NULL,
3406 comp.lisp_obj_type,
3407 "cell");
3408 gcc_jit_param *new_el =
3409 gcc_jit_context_new_param (comp.ctxt,
3410 NULL,
3411 comp.lisp_obj_type,
3412 par_name[i]);
3413
3414 gcc_jit_param *param[] =
3415 { cell,
3416 new_el,
3417 gcc_jit_context_new_param (comp.ctxt,
3418 NULL,
3419 comp.bool_type,
3420 "cert_cons") };
3421
3422 gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr;
3423 *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL,
3424 GCC_JIT_FUNCTION_INTERNAL,
3425 comp.lisp_obj_type,
3426 f_name[i],
3427 3, param, 0);
3428 DECL_BLOCK (entry_block, *f_ref);
3429 comp.func = *f_ref;
3430 comp.block = entry_block;
3431
3432 /* CHECK_CONS (cell); */
3433 emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell));
3434
3435 /* CHECK_IMPURE (cell, XCONS (cell)); */
3436 gcc_jit_rvalue *args[] =
3437 { gcc_jit_param_as_rvalue (cell),
3438 emit_XCONS (gcc_jit_param_as_rvalue (cell)) };
3439
3440 gcc_jit_block_add_eval (entry_block,
3441 NULL,
3442 gcc_jit_context_new_call (comp.ctxt,
3443 NULL,
3444 comp.check_impure,
3445 2,
3446 args));
3447
3448 /* XSETCDR (cell, newel); */
3449 if (!i)
3450 emit_XSETCAR (gcc_jit_param_as_rvalue (cell),
3451 gcc_jit_param_as_rvalue (new_el));
3452 else
3453 emit_XSETCDR (gcc_jit_param_as_rvalue (cell),
3454 gcc_jit_param_as_rvalue (new_el));
3455
3456 /* return newel; */
3457 gcc_jit_block_end_with_return (entry_block,
3458 NULL,
3459 gcc_jit_param_as_rvalue (new_el));
3460 }
3461 }
3462
3463 /*
3464 Define a substitute for Fadd1 Fsub1.
3465 Currently expose just fixnum arithmetic.
3466 */
3467
3468 static void
define_add1_sub1(void)3469 define_add1_sub1 (void)
3470 {
3471 gcc_jit_block *bb_orig = comp.block;
3472 gcc_jit_function *func[2];
3473 char const *f_name[] = { "add1", "sub1" };
3474 char const *fall_back_func[] = { "1+", "1-" };
3475 enum gcc_jit_binary_op op[] =
3476 { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS };
3477 for (ptrdiff_t i = 0; i < 2; i++)
3478 {
3479 gcc_jit_param *param[] =
3480 { gcc_jit_context_new_param (comp.ctxt,
3481 NULL,
3482 comp.lisp_obj_type,
3483 "n"),
3484 gcc_jit_context_new_param (comp.ctxt,
3485 NULL,
3486 comp.bool_type,
3487 "cert_fixnum") };
3488 comp.func = func[i] =
3489 gcc_jit_context_new_function (comp.ctxt, NULL,
3490 GCC_JIT_FUNCTION_INTERNAL,
3491 comp.lisp_obj_type,
3492 f_name[i],
3493 2,
3494 param, 0);
3495 DECL_BLOCK (entry_block, func[i]);
3496 DECL_BLOCK (inline_block, func[i]);
3497 DECL_BLOCK (fcall_block, func[i]);
3498
3499 comp.block = entry_block;
3500
3501 /* cert_fixnum ||
3502 ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM
3503 ? (XFIXNUM (n) + 1)
3504 : Fadd1 (n)) */
3505
3506 gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]);
3507 gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n);
3508 gcc_jit_rvalue *sure_fixnum =
3509 emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
3510 comp.bool_type,
3511 gcc_jit_param_as_rvalue (param[1]),
3512 emit_FIXNUMP (n));
3513 emit_cond_jump (
3514 emit_binary_op (
3515 GCC_JIT_BINARY_OP_LOGICAL_AND,
3516 comp.bool_type,
3517 sure_fixnum,
3518 gcc_jit_context_new_comparison (
3519 comp.ctxt,
3520 NULL,
3521 GCC_JIT_COMPARISON_NE,
3522 n_fixnum,
3523 i == 0
3524 ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM)
3525 : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))),
3526 inline_block,
3527 fcall_block);
3528
3529 comp.block = inline_block;
3530 gcc_jit_rvalue *inline_res =
3531 emit_binary_op (op[i], comp.emacs_int_type, n_fixnum, comp.one);
3532
3533 gcc_jit_block_end_with_return (inline_block,
3534 NULL,
3535 emit_make_fixnum (inline_res));
3536
3537 comp.block = fcall_block;
3538 gcc_jit_rvalue *call_res = emit_call (intern_c_string (fall_back_func[i]),
3539 comp.lisp_obj_type, 1, &n, false);
3540 gcc_jit_block_end_with_return (fcall_block,
3541 NULL,
3542 call_res);
3543 }
3544 comp.block = bb_orig;
3545 comp.add1 = func[0];
3546 comp.sub1 = func[1];
3547 }
3548
3549 static void
define_negate(void)3550 define_negate (void)
3551 {
3552 gcc_jit_block *bb_orig = comp.block;
3553 gcc_jit_param *param[] =
3554 { gcc_jit_context_new_param (comp.ctxt,
3555 NULL,
3556 comp.lisp_obj_type,
3557 "n"),
3558 gcc_jit_context_new_param (comp.ctxt,
3559 NULL,
3560 comp.bool_type,
3561 "cert_fixnum") };
3562
3563 comp.func = comp.negate =
3564 gcc_jit_context_new_function (comp.ctxt, NULL,
3565 GCC_JIT_FUNCTION_INTERNAL,
3566 comp.lisp_obj_type,
3567 "negate",
3568 2, param, 0);
3569
3570 DECL_BLOCK (entry_block, comp.negate);
3571 DECL_BLOCK (inline_block, comp.negate);
3572 DECL_BLOCK (fcall_block, comp.negate);
3573
3574 comp.block = entry_block;
3575
3576 /* (cert_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM
3577 ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */
3578
3579 gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]);
3580 gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n));
3581 gcc_jit_rvalue *sure_fixnum =
3582 emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR,
3583 comp.bool_type,
3584 gcc_jit_param_as_rvalue (param[1]),
3585 emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n)));
3586
3587 emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_AND,
3588 comp.bool_type,
3589 sure_fixnum,
3590 gcc_jit_context_new_comparison (
3591 comp.ctxt,
3592 NULL,
3593 GCC_JIT_COMPARISON_NE,
3594 n_fixnum,
3595 emit_rvalue_from_emacs_int (
3596 MOST_NEGATIVE_FIXNUM))),
3597 inline_block,
3598 fcall_block);
3599
3600 comp.block = inline_block;
3601 gcc_jit_rvalue *inline_res =
3602 gcc_jit_context_new_unary_op (comp.ctxt,
3603 NULL,
3604 GCC_JIT_UNARY_OP_MINUS,
3605 comp.emacs_int_type,
3606 n_fixnum);
3607
3608 gcc_jit_block_end_with_return (inline_block,
3609 NULL,
3610 emit_make_fixnum (inline_res));
3611
3612 comp.block = fcall_block;
3613 gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n, false);
3614 gcc_jit_block_end_with_return (fcall_block,
3615 NULL,
3616 call_res);
3617 comp.block = bb_orig;
3618 }
3619
3620 /* Define a substitute for PSEUDOVECTORP as always inlined function. */
3621
3622 static void
define_PSEUDOVECTORP(void)3623 define_PSEUDOVECTORP (void)
3624 {
3625 gcc_jit_param *param[] =
3626 { gcc_jit_context_new_param (comp.ctxt,
3627 NULL,
3628 comp.lisp_obj_type,
3629 "a"),
3630 gcc_jit_context_new_param (comp.ctxt,
3631 NULL,
3632 comp.int_type,
3633 "code") };
3634
3635 comp.pseudovectorp =
3636 gcc_jit_context_new_function (comp.ctxt, NULL,
3637 GCC_JIT_FUNCTION_INTERNAL,
3638 comp.bool_type,
3639 "PSEUDOVECTORP",
3640 2,
3641 param,
3642 0);
3643
3644 DECL_BLOCK (entry_block, comp.pseudovectorp);
3645 DECL_BLOCK (ret_false_b, comp.pseudovectorp);
3646 DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp);
3647
3648 comp.block = entry_block;
3649 comp.func = comp.pseudovectorp;
3650
3651 emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])),
3652 call_pseudovector_typep_b,
3653 ret_false_b);
3654
3655 comp.block = ret_false_b;
3656 gcc_jit_block_end_with_return (ret_false_b,
3657 NULL,
3658 gcc_jit_context_new_rvalue_from_int (
3659 comp.ctxt,
3660 comp.bool_type,
3661 false));
3662
3663 gcc_jit_rvalue *args[] =
3664 { gcc_jit_param_as_rvalue (param[0]),
3665 gcc_jit_param_as_rvalue (param[1]) };
3666 comp.block = call_pseudovector_typep_b;
3667 /* FIXME use XUNTAG now that's available. */
3668 gcc_jit_block_end_with_return (
3669 call_pseudovector_typep_b,
3670 NULL,
3671 emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"),
3672 comp.bool_type, 2, args, false));
3673 }
3674
3675 static void
define_CHECK_IMPURE(void)3676 define_CHECK_IMPURE (void)
3677 {
3678 gcc_jit_param *param[] =
3679 { gcc_jit_context_new_param (comp.ctxt,
3680 NULL,
3681 comp.lisp_obj_type,
3682 "obj"),
3683 gcc_jit_context_new_param (comp.ctxt,
3684 NULL,
3685 comp.void_ptr_type,
3686 "ptr") };
3687 comp.check_impure =
3688 gcc_jit_context_new_function (comp.ctxt, NULL,
3689 GCC_JIT_FUNCTION_INTERNAL,
3690 comp.void_type,
3691 "CHECK_IMPURE",
3692 2,
3693 param,
3694 0);
3695
3696 DECL_BLOCK (entry_block, comp.check_impure);
3697 DECL_BLOCK (err_block, comp.check_impure);
3698 DECL_BLOCK (ok_block, comp.check_impure);
3699
3700 comp.block = entry_block;
3701 comp.func = comp.check_impure;
3702
3703 emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */
3704 err_block,
3705 ok_block);
3706 gcc_jit_block_end_with_void_return (ok_block, NULL);
3707
3708 gcc_jit_rvalue *pure_write_error_arg =
3709 gcc_jit_param_as_rvalue (param[0]);
3710
3711 comp.block = err_block;
3712 gcc_jit_block_add_eval (comp.block,
3713 NULL,
3714 emit_call (intern_c_string ("pure_write_error"),
3715 comp.void_type, 1,&pure_write_error_arg,
3716 false));
3717
3718 gcc_jit_block_end_with_void_return (err_block, NULL);
3719 }
3720
3721 static void
define_maybe_gc_or_quit(void)3722 define_maybe_gc_or_quit (void)
3723 {
3724
3725 /*
3726 void
3727 maybe_gc_or_quit (void)
3728 {
3729 static unsigned quitcounter;
3730 inc:
3731 quitcounter++;
3732 if (quitcounter >> 14) goto maybe_do_it else goto pass;
3733 maybe_do_it:
3734 quitcounter = 0;
3735 maybe_gc ();
3736 maybe_quit ();
3737 return;
3738 pass:
3739 return;
3740 }
3741 */
3742
3743 gcc_jit_block *bb_orig = comp.block;
3744
3745 gcc_jit_lvalue *quitcounter =
3746 gcc_jit_context_new_global (
3747 comp.ctxt,
3748 NULL,
3749 GCC_JIT_GLOBAL_INTERNAL,
3750 comp.unsigned_type,
3751 "quitcounter");
3752
3753 comp.func = comp.maybe_gc_or_quit =
3754 gcc_jit_context_new_function (comp.ctxt, NULL,
3755 GCC_JIT_FUNCTION_INTERNAL,
3756 comp.void_type,
3757 "maybe_gc_quit",
3758 0, NULL, 0);
3759 DECL_BLOCK (increment_block, comp.maybe_gc_or_quit);
3760 DECL_BLOCK (maybe_do_it_block, comp.maybe_gc_or_quit);
3761 DECL_BLOCK (pass_block, comp.maybe_gc_or_quit);
3762
3763 comp.block = increment_block;
3764
3765 gcc_jit_block_add_assignment (
3766 comp.block,
3767 NULL,
3768 quitcounter,
3769 emit_binary_op (GCC_JIT_BINARY_OP_PLUS,
3770 comp.unsigned_type,
3771 gcc_jit_lvalue_as_rvalue (quitcounter),
3772 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
3773 comp.unsigned_type,
3774 1)));
3775 emit_cond_jump (
3776 emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT,
3777 comp.unsigned_type,
3778 gcc_jit_lvalue_as_rvalue (quitcounter),
3779 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
3780 comp.unsigned_type,
3781 9)),
3782 /* 9 translates into checking for GC or quit every 512 calls to
3783 'maybe_gc_quit'. This is the smallest value I could find with
3784 no performance impact running elisp-banechmarks and the same
3785 used by the byte interpreter (see 'exec_byte_code'). */
3786 maybe_do_it_block,
3787 pass_block);
3788
3789 comp.block = maybe_do_it_block;
3790
3791 gcc_jit_block_add_assignment (
3792 comp.block,
3793 NULL,
3794 quitcounter,
3795 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
3796 comp.unsigned_type,
3797 0));
3798 gcc_jit_block_add_eval (comp.block, NULL,
3799 emit_call (intern_c_string ("maybe_gc"),
3800 comp.void_type, 0, NULL, false));
3801 gcc_jit_block_add_eval (comp.block, NULL,
3802 emit_call (intern_c_string ("maybe_quit"),
3803 comp.void_type, 0, NULL, false));
3804 gcc_jit_block_end_with_void_return (comp.block, NULL);
3805
3806 gcc_jit_block_end_with_void_return (pass_block, NULL);
3807
3808 comp.block = bb_orig;
3809 }
3810
3811 /* Define a function to convert boolean into t or nil */
3812
3813 static void
define_bool_to_lisp_obj(void)3814 define_bool_to_lisp_obj (void)
3815 {
3816 /* x ? Qt : Qnil */
3817 gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt,
3818 NULL,
3819 comp.bool_type,
3820 "x");
3821 comp.bool_to_lisp_obj =
3822 gcc_jit_context_new_function (comp.ctxt, NULL,
3823 GCC_JIT_FUNCTION_INTERNAL,
3824 comp.lisp_obj_type,
3825 "bool_to_lisp_obj",
3826 1,
3827 ¶m,
3828 0);
3829 DECL_BLOCK (entry_block, comp.bool_to_lisp_obj);
3830 DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj);
3831 DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj);
3832 comp.block = entry_block;
3833 comp.func = comp.bool_to_lisp_obj;
3834
3835 emit_cond_jump (gcc_jit_param_as_rvalue (param),
3836 ret_t_block,
3837 ret_nil_block);
3838
3839 comp.block = ret_t_block;
3840 gcc_jit_block_end_with_return (ret_t_block,
3841 NULL,
3842 emit_lisp_obj_rval (Qt));
3843
3844 comp.block = ret_nil_block;
3845 gcc_jit_block_end_with_return (ret_nil_block,
3846 NULL,
3847 emit_lisp_obj_rval (Qnil));
3848 }
3849
3850 static gcc_jit_function *
declare_lex_function(Lisp_Object func)3851 declare_lex_function (Lisp_Object func)
3852 {
3853 gcc_jit_function *res;
3854 Lisp_Object c_name = CALL1I (comp-func-c-name, func);
3855 Lisp_Object args = CALL1I (comp-func-l-args, func);
3856 bool nargs = !NILP (CALL1I (comp-nargs-p, args));
3857 USE_SAFE_ALLOCA;
3858
3859 if (!nargs)
3860 {
3861 EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args));
3862 eassert (max_args < INT_MAX);
3863 gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type));
3864 for (ptrdiff_t i = 0; i < max_args; i++)
3865 type[i] = comp.lisp_obj_type;
3866
3867 gcc_jit_param **params = SAFE_ALLOCA (max_args * sizeof (*params));
3868 for (int i = 0; i < max_args; ++i)
3869 params[i] = gcc_jit_context_new_param (comp.ctxt,
3870 NULL,
3871 type[i],
3872 format_string ("par_%d", i));
3873 res = gcc_jit_context_new_function (comp.ctxt, NULL,
3874 GCC_JIT_FUNCTION_EXPORTED,
3875 comp.lisp_obj_type,
3876 SSDATA (c_name),
3877 max_args,
3878 params,
3879 0);
3880 }
3881 else
3882 {
3883 gcc_jit_param *params[] =
3884 { gcc_jit_context_new_param (comp.ctxt,
3885 NULL,
3886 comp.ptrdiff_type,
3887 "nargs"),
3888 gcc_jit_context_new_param (comp.ctxt,
3889 NULL,
3890 comp.lisp_obj_ptr_type,
3891 "args") };
3892 res =
3893 gcc_jit_context_new_function (comp.ctxt,
3894 NULL,
3895 GCC_JIT_FUNCTION_EXPORTED,
3896 comp.lisp_obj_type,
3897 SSDATA (c_name),
3898 ARRAYELTS (params), params, 0);
3899 }
3900 SAFE_FREE ();
3901 return res;
3902 }
3903
3904 /* Declare a function being compiled and add it to comp.exported_funcs_h. */
3905
3906 static void
declare_function(Lisp_Object func)3907 declare_function (Lisp_Object func)
3908 {
3909 gcc_jit_function *gcc_func =
3910 !NILP (CALL1I (comp-func-l-p, func))
3911 ? declare_lex_function (func)
3912 : gcc_jit_context_new_function (comp.ctxt,
3913 NULL,
3914 GCC_JIT_FUNCTION_EXPORTED,
3915 comp.lisp_obj_type,
3916 SSDATA (CALL1I (comp-func-c-name, func)),
3917 0, NULL, 0);
3918 Fputhash (CALL1I (comp-func-c-name, func),
3919 make_mint_ptr (gcc_func),
3920 comp.exported_funcs_h);
3921 }
3922
3923 static void
compile_function(Lisp_Object func)3924 compile_function (Lisp_Object func)
3925 {
3926 USE_SAFE_ALLOCA;
3927 comp.frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func));
3928 eassert (comp.frame_size < INT_MAX);
3929
3930 comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func),
3931 comp.exported_funcs_h, Qnil));
3932
3933 comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func));
3934 comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func));
3935
3936 comp.func_relocs_local =
3937 gcc_jit_function_new_local (comp.func,
3938 NULL,
3939 comp.func_relocs_ptr_type,
3940 "freloc");
3941
3942 comp.frame = SAFE_ALLOCA (comp.frame_size * sizeof (*comp.frame));
3943 if (comp.func_has_non_local || !comp.func_speed)
3944 {
3945 /* FIXME: See bug#42360. */
3946 gcc_jit_lvalue *arr =
3947 gcc_jit_function_new_local (
3948 comp.func,
3949 NULL,
3950 gcc_jit_context_new_array_type (comp.ctxt,
3951 NULL,
3952 comp.lisp_obj_type,
3953 comp.frame_size),
3954 "frame");
3955
3956 for (ptrdiff_t i = 0; i < comp.frame_size; ++i)
3957 comp.frame[i] =
3958 gcc_jit_context_new_array_access (
3959 comp.ctxt,
3960 NULL,
3961 gcc_jit_lvalue_as_rvalue (arr),
3962 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
3963 comp.int_type,
3964 i));
3965 }
3966 else
3967 for (ptrdiff_t i = 0; i < comp.frame_size; ++i)
3968 comp.frame[i] =
3969 gcc_jit_function_new_local (comp.func,
3970 NULL,
3971 comp.lisp_obj_type,
3972 format_string ("slot_%td", i));
3973
3974 comp.scratch = NULL;
3975
3976 comp.loc_handler = gcc_jit_function_new_local (comp.func,
3977 NULL,
3978 comp.handler_ptr_type,
3979 "c");
3980
3981 comp.func_blocks_h = CALLN (Fmake_hash_table);
3982
3983 /* Pre-declare all basic blocks to gcc.
3984 The "entry" block must be declared as first. */
3985 declare_block (Qentry);
3986 Lisp_Object blocks = CALL1I (comp-func-blocks, func);
3987 struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks);
3988 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
3989 {
3990 Lisp_Object block_name = HASH_KEY (ht, i);
3991 if (!EQ (block_name, Qentry)
3992 && !EQ (block_name, Qunbound))
3993 declare_block (block_name);
3994 }
3995
3996 gcc_jit_block_add_assignment (retrive_block (Qentry),
3997 NULL,
3998 comp.func_relocs_local,
3999 gcc_jit_lvalue_as_rvalue (comp.func_relocs));
4000
4001
4002 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
4003 {
4004 Lisp_Object block_name = HASH_KEY (ht, i);
4005 if (!EQ (block_name, Qunbound))
4006 {
4007 Lisp_Object block = HASH_VALUE (ht, i);
4008 Lisp_Object insns = CALL1I (comp-block-insns, block);
4009 if (NILP (block) || NILP (insns))
4010 xsignal1 (Qnative_ice,
4011 build_string ("basic block is missing or empty"));
4012
4013 comp.block = retrive_block (block_name);
4014 while (CONSP (insns))
4015 {
4016 Lisp_Object insn = XCAR (insns);
4017 emit_limple_insn (insn);
4018 insns = XCDR (insns);
4019 }
4020 }
4021 }
4022 const char *err = gcc_jit_context_get_first_error (comp.ctxt);
4023 if (err)
4024 xsignal3 (Qnative_ice,
4025 build_string ("failing to compile function"),
4026 CALL1I (comp-func-name, func),
4027 build_string (err));
4028 SAFE_FREE ();
4029 }
4030
4031
4032 /**********************************/
4033 /* Entry points exposed to lisp. */
4034 /**********************************/
4035
4036 /* In use by Fcomp_el_to_eln_filename. */
4037 static Lisp_Object loadsearch_re_list;
4038
4039 static Lisp_Object
make_directory_wrapper(Lisp_Object directory)4040 make_directory_wrapper (Lisp_Object directory)
4041 {
4042 CALL2I (make-directory, directory, Qt);
4043 return Qnil;
4044 }
4045
4046 static Lisp_Object
make_directory_wrapper_1(Lisp_Object ignore)4047 make_directory_wrapper_1 (Lisp_Object ignore)
4048 {
4049 return Qt;
4050 }
4051
4052 DEFUN ("comp-el-to-eln-rel-filename", Fcomp_el_to_eln_rel_filename,
4053 Scomp_el_to_eln_rel_filename, 1, 1, 0,
4054 doc: /* Return the relative name of the .eln file for FILENAME.
4055 FILENAME must exist, and if it's a symlink, the target must exist.
4056 If FILENAME is compressed, it must have the \".gz\" extension,
4057 and Emacs must have been compiled with zlib; the file will be
4058 uncompressed on the fly to hash its contents.
4059 Value includes the original base name, followed by 2 hash values,
4060 one for the file name and another for its contents, followed by .eln. */)
4061 (Lisp_Object filename)
4062 {
4063 CHECK_STRING (filename);
4064
4065 /* Resolve possible symlinks in FILENAME, so that path_hash below
4066 always compares equal. (Bug#44701). */
4067 filename = Fexpand_file_name (filename, Qnil);
4068 char *file_normalized = realpath (SSDATA (ENCODE_FILE (filename)), NULL);
4069 if (file_normalized)
4070 {
4071 filename = DECODE_FILE (make_unibyte_string (file_normalized,
4072 strlen (file_normalized)));
4073 xfree (file_normalized);
4074 }
4075
4076 if (NILP (Ffile_exists_p (filename)))
4077 xsignal1 (Qfile_missing, filename);
4078
4079 #ifdef WINDOWSNT
4080 filename = Fw32_long_file_name (filename);
4081 #endif
4082
4083 Lisp_Object content_hash = comp_hash_source_file (filename);
4084
4085 if (suffix_p (filename, ".gz"))
4086 filename = Fsubstring (filename, Qnil, make_fixnum (-3));
4087
4088 /* We create eln filenames with an hash in order to look-up these
4089 starting from the source filename, IOW have a relation
4090
4091 /absolute/path/filename.el + content ->
4092 eln-cache/filename-path_hash-content_hash.eln.
4093
4094 'dlopen' can return the same handle if two shared with the same
4095 filename are loaded in two different times (even if the first was
4096 deleted!). To prevent this scenario the source file content is
4097 included in the hashing algorithm.
4098
4099 As at any point in time no more then one file can exist with the
4100 same filename, should be possible to clean up all
4101 filename-path_hash-* except the most recent one (or the new one
4102 being recompiled).
4103
4104 As installing .eln files compiled during the build changes their
4105 absolute path we need an hashing mechanism that is not sensitive
4106 to that. For this we replace if match PATH_DUMPLOADSEARCH or
4107 *PATH_REL_LOADSEARCH with '//' before computing the hash. */
4108
4109 if (NILP (loadsearch_re_list))
4110 {
4111 Lisp_Object sys_re =
4112 concat2 (build_string ("\\`[[:ascii:]]+"),
4113 Fregexp_quote (build_string ("/" PATH_REL_LOADSEARCH "/")));
4114 Lisp_Object dump_load_search =
4115 Fexpand_file_name (build_string (PATH_DUMPLOADSEARCH "/"), Qnil);
4116 #ifdef WINDOWSNT
4117 dump_load_search = Fw32_long_file_name (dump_load_search);
4118 #endif
4119 loadsearch_re_list = list2 (sys_re, Fregexp_quote (dump_load_search));
4120 }
4121
4122 Lisp_Object lds_re_tail = loadsearch_re_list;
FOR_EACH_TAIL(lds_re_tail)4123 FOR_EACH_TAIL (lds_re_tail)
4124 {
4125 Lisp_Object match_idx =
4126 Fstring_match (XCAR (lds_re_tail), filename, Qnil, Qnil);
4127 if (EQ (match_idx, make_fixnum (0)))
4128 {
4129 filename =
4130 Freplace_match (build_string ("//"), Qt, Qt, filename, Qnil);
4131 break;
4132 }
4133 }
4134 Lisp_Object separator = build_string ("-");
4135 Lisp_Object path_hash = comp_hash_string (filename);
4136 filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil,
4137 make_fixnum (-3))),
4138 separator);
4139 Lisp_Object hash = concat3 (path_hash, separator, content_hash);
4140 return concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX));
4141 }
4142
4143 DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename,
4144 Scomp_el_to_eln_filename, 1, 2, 0,
4145 doc: /* Return the absolute .eln file name for source FILENAME.
4146 The resulting .eln file name is intended to be used for natively
4147 compiling FILENAME. FILENAME must exist and be readable, but other
4148 than that, its leading directories are ignored when constructing
4149 the name of the .eln file.
4150 If BASE-DIR is non-nil, use it as the directory for the .eln file;
4151 non-absolute BASE-DIR is interpreted as relative to `invocation-directory'.
4152 If BASE-DIR is omitted or nil, look for the first writable directory
4153 in `native-comp-eln-load-path', and use as BASE-DIR its subdirectory
4154 whose name is given by `comp-native-version-dir'.
4155 If FILENAME specifies a preloaded file, the directory for the .eln
4156 file is the \"preloaded/\" subdirectory of the directory determined
4157 as described above. FILENAME is considered to be a preloaded file if
4158 the value of `comp-file-preloaded-p' is non-nil, or if FILENAME
4159 appears in the value of the environment variable LISP_PRELOADED;
4160 the latter is supposed to be used by the Emacs build procedure. */)
4161 (Lisp_Object filename, Lisp_Object base_dir)
4162 {
4163 Lisp_Object source_filename = filename;
4164 filename = Fcomp_el_to_eln_rel_filename (filename);
4165
4166 /* If base_dir was not specified search inside Vnative_comp_eln_load_path
4167 for the first directory where we have write access. */
4168 if (NILP (base_dir))
4169 {
4170 Lisp_Object eln_load_paths = Vnative_comp_eln_load_path;
FOR_EACH_TAIL(eln_load_paths)4171 FOR_EACH_TAIL (eln_load_paths)
4172 {
4173 Lisp_Object dir = XCAR (eln_load_paths);
4174 if (!NILP (Ffile_exists_p (dir)))
4175 {
4176 if (!NILP (Ffile_writable_p (dir)))
4177 {
4178 base_dir = dir;
4179 break;
4180 }
4181 }
4182 else
4183 {
4184 /* Try to create the directory and if succeeds use it. */
4185 if (NILP (internal_condition_case_1 (make_directory_wrapper,
4186 dir, Qt,
4187 make_directory_wrapper_1)))
4188 {
4189 base_dir = dir;
4190 break;
4191 }
4192 }
4193 }
4194 if (NILP (base_dir))
4195 error ("Cannot find suitable directory for output in "
4196 "`comp-native-load-path'.");
4197 }
4198
4199 if (!file_name_absolute_p (SSDATA (base_dir)))
4200 base_dir = Fexpand_file_name (base_dir, Vinvocation_directory);
4201
4202 /* In case the file being compiled is found in 'LISP_PRELOADED' or
4203 `comp-file-preloaded-p' is non-nil target for output the
4204 'preloaded' subfolder. */
4205 Lisp_Object lisp_preloaded =
4206 Fgetenv_internal (build_string ("LISP_PRELOADED"), Qnil);
4207 base_dir = Fexpand_file_name (Vcomp_native_version_dir, base_dir);
4208 if (comp_file_preloaded_p
4209 || (!NILP (lisp_preloaded)
4210 && !NILP (Fmember (CALL1I (file-name-base, source_filename),
4211 Fmapcar (intern_c_string ("file-name-base"),
4212 CALL1I (split-string, lisp_preloaded))))))
4213 base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir);
4214
4215 return Fexpand_file_name (filename, base_dir);
4216 }
4217
4218 DEFUN ("comp--install-trampoline", Fcomp__install_trampoline,
4219 Scomp__install_trampoline, 2, 2, 0,
4220 doc: /* Install a TRAMPOLINE for primitive SUBR-NAME. */)
4221 (Lisp_Object subr_name, Lisp_Object trampoline)
4222 {
4223 CHECK_SYMBOL (subr_name);
4224 CHECK_SUBR (trampoline);
4225 Lisp_Object orig_subr = Fsymbol_function (subr_name);
4226 CHECK_SUBR (orig_subr);
4227
4228 /* FIXME: add a post dump load trampoline machinery to remove this
4229 check. */
4230 if (will_dump_p ())
4231 signal_error ("Trying to advice unexpected primitive before dumping",
4232 subr_name);
4233
4234 Lisp_Object subr_l = Vcomp_subr_list;
4235 ptrdiff_t i = ARRAYELTS (helper_link_table);
FOR_EACH_TAIL(subr_l)4236 FOR_EACH_TAIL (subr_l)
4237 {
4238 Lisp_Object subr = XCAR (subr_l);
4239 if (EQ (subr, orig_subr))
4240 {
4241 freloc.link_table[i] = XSUBR (trampoline)->function.a0;
4242 Fputhash (subr_name, trampoline, Vcomp_installed_trampolines_h);
4243 return Qt;
4244 }
4245 i++;
4246 }
4247 signal_error ("Trying to install trampoline for non existent subr",
4248 subr_name);
4249 return Qnil;
4250 }
4251
4252 DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt,
4253 0, 0, 0,
4254 doc: /* Initialize the native compiler context.
4255 Return t on success. */)
4256 (void)
4257 {
4258 load_gccjit_if_necessary (true);
4259
4260 if (comp.ctxt)
4261 {
4262 xsignal1 (Qnative_ice,
4263 build_string ("compiler context already taken"));
4264 return Qnil;
4265 }
4266
4267 if (NILP (comp.emitter_dispatcher))
4268 {
4269 /* Move this into syms_of_comp the day will be dumpable. */
4270 comp.emitter_dispatcher = CALLN (Fmake_hash_table);
4271 register_emitter (Qset_internal, emit_set_internal);
4272 register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret);
4273 register_emitter (Qhelper_unwind_protect,
4274 emit_simple_limple_call_void_ret);
4275 register_emitter (Qrecord_unwind_current_buffer,
4276 emit_simple_limple_call_lisp_ret);
4277 register_emitter (Qrecord_unwind_protect_excursion,
4278 emit_simple_limple_call_void_ret);
4279 register_emitter (Qhelper_save_restriction,
4280 emit_simple_limple_call_void_ret);
4281 /* Inliners. */
4282 register_emitter (Qadd1, emit_add1);
4283 register_emitter (Qsub1, emit_sub1);
4284 register_emitter (Qconsp, emit_consp);
4285 register_emitter (Qcar, emit_car);
4286 register_emitter (Qcdr, emit_cdr);
4287 register_emitter (Qsetcar, emit_setcar);
4288 register_emitter (Qsetcdr, emit_setcdr);
4289 register_emitter (Qnegate, emit_negate);
4290 register_emitter (Qnumberp, emit_numperp);
4291 register_emitter (Qintegerp, emit_integerp);
4292 register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit);
4293 }
4294
4295 comp.ctxt = gcc_jit_context_acquire ();
4296
4297 comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID);
4298 comp.void_ptr_type =
4299 gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR);
4300 comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL);
4301 comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR);
4302 comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT);
4303 comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt,
4304 GCC_JIT_TYPE_UNSIGNED_INT);
4305 comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG);
4306 comp.unsigned_long_type =
4307 gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG);
4308 comp.long_long_type =
4309 gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG);
4310 comp.unsigned_long_long_type =
4311 gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG);
4312 comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type);
4313 comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt,
4314 sizeof (EMACS_INT),
4315 true);
4316 comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt,
4317 sizeof (EMACS_UINT),
4318 false);
4319 #if LISP_WORDS_ARE_POINTERS
4320 comp.lisp_word_type =
4321 gcc_jit_type_get_pointer (
4322 gcc_jit_struct_as_type (
4323 gcc_jit_context_new_opaque_struct (comp.ctxt,
4324 NULL,
4325 "Lisp_X")));
4326 #else
4327 comp.lisp_word_type = comp.emacs_int_type;
4328 #endif
4329 comp.lisp_word_tag_type
4330 = gcc_jit_context_get_int_type (comp.ctxt, sizeof (Lisp_Word_tag), false);
4331 #ifdef LISP_OBJECT_IS_STRUCT
4332 comp.lisp_obj_i = gcc_jit_context_new_field (comp.ctxt,
4333 NULL,
4334 comp.lisp_word_type,
4335 "i");
4336 comp.lisp_obj_s = gcc_jit_context_new_struct_type (comp.ctxt,
4337 NULL,
4338 "Lisp_Object",
4339 1,
4340 &comp.lisp_obj_i);
4341 comp.lisp_obj_type = gcc_jit_struct_as_type (comp.lisp_obj_s);
4342 #else
4343 comp.lisp_obj_type = comp.lisp_word_type;
4344 #endif
4345 comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type);
4346 comp.zero =
4347 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
4348 comp.emacs_int_type,
4349 0);
4350 comp.one =
4351 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
4352 comp.emacs_int_type,
4353 1);
4354 comp.inttypebits =
4355 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
4356 comp.emacs_uint_type,
4357 INTTYPEBITS);
4358 comp.lisp_int0 =
4359 gcc_jit_context_new_rvalue_from_int (comp.ctxt,
4360 comp.emacs_int_type,
4361 Lisp_Int0);
4362 comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt,
4363 sizeof (void *),
4364 true);
4365 comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt,
4366 sizeof (void *),
4367 false);
4368 comp.size_t_type = gcc_jit_context_get_int_type (comp.ctxt,
4369 sizeof (size_t),
4370 false);
4371
4372 comp.exported_funcs_h = CALLN (Fmake_hash_table, QCtest, Qequal);
4373 /*
4374 Always reinitialize this cause old function definitions are garbage
4375 collected by libgccjit when the ctxt is released.
4376 */
4377 comp.imported_funcs_h = CALLN (Fmake_hash_table);
4378
4379 define_memcpy ();
4380
4381 /* Define data structures. */
4382
4383 define_lisp_cons ();
4384 define_jmp_buf ();
4385 define_handler_struct ();
4386 define_thread_state_struct ();
4387 define_cast_functions ();
4388
4389 return Qt;
4390 }
4391
4392 DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt,
4393 0, 0, 0,
4394 doc: /* Release the native compiler context. */)
4395 (void)
4396 {
4397 load_gccjit_if_necessary (true);
4398
4399 if (comp.ctxt)
4400 gcc_jit_context_release (comp.ctxt);
4401
4402 if (logfile)
4403 fclose (logfile);
4404 comp.ctxt = NULL;
4405
4406 return Qt;
4407 }
4408
4409 #pragma GCC diagnostic ignored "-Waddress"
4410 DEFUN ("comp-native-driver-options-effective-p",
4411 Fcomp_native_driver_options_effective_p,
4412 Scomp_native_driver_options_effective_p,
4413 0, 0, 0,
4414 doc: /* Return t if `comp-native-driver-options' is effective. */)
4415 (void)
4416 {
4417 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option)
4418 if (gcc_jit_context_add_driver_option)
4419 return Qt;
4420 #endif
4421 return Qnil;
4422 }
4423 #pragma GCC diagnostic pop
4424
4425 #pragma GCC diagnostic ignored "-Waddress"
4426 DEFUN ("comp-native-compiler-options-effective-p",
4427 Fcomp_native_compiler_options_effective_p,
4428 Scomp_native_compiler_options_effective_p,
4429 0, 0, 0,
4430 doc: /* Return t if `comp-native-compiler-options' is effective. */)
4431 (void)
4432 {
4433 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option)
4434 if (gcc_jit_context_add_command_line_option)
4435 return Qt;
4436 #endif
4437 return Qnil;
4438 }
4439 #pragma GCC diagnostic pop
4440
4441 static void
add_driver_options(void)4442 add_driver_options (void)
4443 {
4444 Lisp_Object options = Fsymbol_value (Qnative_comp_driver_options);
4445
4446 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option)
4447 load_gccjit_if_necessary (true);
4448 if (!NILP (Fcomp_native_driver_options_effective_p ()))
4449 FOR_EACH_TAIL (options)
4450 gcc_jit_context_add_driver_option (comp.ctxt,
4451 /* FIXME: Need to encode
4452 this, but how? either
4453 ENCODE_FILE or
4454 ENCODE_SYSTEM. */
4455 SSDATA (XCAR (options)));
4456 #endif
4457 if (CONSP (options))
4458 xsignal1 (Qnative_compiler_error,
4459 build_string ("Customizing native compiler options"
4460 " via `comp-native-driver-options' is"
4461 " only available on libgccjit version 9"
4462 " and above."));
4463
4464 /* Captured `comp-native-driver-options' because file-local. */
4465 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option)
4466 options = comp.driver_options;
4467 if (!NILP (Fcomp_native_driver_options_effective_p ()))
4468 FOR_EACH_TAIL (options)
4469 gcc_jit_context_add_driver_option (comp.ctxt,
4470 /* FIXME: Need to encode
4471 this, but how? either
4472 ENCODE_FILE or
4473 ENCODE_SYSTEM. */
4474 SSDATA (XCAR (options)));
4475 #endif
4476 }
4477
4478 static void
add_compiler_options(void)4479 add_compiler_options (void)
4480 {
4481 Lisp_Object options = Fsymbol_value (Qnative_comp_compiler_options);
4482
4483 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option)
4484 load_gccjit_if_necessary (true);
4485 if (!NILP (Fcomp_native_compiler_options_effective_p ()))
4486 FOR_EACH_TAIL (options)
4487 gcc_jit_context_add_command_line_option (comp.ctxt,
4488 /* FIXME: Need to encode
4489 this, but how? either
4490 ENCODE_FILE or
4491 ENCODE_SYSTEM. */
4492 SSDATA (XCAR (options)));
4493 #endif
4494 if (CONSP (options))
4495 xsignal1 (Qnative_compiler_error,
4496 build_string ("Customizing native compiler options"
4497 " via `comp-native-compiler-options' is"
4498 " only available on libgccjit version 9"
4499 " and above."));
4500
4501 /* Captured `comp-native-compiler-options' because file-local. */
4502 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option)
4503 options = comp.compiler_options;
4504 if (!NILP (Fcomp_native_compiler_options_effective_p ()))
4505 FOR_EACH_TAIL (options)
4506 gcc_jit_context_add_command_line_option (comp.ctxt,
4507 /* FIXME: Need to encode
4508 this, but how? either
4509 ENCODE_FILE or
4510 ENCODE_SYSTEM. */
4511 SSDATA (XCAR (options)));
4512 #endif
4513 }
4514
4515 DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
4516 Scomp__compile_ctxt_to_file,
4517 1, 1, 0,
4518 doc: /* Compile the current context as native code to file FILENAME. */)
4519 (Lisp_Object filename)
4520 {
4521 load_gccjit_if_necessary (true);
4522
4523 CHECK_STRING (filename);
4524 Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4));
4525 Lisp_Object ebase_name = ENCODE_FILE (base_name);
4526
4527 comp.func_relocs_local = NULL;
4528
4529 #ifdef WINDOWSNT
4530 ebase_name = ansi_encode_filename (ebase_name);
4531 /* Tell libgccjit the actual file name of the loaded DLL, otherwise
4532 it will use 'libgccjit.so', which is not useful. */
4533 Lisp_Object libgccjit_loaded_from = Fget (Qgccjit, QCloaded_from);
4534 Lisp_Object libgccjit_fname;
4535
4536 if (CONSP (libgccjit_loaded_from))
4537 {
4538 /* Use the absolute file name if available, otherwise the name
4539 we looked for in w32_delayed_load. */
4540 libgccjit_fname = XCDR (libgccjit_loaded_from);
4541 if (NILP (libgccjit_fname))
4542 libgccjit_fname = XCAR (libgccjit_loaded_from);
4543 /* Must encode to ANSI, as libgccjit will not be able to handle
4544 UTF-8 encoded file names. */
4545 libgccjit_fname = ENCODE_FILE (libgccjit_fname);
4546 libgccjit_fname = ansi_encode_filename (libgccjit_fname);
4547 gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME,
4548 SSDATA (libgccjit_fname));
4549 }
4550 else /* this should never happen */
4551 gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME,
4552 "libgccjit-0.dll");
4553 #endif
4554
4555 comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt));
4556 eassert (comp.speed < INT_MAX);
4557 comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt));
4558 eassert (comp.debug < INT_MAX);
4559 comp.driver_options = CALL1I (comp-ctxt-driver-options, Vcomp_ctxt);
4560 comp.compiler_options = CALL1I (comp-ctxt-compiler-options, Vcomp_ctxt);
4561
4562 if (comp.debug)
4563 gcc_jit_context_set_bool_option (comp.ctxt,
4564 GCC_JIT_BOOL_OPTION_DEBUGINFO,
4565 1);
4566 if (comp.debug >= 3)
4567 {
4568 logfile = emacs_fopen ("libgccjit.log", "w");
4569 gcc_jit_context_set_logfile (comp.ctxt,
4570 logfile,
4571 0, 0);
4572 gcc_jit_context_set_bool_option (comp.ctxt,
4573 GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES,
4574 1);
4575 gcc_jit_context_set_bool_option (comp.ctxt,
4576 GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING,
4577 1);
4578 }
4579
4580 gcc_jit_context_set_int_option (comp.ctxt,
4581 GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL,
4582 comp.speed < 0 ? 0
4583 : (comp.speed > 3 ? 3 : comp.speed));
4584
4585 /* On MacOS set a unique dylib ID. */
4586 #if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \
4587 && defined (DARWIN_OS)
4588 gcc_jit_context_add_driver_option (comp.ctxt, "-install_name");
4589 gcc_jit_context_add_driver_option (
4590 comp.ctxt, SSDATA (Ffile_name_nondirectory (filename)));
4591 #endif
4592
4593 comp.d_default_idx =
4594 CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt));
4595 comp.d_impure_idx =
4596 CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-impure, Vcomp_ctxt));
4597 comp.d_ephemeral_idx =
4598 CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt));
4599
4600 emit_ctxt_code ();
4601
4602 /* Define inline functions. */
4603 define_CAR_CDR ();
4604 define_PSEUDOVECTORP ();
4605 define_CHECK_TYPE ();
4606 define_CHECK_IMPURE ();
4607 define_bool_to_lisp_obj ();
4608 define_setcar_setcdr ();
4609 define_add1_sub1 ();
4610 define_negate ();
4611 define_maybe_gc_or_quit ();
4612
4613 struct Lisp_Hash_Table *func_h =
4614 XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt));
4615 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++)
4616 if (!EQ (HASH_VALUE (func_h, i), Qunbound))
4617 declare_function (HASH_VALUE (func_h, i));
4618 /* Compile all functions. Can't be done before because the
4619 relocation structs has to be already defined. */
4620 for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++)
4621 if (!EQ (HASH_VALUE (func_h, i), Qunbound))
4622 compile_function (HASH_VALUE (func_h, i));
4623
4624 /* Work around bug#46495 (GCC PR99126). */
4625 #if defined (WIDE_EMACS_INT) \
4626 && defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option)
4627 Lisp_Object version = Fcomp_libgccjit_version ();
4628 if (NILP (version)
4629 || XFIXNUM (XCAR (version)) < 11)
4630 gcc_jit_context_add_command_line_option (comp.ctxt,
4631 "-fdisable-tree-isolate-paths");
4632 #endif
4633
4634 add_compiler_options ();
4635 add_driver_options ();
4636
4637 if (comp.debug > 1)
4638 gcc_jit_context_dump_to_file (comp.ctxt,
4639 format_string ("%s.c", SSDATA (ebase_name)),
4640 1);
4641 if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer)))
4642 gcc_jit_context_dump_reproducer_to_file (
4643 comp.ctxt,
4644 format_string ("%s_libgccjit_repro.c", SSDATA (ebase_name)));
4645
4646 Lisp_Object tmp_file =
4647 Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil);
4648 Lisp_Object encoded_tmp_file = ENCODE_FILE (tmp_file);
4649 #ifdef WINDOWSNT
4650 encoded_tmp_file = ansi_encode_filename (encoded_tmp_file);
4651 #endif
4652 gcc_jit_context_compile_to_file (comp.ctxt,
4653 GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY,
4654 SSDATA (encoded_tmp_file));
4655
4656 const char *err = gcc_jit_context_get_first_error (comp.ctxt);
4657 if (err)
4658 xsignal3 (Qnative_ice,
4659 build_string ("failed to compile"),
4660 filename,
4661 build_string (err));
4662
4663 CALL1I (comp-clean-up-stale-eln, filename);
4664 CALL2I (comp-delete-or-replace-file, filename, tmp_file);
4665
4666 return filename;
4667 }
4668
4669 #pragma GCC diagnostic ignored "-Waddress"
4670 DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version,
4671 Scomp_libgccjit_version, 0, 0, 0,
4672 doc: /* Return libgccjit version in use.
4673
4674 The return value has the form (MAJOR MINOR PATCHLEVEL) or nil if
4675 unknown (before GCC version 10). */)
4676 (void)
4677 {
4678 #if defined (LIBGCCJIT_HAVE_gcc_jit_version)
4679 load_gccjit_if_necessary (true);
4680
4681 return gcc_jit_version_major
4682 ? list3 (make_fixnum (gcc_jit_version_major ()),
4683 make_fixnum (gcc_jit_version_minor ()),
4684 make_fixnum (gcc_jit_version_patchlevel ()))
4685 : Qnil;
4686 #else
4687 return Qnil;
4688 #endif
4689 }
4690 #pragma GCC diagnostic pop
4691
4692
4693 /******************************************************************************/
4694 /* Helper functions called from the run-time. */
4695 /* These can't be statics till shared mechanism is used to solve relocations. */
4696 /* Note: this are all potentially definable directly to gcc and are here just */
4697 /* for laziness. Change this if a performance impact is measured. */
4698 /******************************************************************************/
4699
4700 void
helper_unwind_protect(Lisp_Object handler)4701 helper_unwind_protect (Lisp_Object handler)
4702 {
4703 /* Support for a function here is new in 24.4. */
4704 record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore,
4705 handler);
4706 }
4707
4708 Lisp_Object
helper_temp_output_buffer_setup(Lisp_Object x)4709 helper_temp_output_buffer_setup (Lisp_Object x)
4710 {
4711 CHECK_STRING (x);
4712 temp_output_buffer_setup (SSDATA (x));
4713 return Vstandard_output;
4714 }
4715
4716 Lisp_Object
helper_unbind_n(Lisp_Object n)4717 helper_unbind_n (Lisp_Object n)
4718 {
4719 return unbind_to (SPECPDL_INDEX () - XFIXNUM (n), Qnil);
4720 }
4721
4722 void
helper_save_restriction(void)4723 helper_save_restriction (void)
4724 {
4725 record_unwind_protect (save_restriction_restore,
4726 save_restriction_save ());
4727 }
4728
4729 bool
helper_PSEUDOVECTOR_TYPEP_XUNTAG(Lisp_Object a,enum pvec_type code)4730 helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code)
4731 {
4732 return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike,
4733 union vectorlike_header),
4734 code);
4735 }
4736
4737
4738 /* `native-comp-eln-load-path' clean-up support code. */
4739
4740 static Lisp_Object all_loaded_comp_units_h;
4741
4742 #ifdef WINDOWSNT
4743 static Lisp_Object
return_nil(Lisp_Object arg)4744 return_nil (Lisp_Object arg)
4745 {
4746 return Qnil;
4747 }
4748 #endif
4749
4750 /* Windows does not let us delete a .eln file that is currently loaded
4751 by a process. The strategy is to rename .eln files into .old.eln
4752 instead of removing them when this is not possible and clean-up
4753 `native-comp-eln-load-path' when exiting.
4754
4755 Any error is ignored because it may be due to the file being loaded
4756 in another Emacs instance. */
4757 void
eln_load_path_final_clean_up(void)4758 eln_load_path_final_clean_up (void)
4759 {
4760 #ifdef WINDOWSNT
4761 Lisp_Object dir_tail = Vnative_comp_eln_load_path;
4762 FOR_EACH_TAIL (dir_tail)
4763 {
4764 Lisp_Object files_in_dir =
4765 internal_condition_case_5 (Fdirectory_files,
4766 Fexpand_file_name (Vcomp_native_version_dir,
4767 XCAR (dir_tail)),
4768 Qt, build_string ("\\.eln\\.old\\'"), Qnil,
4769 Qnil, Qt, return_nil);
4770 FOR_EACH_TAIL (files_in_dir)
4771 internal_delete_file (XCAR (files_in_dir));
4772 }
4773 #endif
4774 }
4775
4776 /* This function puts the compilation unit in the
4777 `all_loaded_comp_units_h` hashmap. */
4778 static void
register_native_comp_unit(Lisp_Object comp_u)4779 register_native_comp_unit (Lisp_Object comp_u)
4780 {
4781 Fputhash (XNATIVE_COMP_UNIT (comp_u)->file, comp_u, all_loaded_comp_units_h);
4782 }
4783
4784
4785 /***********************************/
4786 /* Deferred compilation mechanism. */
4787 /***********************************/
4788
4789 /* Queue an asynchronous compilation for the source file defining
4790 FUNCTION_NAME and perform a late load.
4791
4792 NOTE: ideally would be nice to move its call simply into Fload but
4793 we need DEFINITION to guard against function redefinition while
4794 async compilation happen. */
4795
4796 void
maybe_defer_native_compilation(Lisp_Object function_name,Lisp_Object definition)4797 maybe_defer_native_compilation (Lisp_Object function_name,
4798 Lisp_Object definition)
4799 {
4800 #if 0
4801 #include <sys/types.h>
4802 #include <unistd.h>
4803 if (!NILP (function_name) &&
4804 STRINGP (Vload_true_file_name))
4805 {
4806 static FILE *f;
4807 if (!f)
4808 {
4809 char str[128];
4810 sprintf (str, "log_%d", getpid ());
4811 f = fopen (str, "w");
4812 }
4813 if (!f)
4814 exit (1);
4815 fprintf (f, "function %s file %s\n",
4816 SSDATA (Fsymbol_name (function_name)),
4817 SSDATA (Vload_true_file_name));
4818 fflush (f);
4819 }
4820 #endif
4821 if (!load_gccjit_if_necessary (false))
4822 return;
4823
4824 if (!native_comp_deferred_compilation
4825 || noninteractive
4826 || !NILP (Vpurify_flag)
4827 || !COMPILEDP (definition)
4828 || !STRINGP (Vload_true_file_name)
4829 || !suffix_p (Vload_true_file_name, ".elc")
4830 || !NILP (Fgethash (Vload_true_file_name, V_comp_no_native_file_h, Qnil)))
4831 return;
4832
4833 Lisp_Object src =
4834 concat2 (CALL1I (file-name-sans-extension, Vload_true_file_name),
4835 build_pure_c_string (".el"));
4836 if (NILP (Ffile_exists_p (src)))
4837 {
4838 src = concat2 (src, build_pure_c_string (".gz"));
4839 if (NILP (Ffile_exists_p (src)))
4840 return;
4841 }
4842
4843 /* This is so deferred compilation is able to compile comp
4844 dependencies breaking circularity. */
4845 if (comp__loadable)
4846 {
4847 /* Startup is done, comp is usable. */
4848 Frequire (Qcomp, Qnil, Qnil);
4849 Fputhash (function_name, definition, Vcomp_deferred_pending_h);
4850 CALLN (Ffuncall, intern_c_string ("native--compile-async"),
4851 src, Qnil, Qlate);
4852 }
4853 else
4854 Vcomp__delayed_sources = Fcons (src, Vcomp__delayed_sources);
4855 }
4856
4857
4858 /**************************************/
4859 /* Functions used to load eln files. */
4860 /**************************************/
4861
4862 /* Fixup the system eln-cache directory, which is the last entry in
4863 `native-comp-eln-load-path'. Argument is a .eln file in that directory. */
4864 void
fixup_eln_load_path(Lisp_Object eln_filename)4865 fixup_eln_load_path (Lisp_Object eln_filename)
4866 {
4867 Lisp_Object last_cell = Qnil;
4868 Lisp_Object tem = Vnative_comp_eln_load_path;
4869 FOR_EACH_TAIL (tem)
4870 if (CONSP (tem))
4871 last_cell = tem;
4872
4873 const char preloaded[] = "/preloaded/";
4874 Lisp_Object eln_cache_sys = Ffile_name_directory (eln_filename);
4875 const char *p_preloaded =
4876 SSDATA (eln_cache_sys) + SBYTES (eln_cache_sys) - sizeof (preloaded) + 1;
4877 bool preloaded_p = strcmp (p_preloaded, preloaded) == 0;
4878
4879 /* One or two directories up... */
4880 for (int i = 0; i < (preloaded_p ? 2 : 1); i++)
4881 eln_cache_sys =
4882 Ffile_name_directory (Fsubstring_no_properties (eln_cache_sys, Qnil,
4883 make_fixnum (-1)));
4884 Fsetcar (last_cell, eln_cache_sys);
4885 }
4886
4887 typedef char *(*comp_lit_str_func) (void);
4888
4889 /* Deserialize read and return static object. */
4890 static Lisp_Object
load_static_obj(struct Lisp_Native_Comp_Unit * comp_u,const char * name)4891 load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name)
4892 {
4893 static_obj_t *blob =
4894 dynlib_sym (comp_u->handle, format_string ("%s_blob", name));
4895 if (blob)
4896 /* New blob format. */
4897 return Fread (make_string (blob->data, blob->len));
4898
4899 static_obj_t *(*f)(void) = dynlib_sym (comp_u->handle, name);
4900 if (!f)
4901 xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
4902
4903 blob = f ();
4904 return Fread (make_string (blob->data, blob->len));
4905
4906 }
4907
4908 /* Return false when something is wrong or true otherwise. */
4909
4910 static bool
check_comp_unit_relocs(struct Lisp_Native_Comp_Unit * comp_u)4911 check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u)
4912 {
4913 dynlib_handle_ptr handle = comp_u->handle;
4914 Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
4915 Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
4916
4917 EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec));
4918 for (ptrdiff_t i = 0; i < d_vec_len; i++)
4919 if (!EQ (data_relocs[i], AREF (comp_u->data_vec, i)))
4920 return false;
4921
4922 d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec));
4923 for (ptrdiff_t i = 0; i < d_vec_len; i++)
4924 {
4925 Lisp_Object x = data_imp_relocs[i];
4926 if (EQ (x, Qlambda_fixup))
4927 return false;
4928 else if (SUBR_NATIVE_COMPILEDP (x))
4929 {
4930 if (NILP (Fgethash (x, comp_u->lambda_gc_guard_h, Qnil)))
4931 return false;
4932 }
4933 else if (!EQ (data_imp_relocs[i], AREF (comp_u->data_impure_vec, i)))
4934 return false;
4935 }
4936 return true;
4937 }
4938
4939 static void
unset_cu_load_ongoing(Lisp_Object comp_u)4940 unset_cu_load_ongoing (Lisp_Object comp_u)
4941 {
4942 XNATIVE_COMP_UNIT (comp_u)->load_ongoing = false;
4943 }
4944
4945 Lisp_Object
load_comp_unit(struct Lisp_Native_Comp_Unit * comp_u,bool loading_dump,bool late_load)4946 load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump,
4947 bool late_load)
4948 {
4949 Lisp_Object res = Qnil;
4950 dynlib_handle_ptr handle = comp_u->handle;
4951 Lisp_Object comp_u_lisp_obj;
4952 XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u);
4953
4954 Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM);
4955 if (!saved_cu)
4956 xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
4957 comp_u->loaded_once = !NILP (*saved_cu);
4958 Lisp_Object *data_eph_relocs =
4959 dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM);
4960
4961 /* While resurrecting from an image dump loading more than once the
4962 same compilation unit does not make any sense. */
4963 eassert (!(loading_dump && comp_u->loaded_once));
4964
4965 if (comp_u->loaded_once)
4966 /* 'dlopen' returns the same handle when trying to load two times
4967 the same shared. In this case touching 'd_reloc' etc leads to
4968 fails in case a frame with a reference to it in a live reg is
4969 active (native-comp-speed > 0).
4970
4971 We must *never* mess with static pointers in an already loaded
4972 eln. */
4973 {
4974 comp_u_lisp_obj = *saved_cu;
4975 comp_u = XNATIVE_COMP_UNIT (comp_u_lisp_obj);
4976 comp_u->loaded_once = true;
4977 }
4978 else
4979 *saved_cu = comp_u_lisp_obj;
4980
4981 /* Once we are sure to have the right compilation unit we want to
4982 identify is we have at least another load active on it. */
4983 bool recursive_load = comp_u->load_ongoing;
4984 comp_u->load_ongoing = true;
4985 ptrdiff_t count = SPECPDL_INDEX ();
4986 if (!recursive_load)
4987 record_unwind_protect (unset_cu_load_ongoing, comp_u_lisp_obj);
4988
4989 freloc_check_fill ();
4990
4991 Lisp_Object (*top_level_run)(Lisp_Object)
4992 = dynlib_sym (handle,
4993 late_load ? "late_top_level_run" : "top_level_run");
4994
4995 /* Always set data_imp_relocs pointer in the compilation unit (in can be
4996 used in 'dump_do_dump_relocation'). */
4997 comp_u->data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM);
4998
4999 if (!comp_u->loaded_once)
5000 {
5001 struct thread_state ***current_thread_reloc =
5002 dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM);
5003 void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM);
5004 Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM);
5005 Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs;
5006 void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM);
5007
5008 if (!(current_thread_reloc
5009 && pure_reloc
5010 && data_relocs
5011 && data_imp_relocs
5012 && data_eph_relocs
5013 && freloc_link_table
5014 && top_level_run)
5015 || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM),
5016 Vcomp_abi_hash)))
5017 xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file);
5018
5019 *current_thread_reloc = ¤t_thread;
5020 *pure_reloc = pure;
5021
5022 /* Imported functions. */
5023 *freloc_link_table = freloc.link_table;
5024
5025 /* Imported data. */
5026 if (!loading_dump)
5027 {
5028 comp_u->optimize_qualities =
5029 load_static_obj (comp_u, TEXT_OPTIM_QLY_SYM);
5030 comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM);
5031 comp_u->data_impure_vec =
5032 load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM);
5033
5034 if (!NILP (Vpurify_flag))
5035 /* Non impure can be copied into pure space. */
5036 comp_u->data_vec = Fpurecopy (comp_u->data_vec);
5037 }
5038
5039 EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec));
5040 for (EMACS_INT i = 0; i < d_vec_len; i++)
5041 data_relocs[i] = AREF (comp_u->data_vec, i);
5042
5043 d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec));
5044 for (EMACS_INT i = 0; i < d_vec_len; i++)
5045 data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i);
5046 }
5047
5048 if (!loading_dump)
5049 {
5050 /* Note: data_ephemeral_vec is not GC protected except than by
5051 this function frame. After this functions will be
5052 deactivated GC will be free to collect it, but it MUST
5053 survive till 'top_level_run' has finished his job. We store
5054 into the ephemeral allocation class only objects that we know
5055 are necessary exclusively during the first load. Once these
5056 are collected we don't have to maintain them in the heap
5057 forever. */
5058 Lisp_Object volatile data_ephemeral_vec;
5059 /* In case another load of the same CU is active on the stack
5060 all ephemeral data is hold by that frame. Re-writing
5061 'data_ephemeral_vec' would be not only a waste of cycles but
5062 more importantly would lead to crashes if the contained data
5063 is not cons hashed. */
5064 if (!recursive_load)
5065 {
5066 data_ephemeral_vec =
5067 load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM);
5068
5069 EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec));
5070 for (EMACS_INT i = 0; i < d_vec_len; i++)
5071 data_eph_relocs[i] = AREF (data_ephemeral_vec, i);
5072 }
5073 /* Executing this will perform all the expected environment
5074 modifications. */
5075 res = top_level_run (comp_u_lisp_obj);
5076 /* Make sure data_ephemeral_vec still exists after top_level_run has run.
5077 Guard against sibling call optimization (or any other). */
5078 data_ephemeral_vec = data_ephemeral_vec;
5079 eassert (check_comp_unit_relocs (comp_u));
5080 }
5081
5082 if (!recursive_load)
5083 /* Clean-up the load ongoing flag in case. */
5084 unbind_to (count, Qnil);
5085
5086 register_native_comp_unit (comp_u_lisp_obj);
5087
5088 return res;
5089 }
5090
5091 void
unload_comp_unit(struct Lisp_Native_Comp_Unit * cu)5092 unload_comp_unit (struct Lisp_Native_Comp_Unit *cu)
5093 {
5094 if (cu->handle == NULL)
5095 return;
5096
5097 Lisp_Object *saved_cu = dynlib_sym (cu->handle, COMP_UNIT_SYM);
5098 Lisp_Object this_cu;
5099 XSETNATIVE_COMP_UNIT (this_cu, cu);
5100 if (EQ (this_cu, *saved_cu))
5101 *saved_cu = Qnil;
5102 dynlib_close (cu->handle);
5103 }
5104
5105 Lisp_Object
native_function_doc(Lisp_Object function)5106 native_function_doc (Lisp_Object function)
5107 {
5108 struct Lisp_Native_Comp_Unit *cu =
5109 XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function));
5110
5111 if (NILP (cu->data_fdoc_v))
5112 cu->data_fdoc_v = load_static_obj (cu, TEXT_FDOC_SYM);
5113 if (!VECTORP (cu->data_fdoc_v))
5114 xsignal2 (Qnative_lisp_file_inconsistent, cu->file,
5115 build_string ("missing documentation vector"));
5116 return AREF (cu->data_fdoc_v, XSUBR (function)->doc);
5117 }
5118
5119 static Lisp_Object
make_subr(Lisp_Object symbol_name,Lisp_Object minarg,Lisp_Object maxarg,Lisp_Object c_name,Lisp_Object type,Lisp_Object doc_idx,Lisp_Object intspec,Lisp_Object comp_u)5120 make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg,
5121 Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx,
5122 Lisp_Object intspec, Lisp_Object comp_u)
5123 {
5124 struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
5125 dynlib_handle_ptr handle = cu->handle;
5126 if (!handle)
5127 xsignal0 (Qwrong_register_subr_call);
5128
5129 void *func = dynlib_sym (handle, SSDATA (c_name));
5130 eassert (func);
5131 union Aligned_Lisp_Subr *x =
5132 (union Aligned_Lisp_Subr *) allocate_pseudovector (
5133 VECSIZE (union Aligned_Lisp_Subr),
5134 0, VECSIZE (union Aligned_Lisp_Subr),
5135 PVEC_SUBR);
5136 if (CONSP (minarg))
5137 {
5138 /* Dynamic code. */
5139 #ifdef HAVE_NATIVE_COMP
5140 x->s.lambda_list = maxarg;
5141 #endif
5142 maxarg = XCDR (minarg);
5143 minarg = XCAR (minarg);
5144 }
5145 else
5146 {
5147 #ifdef HAVE_NATIVE_COMP
5148 x->s.lambda_list = Qnil;
5149 #endif
5150 }
5151 x->s.function.a0 = func;
5152 x->s.min_args = XFIXNUM (minarg);
5153 x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY;
5154 x->s.symbol_name = xstrdup (SSDATA (symbol_name));
5155 x->s.native_intspec = intspec;
5156 x->s.doc = XFIXNUM (doc_idx);
5157 #ifdef HAVE_NATIVE_COMP
5158 x->s.native_comp_u = comp_u;
5159 x->s.native_c_name = xstrdup (SSDATA (c_name));
5160 x->s.type = type;
5161 #endif
5162 Lisp_Object tem;
5163 XSETSUBR (tem, &x->s);
5164
5165 return tem;
5166 }
5167
5168 DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda,
5169 7, 7, 0,
5170 doc: /* Register anonymous lambda.
5171 This gets called by top_level_run during the load phase. */)
5172 (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg,
5173 Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
5174 Lisp_Object comp_u)
5175 {
5176 Lisp_Object doc_idx = FIRST (rest);
5177 Lisp_Object intspec = SECOND (rest);
5178 struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u);
5179 if (cu->loaded_once)
5180 return Qnil;
5181
5182 Lisp_Object tem =
5183 make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, comp_u);
5184
5185 /* We must protect it against GC because the function is not
5186 reachable through symbols. */
5187 Fputhash (tem, Qt, cu->lambda_gc_guard_h);
5188 /* This is for fixing up the value in d_reloc while resurrecting
5189 from dump. See 'dump_do_dump_relocation'. */
5190 eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil)));
5191 Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h);
5192 /* Do the real relocation fixup. */
5193 cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem;
5194
5195 return tem;
5196 }
5197
5198 DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr,
5199 7, 7, 0,
5200 doc: /* Register exported subr.
5201 This gets called by top_level_run during the load phase. */)
5202 (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg,
5203 Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
5204 Lisp_Object comp_u)
5205 {
5206 Lisp_Object doc_idx = FIRST (rest);
5207 Lisp_Object intspec = SECOND (rest);
5208 Lisp_Object tem =
5209 make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx,
5210 intspec, comp_u);
5211
5212 if (AUTOLOADP (XSYMBOL (name)->u.s.function))
5213 /* Remember that the function was already an autoload. */
5214 LOADHIST_ATTACH (Fcons (Qt, name));
5215 LOADHIST_ATTACH (Fcons (Qdefun, name));
5216
5217 { /* Handle automatic advice activation (bug#42038).
5218 See `defalias'. */
5219 Lisp_Object hook = Fget (name, Qdefalias_fset_function);
5220 if (!NILP (hook))
5221 call2 (hook, name, tem);
5222 else
5223 Ffset (name, tem);
5224 }
5225
5226 return tem;
5227 }
5228
5229 DEFUN ("comp--late-register-subr", Fcomp__late_register_subr,
5230 Scomp__late_register_subr, 7, 7, 0,
5231 doc: /* Register exported subr.
5232 This gets called by late_top_level_run during the load phase. */)
5233 (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg,
5234 Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest,
5235 Lisp_Object comp_u)
5236 {
5237 if (!NILP (Fequal (Fsymbol_function (name),
5238 Fgethash (name, Vcomp_deferred_pending_h, Qnil))))
5239 Fcomp__register_subr (name, c_name, minarg, maxarg, type, rest, comp_u);
5240 Fremhash (name, Vcomp_deferred_pending_h);
5241 return Qnil;
5242 }
5243
5244 static bool
file_in_eln_sys_dir(Lisp_Object filename)5245 file_in_eln_sys_dir (Lisp_Object filename)
5246 {
5247 Lisp_Object eln_sys_dir = Qnil;
5248 Lisp_Object tmp = Vnative_comp_eln_load_path;
5249 FOR_EACH_TAIL (tmp)
5250 eln_sys_dir = XCAR (tmp);
5251 return !NILP (Fstring_match (Fregexp_quote (Fexpand_file_name (eln_sys_dir,
5252 Qnil)),
5253 Fexpand_file_name (filename, Qnil),
5254 Qnil, Qnil));
5255 }
5256
5257 /* Load related routines. */
5258 DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0,
5259 doc: /* Load native elisp code FILENAME.
5260 LATE_LOAD has to be non-nil when loading for deferred compilation. */)
5261 (Lisp_Object filename, Lisp_Object late_load)
5262 {
5263 CHECK_STRING (filename);
5264 if (NILP (Ffile_exists_p (filename)))
5265 xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"),
5266 filename);
5267 struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit ();
5268 Lisp_Object encoded_filename = ENCODE_FILE (filename);
5269
5270 if (!NILP (Fgethash (filename, all_loaded_comp_units_h, Qnil))
5271 && !file_in_eln_sys_dir (filename)
5272 && !NILP (Ffile_writable_p (filename)))
5273 {
5274 /* If in this session there was ever a file loaded with this
5275 name, rename it before loading, to make sure we always get a
5276 new handle! */
5277 Lisp_Object tmp_filename =
5278 Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"),
5279 Qnil);
5280 if (NILP (Ffile_writable_p (tmp_filename)))
5281 comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename));
5282 else
5283 {
5284 Frename_file (filename, tmp_filename, Qt);
5285 comp_u->handle = dynlib_open_for_eln (SSDATA (ENCODE_FILE (tmp_filename)));
5286 Frename_file (tmp_filename, filename, Qnil);
5287 }
5288 }
5289 else
5290 comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename));
5291
5292 if (!comp_u->handle)
5293 xsignal2 (Qnative_lisp_load_failed, filename,
5294 build_string (dynlib_error ()));
5295 comp_u->file = filename;
5296 comp_u->data_vec = Qnil;
5297 comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq);
5298 comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal);
5299 return load_comp_unit (comp_u, false, !NILP (late_load));
5300 }
5301
5302 #endif /* HAVE_NATIVE_COMP */
5303
5304 DEFUN ("native-comp-available-p", Fnative_comp_available_p,
5305 Snative_comp_available_p, 0, 0, 0,
5306 doc: /* Return non-nil if native compilation support is built-in. */)
5307 (void)
5308 {
5309 #ifdef HAVE_NATIVE_COMP
5310 return load_gccjit_if_necessary (false) ? Qt : Qnil;
5311 #else
5312 return Qnil;
5313 #endif
5314 }
5315
5316
5317 void
syms_of_comp(void)5318 syms_of_comp (void)
5319 {
5320 #ifdef HAVE_NATIVE_COMP
5321 DEFVAR_LISP ("comp--delayed-sources", Vcomp__delayed_sources,
5322 doc: /* List of sources to be native-compiled when startup is finished.
5323 For internal use. */);
5324 DEFVAR_BOOL ("comp--loadable",
5325 comp__loadable,
5326 doc: /* Non-nil when comp.el can be loaded.
5327 For internal use. */);
5328 /* Compiler control customizes. */
5329 DEFVAR_BOOL ("native-comp-deferred-compilation",
5330 native_comp_deferred_compilation,
5331 doc: /* If non-nil compile loaded .elc files asynchronously.
5332
5333 After compilation, each function definition is updated to the native
5334 compiled one. */);
5335 native_comp_deferred_compilation = true;
5336
5337 DEFSYM (Qnative_comp_speed, "native-comp-speed");
5338 DEFSYM (Qnative_comp_debug, "native-comp-debug");
5339 DEFSYM (Qnative_comp_driver_options, "native-comp-driver-options");
5340 DEFSYM (Qnative_comp_compiler_options, "native-comp-compiler-options");
5341 DEFSYM (Qcomp_libgccjit_reproducer, "comp-libgccjit-reproducer");
5342
5343 /* Limple instruction set. */
5344 DEFSYM (Qcomment, "comment");
5345 DEFSYM (Qjump, "jump");
5346 DEFSYM (Qcall, "call");
5347 DEFSYM (Qcallref, "callref");
5348 DEFSYM (Qdirect_call, "direct-call");
5349 DEFSYM (Qdirect_callref, "direct-callref");
5350 DEFSYM (Qassume, "assume");
5351 DEFSYM (Qsetimm, "setimm");
5352 DEFSYM (Qreturn, "return");
5353 DEFSYM (Qunreachable, "unreachable");
5354 DEFSYM (Qcomp_mvar, "comp-mvar");
5355 DEFSYM (Qcond_jump, "cond-jump");
5356 DEFSYM (Qphi, "phi");
5357 /* Ops in use for prologue emission. */
5358 DEFSYM (Qset_par_to_local, "set-par-to-local");
5359 DEFSYM (Qset_args_to_local, "set-args-to-local");
5360 DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local");
5361 DEFSYM (Qinc_args, "inc-args");
5362 DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq");
5363 /* Others. */
5364 DEFSYM (Qpush_handler, "push-handler");
5365 DEFSYM (Qpop_handler, "pop-handler");
5366 DEFSYM (Qfetch_handler, "fetch-handler");
5367 DEFSYM (Qcondition_case, "condition-case");
5368 /* call operands. */
5369 DEFSYM (Qcatcher, "catcher");
5370 DEFSYM (Qentry, "entry");
5371 DEFSYM (Qset_internal, "set_internal");
5372 DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer");
5373 DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion");
5374 DEFSYM (Qhelper_unbind_n, "helper_unbind_n");
5375 DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect");
5376 DEFSYM (Qhelper_save_restriction, "helper_save_restriction");
5377 /* Inliners. */
5378 DEFSYM (Qadd1, "1+");
5379 DEFSYM (Qsub1, "1-");
5380 DEFSYM (Qconsp, "consp");
5381 DEFSYM (Qcar, "car");
5382 DEFSYM (Qcdr, "cdr");
5383 DEFSYM (Qsetcar, "setcar");
5384 DEFSYM (Qsetcdr, "setcdr");
5385 DEFSYM (Qnegate, "negate");
5386 DEFSYM (Qnumberp, "numberp");
5387 DEFSYM (Qintegerp, "integerp");
5388 DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit");
5389
5390 /* Allocation classes. */
5391 DEFSYM (Qd_default, "d-default");
5392 DEFSYM (Qd_impure, "d-impure");
5393 DEFSYM (Qd_ephemeral, "d-ephemeral");
5394
5395 /* Others. */
5396 DEFSYM (Qcomp, "comp");
5397 DEFSYM (Qfixnum, "fixnum");
5398 DEFSYM (Qscratch, "scratch");
5399 DEFSYM (Qlate, "late");
5400 DEFSYM (Qlambda_fixup, "lambda-fixup");
5401 DEFSYM (Qgccjit, "gccjit");
5402 DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install");
5403 DEFSYM (Qnative_comp_warning_on_missing_source,
5404 "native-comp-warning-on-missing-source");
5405
5406 /* To be signaled by the compiler. */
5407 DEFSYM (Qnative_compiler_error, "native-compiler-error");
5408 Fput (Qnative_compiler_error, Qerror_conditions,
5409 pure_list (Qnative_compiler_error, Qerror));
5410 Fput (Qnative_compiler_error, Qerror_message,
5411 build_pure_c_string ("Native compiler error"));
5412
5413 DEFSYM (Qnative_ice, "native-ice");
5414 Fput (Qnative_ice, Qerror_conditions,
5415 pure_list (Qnative_ice, Qnative_compiler_error, Qerror));
5416 Fput (Qnative_ice, Qerror_message,
5417 build_pure_c_string ("Internal native compiler error"));
5418
5419 /* By the load machinery. */
5420 DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed");
5421 Fput (Qnative_lisp_load_failed, Qerror_conditions,
5422 pure_list (Qnative_lisp_load_failed, Qerror));
5423 Fput (Qnative_lisp_load_failed, Qerror_message,
5424 build_pure_c_string ("Native elisp load failed"));
5425
5426 DEFSYM (Qnative_lisp_wrong_reloc, "native-lisp-wrong-reloc");
5427 Fput (Qnative_lisp_wrong_reloc, Qerror_conditions,
5428 pure_list (Qnative_lisp_wrong_reloc, Qnative_lisp_load_failed, Qerror));
5429 Fput (Qnative_lisp_wrong_reloc, Qerror_message,
5430 build_pure_c_string ("Primitive redefined or wrong relocation"));
5431
5432 DEFSYM (Qwrong_register_subr_call, "wrong-register-subr-call");
5433 Fput (Qwrong_register_subr_call, Qerror_conditions,
5434 pure_list (Qwrong_register_subr_call, Qnative_lisp_load_failed, Qerror));
5435 Fput (Qwrong_register_subr_call, Qerror_message,
5436 build_pure_c_string ("comp--register-subr can only be called during "
5437 "native lisp load phase."));
5438
5439 DEFSYM (Qnative_lisp_file_inconsistent, "native-lisp-file-inconsistent");
5440 Fput (Qnative_lisp_file_inconsistent, Qerror_conditions,
5441 pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed, Qerror));
5442 Fput (Qnative_lisp_file_inconsistent, Qerror_message,
5443 build_pure_c_string ("eln file inconsistent with current runtime "
5444 "configuration, please recompile"));
5445
5446 defsubr (&Scomp__subr_signature);
5447 defsubr (&Scomp_el_to_eln_rel_filename);
5448 defsubr (&Scomp_el_to_eln_filename);
5449 defsubr (&Scomp_native_driver_options_effective_p);
5450 defsubr (&Scomp_native_compiler_options_effective_p);
5451 defsubr (&Scomp__install_trampoline);
5452 defsubr (&Scomp__init_ctxt);
5453 defsubr (&Scomp__release_ctxt);
5454 defsubr (&Scomp__compile_ctxt_to_file);
5455 defsubr (&Scomp_libgccjit_version);
5456 defsubr (&Scomp__register_lambda);
5457 defsubr (&Scomp__register_subr);
5458 defsubr (&Scomp__late_register_subr);
5459 defsubr (&Snative_elisp_load);
5460
5461 staticpro (&comp.exported_funcs_h);
5462 comp.exported_funcs_h = Qnil;
5463 staticpro (&comp.imported_funcs_h);
5464 comp.imported_funcs_h = Qnil;
5465 staticpro (&comp.func_blocks_h);
5466 staticpro (&comp.emitter_dispatcher);
5467 comp.emitter_dispatcher = Qnil;
5468 staticpro (&loadsearch_re_list);
5469 loadsearch_re_list = Qnil;
5470
5471 staticpro (&all_loaded_comp_units_h);
5472 all_loaded_comp_units_h =
5473 CALLN (Fmake_hash_table, QCweakness, Qkey_and_value, QCtest, Qequal);
5474
5475 DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt,
5476 doc: /* The compiler context. */);
5477 Vcomp_ctxt = Qnil;
5478
5479 /* FIXME should be initialized but not here... Plus this don't have
5480 to be necessarily exposed to lisp but can easy debug for now. */
5481 DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list,
5482 doc: /* List of all defined subrs. */);
5483 DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash,
5484 doc: /* String signing the .eln files ABI. */);
5485 Vcomp_abi_hash = Qnil;
5486 DEFVAR_LISP ("comp-native-version-dir", Vcomp_native_version_dir,
5487 doc: /* Directory in use to disambiguate eln compatibility. */);
5488 Vcomp_native_version_dir = Qnil;
5489
5490 DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h,
5491 doc: /* Hash table symbol-name -> function-value.
5492 For internal use. */);
5493 Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq);
5494
5495 DEFVAR_LISP ("comp-eln-to-el-h", Vcomp_eln_to_el_h,
5496 doc: /* Hash table eln-filename -> el-filename. */);
5497 Vcomp_eln_to_el_h = CALLN (Fmake_hash_table, QCtest, Qequal);
5498
5499 DEFVAR_LISP ("native-comp-eln-load-path", Vnative_comp_eln_load_path,
5500 doc: /* List of eln cache directories.
5501
5502 If a directory is non absolute is assumed to be relative to
5503 `invocation-directory'.
5504 `comp-native-version-dir' value is used as a sub-folder name inside
5505 each eln cache directory.
5506 The last directory of this list is assumed to be the system one. */);
5507
5508 /* Temporary value in use for bootstrap. We can't do better as
5509 `invocation-directory' is still unset, will be fixed up during
5510 dump reload. */
5511 Vnative_comp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil);
5512
5513 DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines,
5514 doc: /* If non-nil enable primitive trampoline synthesis.
5515 This makes primitive functions redefinable or advisable effectively. */);
5516
5517 DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h,
5518 doc: /* Hash table subr-name -> installed trampoline.
5519 This is used to prevent double trampoline instantiation but also to
5520 protect the trampolines against GC. */);
5521 Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table);
5522
5523 DEFVAR_LISP ("comp-no-native-file-h", V_comp_no_native_file_h,
5524 doc: /* Files for which no deferred compilation has to be performed.
5525 These files' compilation should not be deferred because the bytecode
5526 version was explicitly requested by the user during load.
5527 For internal use. */);
5528 V_comp_no_native_file_h = CALLN (Fmake_hash_table, QCtest, Qequal);
5529
5530 DEFVAR_BOOL ("comp-file-preloaded-p", comp_file_preloaded_p,
5531 doc: /* When non-nil assume the file being compiled to
5532 be preloaded. */);
5533
5534 Fprovide (intern_c_string ("native-compile"), Qnil);
5535 #endif /* #ifdef HAVE_NATIVE_COMP */
5536
5537 defsubr (&Snative_comp_available_p);
5538 }
5539