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