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