diff options
Diffstat (limited to 'src/comp.c')
| -rw-r--r-- | src/comp.c | 5828 |
1 files changed, 5828 insertions, 0 deletions
diff --git a/src/comp.c b/src/comp.c new file mode 100644 index 00000000000..4813ca04a90 --- /dev/null +++ b/src/comp.c @@ -0,0 +1,5828 @@ +/* Compile Emacs Lisp into native code. + Copyright (C) 2019-2022 Free Software Foundation, Inc. + +Author: Andrea Corallo <akrl@sdf.org> + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include "lisp.h" + +#ifdef HAVE_NATIVE_COMP + +#include <setjmp.h> +#include <stdlib.h> +#include <stdio.h> +#include <signal.h> +#include <libgccjit.h> +#include <epaths.h> + +#include "puresize.h" +#include "window.h" +#include "dynlib.h" +#include "buffer.h" +#include "blockinput.h" +#include "coding.h" +#include "md5.h" +#include "sysstdio.h" +#include "zlib.h" + + +/********************************/ +/* Dynamic loading of libgccjit */ +/********************************/ + +#ifdef WINDOWSNT +# include "w32common.h" + +#undef gcc_jit_block_add_assignment +#undef gcc_jit_block_add_comment +#undef gcc_jit_block_add_eval +#undef gcc_jit_block_end_with_conditional +#undef gcc_jit_block_end_with_jump +#undef gcc_jit_block_end_with_return +#undef gcc_jit_block_end_with_void_return +#undef gcc_jit_context_acquire +#undef gcc_jit_context_add_command_line_option +#undef gcc_jit_context_add_driver_option +#undef gcc_jit_context_compile_to_file +#undef gcc_jit_context_dump_reproducer_to_file +#undef gcc_jit_context_dump_to_file +#undef gcc_jit_context_get_builtin_function +#undef gcc_jit_context_get_first_error +#undef gcc_jit_context_get_int_type +#undef gcc_jit_context_get_type +#undef gcc_jit_context_new_array_access +#undef gcc_jit_context_new_array_type +#undef gcc_jit_context_new_binary_op +#undef gcc_jit_context_new_call +#undef gcc_jit_context_new_call_through_ptr +#undef gcc_jit_context_new_cast +#undef gcc_jit_context_new_comparison +#undef gcc_jit_context_new_field +#undef gcc_jit_context_new_function +#undef gcc_jit_context_new_function_ptr_type +#undef gcc_jit_context_new_global +#undef gcc_jit_context_new_opaque_struct +#undef gcc_jit_context_new_param +#undef gcc_jit_context_new_rvalue_from_int +#undef gcc_jit_context_new_rvalue_from_long +#undef gcc_jit_context_new_rvalue_from_ptr +#undef gcc_jit_context_new_string_literal +#undef gcc_jit_context_new_struct_type +#undef gcc_jit_context_new_unary_op +#undef gcc_jit_context_new_union_type +#undef gcc_jit_context_release +#undef gcc_jit_context_set_bool_option +#undef gcc_jit_context_set_int_option +#undef gcc_jit_context_set_logfile +#undef gcc_jit_context_set_str_option +#undef gcc_jit_function_get_param +#undef gcc_jit_function_new_block +#undef gcc_jit_function_new_local +#undef gcc_jit_global_set_initializer +#undef gcc_jit_lvalue_access_field +#undef gcc_jit_lvalue_as_rvalue +#undef gcc_jit_lvalue_get_address +#undef gcc_jit_param_as_lvalue +#undef gcc_jit_param_as_rvalue +#undef gcc_jit_rvalue_access_field +#undef gcc_jit_rvalue_dereference +#undef gcc_jit_rvalue_dereference_field +#undef gcc_jit_rvalue_get_type +#undef gcc_jit_struct_as_type +#undef gcc_jit_struct_set_fields +#undef gcc_jit_type_get_const +#undef gcc_jit_type_get_pointer +#undef gcc_jit_version_major +#undef gcc_jit_version_minor +#undef gcc_jit_version_patchlevel + +/* In alphabetical order */ +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_int, + (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, int value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_as_rvalue, + (gcc_jit_lvalue *lvalue)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_rvalue_access_field, + (gcc_jit_rvalue *struct_or_union, gcc_jit_location *loc, + gcc_jit_field *field)); +DEF_DLL_FN (void, gcc_jit_block_add_comment, + (gcc_jit_block *block, gcc_jit_location *loc, const char *text)); +DEF_DLL_FN (void, gcc_jit_context_release, (gcc_jit_context *ctxt)); +DEF_DLL_FN (const char *, gcc_jit_context_get_first_error, + (gcc_jit_context *ctxt)); +DEF_DLL_FN (gcc_jit_block *, gcc_jit_function_new_block, + (gcc_jit_function *func, const char *name)); +DEF_DLL_FN (gcc_jit_context *, gcc_jit_context_acquire, (void)); +DEF_DLL_FN (void, gcc_jit_context_add_command_line_option, + (gcc_jit_context *ctxt, const char *optname)); +DEF_DLL_FN (void, gcc_jit_context_add_driver_option, + (gcc_jit_context *ctxt, const char *optname)); +DEF_DLL_FN (gcc_jit_field *, gcc_jit_context_new_field, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_get_builtin_function, + (gcc_jit_context *ctxt, const char *name)); +DEF_DLL_FN (gcc_jit_function *, gcc_jit_context_new_function, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_function_kind kind, gcc_jit_type *return_type, + const char *name, int num_params, gcc_jit_param **params, + int is_variadic)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_array_access, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_rvalue *ptr, + gcc_jit_rvalue *index)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_context_new_global, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_global_kind kind, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_function_new_local, + (gcc_jit_function *func, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +#if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_global_set_initializer, + (gcc_jit_lvalue *global, const void *blob, size_t num_bytes)); +#endif +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_lvalue_access_field, + (gcc_jit_lvalue *struct_or_union, gcc_jit_location *loc, + gcc_jit_field *field)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_param_as_lvalue, (gcc_jit_param *param)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference, + (gcc_jit_rvalue *rvalue, gcc_jit_location *loc)); +DEF_DLL_FN (gcc_jit_lvalue *, gcc_jit_rvalue_dereference_field, + (gcc_jit_rvalue *ptr, gcc_jit_location *loc, gcc_jit_field *field)); +DEF_DLL_FN (gcc_jit_param *, gcc_jit_context_new_param, + (gcc_jit_context *ctxt, gcc_jit_location *loc, gcc_jit_type *type, + const char *name)); +DEF_DLL_FN (gcc_jit_param *, gcc_jit_function_get_param, + (gcc_jit_function *func, int index)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_binary_op, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_binary_op op, gcc_jit_type *result_type, + gcc_jit_rvalue *a, gcc_jit_rvalue *b)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_function *func, int numargs , gcc_jit_rvalue **args)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_call_through_ptr, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_rvalue *fn_ptr, int numargs, gcc_jit_rvalue **args)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_cast, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_rvalue *rvalue, gcc_jit_type *type)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_comparison, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_comparison op, gcc_jit_rvalue *a, gcc_jit_rvalue *b)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_long, + (gcc_jit_context *ctxt, gcc_jit_type *numeric_type, long value)); +#if LISP_WORDS_ARE_POINTERS +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr, + (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value)); +#endif +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_string_literal, + (gcc_jit_context *ctxt, const char *value)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_unary_op, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + enum gcc_jit_unary_op op, gcc_jit_type *result_type, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_lvalue_get_address, + (gcc_jit_lvalue *lvalue, gcc_jit_location *loc)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_param_as_rvalue, (gcc_jit_param *param)); +DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_opaque_struct, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name)); +DEF_DLL_FN (gcc_jit_struct *, gcc_jit_context_new_struct_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name, + int num_fields, gcc_jit_field **fields)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_int_type, + (gcc_jit_context *ctxt, int num_bytes, int is_signed)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_get_type, + (gcc_jit_context *ctxt, enum gcc_jit_types type_)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_array_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_type *element_type, int num_elements)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_function_ptr_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, + gcc_jit_type *return_type, int num_params, + gcc_jit_type **param_types, int is_variadic)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_context_new_union_type, + (gcc_jit_context *ctxt, gcc_jit_location *loc, const char *name, + int num_fields, gcc_jit_field **fields)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_rvalue_get_type, (gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_struct_as_type, + (gcc_jit_struct *struct_type)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_const, (gcc_jit_type *type)); +DEF_DLL_FN (gcc_jit_type *, gcc_jit_type_get_pointer, (gcc_jit_type *type)); +DEF_DLL_FN (void, gcc_jit_block_add_assignment, + (gcc_jit_block *block, gcc_jit_location *loc, gcc_jit_lvalue *lvalue, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_add_eval, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_end_with_conditional, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *boolval, gcc_jit_block *on_true, + gcc_jit_block *on_false)); +DEF_DLL_FN (void, gcc_jit_block_end_with_jump, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_block *target)); +DEF_DLL_FN (void, gcc_jit_block_end_with_return, + (gcc_jit_block *block, gcc_jit_location *loc, + gcc_jit_rvalue *rvalue)); +DEF_DLL_FN (void, gcc_jit_block_end_with_void_return, + (gcc_jit_block *block, gcc_jit_location *loc)); +DEF_DLL_FN (void, gcc_jit_context_compile_to_file, + (gcc_jit_context *ctxt, enum gcc_jit_output_kind output_kind, + const char *output_path)); +DEF_DLL_FN (void, gcc_jit_context_dump_reproducer_to_file, + (gcc_jit_context *ctxt, const char *path)); +DEF_DLL_FN (void, gcc_jit_context_dump_to_file, + (gcc_jit_context *ctxt, const char *path, int update_locations)); +DEF_DLL_FN (void, gcc_jit_context_set_bool_option, + (gcc_jit_context *ctxt, enum gcc_jit_bool_option opt, int value)); +DEF_DLL_FN (void, gcc_jit_context_set_int_option, + (gcc_jit_context *ctxt, enum gcc_jit_int_option opt, int value)); +DEF_DLL_FN (void, gcc_jit_context_set_logfile, + (gcc_jit_context *ctxt, FILE *logfile, int flags, int verbosity)); +DEF_DLL_FN (void, gcc_jit_context_set_str_option, + (gcc_jit_context *ctxt, enum gcc_jit_str_option opt, + const char *value)); +DEF_DLL_FN (void, gcc_jit_struct_set_fields, + (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, + gcc_jit_field **fields)); +#if defined (LIBGCCJIT_HAVE_gcc_jit_version) +DEF_DLL_FN (int, gcc_jit_version_major, (void)); +DEF_DLL_FN (int, gcc_jit_version_minor, (void)); +DEF_DLL_FN (int, gcc_jit_version_patchlevel, (void)); +#endif + +static bool +init_gccjit_functions (void) +{ + HMODULE library = w32_delayed_load (Qgccjit); + + if (!library) + return false; + + /* In alphabetical order */ + LOAD_DLL_FN (library, gcc_jit_block_add_assignment); + LOAD_DLL_FN (library, gcc_jit_block_add_comment); + LOAD_DLL_FN (library, gcc_jit_block_add_eval); + LOAD_DLL_FN (library, gcc_jit_block_end_with_conditional); + LOAD_DLL_FN (library, gcc_jit_block_end_with_jump); + LOAD_DLL_FN (library, gcc_jit_block_end_with_return); + LOAD_DLL_FN (library, gcc_jit_block_end_with_void_return); + LOAD_DLL_FN (library, gcc_jit_context_acquire); + LOAD_DLL_FN (library, gcc_jit_context_compile_to_file); + LOAD_DLL_FN (library, gcc_jit_context_dump_reproducer_to_file); + LOAD_DLL_FN (library, gcc_jit_context_dump_to_file); + LOAD_DLL_FN (library, gcc_jit_context_get_builtin_function); + LOAD_DLL_FN (library, gcc_jit_context_get_first_error); + LOAD_DLL_FN (library, gcc_jit_context_get_int_type); + LOAD_DLL_FN (library, gcc_jit_context_get_type); + LOAD_DLL_FN (library, gcc_jit_context_new_array_access); + LOAD_DLL_FN (library, gcc_jit_context_new_array_type); + LOAD_DLL_FN (library, gcc_jit_context_new_binary_op); + LOAD_DLL_FN (library, gcc_jit_context_new_call); + LOAD_DLL_FN (library, gcc_jit_context_new_call_through_ptr); + LOAD_DLL_FN (library, gcc_jit_context_new_cast); + LOAD_DLL_FN (library, gcc_jit_context_new_comparison); + LOAD_DLL_FN (library, gcc_jit_context_new_field); + LOAD_DLL_FN (library, gcc_jit_context_new_function); + LOAD_DLL_FN (library, gcc_jit_context_new_function_ptr_type); + LOAD_DLL_FN (library, gcc_jit_context_new_global); + LOAD_DLL_FN (library, gcc_jit_context_new_opaque_struct); + LOAD_DLL_FN (library, gcc_jit_context_new_param); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_int); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_long); +#if LISP_WORDS_ARE_POINTERS + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr); +#endif + LOAD_DLL_FN (library, gcc_jit_context_new_string_literal); + LOAD_DLL_FN (library, gcc_jit_context_new_struct_type); + LOAD_DLL_FN (library, gcc_jit_context_new_unary_op); + LOAD_DLL_FN (library, gcc_jit_context_new_union_type); + LOAD_DLL_FN (library, gcc_jit_context_release); + LOAD_DLL_FN (library, gcc_jit_context_set_bool_option); + LOAD_DLL_FN (library, gcc_jit_context_set_int_option); + LOAD_DLL_FN (library, gcc_jit_context_set_logfile); + LOAD_DLL_FN (library, gcc_jit_context_set_str_option); + LOAD_DLL_FN (library, gcc_jit_function_get_param); + LOAD_DLL_FN (library, gcc_jit_function_new_block); + LOAD_DLL_FN (library, gcc_jit_function_new_local); + LOAD_DLL_FN (library, gcc_jit_lvalue_access_field); + LOAD_DLL_FN (library, gcc_jit_lvalue_as_rvalue); + LOAD_DLL_FN (library, gcc_jit_lvalue_get_address); + LOAD_DLL_FN (library, gcc_jit_param_as_lvalue); + LOAD_DLL_FN (library, gcc_jit_param_as_rvalue); + LOAD_DLL_FN (library, gcc_jit_rvalue_access_field); + LOAD_DLL_FN (library, gcc_jit_rvalue_dereference); + LOAD_DLL_FN (library, gcc_jit_rvalue_dereference_field); + LOAD_DLL_FN (library, gcc_jit_rvalue_get_type); + LOAD_DLL_FN (library, gcc_jit_struct_as_type); + LOAD_DLL_FN (library, gcc_jit_struct_set_fields); + LOAD_DLL_FN (library, gcc_jit_type_get_const); + LOAD_DLL_FN (library, gcc_jit_type_get_pointer); + LOAD_DLL_FN_OPT (library, gcc_jit_context_add_command_line_option); + LOAD_DLL_FN_OPT (library, gcc_jit_context_add_driver_option); +#if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) + LOAD_DLL_FN_OPT (library, gcc_jit_global_set_initializer); +#endif +#if defined (LIBGCCJIT_HAVE_gcc_jit_version) + LOAD_DLL_FN_OPT (library, gcc_jit_version_major); + LOAD_DLL_FN_OPT (library, gcc_jit_version_minor); + LOAD_DLL_FN_OPT (library, gcc_jit_version_patchlevel); +#endif + + return true; +} + +/* In alphabetical order */ +#define gcc_jit_block_add_assignment fn_gcc_jit_block_add_assignment +#define gcc_jit_block_add_comment fn_gcc_jit_block_add_comment +#define gcc_jit_block_add_eval fn_gcc_jit_block_add_eval +#define gcc_jit_block_end_with_conditional fn_gcc_jit_block_end_with_conditional +#define gcc_jit_block_end_with_jump fn_gcc_jit_block_end_with_jump +#define gcc_jit_block_end_with_return fn_gcc_jit_block_end_with_return +#define gcc_jit_block_end_with_void_return fn_gcc_jit_block_end_with_void_return +#define gcc_jit_context_acquire fn_gcc_jit_context_acquire +#define gcc_jit_context_add_command_line_option fn_gcc_jit_context_add_command_line_option +#define gcc_jit_context_add_driver_option fn_gcc_jit_context_add_driver_option +#define gcc_jit_context_compile_to_file fn_gcc_jit_context_compile_to_file +#define gcc_jit_context_dump_reproducer_to_file fn_gcc_jit_context_dump_reproducer_to_file +#define gcc_jit_context_dump_to_file fn_gcc_jit_context_dump_to_file +#define gcc_jit_context_get_builtin_function fn_gcc_jit_context_get_builtin_function +#define gcc_jit_context_get_first_error fn_gcc_jit_context_get_first_error +#define gcc_jit_context_get_int_type fn_gcc_jit_context_get_int_type +#define gcc_jit_context_get_type fn_gcc_jit_context_get_type +#define gcc_jit_context_new_array_access fn_gcc_jit_context_new_array_access +#define gcc_jit_context_new_array_type fn_gcc_jit_context_new_array_type +#define gcc_jit_context_new_binary_op fn_gcc_jit_context_new_binary_op +#define gcc_jit_context_new_call fn_gcc_jit_context_new_call +#define gcc_jit_context_new_call_through_ptr fn_gcc_jit_context_new_call_through_ptr +#define gcc_jit_context_new_cast fn_gcc_jit_context_new_cast +#define gcc_jit_context_new_comparison fn_gcc_jit_context_new_comparison +#define gcc_jit_context_new_field fn_gcc_jit_context_new_field +#define gcc_jit_context_new_function fn_gcc_jit_context_new_function +#define gcc_jit_context_new_function_ptr_type fn_gcc_jit_context_new_function_ptr_type +#define gcc_jit_context_new_global fn_gcc_jit_context_new_global +#define gcc_jit_context_new_opaque_struct fn_gcc_jit_context_new_opaque_struct +#define gcc_jit_context_new_param fn_gcc_jit_context_new_param +#define gcc_jit_context_new_rvalue_from_int fn_gcc_jit_context_new_rvalue_from_int +#define gcc_jit_context_new_rvalue_from_long fn_gcc_jit_context_new_rvalue_from_long +#if LISP_WORDS_ARE_POINTERS +# define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#endif +#define gcc_jit_context_new_string_literal fn_gcc_jit_context_new_string_literal +#define gcc_jit_context_new_struct_type fn_gcc_jit_context_new_struct_type +#define gcc_jit_context_new_unary_op fn_gcc_jit_context_new_unary_op +#define gcc_jit_context_new_union_type fn_gcc_jit_context_new_union_type +#define gcc_jit_context_release fn_gcc_jit_context_release +#define gcc_jit_context_set_bool_option fn_gcc_jit_context_set_bool_option +#define gcc_jit_context_set_int_option fn_gcc_jit_context_set_int_option +#define gcc_jit_context_set_logfile fn_gcc_jit_context_set_logfile +#define gcc_jit_context_set_str_option fn_gcc_jit_context_set_str_option +#define gcc_jit_function_get_param fn_gcc_jit_function_get_param +#define gcc_jit_function_new_block fn_gcc_jit_function_new_block +#define gcc_jit_function_new_local fn_gcc_jit_function_new_local +#if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) + #define gcc_jit_global_set_initializer fn_gcc_jit_global_set_initializer +#endif +#define gcc_jit_lvalue_access_field fn_gcc_jit_lvalue_access_field +#define gcc_jit_lvalue_as_rvalue fn_gcc_jit_lvalue_as_rvalue +#define gcc_jit_lvalue_get_address fn_gcc_jit_lvalue_get_address +#define gcc_jit_param_as_lvalue fn_gcc_jit_param_as_lvalue +#define gcc_jit_param_as_rvalue fn_gcc_jit_param_as_rvalue +#define gcc_jit_rvalue_access_field fn_gcc_jit_rvalue_access_field +#define gcc_jit_rvalue_dereference fn_gcc_jit_rvalue_dereference +#define gcc_jit_rvalue_dereference_field fn_gcc_jit_rvalue_dereference_field +#define gcc_jit_rvalue_get_type fn_gcc_jit_rvalue_get_type +#define gcc_jit_struct_as_type fn_gcc_jit_struct_as_type +#define gcc_jit_struct_set_fields fn_gcc_jit_struct_set_fields +#define gcc_jit_type_get_const fn_gcc_jit_type_get_const +#define gcc_jit_type_get_pointer fn_gcc_jit_type_get_pointer +#if defined (LIBGCCJIT_HAVE_gcc_jit_version) + #define gcc_jit_version_major fn_gcc_jit_version_major + #define gcc_jit_version_minor fn_gcc_jit_version_minor + #define gcc_jit_version_patchlevel fn_gcc_jit_version_patchlevel +#endif + +#endif + +static bool +load_gccjit_if_necessary (bool mandatory) +{ +#ifdef WINDOWSNT + static bool tried_to_initialize_once; + static bool gccjit_initialized; + + if (!tried_to_initialize_once) + { + tried_to_initialize_once = true; + Lisp_Object status; + gccjit_initialized = init_gccjit_functions (); + status = gccjit_initialized ? Qt : Qnil; + Vlibrary_cache = Fcons (Fcons (Qgccjit, status), Vlibrary_cache); + } + + if (mandatory && !gccjit_initialized) + xsignal1 (Qnative_compiler_error, build_string ("libgccjit not found")); + + return gccjit_initialized; +#else + return true; +#endif +} + + +/* Increase this number to force a new Vcomp_abi_hash to be generated. */ +#define ABI_VERSION "5" + +/* Length of the hashes used for eln file naming. */ +#define HASH_LENGTH 8 + +/* C symbols emitted for the load relocation mechanism. */ +#define CURRENT_THREAD_RELOC_SYM "current_thread_reloc" +#define F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM "f_symbols_with_pos_enabled_reloc" +#define PURE_RELOC_SYM "pure_reloc" +#define DATA_RELOC_SYM "d_reloc" +#define DATA_RELOC_IMPURE_SYM "d_reloc_imp" +#define DATA_RELOC_EPHEMERAL_SYM "d_reloc_eph" + +#define FUNC_LINK_TABLE_SYM "freloc_link_table" +#define LINK_TABLE_HASH_SYM "freloc_hash" +#define COMP_UNIT_SYM "comp_unit" +#define TEXT_DATA_RELOC_SYM "text_data_reloc" +#define TEXT_DATA_RELOC_IMPURE_SYM "text_data_reloc_imp" +#define TEXT_DATA_RELOC_EPHEMERAL_SYM "text_data_reloc_eph" + +#define TEXT_OPTIM_QLY_SYM "text_optim_qly" +#define TEXT_FDOC_SYM "text_data_fdoc" + +#define STR_VALUE(s) #s +#define STR(s) STR_VALUE (s) + +#define FIRST(x) \ + XCAR(x) +#define SECOND(x) \ + XCAR (XCDR (x)) +#define THIRD(x) \ + XCAR (XCDR (XCDR (x))) + +/* Like call0 but stringify and intern. */ +#define CALL0I(fun) \ + CALLN (Ffuncall, intern_c_string (STR (fun))) + +/* Like call1 but stringify and intern. */ +#define CALL1I(fun, arg) \ + CALLN (Ffuncall, intern_c_string (STR (fun)), arg) + +/* Like call2 but stringify and intern. */ +#define CALL2I(fun, arg1, arg2) \ + CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2) + +#define DECL_BLOCK(name, func) \ + gcc_jit_block *(name) = \ + gcc_jit_function_new_block ((func), STR (name)) + +#ifndef WINDOWSNT +# ifdef HAVE__SETJMP +# define SETJMP _setjmp +# else +# define SETJMP setjmp +# endif +#else +/* snippet from MINGW-64 setjmp.h */ +# define SETJMP _setjmp +#endif +#define SETJMP_NAME SETJMP + +/* Max number function importable by native compiled code. */ +#define F_RELOC_MAX_SIZE 1500 + +typedef struct { + void *link_table[F_RELOC_MAX_SIZE]; + ptrdiff_t size; +} f_reloc_t; + +static f_reloc_t freloc; + +#define NUM_CAST_TYPES 15 + +typedef struct { + EMACS_INT len; + gcc_jit_rvalue *r_val; +} reloc_array_t; + +/* C side of the compiler context. */ + +typedef struct { + EMACS_INT speed; + EMACS_INT debug; + Lisp_Object compiler_options; + Lisp_Object driver_options; + gcc_jit_context *ctxt; + gcc_jit_type *void_type; + gcc_jit_type *bool_type; + gcc_jit_type *char_type; + gcc_jit_type *int_type; + gcc_jit_type *unsigned_type; + gcc_jit_type *long_type; + gcc_jit_type *unsigned_long_type; + gcc_jit_type *long_long_type; + gcc_jit_type *unsigned_long_long_type; + gcc_jit_type *emacs_int_type; + gcc_jit_type *emacs_uint_type; + gcc_jit_type *void_ptr_type; + gcc_jit_type *bool_ptr_type; + gcc_jit_type *char_ptr_type; + gcc_jit_type *ptrdiff_type; + gcc_jit_type *uintptr_type; + gcc_jit_type *size_t_type; + gcc_jit_type *lisp_word_type; + gcc_jit_type *lisp_word_tag_type; +#ifdef LISP_OBJECT_IS_STRUCT + gcc_jit_field *lisp_obj_i; + gcc_jit_struct *lisp_obj_s; +#endif + gcc_jit_type *lisp_obj_type; + gcc_jit_type *lisp_obj_ptr_type; + /* struct Lisp_Cons */ + gcc_jit_struct *lisp_cons_s; + gcc_jit_field *lisp_cons_u; + gcc_jit_field *lisp_cons_u_s; + gcc_jit_field *lisp_cons_u_s_car; + gcc_jit_field *lisp_cons_u_s_u; + gcc_jit_field *lisp_cons_u_s_u_cdr; + gcc_jit_type *lisp_cons_type; + gcc_jit_type *lisp_cons_ptr_type; + /* struct Lisp_Symbol_With_Position */ + gcc_jit_rvalue *f_symbols_with_pos_enabled_ref; + gcc_jit_struct *lisp_symbol_with_position; + gcc_jit_field *lisp_symbol_with_position_header; + gcc_jit_field *lisp_symbol_with_position_sym; + gcc_jit_field *lisp_symbol_with_position_pos; + gcc_jit_type *lisp_symbol_with_position_type; + gcc_jit_type *lisp_symbol_with_position_ptr_type; + gcc_jit_function *get_symbol_with_position; + gcc_jit_function *symbol_with_pos_sym; + /* struct jmp_buf. */ + gcc_jit_struct *jmp_buf_s; + /* struct handler. */ + gcc_jit_struct *handler_s; + gcc_jit_field *handler_jmp_field; + gcc_jit_field *handler_val_field; + gcc_jit_field *handler_next_field; + gcc_jit_type *handler_ptr_type; + gcc_jit_lvalue *loc_handler; + /* struct thread_state. */ + gcc_jit_struct *thread_state_s; + gcc_jit_field *m_handlerlist; + gcc_jit_type *thread_state_ptr_type; + gcc_jit_rvalue *current_thread_ref; + /* Other globals. */ + gcc_jit_rvalue *pure_ptr; + /* libgccjit has really limited support for casting therefore this union will + be used for the scope. */ + gcc_jit_type *cast_union_type; + gcc_jit_function *cast_functions_from_to[NUM_CAST_TYPES][NUM_CAST_TYPES]; + gcc_jit_function *cast_ptr_to_int; + gcc_jit_function *cast_int_to_ptr; + gcc_jit_type *cast_types[NUM_CAST_TYPES]; + gcc_jit_function *func; /* Current function being compiled. */ + bool func_has_non_local; /* From comp-func has-non-local slot. */ + EMACS_INT func_speed; /* From comp-func speed slot. */ + gcc_jit_block *block; /* Current basic block being compiled. */ + gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch). */ + ptrdiff_t frame_size; /* Size of the following array in elements. */ + gcc_jit_lvalue **frame; /* Frame slot n -> gcc_jit_lvalue *. */ + gcc_jit_rvalue *zero; + gcc_jit_rvalue *one; + gcc_jit_rvalue *inttypebits; + gcc_jit_rvalue *lisp_int0; + gcc_jit_function *pseudovectorp; + gcc_jit_function *bool_to_lisp_obj; + gcc_jit_function *add1; + gcc_jit_function *sub1; + gcc_jit_function *negate; + gcc_jit_function *car; + gcc_jit_function *cdr; + gcc_jit_function *setcar; + gcc_jit_function *setcdr; + gcc_jit_function *check_type; + gcc_jit_function *check_impure; + gcc_jit_function *maybe_gc_or_quit; + Lisp_Object func_blocks_h; /* blk_name -> gcc_block. */ + Lisp_Object exported_funcs_h; /* c-func-name -> gcc_jit_function *. */ + Lisp_Object imported_funcs_h; /* subr_name -> gcc_jit_field *reloc_field. */ + Lisp_Object emitter_dispatcher; + /* Synthesized struct holding data relocs. */ + reloc_array_t data_relocs; + /* Same as before but can't go in pure space. */ + reloc_array_t data_relocs_impure; + /* Same as before but content does not survive load phase. */ + reloc_array_t data_relocs_ephemeral; + /* Global structure holding function relocations. */ + gcc_jit_lvalue *func_relocs; + gcc_jit_type *func_relocs_ptr_type; + /* Pointer to this structure local to each function. */ + gcc_jit_lvalue *func_relocs_local; + gcc_jit_function *memcpy; + Lisp_Object d_default_idx; + Lisp_Object d_impure_idx; + Lisp_Object d_ephemeral_idx; +} comp_t; + +static comp_t comp; + +static FILE *logfile; + +/* This is used for serialized objects by the reload mechanism. */ +typedef struct { + ptrdiff_t len; + char data[]; +} static_obj_t; + +typedef struct { + reloc_array_t array; + gcc_jit_rvalue *idx; +} imm_reloc_t; + + +/* + Helper functions called by the run-time. +*/ + +static void helper_unwind_protect (Lisp_Object); +static Lisp_Object helper_unbind_n (Lisp_Object); +static void helper_save_restriction (void); +static bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object, enum pvec_type); +static struct Lisp_Symbol_With_Pos * +helper_GET_SYMBOL_WITH_POSITION (Lisp_Object); + +/* Note: helper_link_table must match the list created by + `declare_runtime_imported_funcs'. */ +static void *helper_link_table[] = + { wrong_type_argument, + helper_PSEUDOVECTOR_TYPEP_XUNTAG, + pure_write_error, + push_handler, + record_unwind_protect_excursion, + helper_unbind_n, + helper_save_restriction, + helper_GET_SYMBOL_WITH_POSITION, + record_unwind_current_buffer, + set_internal, + helper_unwind_protect, + specbind, + maybe_gc, + maybe_quit }; + + +static char * ATTRIBUTE_FORMAT_PRINTF (1, 2) +format_string (const char *format, ...) +{ + static char scratch_area[512]; + va_list va; + va_start (va, format); + int res = vsnprintf (scratch_area, sizeof (scratch_area), format, va); + if (res >= sizeof (scratch_area)) + { + scratch_area[sizeof (scratch_area) - 4] = '.'; + scratch_area[sizeof (scratch_area) - 3] = '.'; + scratch_area[sizeof (scratch_area) - 2] = '.'; + } + va_end (va); + return scratch_area; +} + +static Lisp_Object +comp_hash_string (Lisp_Object string) +{ + Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2); + md5_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + hexbuf_digest (SSDATA (digest), SDATA (digest), MD5_DIGEST_SIZE); + + return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); +} + +static Lisp_Object +comp_hash_source_file (Lisp_Object filename) +{ + /* Can't use Finsert_file_contents + Fbuffer_hash as this is called + by Fcomp_el_to_eln_filename too early during bootstrap. */ + bool is_gz = suffix_p (filename, ".gz"); +#ifndef HAVE_ZLIB + if (is_gz) + xsignal2 (Qfile_notify_error, + build_string ("Cannot natively compile compressed *.el files without zlib support"), + filename); +#endif + Lisp_Object encoded_filename = ENCODE_FILE (filename); + FILE *f = emacs_fopen (SSDATA (encoded_filename), is_gz ? "rb" : "r"); + + if (!f) + report_file_error ("Opening source file", filename); + + Lisp_Object digest = make_uninit_string (MD5_DIGEST_SIZE * 2); + +#ifdef HAVE_ZLIB + int res = is_gz + ? md5_gz_stream (f, SSDATA (digest)) + : md5_stream (f, SSDATA (digest)); +#else + int res = md5_stream (f, SSDATA (digest)); +#endif + fclose (f); + + if (res) + xsignal2 (Qfile_notify_error, build_string ("hashing failed"), filename); + + hexbuf_digest (SSDATA (digest), SSDATA (digest), MD5_DIGEST_SIZE); + + return Fsubstring (digest, Qnil, make_fixnum (HASH_LENGTH)); +} + +DEFUN ("comp--subr-signature", Fcomp__subr_signature, + Scomp__subr_signature, 1, 1, 0, + doc: /* Support function to hash_native_abi. +For internal use. */) + (Lisp_Object subr) +{ + return concat2 (Fsubr_name (subr), + Fprin1_to_string (Fsubr_arity (subr), Qnil, Qnil)); +} + +/* Produce a key hashing Vcomp_subr_list. */ + +void +hash_native_abi (void) +{ + /* Check runs once. */ + eassert (NILP (Vcomp_abi_hash)); + + Vcomp_abi_hash = + comp_hash_string ( + concat3 (build_string (ABI_VERSION), + concat3 (Vemacs_version, Vsystem_configuration, + Vsystem_configuration_options), + Fmapconcat (intern_c_string ("comp--subr-signature"), + Vcomp_subr_list, build_string ("")))); + + Lisp_Object version = Vemacs_version; + +#ifdef NS_SELF_CONTAINED + /* MacOS self contained app bundles do not like having dots in the + directory names under the Contents/Frameworks directory, so + convert them to underscores. */ + version = STRING_MULTIBYTE (Vemacs_version) + ? make_uninit_multibyte_string (SCHARS (Vemacs_version), + SBYTES (Vemacs_version)) + : make_uninit_string (SBYTES (Vemacs_version)); + + const unsigned char *from = SDATA (Vemacs_version); + unsigned char *to = SDATA (version); + + while (from < SDATA (Vemacs_version) + SBYTES (Vemacs_version)) + { + unsigned char c = *from++; + + if (c == '.') + c = '_'; + + *to++ = c; + } +#endif + + Vcomp_native_version_dir = + concat3 (version, build_string ("-"), Vcomp_abi_hash); +} + +static void +freloc_check_fill (void) +{ + if (freloc.size) + return; + + eassert (!NILP (Vcomp_subr_list)); + + if (ARRAYELTS (helper_link_table) > F_RELOC_MAX_SIZE) + goto overflow; + memcpy (freloc.link_table, helper_link_table, sizeof (helper_link_table)); + freloc.size = ARRAYELTS (helper_link_table); + + Lisp_Object subr_l = Vcomp_subr_list; + FOR_EACH_TAIL (subr_l) + { + if (freloc.size == F_RELOC_MAX_SIZE) + goto overflow; + struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); + freloc.link_table[freloc.size] = subr->function.a0; + freloc.size++; + } + return; + + overflow: + fatal ("Overflowing function relocation table, increase F_RELOC_MAX_SIZE"); +} + +static void +bcall0 (Lisp_Object f) +{ + Ffuncall (1, &f); +} + +static gcc_jit_block * +retrive_block (Lisp_Object block_name) +{ + Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil); + + if (NILP (value)) + xsignal2 (Qnative_ice, build_string ("missing basic block"), block_name); + + return (gcc_jit_block *) xmint_pointer (value); +} + +static void +declare_block (Lisp_Object block_name) +{ + char *name_str = SSDATA (SYMBOL_NAME (block_name)); + gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str); + Lisp_Object value = make_mint_ptr (block); + + if (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil))) + xsignal1 (Qnative_ice, build_string ("double basic block declaration")); + + Fputhash (block_name, value, comp.func_blocks_h); +} + +static gcc_jit_lvalue * +emit_mvar_lval (Lisp_Object mvar) +{ + Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar); + + if (EQ (mvar_slot, Qscratch)) + { + if (!comp.scratch) + comp.scratch = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "scratch"); + return comp.scratch; + } + + EMACS_INT slot_n = XFIXNUM (mvar_slot); + eassert (slot_n < comp.frame_size); + return comp.frame[slot_n]; +} + +static void +register_emitter (Lisp_Object key, void *func) +{ + Lisp_Object value = make_mint_ptr (func); + Fputhash (key, value, comp.emitter_dispatcher); +} + +static imm_reloc_t +obj_to_reloc (Lisp_Object obj) +{ + imm_reloc_t reloc; + Lisp_Object idx; + + idx = Fgethash (obj, comp.d_default_idx, Qnil); + if (!NILP (idx)) { + reloc.array = comp.data_relocs; + goto found; + } + + idx = Fgethash (obj, comp.d_impure_idx, Qnil); + if (!NILP (idx)) + { + reloc.array = comp.data_relocs_impure; + goto found; + } + + idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil); + if (!NILP (idx)) + { + reloc.array = comp.data_relocs_ephemeral; + goto found; + } + + xsignal1 (Qnative_ice, + build_string ("cant't find data in relocation containers")); + assume (false); + + found: + eassert (XFIXNUM (idx) < reloc.array.len); + if (!FIXNUMP (idx)) + xsignal1 (Qnative_ice, + build_string ("inconsistent data relocation container")); + reloc.idx = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (idx)); + return reloc; +} + +static void +emit_comment (const char *str) +{ + if (comp.debug) + gcc_jit_block_add_comment (comp.block, + NULL, + str); +} + +/* + Declare an imported function. + When nargs is MANY (ptrdiff_t nargs, Lisp_Object *args) signature is assumed. + When types is NULL args are assumed to be all Lisp_Objects. +*/ +static gcc_jit_field * +declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type, + int nargs, gcc_jit_type **types) +{ + USE_SAFE_ALLOCA; + /* Don't want to declare the same function two times. */ + if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil))) + xsignal2 (Qnative_ice, + build_string ("unexpected double function declaration"), + subr_sym); + + if (nargs == MANY) + { + nargs = 2; + types = SAFE_ALLOCA (nargs * sizeof (* types)); + types[0] = comp.ptrdiff_type; + types[1] = comp.lisp_obj_ptr_type; + } + else if (nargs == UNEVALLED) + { + nargs = 1; + types = SAFE_ALLOCA (nargs * sizeof (* types)); + types[0] = comp.lisp_obj_type; + } + else if (!types) + { + types = SAFE_ALLOCA (nargs * sizeof (* types)); + for (ptrdiff_t i = 0; i < nargs; i++) + types[i] = comp.lisp_obj_type; + } + + /* String containing the function ptr name. */ + Lisp_Object f_ptr_name = + CALLN (Ffuncall, intern_c_string ("comp-c-func-name"), + subr_sym, make_string ("R", 1)); + + gcc_jit_type *f_ptr_type = + gcc_jit_type_get_const ( + gcc_jit_context_new_function_ptr_type (comp.ctxt, + NULL, + ret_type, + nargs, + types, + 0)); + gcc_jit_field *field = + gcc_jit_context_new_field (comp.ctxt, + NULL, + f_ptr_type, + SSDATA (f_ptr_name)); + + Fputhash (subr_sym, make_mint_ptr (field), comp.imported_funcs_h); + SAFE_FREE (); + return field; +} + +/* Emit calls fetching from existing declarations. */ + +static gcc_jit_rvalue * +emit_call (Lisp_Object func, gcc_jit_type *ret_type, ptrdiff_t nargs, + gcc_jit_rvalue **args, bool direct) +{ + Lisp_Object gcc_func = + Fgethash (func, + direct ? comp.exported_funcs_h : comp.imported_funcs_h, + Qnil); + + if (NILP (gcc_func)) + xsignal2 (Qnative_ice, + build_string ("missing function declaration"), + func); + + if (direct) + { + emit_comment (format_string ("direct call to: %s", + SSDATA (func))); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + xmint_pointer (gcc_func), + nargs, + args); + } + else + { + /* Inline functions so far don't have a local variable for + function reloc table so we fall back to the global one. Even + if this is not aesthetic calling into C from open-code is + always a fallback and therefore not be performance critical. + To fix this could think do the inline our-self without + relying on GCC. */ + gcc_jit_lvalue *f_ptr = + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.func_relocs_local + ? comp.func_relocs_local + : comp.func_relocs), + NULL, + (gcc_jit_field *) xmint_pointer (gcc_func)); + + if (!f_ptr) + xsignal2 (Qnative_ice, + build_string ("missing function relocation"), + func); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (func)))); + return gcc_jit_context_new_call_through_ptr (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (f_ptr), + nargs, + args); + } +} + +static gcc_jit_rvalue * +emit_call_ref (Lisp_Object func, ptrdiff_t nargs, + gcc_jit_lvalue *base_arg, bool direct) +{ + gcc_jit_rvalue *args[] = + { gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + nargs), + gcc_jit_lvalue_get_address (base_arg, NULL) }; + return emit_call (func, comp.lisp_obj_type, 2, args, direct); +} + +/* Close current basic block emitting a conditional. */ + +static void +emit_cond_jump (gcc_jit_rvalue *test, + gcc_jit_block *then_target, gcc_jit_block *else_target) +{ + if (gcc_jit_rvalue_get_type (test) == comp.bool_type) + gcc_jit_block_end_with_conditional (comp.block, + NULL, + test, + then_target, + else_target); + else + /* In case test is not bool we do a logical negation to obtain a bool as + result. */ + gcc_jit_block_end_with_conditional ( + comp.block, + NULL, + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.bool_type, + test), + else_target, + then_target); + +} + +static int +type_to_cast_index (gcc_jit_type * type) +{ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + if (type == comp.cast_types[i]) + return i; + + xsignal1 (Qnative_ice, build_string ("unsupported cast")); +} + +static gcc_jit_rvalue * +emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +{ + gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj); + + if (new_type == old_type) + return obj; + +#ifdef LISP_OBJECT_IS_STRUCT + if (old_type == comp.lisp_obj_type) + { + gcc_jit_rvalue *lwordobj = + gcc_jit_rvalue_access_field (obj, NULL, comp.lisp_obj_i); + return emit_coerce (new_type, lwordobj); + } + + if (new_type == comp.lisp_obj_type) + { + gcc_jit_rvalue *lwordobj = + emit_coerce (comp.lisp_word_type, obj); + + static ptrdiff_t i; + gcc_jit_lvalue *tmp_s = + gcc_jit_function_new_local (comp.func, NULL, comp.lisp_obj_type, + format_string ("lisp_obj_%td", i++)); + + gcc_jit_block_add_assignment ( + comp.block, NULL, + gcc_jit_lvalue_access_field (tmp_s, NULL, + comp.lisp_obj_i), + lwordobj); + return gcc_jit_lvalue_as_rvalue (tmp_s); + } +#endif + + int old_index = type_to_cast_index (old_type); + int new_index = type_to_cast_index (new_type); + + /* Lookup the appropriate cast function in the cast matrix. */ + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.cast_functions_from_to[old_index][new_index], + 1, &obj); +} + +static gcc_jit_rvalue * +emit_binary_op (enum gcc_jit_binary_op op, + gcc_jit_type *result_type, + gcc_jit_rvalue *a, gcc_jit_rvalue *b) +{ + /* FIXME Check here for possible UB. */ + return gcc_jit_context_new_binary_op (comp.ctxt, NULL, + op, + result_type, + emit_coerce (result_type, a), + emit_coerce (result_type, b)); +} + +/* Should come with libgccjit. */ + +static gcc_jit_rvalue * +emit_rvalue_from_long_long (gcc_jit_type *type, long long n) +{ + emit_comment (format_string ("emit long long: %lld", n)); + + gcc_jit_rvalue *high = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.unsigned_long_long_type, + (unsigned long long)n >> 32); + gcc_jit_rvalue *low = + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.unsigned_long_long_type, + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + gcc_jit_context_new_rvalue_from_long ( + comp.ctxt, + comp.unsigned_long_long_type, + n), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_long_long_type, + 32)); + + return + emit_coerce (type, + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_OR, + comp.unsigned_long_long_type, + emit_binary_op ( + GCC_JIT_BINARY_OP_LSHIFT, + comp.unsigned_long_long_type, + high, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_long_long_type, + 32)), + low)); +} + +static gcc_jit_rvalue * +emit_rvalue_from_emacs_uint (EMACS_UINT val) +{ +#ifdef WIDE_EMACS_INT + if (val > ULONG_MAX) + return emit_rvalue_from_long_long (comp.emacs_uint_type, val); +#endif + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_uint_type, + val); +} + +static gcc_jit_rvalue * +emit_rvalue_from_emacs_int (EMACS_INT val) +{ + if (val > LONG_MAX || val < LONG_MIN) + return emit_rvalue_from_long_long (comp.emacs_int_type, val); + else + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, val); +} + +static gcc_jit_rvalue * +emit_rvalue_from_lisp_word_tag (Lisp_Word_tag val) +{ +#ifdef WIDE_EMACS_INT + if (val > ULONG_MAX) + return emit_rvalue_from_long_long (comp.lisp_word_tag_type, val); +#endif + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_tag_type, + val); +} + +static gcc_jit_rvalue * +emit_rvalue_from_lisp_word (Lisp_Word val) +{ +#if LISP_WORDS_ARE_POINTERS + return gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.lisp_word_type, + val); +#else + if (val > LONG_MAX || val < LONG_MIN) + return emit_rvalue_from_long_long (comp.lisp_word_type, val); + else + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.lisp_word_type, + val); +#endif +} + +static gcc_jit_rvalue * +emit_rvalue_from_lisp_obj (Lisp_Object obj) +{ +#ifdef LISP_OBJECT_IS_STRUCT + return emit_coerce (comp.lisp_obj_type, + emit_rvalue_from_lisp_word (obj.i)); +#else + return emit_rvalue_from_lisp_word (obj); +#endif +} + +/* + Emit the equivalent of: + (typeof_ptr) ((uintptr) ptr + size_of_ptr_ref * i) +*/ + +static gcc_jit_rvalue * +emit_ptr_arithmetic (gcc_jit_rvalue *ptr, gcc_jit_type *ptr_type, + int size_of_ptr_ref, gcc_jit_rvalue *i) +{ + emit_comment ("ptr_arithmetic"); + + gcc_jit_rvalue *offset = + emit_binary_op ( + GCC_JIT_BINARY_OP_MULT, + comp.uintptr_type, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + size_of_ptr_ref), + i); + + return + emit_coerce ( + ptr_type, + emit_binary_op ( + GCC_JIT_BINARY_OP_PLUS, + comp.uintptr_type, + ptr, + offset)); +} + +static gcc_jit_rvalue * +emit_XLI (gcc_jit_rvalue *obj) +{ + emit_comment ("XLI"); + return emit_coerce (comp.emacs_int_type, obj); +} + +static gcc_jit_rvalue * +emit_XLP (gcc_jit_rvalue *obj) +{ + emit_comment ("XLP"); + + return emit_coerce (comp.void_ptr_type, obj); +} + +static gcc_jit_rvalue * +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, Lisp_Word_tag lisp_word_tag) +{ + /* #define XUNTAG(a, type, ctype) ((ctype *) + ((char *) XLP (a) - LISP_WORD_TAG (type))) */ + emit_comment ("XUNTAG"); + + return emit_coerce ( + gcc_jit_type_get_pointer (type), + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.uintptr_type, + emit_XLP (a), + emit_rvalue_from_lisp_word_tag (lisp_word_tag))); +} + +static gcc_jit_rvalue * +emit_XCONS (gcc_jit_rvalue *a) +{ + emit_comment ("XCONS"); + + return emit_XUNTAG (a, + gcc_jit_struct_as_type (comp.lisp_cons_s), + LISP_WORD_TAG (Lisp_Cons)); +} + +static gcc_jit_rvalue * +emit_BASE_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + emit_comment ("BASE_EQ"); + + return gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_EQ, + emit_XLI (x), + emit_XLI (y)); +} + +static gcc_jit_rvalue * +emit_AND (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + x, + y); +} + +static gcc_jit_rvalue * +emit_OR (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return gcc_jit_context_new_binary_op ( + comp.ctxt, + NULL, + GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + x, + y); +} + +static gcc_jit_rvalue * +emit_TAGGEDP (gcc_jit_rvalue *obj, Lisp_Word_tag tag) +{ + /* (! (((unsigned) (XLI (a) >> (USE_LSB_TAG ? 0 : VALBITS)) \ + - (unsigned) (tag)) \ + & ((1 << GCTYPEBITS) - 1))) */ + emit_comment ("TAGGEDP"); + + gcc_jit_rvalue *sh_res = + emit_binary_op ( + GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + (USE_LSB_TAG ? 0 : VALBITS))); + + gcc_jit_rvalue *minus_res = + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + sh_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + tag)); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << GCTYPEBITS) - 1)))); + + return res; +} + +static gcc_jit_rvalue * +emit_VECTORLIKEP (gcc_jit_rvalue *obj) +{ + emit_comment ("VECTORLIKEP"); + + return emit_TAGGEDP (obj, Lisp_Vectorlike); +} + +static gcc_jit_rvalue * +emit_CONSP (gcc_jit_rvalue *obj) +{ + emit_comment ("CONSP"); + + return emit_TAGGEDP (obj, Lisp_Cons); +} + +static gcc_jit_rvalue * +emit_BARE_SYMBOL_P (gcc_jit_rvalue *obj) +{ + emit_comment ("BARE_SYMBOL_P"); + + return gcc_jit_context_new_cast (comp.ctxt, + NULL, + emit_TAGGEDP (obj, Lisp_Symbol), + comp.bool_type); +} + +static gcc_jit_rvalue * +emit_SYMBOL_WITH_POS_P (gcc_jit_rvalue *obj) +{ + emit_comment ("SYMBOL_WITH_POS_P"); + + gcc_jit_rvalue *args[] = + { obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_SYMBOL_WITH_POS) + }; + + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); +} + +static gcc_jit_rvalue * +emit_SYMBOL_WITH_POS_SYM (gcc_jit_rvalue *obj) +{ + emit_comment ("SYMBOL_WITH_POS_SYM"); + + gcc_jit_rvalue *arg [] = { obj }; + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.symbol_with_pos_sym, + 1, + arg); +} + +static gcc_jit_rvalue * +emit_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + return + emit_OR ( + gcc_jit_context_new_comparison ( + comp.ctxt, NULL, + GCC_JIT_COMPARISON_EQ, + emit_XLI (x), emit_XLI (y)), + emit_AND ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.f_symbols_with_pos_enabled_ref, + NULL)), + emit_OR ( + emit_AND ( + emit_SYMBOL_WITH_POS_P (x), + emit_OR ( + emit_AND ( + emit_SYMBOL_WITH_POS_P (y), + emit_BASE_EQ ( + emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)), + emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))), + emit_AND ( + emit_BARE_SYMBOL_P (y), + emit_BASE_EQ ( + emit_XLI (emit_SYMBOL_WITH_POS_SYM (x)), + emit_XLI (y))))), + emit_AND ( + emit_BARE_SYMBOL_P (x), + emit_AND ( + emit_SYMBOL_WITH_POS_P (y), + emit_BASE_EQ ( + emit_XLI (x), + emit_XLI (emit_SYMBOL_WITH_POS_SYM (y)))))))); +} + +static gcc_jit_rvalue * +emit_FLOATP (gcc_jit_rvalue *obj) +{ + emit_comment ("FLOATP"); + + return emit_TAGGEDP (obj, Lisp_Float); +} + +static gcc_jit_rvalue * +emit_BIGNUMP (gcc_jit_rvalue *obj) +{ + /* PSEUDOVECTORP (x, PVEC_BIGNUM); */ + emit_comment ("BIGNUMP"); + + gcc_jit_rvalue *args[] = + { obj, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + PVEC_BIGNUM) }; + + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.pseudovectorp, + 2, + args); +} + +static gcc_jit_rvalue * +emit_FIXNUMP (gcc_jit_rvalue *obj) +{ + /* (! (((unsigned) (XLI (x) >> (USE_LSB_TAG ? 0 : FIXNUM_BITS)) + - (unsigned) (Lisp_Int0 >> !USE_LSB_TAG)) + & ((1 << INTTYPEBITS) - 1))) */ + emit_comment ("FIXNUMP"); + + gcc_jit_rvalue *sh_res = + USE_LSB_TAG ? obj + : emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + emit_XLI (obj), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_int_type, + FIXNUM_BITS)); + + gcc_jit_rvalue *minus_res = + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_type, + sh_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + (Lisp_Int0 >> !USE_LSB_TAG))); + + gcc_jit_rvalue *res = + gcc_jit_context_new_unary_op ( + comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_LOGICAL_NEGATE, + comp.int_type, + emit_binary_op ( + GCC_JIT_BINARY_OP_BITWISE_AND, + comp.unsigned_type, + minus_res, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.unsigned_type, + ((1 << INTTYPEBITS) - 1)))); + + return res; +} + +static gcc_jit_rvalue * +emit_XFIXNUM (gcc_jit_rvalue *obj) +{ + emit_comment ("XFIXNUM"); + gcc_jit_rvalue *i = emit_coerce (comp.emacs_uint_type, emit_XLI (obj)); + + /* FIXME: Implementation dependent (both RSHIFT are arithmetic). */ + + if (!USE_LSB_TAG) + { + i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + i, + comp.inttypebits); + + return emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits); + } + else + return emit_coerce (comp.emacs_int_type, + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_int_type, + i, + comp.inttypebits)); +} + +static gcc_jit_rvalue * +emit_INTEGERP (gcc_jit_rvalue *obj) +{ + emit_comment ("INTEGERP"); + + return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_FIXNUMP (obj), + emit_BIGNUMP (obj)); +} + +static gcc_jit_rvalue * +emit_NUMBERP (gcc_jit_rvalue *obj) +{ + emit_comment ("NUMBERP"); + + return emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + emit_INTEGERP (obj), + emit_FLOATP (obj)); +} + +static gcc_jit_rvalue * +emit_make_fixnum_LSB_TAG (gcc_jit_rvalue *n) +{ + /* + EMACS_UINT u = n; + n = u << INTTYPEBITS; + n += int0; + */ + + gcc_jit_rvalue *tmp = + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_int_type, + n, comp.inttypebits); + + tmp = emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.emacs_int_type, + tmp, comp.lisp_int0); + + return emit_coerce (comp.lisp_obj_type, tmp); +} + +static gcc_jit_rvalue * +emit_make_fixnum_MSB_TAG (gcc_jit_rvalue *n) +{ + /* + n &= INTMASK; + n += (int0 << VALBITS); + return XIL (n); + */ + + gcc_jit_rvalue *intmask = emit_rvalue_from_emacs_uint (INTMASK); + + n = emit_binary_op (GCC_JIT_BINARY_OP_BITWISE_AND, + comp.emacs_uint_type, + intmask, n); + + n = + emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.emacs_uint_type, + emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + comp.lisp_int0, + emit_rvalue_from_emacs_uint (VALBITS)), + n); + + return emit_coerce (comp.lisp_obj_type, n); +} + + +static gcc_jit_rvalue * +emit_make_fixnum (gcc_jit_rvalue *obj) +{ + emit_comment ("make_fixnum"); + return USE_LSB_TAG + ? emit_make_fixnum_LSB_TAG (obj) + : emit_make_fixnum_MSB_TAG (obj); +} + +static gcc_jit_lvalue * +emit_lisp_obj_reloc_lval (Lisp_Object obj) +{ + emit_comment (format_string ("l-value for lisp obj: %s", + SSDATA (Fprin1_to_string (obj, Qnil, Qnil)))); + + imm_reloc_t reloc = obj_to_reloc (obj); + return gcc_jit_context_new_array_access (comp.ctxt, + NULL, + reloc.array.r_val, + reloc.idx); +} + +static gcc_jit_rvalue * +emit_lisp_obj_rval (Lisp_Object obj) +{ + emit_comment (format_string ("const lisp obj: %s", + SSDATA (Fprin1_to_string (obj, Qnil, Qnil)))); + + if (NILP (obj)) + { + gcc_jit_rvalue *n; + n = emit_rvalue_from_lisp_word ((Lisp_Word) iQnil); + return emit_coerce (comp.lisp_obj_type, n); + } + + return gcc_jit_lvalue_as_rvalue (emit_lisp_obj_reloc_lval (obj)); +} + +static gcc_jit_rvalue * +emit_NILP (gcc_jit_rvalue *x) +{ + emit_comment ("NILP"); + return emit_BASE_EQ (x, emit_lisp_obj_rval (Qnil)); +} + +static gcc_jit_rvalue * +emit_XCAR (gcc_jit_rvalue *c) +{ + emit_comment ("XCAR"); + + /* XCONS (c)->u.s.car */ + return + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); +} + +static gcc_jit_lvalue * +emit_lval_XCAR (gcc_jit_rvalue *c) +{ + emit_comment ("lval_XCAR"); + + /* XCONS (c)->u.s.car */ + return + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_car); +} + +static gcc_jit_rvalue * +emit_XCDR (gcc_jit_rvalue *c) +{ + emit_comment ("XCDR"); + /* XCONS (c)->u.s.u.cdr */ + return + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s.u */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_rvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u)), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_u), + NULL, + comp.lisp_cons_u_s_u_cdr); +} + +static gcc_jit_lvalue * +emit_lval_XCDR (gcc_jit_rvalue *c) +{ + emit_comment ("lval_XCDR"); + + /* XCONS (c)->u.s.u.cdr */ + return + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s.u */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u.s */ + gcc_jit_lvalue_access_field ( + /* XCONS (c)->u */ + gcc_jit_rvalue_dereference_field ( + emit_XCONS (c), + NULL, + comp.lisp_cons_u), + NULL, + comp.lisp_cons_u_s), + NULL, + comp.lisp_cons_u_s_u), + NULL, + comp.lisp_cons_u_s_u_cdr); +} + +static void +emit_CHECK_CONS (gcc_jit_rvalue *x) +{ + emit_comment ("CHECK_CONS"); + + gcc_jit_rvalue *args[] = + { emit_CONSP (x), + emit_lisp_obj_rval (Qconsp), + x }; + + gcc_jit_block_add_eval ( + comp.block, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args)); +} + +static void +emit_CHECK_SYMBOL_WITH_POS (gcc_jit_rvalue *x) +{ + emit_comment ("CHECK_SYMBOL_WITH_POS"); + + gcc_jit_rvalue *args[] = + { gcc_jit_context_new_cast (comp.ctxt, + NULL, + emit_SYMBOL_WITH_POS_P (x), + comp.int_type), + emit_lisp_obj_rval (Qsymbol_with_pos_p), + x }; + + gcc_jit_block_add_eval ( + comp.block, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_type, + 3, + args)); +} + +static gcc_jit_rvalue * +emit_car_addr (gcc_jit_rvalue *c) +{ + emit_comment ("car_addr"); + + return gcc_jit_lvalue_get_address (emit_lval_XCAR (c), NULL); +} + +static gcc_jit_rvalue * +emit_cdr_addr (gcc_jit_rvalue *c) +{ + emit_comment ("cdr_addr"); + + return gcc_jit_lvalue_get_address (emit_lval_XCDR (c), NULL); +} + +static void +emit_XSETCAR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) +{ + emit_comment ("XSETCAR"); + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + gcc_jit_rvalue_dereference ( + emit_car_addr (c), + NULL), + n); +} + +static void +emit_XSETCDR (gcc_jit_rvalue *c, gcc_jit_rvalue *n) +{ + emit_comment ("XSETCDR"); + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + gcc_jit_rvalue_dereference ( + emit_cdr_addr (c), + NULL), + n); +} + +static gcc_jit_rvalue * +emit_PURE_P (gcc_jit_rvalue *ptr) +{ + + emit_comment ("PURE_P"); + + return + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_LE, + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.uintptr_type, + ptr, + comp.pure_ptr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + PURESIZE)); +} + + +/*************************************/ +/* Code emitted by LIMPLE statemes. */ +/*************************************/ + +/* Emit an r-value from an mvar meta variable. + In case this is a constant that was propagated return it otherwise load it + from frame. */ + +static gcc_jit_rvalue * +emit_mvar_rval (Lisp_Object mvar) +{ + Lisp_Object const_vld = CALL1I (comp-cstr-imm-vld-p, mvar); + + if (!NILP (const_vld)) + { + Lisp_Object value = CALL1I (comp-cstr-imm, mvar); + if (comp.debug > 1) + { + Lisp_Object func = + Fgethash (value, + CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt), + Qnil); + + emit_comment ( + SSDATA ( + Fprin1_to_string ( + NILP (func) ? value : CALL1I (comp-func-c-name, func), + Qnil, Qnil))); + } + if (FIXNUMP (value)) + { + /* We can still emit directly objects that are self-contained in a + word (read fixnums). */ + return emit_rvalue_from_lisp_obj (value); + } + /* Other const objects are fetched from the reloc array. */ + return emit_lisp_obj_rval (value); + } + + return gcc_jit_lvalue_as_rvalue (emit_mvar_lval (mvar)); +} + +static void +emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) +{ + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + emit_mvar_lval (dst_mvar), + val); +} + +static gcc_jit_rvalue * +emit_set_internal (Lisp_Object args) +{ + /* + Ex: (set_internal #s(comp-mvar nil nil t comp-test-up-val nil nil) + #s(comp-mvar 1 4 t nil symbol nil)). + */ + /* TODO: Inline the most common case. */ + if (list_length (args) != 3) + xsignal2 (Qnative_ice, + build_string ("unexpected arg length for insns"), + args); + + args = XCDR (args); + int i = 0; + gcc_jit_rvalue *gcc_args[4]; + FOR_EACH_TAIL (args) + gcc_args[i++] = emit_mvar_rval (XCAR (args)); + gcc_args[2] = emit_lisp_obj_rval (Qnil); + gcc_args[3] = gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + SET_INTERNAL_SET); + return emit_call (intern_c_string ("set_internal"), comp.void_type , 4, + gcc_args, false); +} + +/* This is for a regular function with arguments as m-var. */ + +static gcc_jit_rvalue * +emit_simple_limple_call (Lisp_Object args, gcc_jit_type *ret_type, bool direct) +{ + USE_SAFE_ALLOCA; + int i = 0; + Lisp_Object callee = FIRST (args); + args = XCDR (args); + ptrdiff_t nargs = list_length (args); + gcc_jit_rvalue **gcc_args = SAFE_ALLOCA (nargs * sizeof (*gcc_args)); + FOR_EACH_TAIL (args) + gcc_args[i++] = emit_mvar_rval (XCAR (args)); + + SAFE_FREE (); + return emit_call (callee, ret_type, nargs, gcc_args, direct); +} + +static gcc_jit_rvalue * +emit_simple_limple_call_lisp_ret (Lisp_Object args) +{ + /* + Ex: (call Fcons #s(comp-mvar 3 0 t 1 nil) #s(comp-mvar 4 nil t nil nil)). + */ + return emit_simple_limple_call (args, comp.lisp_obj_type, false); +} + +static gcc_jit_rvalue * +emit_simple_limple_call_void_ret (Lisp_Object args) +{ + return emit_simple_limple_call (args, comp.void_type, false); +} + +/* Entry point to dispatch emitting (call fun ...). */ + +static gcc_jit_rvalue * +emit_limple_call (Lisp_Object insn) +{ + Lisp_Object callee_sym = FIRST (insn); + Lisp_Object emitter = Fgethash (callee_sym, comp.emitter_dispatcher, Qnil); + + if (!NILP (emitter)) + { + gcc_jit_rvalue * (* emitter_ptr) (Lisp_Object) = xmint_pointer (emitter); + return emitter_ptr (insn); + } + + return emit_simple_limple_call_lisp_ret (insn); +} + +static gcc_jit_rvalue * +emit_limple_call_ref (Lisp_Object insn, bool direct) +{ + /* Ex: (funcall #s(comp-mvar 1 5 t eql symbol t) + #s(comp-mvar 2 6 nil nil nil t) + #s(comp-mvar 3 7 t 0 fixnum t)). */ + static int i = 0; + Lisp_Object callee = FIRST (insn); + EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); + + if (!nargs) + return emit_call_ref (callee, 0, comp.frame[0], direct); + + if (comp.func_has_non_local || !comp.func_speed) + { + /* FIXME: See bug#42360. */ + Lisp_Object first_arg = SECOND (insn); + EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg)); + return emit_call_ref (callee, nargs, comp.frame[first_slot], direct); + } + + gcc_jit_lvalue *tmp_arr = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + nargs), + format_string ("call_arr_%d", i++)); + + ptrdiff_t j = 0; + Lisp_Object arg = CDR (insn); + FOR_EACH_TAIL (arg) + { + gcc_jit_block_add_assignment ( + comp.block, + NULL, + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (tmp_arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + j)), + emit_mvar_rval (XCAR (arg))); + ++j; + } + + return emit_call_ref ( + callee, + nargs, + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (tmp_arr), + comp.zero), + direct); +} + +static gcc_jit_rvalue * +emit_setjmp (gcc_jit_rvalue *buf) +{ +#ifndef WINDOWSNT + gcc_jit_rvalue *args[] = {buf}; + gcc_jit_param *params[] = + { + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"), + }; + /* Don't call setjmp through a function pointer (Bug#46824) */ + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_IMPORTED, + comp.int_type, STR (SETJMP_NAME), + ARRAYELTS (params), params, + false); + + return gcc_jit_context_new_call (comp.ctxt, NULL, f, 1, args); +#else + /* _setjmp (buf, __builtin_frame_address (0)) */ + gcc_jit_param *params[] = + { + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "buf"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "frame"), + }; + gcc_jit_rvalue *args[2]; + + args[0] = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.unsigned_type, 0); + + args[1] = + gcc_jit_context_new_call ( + comp.ctxt, + NULL, + gcc_jit_context_get_builtin_function (comp.ctxt, + "__builtin_frame_address"), + 1, args); + args[0] = buf; + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_IMPORTED, + comp.int_type, STR (SETJMP_NAME), + ARRAYELTS (params), params, + false); + + return gcc_jit_context_new_call (comp.ctxt, NULL, f, 2, args); +#endif +} + +/* Register an handler for a non local exit. */ + +static void +emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type, + gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb, + Lisp_Object clobbered_mvar) +{ + /* struct handler *c = push_handler (POP, type); */ + + gcc_jit_rvalue *args[] = { handler, handler_type }; + gcc_jit_block_add_assignment ( + comp.block, + NULL, + comp.loc_handler, + emit_call (intern_c_string ("push_handler"), + comp.handler_ptr_type, 2, args, false)); + + args[0] = + gcc_jit_lvalue_get_address ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_jmp_field), + NULL); + + gcc_jit_rvalue *res; + res = emit_setjmp (args[0]); + emit_cond_jump (res, handler_bb, guarded_bb); +} + +static void +emit_limple_insn (Lisp_Object insn) +{ + Lisp_Object op = XCAR (insn); + Lisp_Object args = XCDR (insn); + gcc_jit_rvalue *res; + Lisp_Object arg[6]; + + Lisp_Object p = XCDR (insn); + ptrdiff_t i = 0; + FOR_EACH_TAIL (p) + { + if (i == sizeof (arg) / sizeof (Lisp_Object)) + break; + arg[i++] = XCAR (p); + } + + if (EQ (op, Qjump)) + { + /* Unconditional branch. */ + gcc_jit_block *target = retrive_block (arg[0]); + gcc_jit_block_end_with_jump (comp.block, NULL, target); + } + else if (EQ (op, Qcond_jump)) + { + /* Conditional branch. */ + gcc_jit_rvalue *a = emit_mvar_rval (arg[0]); + gcc_jit_rvalue *b = emit_mvar_rval (arg[1]); + gcc_jit_block *target1 = retrive_block (arg[2]); + gcc_jit_block *target2 = retrive_block (arg[3]); + + if ((!NILP (CALL1I (comp-cstr-imm-vld-p, arg[0])) + && NILP (CALL1I (comp-cstr-imm, arg[0]))) + || (!NILP (CALL1I (comp-cstr-imm-vld-p, arg[1])) + && NILP (CALL1I (comp-cstr-imm, arg[1])))) + emit_cond_jump (emit_BASE_EQ (a, b), target1, target2); + else + emit_cond_jump (emit_EQ (a, b), target1, target2); + } + else if (EQ (op, Qcond_jump_narg_leq)) + { + /* + Limple: (cond-jump-narg-less 2 entry_2 entry_fallback_2) + C: if (nargs < 2) goto entry2_fallback; else goto entry_2; + */ + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + eassert (XFIXNUM (arg[0]) < INT_MAX); + gcc_jit_rvalue *n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + XFIXNUM (arg[0])); + gcc_jit_block *target1 = retrive_block (arg[1]); + gcc_jit_block *target2 = retrive_block (arg[2]); + gcc_jit_rvalue *test = gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_LE, + gcc_jit_lvalue_as_rvalue (nargs), + n); + emit_cond_jump (test, target1, target2); + } + else if (EQ (op, Qphi) || EQ (op, Qassume)) + { + /* Nothing to do for phis or assumes in the backend. */ + } + else if (EQ (op, Qpush_handler)) + { + /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */ + int h_num UNINIT; + Lisp_Object handler_spec = arg[0]; + gcc_jit_rvalue *handler = emit_mvar_rval (arg[1]); + if (EQ (handler_spec, Qcatcher)) + h_num = CATCHER; + else if (EQ (handler_spec, Qcondition_case)) + h_num = CONDITION_CASE; + else + xsignal2 (Qnative_ice, build_string ("incoherent insn"), insn); + gcc_jit_rvalue *handler_type = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + h_num); + gcc_jit_block *handler_bb = retrive_block (arg[2]); + gcc_jit_block *guarded_bb = retrive_block (arg[3]); + emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb, + arg[0]); + } + else if (EQ (op, Qpop_handler)) + { + /* + C: current_thread->m_handlerlist = + current_thread->m_handlerlist->next; + */ + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), + NULL, + comp.m_handlerlist); + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (m_handlerlist), + NULL, + comp.handler_next_field))); + + } + else if (EQ (op, Qfetch_handler)) + { + gcc_jit_lvalue *m_handlerlist = + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.current_thread_ref, NULL)), + NULL, + comp.m_handlerlist); + gcc_jit_block_add_assignment (comp.block, + NULL, + comp.loc_handler, + gcc_jit_lvalue_as_rvalue (m_handlerlist)); + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + m_handlerlist, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_next_field))); + emit_frame_assignment ( + arg[0], + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (comp.loc_handler), + NULL, + comp.handler_val_field))); + } + else if (EQ (op, Qcall)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call (args)); + } + else if (EQ (op, Qcallref)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call_ref (args, false)); + } + else if (EQ (op, Qdirect_call)) + { + gcc_jit_block_add_eval ( + comp.block, NULL, + emit_simple_limple_call (XCDR (insn), comp.lisp_obj_type, true)); + } + else if (EQ (op, Qdirect_callref)) + { + gcc_jit_block_add_eval (comp.block, NULL, + emit_limple_call_ref (XCDR (insn), true)); + } + else if (EQ (op, Qset)) + { + Lisp_Object arg1 = arg[1]; + + if (EQ (Ftype_of (arg1), Qcomp_mvar)) + res = emit_mvar_rval (arg1); + else if (EQ (FIRST (arg1), Qcall)) + res = emit_limple_call (XCDR (arg1)); + else if (EQ (FIRST (arg1), Qcallref)) + res = emit_limple_call_ref (XCDR (arg1), false); + else if (EQ (FIRST (arg1), Qdirect_call)) + res = emit_simple_limple_call (XCDR (arg1), comp.lisp_obj_type, true); + else if (EQ (FIRST (arg1), Qdirect_callref)) + res = emit_limple_call_ref (XCDR (arg1), true); + else + xsignal2 (Qnative_ice, + build_string ("LIMPLE inconsistent arg1 for insn"), + insn); + + if (!res) + xsignal1 (Qnative_ice, + build_string (gcc_jit_context_get_first_error (comp.ctxt))); + + emit_frame_assignment (arg[0], res); + } + else if (EQ (op, Qset_par_to_local)) + { + /* Ex: (set-par-to-local #s(comp-mvar 0 3 nil nil nil nil) 0). */ + EMACS_INT param_n = XFIXNUM (arg[1]); + eassert (param_n < INT_MAX); + gcc_jit_rvalue *param = + gcc_jit_param_as_rvalue (gcc_jit_function_get_param (comp.func, + param_n)); + emit_frame_assignment (arg[0], param); + } + else if (EQ (op, Qset_args_to_local)) + { + /* + Ex: (set-args-to-local #s(comp-mvar 1 6 nil nil nil nil)) + C: local[1] = *args; + */ + gcc_jit_rvalue *gcc_args = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1))); + + gcc_jit_rvalue *res = + gcc_jit_lvalue_as_rvalue (gcc_jit_rvalue_dereference (gcc_args, NULL)); + + emit_frame_assignment (arg[0], res); + } + else if (EQ (op, Qset_rest_args_to_local)) + { + /* + Ex: (set-rest-args-to-local #s(comp-mvar 2 9 nil nil nil nil)) + C: local[2] = list (nargs - 2, args); + */ + + EMACS_INT slot_n = XFIXNUM (CALL1I (comp-mvar-slot, arg[0])); + eassert (slot_n < INT_MAX); + gcc_jit_rvalue *n = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + slot_n); + gcc_jit_lvalue *nargs = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 0)); + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + + gcc_jit_rvalue *list_args[] = + { emit_binary_op (GCC_JIT_BINARY_OP_MINUS, + comp.ptrdiff_type, + gcc_jit_lvalue_as_rvalue (nargs), + n), + gcc_jit_lvalue_as_rvalue (args) }; + + res = emit_call (Qlist, comp.lisp_obj_type, 2, + list_args, false); + + emit_frame_assignment (arg[0], res); + } + else if (EQ (op, Qinc_args)) + { + /* + Ex: (inc-args) + C: ++args; + */ + gcc_jit_lvalue *args = + gcc_jit_param_as_lvalue (gcc_jit_function_get_param (comp.func, 1)); + + gcc_jit_block_add_assignment (comp.block, + NULL, + args, + emit_ptr_arithmetic ( + gcc_jit_lvalue_as_rvalue (args), + comp.lisp_obj_ptr_type, + sizeof (Lisp_Object), + comp.one)); + } + else if (EQ (op, Qsetimm)) + { + /* Ex: (setimm #s(comp-mvar 9 1 t 3 nil) a). */ + emit_comment (SSDATA (Fprin1_to_string (arg[1], Qnil, Qnil))); + imm_reloc_t reloc = obj_to_reloc (arg[1]); + emit_frame_assignment ( + arg[0], + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + reloc.array.r_val, + reloc.idx))); + } + else if (EQ (op, Qcomment)) + { + /* Ex: (comment "Function: foo"). */ + emit_comment (SSDATA (arg[0])); + } + else if (EQ (op, Qreturn)) + { + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_mvar_rval (arg[0])); + } + else if (EQ (op, Qunreachable)) + { + /* Libgccjit has no __builtin_unreachable. */ + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_lisp_obj_rval (Qnil)); + } + else + { + xsignal2 (Qnative_ice, + build_string ("LIMPLE op inconsistent"), + op); + } +} + + +/**************/ +/* Inliners. */ +/**************/ + +static gcc_jit_rvalue * +emit_call_with_type_hint (gcc_jit_function *func, Lisp_Object insn, + Lisp_Object type) +{ + bool hint_match = + !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type)); + gcc_jit_rvalue *args[] = + { emit_mvar_rval (SECOND (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + hint_match) }; + + return gcc_jit_context_new_call (comp.ctxt, NULL, func, 2, args); +} + +/* Same as before but with two args. The type hint is on the 2th. */ +static gcc_jit_rvalue * +emit_call2_with_type_hint (gcc_jit_function *func, Lisp_Object insn, + Lisp_Object type) +{ + bool hint_match = + !NILP (CALL2I (comp-mvar-type-hint-match-p, SECOND (insn), type)); + gcc_jit_rvalue *args[] = + { emit_mvar_rval (SECOND (insn)), + emit_mvar_rval (THIRD (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + hint_match) }; + + return gcc_jit_context_new_call (comp.ctxt, NULL, func, 3, args); +} + + +static gcc_jit_rvalue * +emit_add1 (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.add1, insn, Qfixnum); +} + +static gcc_jit_rvalue * +emit_sub1 (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.sub1, insn, Qfixnum); +} + +static gcc_jit_rvalue * +emit_negate (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.negate, insn, Qfixnum); +} + +static gcc_jit_rvalue * +emit_consp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); + gcc_jit_rvalue *res = emit_coerce (comp.bool_type, + emit_CONSP (x)); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.bool_to_lisp_obj, + 1, &res); +} + +static gcc_jit_rvalue * +emit_car (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.car, insn, Qcons); +} + +static gcc_jit_rvalue * +emit_cdr (Lisp_Object insn) +{ + return emit_call_with_type_hint (comp.cdr, insn, Qcons); +} + +static gcc_jit_rvalue * +emit_setcar (Lisp_Object insn) +{ + return emit_call2_with_type_hint (comp.setcar, insn, Qcons); +} + +static gcc_jit_rvalue * +emit_setcdr (Lisp_Object insn) +{ + return emit_call2_with_type_hint (comp.setcdr, insn, Qcons); +} + +static gcc_jit_rvalue * +emit_numperp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); + gcc_jit_rvalue *res = emit_NUMBERP (x); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, + &res); +} + +static gcc_jit_rvalue * +emit_integerp (Lisp_Object insn) +{ + gcc_jit_rvalue *x = emit_mvar_rval (SECOND (insn)); + gcc_jit_rvalue *res = emit_INTEGERP (x); + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.bool_to_lisp_obj, 1, + &res); +} + +static gcc_jit_rvalue * +emit_maybe_gc_or_quit (Lisp_Object insn) +{ + return gcc_jit_context_new_call (comp.ctxt, NULL, comp.maybe_gc_or_quit, 0, + NULL); +} + +/* This is in charge of serializing an object and export a function to + retrieve it at load time. */ +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Waddress" +static void +emit_static_object (const char *name, Lisp_Object obj) +{ + /* libgccjit has no support for initialized static data. + The mechanism below is certainly not aesthetic but I assume the bottle neck + in terms of performance at load time will still be the reader. + NOTE: we can not rely on libgccjit even for valid NULL terminated C + strings cause of this funny bug that will affect all pre gcc10 era gccs: + https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html */ + + specpdl_ref count = SPECPDL_INDEX (); + /* Preserve uninterned symbols, this is specifically necessary for + CL macro expansion in dynamic scope code (bug#42088). See + `byte-compile-output-file-form'. */ + specbind (intern_c_string ("print-escape-newlines"), Qt); + specbind (intern_c_string ("print-length"), Qnil); + specbind (intern_c_string ("print-level"), Qnil); + specbind (intern_c_string ("print-quoted"), Qt); + specbind (intern_c_string ("print-gensym"), Qt); + specbind (intern_c_string ("print-circle"), Qt); + Lisp_Object str = Fprin1_to_string (obj, Qnil, Qnil); + unbind_to (count, Qnil); + + ptrdiff_t len = SBYTES (str); + const char *p = SSDATA (str); + +#if defined (LIBGCCJIT_HAVE_gcc_jit_global_set_initializer) + if (gcc_jit_global_set_initializer) + { + ptrdiff_t str_size = len + 1; + ptrdiff_t size = sizeof (static_obj_t) + str_size; + static_obj_t *static_obj = xmalloc (size); + static_obj->len = str_size; + memcpy (static_obj->data, p, str_size); + gcc_jit_lvalue *blob = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, NULL, + comp.char_type, + size), + format_string ("%s_blob", name)); + gcc_jit_global_set_initializer (blob, static_obj, size); + xfree (static_obj); + + return; + } +#endif + + gcc_jit_type *a_type = + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + len + 1); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "len"), + gcc_jit_context_new_field (comp.ctxt, + NULL, + a_type, + "data") }; + + gcc_jit_type *data_struct_t = + gcc_jit_struct_as_type ( + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + format_string ("%s_struct", name), + ARRAYELTS (fields), fields)); + + gcc_jit_lvalue *data_struct = + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + data_struct_t, + format_string ("%s_s", name)); + + gcc_jit_function *f = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + gcc_jit_type_get_pointer (data_struct_t), + name, + 0, NULL, 0); + DECL_BLOCK (block, f); + + if (comp.debug > 1) + { + char *comment = memcpy (xmalloc (len), p, len); + for (ptrdiff_t i = 0; i < len - 1; i++) + if (!comment[i]) + comment[i] = '\n'; + gcc_jit_block_add_comment (block, NULL, comment); + xfree (comment); + } + + gcc_jit_lvalue *arr = + gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); + + gcc_jit_lvalue *ptrvar = gcc_jit_function_new_local (f, NULL, + comp.char_ptr_type, + "ptr"); + + gcc_jit_block_add_assignment ( + block, + NULL, + ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, comp.int_type, 0)), + NULL)); + + /* We can't use always string literals longer that 200 bytes because + they cause a crash in pre GCC 10 libgccjit. + <https://gcc.gnu.org/ml/jit/2019-q3/msg00013.html>. + + Adjust if possible to reduce the number of function calls. */ + size_t chunck_size = NILP (Fcomp_libgccjit_version ()) ? 200 : 1024; + char *buff = xmalloc (chunck_size); + for (ptrdiff_t i = 0; i < len;) + { + strncpy (buff, p, chunck_size); + buff[chunck_size - 1] = 0; + uintptr_t l = strlen (buff); + + if (l != 0) + { + p += l; + i += l; + + gcc_jit_rvalue *args[] = + { gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_string_literal (comp.ctxt, buff), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.size_t_type, + l) }; + + gcc_jit_block_add_eval (block, NULL, + gcc_jit_context_new_call (comp.ctxt, NULL, + comp.memcpy, + ARRAYELTS (args), + args)); + gcc_jit_block_add_assignment (block, NULL, ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access (comp.ctxt, NULL, + gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, + l)), + NULL)); + } + else + { + /* If strlen returned 0 that means that the static object + contains a NULL byte. In that case just move over to the + next block. We can rely on the byte being zero because + of the previous call to bzero and because the dynamic + linker cleared it. */ + p++; + i++; + gcc_jit_block_add_assignment ( + block, NULL, ptrvar, + gcc_jit_lvalue_get_address ( + gcc_jit_context_new_array_access ( + comp.ctxt, NULL, gcc_jit_lvalue_as_rvalue (ptrvar), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.uintptr_type, 1)), + NULL)); + } + } + xfree (buff); + + gcc_jit_block_add_assignment ( + block, + NULL, + gcc_jit_lvalue_access_field (data_struct, NULL, fields[0]), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.ptrdiff_type, + len)); + gcc_jit_rvalue *res = gcc_jit_lvalue_get_address (data_struct, NULL); + gcc_jit_block_end_with_return (block, NULL, res); +} +#pragma GCC diagnostic pop + +static reloc_array_t +declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, + const char *text_symbol) +{ + /* Imported objects. */ + reloc_array_t res; + res.len = + XFIXNUM (CALL1I (hash-table-count, + CALL1I (comp-data-container-idx, container))); + Lisp_Object d_reloc = CALL1I (comp-data-container-l, container); + d_reloc = Fvconcat (1, &d_reloc); + + res.r_val = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + res.len), + code_symbol)); + + emit_static_object (text_symbol, d_reloc); + + return res; +} + +static void +declare_imported_data (void) +{ + /* Imported objects. */ + comp.data_relocs = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-default, Vcomp_ctxt), + DATA_RELOC_SYM, + TEXT_DATA_RELOC_SYM); + comp.data_relocs_impure = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-impure, Vcomp_ctxt), + DATA_RELOC_IMPURE_SYM, + TEXT_DATA_RELOC_IMPURE_SYM); + comp.data_relocs_ephemeral = + declare_imported_data_relocs (CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt), + DATA_RELOC_EPHEMERAL_SYM, + TEXT_DATA_RELOC_EPHEMERAL_SYM); +} + +/* + Declare as imported all the functions that are requested from the runtime. + These are either subrs or not. Note that the list created here must match + the array `helper_link_table'. +*/ +static Lisp_Object +declare_runtime_imported_funcs (void) +{ + Lisp_Object field_list = Qnil; + +#define ADD_IMPORTED(f_name, ret_type, nargs, args) \ + do { \ + Lisp_Object name = intern_c_string (STR (f_name)); \ + Lisp_Object field = \ + make_mint_ptr (declare_imported_func (name, ret_type, nargs, args)); \ + Lisp_Object el = Fcons (name, field); \ + field_list = Fcons (el, field_list); \ + } while (0) + + gcc_jit_type *args[4]; + + ADD_IMPORTED (wrong_type_argument, comp.void_type, 2, NULL); + + args[0] = comp.lisp_obj_type; + args[1] = comp.int_type; + ADD_IMPORTED (helper_PSEUDOVECTOR_TYPEP_XUNTAG, comp.bool_type, 2, args); + + ADD_IMPORTED (pure_write_error, comp.void_type, 1, NULL); + + args[0] = comp.lisp_obj_type; + args[1] = comp.int_type; + ADD_IMPORTED (push_handler, comp.handler_ptr_type, 2, args); + + ADD_IMPORTED (record_unwind_protect_excursion, comp.void_type, 0, NULL); + + args[0] = comp.lisp_obj_type; + ADD_IMPORTED (helper_unbind_n, comp.lisp_obj_type, 1, args); + + ADD_IMPORTED (helper_save_restriction, comp.void_type, 0, NULL); + + args[0] = comp.lisp_obj_type; + ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type, + 1, args); + + ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); + + args[0] = args[1] = args[2] = comp.lisp_obj_type; + args[3] = comp.int_type; + ADD_IMPORTED (set_internal, comp.void_type, 4, args); + + args[0] = comp.lisp_obj_type; + ADD_IMPORTED (helper_unwind_protect, comp.void_type, 1, args); + + args[0] = args[1] = comp.lisp_obj_type; + ADD_IMPORTED (specbind, comp.void_type, 2, args); + + ADD_IMPORTED (maybe_gc, comp.void_type, 0, NULL); + + ADD_IMPORTED (maybe_quit, comp.void_type, 0, NULL); + +#undef ADD_IMPORTED + + return Freverse (field_list); +} + +/* + This emit the code needed by every compilation unit to be loaded. +*/ +static void +emit_ctxt_code (void) +{ + /* Emit optimize qualities. */ + Lisp_Object opt_qly[] = + { Fcons (Qnative_comp_speed, make_fixnum (comp.speed)), + Fcons (Qnative_comp_debug, make_fixnum (comp.debug)), + Fcons (Qgccjit, + Fcomp_libgccjit_version ()) }; + emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (ARRAYELTS (opt_qly), opt_qly)); + + emit_static_object (TEXT_FDOC_SYM, + CALL1I (comp-ctxt-function-docs, Vcomp_ctxt)); + + comp.current_thread_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (comp.thread_state_ptr_type), + CURRENT_THREAD_RELOC_SYM)); + + comp.f_symbols_with_pos_enabled_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.bool_ptr_type, + F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM)); + + comp.pure_ptr = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.void_ptr_type, + PURE_RELOC_SYM)); + + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.lisp_obj_type, + COMP_UNIT_SYM); + + declare_imported_data (); + + /* Functions imported from Lisp code. */ + freloc_check_fill (); + gcc_jit_field **fields = xmalloc (freloc.size * sizeof (*fields)); + ptrdiff_t n_frelocs = 0; + Lisp_Object f_runtime = declare_runtime_imported_funcs (); + FOR_EACH_TAIL (f_runtime) + { + Lisp_Object el = XCAR (f_runtime); + eassert (n_frelocs < freloc.size); + fields[n_frelocs++] = xmint_pointer (XCDR (el)); + } + + /* Sign the .eln for the exposed ABI it expects at load. */ + eassert (!NILP (Vcomp_abi_hash)); + emit_static_object (LINK_TABLE_HASH_SYM, Vcomp_abi_hash); + + Lisp_Object subr_l = Vcomp_subr_list; + FOR_EACH_TAIL (subr_l) + { + struct Lisp_Subr *subr = XSUBR (XCAR (subr_l)); + Lisp_Object subr_sym = intern_c_string (subr->symbol_name); + eassert (n_frelocs < freloc.size); + fields[n_frelocs++] = declare_imported_func (subr_sym, comp.lisp_obj_type, + subr->max_args, NULL); + } + + gcc_jit_struct *f_reloc_struct = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "freloc_link_table", + n_frelocs, fields); + comp.func_relocs_ptr_type = + gcc_jit_type_get_pointer ( + gcc_jit_struct_as_type (f_reloc_struct)); + + comp.func_relocs = + gcc_jit_context_new_global (comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + comp.func_relocs_ptr_type, + FUNC_LINK_TABLE_SYM); + + xfree (fields); +} + + +/****************************************************************/ +/* Inline function definition and lisp data structure follows. */ +/****************************************************************/ + +/* struct Lisp_Cons definition. */ + +static void +define_lisp_cons (void) +{ + /* + union cdr_u + { + Lisp_Object cdr; + struct Lisp_Cons *chain; + }; + + struct cons_s + { + Lisp_Object car; + union cdr_u u; + }; + + union cons_u + { + struct cons_s s; + char align_pad[sizeof (struct Lisp_Cons)]; + }; + + struct Lisp_Cons + { + union cons_u u; + }; + */ + + comp.lisp_cons_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "comp_Lisp_Cons"); + comp.lisp_cons_type = + gcc_jit_struct_as_type (comp.lisp_cons_s); + comp.lisp_cons_ptr_type = + gcc_jit_type_get_pointer (comp.lisp_cons_type); + + comp.lisp_cons_u_s_u_cdr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cdr"); + + gcc_jit_field *cdr_u_fields[] = + { comp.lisp_cons_u_s_u_cdr, + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_cons_ptr_type, + "chain") }; + + gcc_jit_type *cdr_u = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_cdr_u", + ARRAYELTS (cdr_u_fields), + cdr_u_fields); + + comp.lisp_cons_u_s_car = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "car"); + comp.lisp_cons_u_s_u = gcc_jit_context_new_field (comp.ctxt, + NULL, + cdr_u, + "u"); + gcc_jit_field *cons_s_fields[] = + { comp.lisp_cons_u_s_car, + comp.lisp_cons_u_s_u }; + + gcc_jit_struct *cons_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_cons_s", + ARRAYELTS (cons_s_fields), + cons_s_fields); + + comp.lisp_cons_u_s = gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_struct_as_type (cons_s), + "s"); + + gcc_jit_field *cons_u_fields[] = + { comp.lisp_cons_u_s, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct Lisp_Cons)), + "align_pad") }; + + gcc_jit_type *lisp_cons_u_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "comp_cons_u", + ARRAYELTS (cons_u_fields), + cons_u_fields); + + comp.lisp_cons_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + lisp_cons_u_type, + "u"); + gcc_jit_struct_set_fields (comp.lisp_cons_s, + NULL, 1, &comp.lisp_cons_u); + +} + +static void +define_lisp_symbol_with_position (void) +{ + comp.lisp_symbol_with_position_header = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "header"); + comp.lisp_symbol_with_position_sym = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "sym"); + comp.lisp_symbol_with_position_pos = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "pos"); + gcc_jit_field *fields [3] = {comp.lisp_symbol_with_position_header, + comp.lisp_symbol_with_position_sym, + comp.lisp_symbol_with_position_pos}; + comp.lisp_symbol_with_position = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_lisp_symbol_with_position", + 3, + fields); + comp.lisp_symbol_with_position_type = + gcc_jit_struct_as_type (comp.lisp_symbol_with_position); + comp.lisp_symbol_with_position_ptr_type = + gcc_jit_type_get_pointer (comp.lisp_symbol_with_position_type); +} + +/* Opaque jmp_buf definition. */ + +static void +define_jmp_buf (void) +{ + gcc_jit_field *field = + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (sys_jmp_buf)), + "stuff"); + comp.jmp_buf_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_jmp_buf", + 1, &field); +} + +static void +define_memcpy (void) +{ + + gcc_jit_param *params[] = + { gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "dest"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.void_ptr_type, "src"), + gcc_jit_context_new_param (comp.ctxt, NULL, comp.size_t_type, "n") }; + + comp.memcpy = + gcc_jit_context_new_function (comp.ctxt, NULL, GCC_JIT_FUNCTION_IMPORTED, + comp.void_ptr_type, "memcpy", + ARRAYELTS (params), params, false); +} + +/* struct handler definition */ + +static void +define_handler_struct (void) +{ + comp.handler_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); + comp.handler_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler_s)); + + comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_struct_as_type ( + comp.jmp_buf_s), + "jmp"); + comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "val"); + comp.handler_next_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "next"); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, val)), + "pad0"), + comp.handler_val_field, + comp.handler_next_field, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, jmp) + - offsetof (struct handler, next) + - sizeof (((struct handler *) 0)->next)), + "pad1"), + comp.handler_jmp_field, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct handler) + - offsetof (struct handler, jmp) + - sizeof (((struct handler *) 0)->jmp)), + "pad2") }; + gcc_jit_struct_set_fields (comp.handler_s, + NULL, + ARRAYELTS (fields), + fields); + +} + +static void +define_thread_state_struct (void) +{ + /* Partially opaque definition for `thread_state'. + Because we need to access just m_handlerlist hopefully this is requires + less manutention then the full deifnition. */ + + comp.m_handlerlist = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "m_handlerlist"); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct thread_state, + m_handlerlist)), + "pad0"), + comp.m_handlerlist, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type ( + comp.ctxt, + NULL, + comp.char_type, + sizeof (struct thread_state) + - offsetof (struct thread_state, + m_handlerlist) + - sizeof (((struct thread_state *) 0)->m_handlerlist)), + "pad1") }; + + comp.thread_state_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_thread_state", + ARRAYELTS (fields), + fields); + comp.thread_state_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); +} + +static gcc_jit_function * +define_type_punning (const char *name, + gcc_jit_type *from, gcc_jit_field *from_field, + gcc_jit_type *to, gcc_jit_field *to_field) +{ + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, + from, "arg"); + gcc_jit_function *result = gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_INTERNAL, + to, + name, + 1, + ¶m, + 0); + + DECL_BLOCK (entry_block, result); + + gcc_jit_lvalue *tmp_union + = gcc_jit_function_new_local (result, + NULL, + comp.cast_union_type, + "union_cast"); + + gcc_jit_block_add_assignment (entry_block, NULL, + gcc_jit_lvalue_access_field (tmp_union, NULL, + from_field), + gcc_jit_param_as_rvalue (param)); + + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_rvalue_access_field ( + gcc_jit_lvalue_as_rvalue (tmp_union), + NULL, to_field)); + + return result; +} + +struct cast_type +{ + gcc_jit_type *type; + const char *name; + bool is_ptr; +}; + +static gcc_jit_function * +define_cast_from_to (struct cast_type from, struct cast_type to) +{ + char *name = format_string ("cast_from_%s_to_%s", from.name, to.name); + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, NULL, + from.type, "arg"); + gcc_jit_function *result + = gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_INTERNAL, + to.type, name, + 1, ¶m, 0); + DECL_BLOCK (entry_block, result); + + gcc_jit_rvalue *tmp = gcc_jit_param_as_rvalue (param); + if (from.is_ptr != to.is_ptr) + { + if (from.is_ptr) + { + tmp = gcc_jit_context_new_cast (comp.ctxt, NULL, + tmp, comp.void_ptr_type); + tmp = gcc_jit_context_new_call (comp.ctxt, NULL, + comp.cast_ptr_to_int, 1, &tmp); + } + else + { + tmp = gcc_jit_context_new_cast (comp.ctxt, NULL, + tmp, comp.uintptr_type); + tmp = gcc_jit_context_new_call (comp.ctxt, NULL, + comp.cast_int_to_ptr, 1, &tmp); + } + } + + tmp = gcc_jit_context_new_cast (comp.ctxt, NULL, tmp, to.type); + + gcc_jit_block_end_with_return (entry_block, NULL, tmp); + + return result; +} + +static void +define_cast_functions (void) +{ + struct cast_type cast_types[NUM_CAST_TYPES] + = { { comp.bool_type, "bool", false }, + { comp.char_ptr_type, "char_ptr", true }, + { comp.int_type, "int", false }, + { comp.lisp_cons_ptr_type, "lisp_cons_ptr", true }, + { comp.lisp_obj_ptr_type, "lisp_obj_ptr", true }, + { comp.lisp_word_tag_type, "lisp_word_tag", false }, + { comp.lisp_word_type, "lisp_word", LISP_WORDS_ARE_POINTERS }, + { comp.long_long_type, "long_long", false }, + { comp.long_type, "long", false }, + { comp.ptrdiff_type, "ptrdiff", false }, + { comp.uintptr_type, "uintptr", false }, + { comp.unsigned_long_long_type, "unsigned_long_long", false }, + { comp.unsigned_long_type, "unsigned_long", false }, + { comp.unsigned_type, "unsigned", false }, + { comp.void_ptr_type, "void_ptr", true } }; + gcc_jit_field *cast_union_fields[2]; + + /* Define the union used for type punning. */ + cast_union_fields[0] = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "void_ptr"); + cast_union_fields[1] = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.uintptr_type, + "uintptr"); + + comp.cast_union_type + = gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + 2, cast_union_fields); + + comp.cast_ptr_to_int = define_type_punning ("cast_pointer_to_uintptr_t", + comp.void_ptr_type, + cast_union_fields[0], + comp.uintptr_type, + cast_union_fields[1]); + comp.cast_int_to_ptr = define_type_punning ("cast_uintptr_t_to_pointer", + comp.uintptr_type, + cast_union_fields[1], + comp.void_ptr_type, + cast_union_fields[0]); + + for (int i = 0; i < NUM_CAST_TYPES; ++i) + comp.cast_types[i] = cast_types[i].type; + + /* Define the cast functions using a matrix. */ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + for (int j = 0; j < NUM_CAST_TYPES; ++j) + comp.cast_functions_from_to[i][j] = + define_cast_from_to (cast_types[i], cast_types[j]); +} + +static void +define_CHECK_TYPE (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "ok"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "predicate"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "x") }; + comp.check_type = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.void_type, + "CHECK_TYPE", + 3, + param, + 0); + gcc_jit_rvalue *ok = gcc_jit_param_as_rvalue (param[0]); + gcc_jit_rvalue *predicate = gcc_jit_param_as_rvalue (param[1]); + gcc_jit_rvalue *x = gcc_jit_param_as_rvalue (param[2]); + + DECL_BLOCK (entry_block, comp.check_type); + DECL_BLOCK (ok_block, comp.check_type); + DECL_BLOCK (not_ok_block, comp.check_type); + + comp.block = entry_block; + comp.func = comp.check_type; + + emit_cond_jump (ok, ok_block, not_ok_block); + + gcc_jit_block_end_with_void_return (ok_block, NULL); + + comp.block = not_ok_block; + + gcc_jit_rvalue *wrong_type_args[] = { predicate, x }; + + gcc_jit_block_add_eval (comp.block, + NULL, + emit_call (intern_c_string ("wrong_type_argument"), + comp.void_type, 2, wrong_type_args, + false)); + + gcc_jit_block_end_with_void_return (not_ok_block, NULL); +} + +/* Define a substitute for CAR as always inlined function. */ + +static void +define_CAR_CDR (void) +{ + gcc_jit_function *func[2]; + char const *f_name[] = { "CAR", "CDR" }; + for (int i = 0; i < 2; i++) + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "c"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "cert_cons") }; + /* TODO: understand why after ipa-prop pass gcc is less keen on inlining + and as consequence can refuse to compile these. (see dhrystone.el) + Flag this and all the one involved in ipa-prop as + GCC_JIT_FUNCTION_INTERNAL not to fail compilation in case. + This seems at least to have no perf downside. */ + func[i] = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + f_name[i], + 2, param, 0); + + gcc_jit_rvalue *c = gcc_jit_param_as_rvalue (param[0]); + DECL_BLOCK (entry_block, func[i]); + DECL_BLOCK (is_cons_b, func[i]); + DECL_BLOCK (not_a_cons_b, func[i]); + comp.block = entry_block; + comp.func = func[i]; + emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_CONSP (c)), + is_cons_b, + not_a_cons_b); + comp.block = is_cons_b; + if (i == 0) + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCAR (c)); + else + gcc_jit_block_end_with_return (comp.block, NULL, emit_XCDR (c)); + + comp.block = not_a_cons_b; + + DECL_BLOCK (is_nil_b, func[i]); + DECL_BLOCK (not_nil_b, func[i]); + + emit_cond_jump (emit_NILP (c), is_nil_b, not_nil_b); + + comp.block = is_nil_b; + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_lisp_obj_rval (Qnil)); + + comp.block = not_nil_b; + gcc_jit_rvalue *wrong_type_args[] = + { emit_lisp_obj_rval (Qlistp), c }; + + gcc_jit_block_add_eval (comp.block, + NULL, + emit_call (intern_c_string ("wrong_type_argument"), + comp.void_type, 2, wrong_type_args, + false)); + gcc_jit_block_end_with_return (comp.block, + NULL, + emit_lisp_obj_rval (Qnil)); + } + comp.car = func[0]; + comp.cdr = func[1]; +} + +static void +define_setcar_setcdr (void) +{ + char const *f_name[] = { "setcar", "setcdr" }; + char const *par_name[] = { "new_car", "new_cdr" }; + + for (int i = 0; i < 2; i++) + { + gcc_jit_param *cell = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "cell"); + gcc_jit_param *new_el = + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + par_name[i]); + + gcc_jit_param *param[] = + { cell, + new_el, + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "cert_cons") }; + + gcc_jit_function **f_ref = !i ? &comp.setcar : &comp.setcdr; + *f_ref = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + f_name[i], + 3, param, 0); + DECL_BLOCK (entry_block, *f_ref); + comp.func = *f_ref; + comp.block = entry_block; + + /* CHECK_CONS (cell); */ + emit_CHECK_CONS (gcc_jit_param_as_rvalue (cell)); + + /* CHECK_IMPURE (cell, XCONS (cell)); */ + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (cell), + emit_XCONS (gcc_jit_param_as_rvalue (cell)) }; + + gcc_jit_block_add_eval (entry_block, + NULL, + gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.check_impure, + 2, + args)); + + /* XSETCDR (cell, newel); */ + if (!i) + emit_XSETCAR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_el)); + else + emit_XSETCDR (gcc_jit_param_as_rvalue (cell), + gcc_jit_param_as_rvalue (new_el)); + + /* return newel; */ + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_param_as_rvalue (new_el)); + } +} + +/* + Define a substitute for Fadd1 Fsub1. + Currently expose just fixnum arithmetic. +*/ + +static void +define_add1_sub1 (void) +{ + gcc_jit_block *bb_orig = comp.block; + gcc_jit_function *func[2]; + char const *f_name[] = { "add1", "sub1" }; + char const *fall_back_func[] = { "1+", "1-" }; + enum gcc_jit_binary_op op[] = + { GCC_JIT_BINARY_OP_PLUS, GCC_JIT_BINARY_OP_MINUS }; + for (ptrdiff_t i = 0; i < 2; i++) + { + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "cert_fixnum") }; + comp.func = func[i] = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + f_name[i], + 2, + param, 0); + DECL_BLOCK (entry_block, func[i]); + DECL_BLOCK (inline_block, func[i]); + DECL_BLOCK (fcall_block, func[i]); + + comp.block = entry_block; + + /* cert_fixnum || + ((FIXNUMP (n) && XFIXNUM (n) != MOST_POSITIVE_FIXNUM + ? (XFIXNUM (n) + 1) + : Fadd1 (n)) */ + + gcc_jit_rvalue *n = gcc_jit_param_as_rvalue (param[0]); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (n); + gcc_jit_rvalue *sure_fixnum = + emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_FIXNUMP (n)); + emit_cond_jump ( + emit_binary_op ( + GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + sure_fixnum, + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + i == 0 + ? emit_rvalue_from_emacs_int (MOST_POSITIVE_FIXNUM) + : emit_rvalue_from_emacs_int (MOST_NEGATIVE_FIXNUM))), + inline_block, + fcall_block); + + comp.block = inline_block; + gcc_jit_rvalue *inline_res = + emit_binary_op (op[i], comp.emacs_int_type, n_fixnum, comp.one); + + gcc_jit_block_end_with_return (inline_block, + NULL, + emit_make_fixnum (inline_res)); + + comp.block = fcall_block; + gcc_jit_rvalue *call_res = emit_call (intern_c_string (fall_back_func[i]), + comp.lisp_obj_type, 1, &n, false); + gcc_jit_block_end_with_return (fcall_block, + NULL, + call_res); + } + comp.block = bb_orig; + comp.add1 = func[0]; + comp.sub1 = func[1]; +} + +static void +define_negate (void) +{ + gcc_jit_block *bb_orig = comp.block; + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "n"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "cert_fixnum") }; + + comp.func = comp.negate = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + "negate", + 2, param, 0); + + DECL_BLOCK (entry_block, comp.negate); + DECL_BLOCK (inline_block, comp.negate); + DECL_BLOCK (fcall_block, comp.negate); + + comp.block = entry_block; + + /* (cert_fixnum || FIXNUMP (TOP)) && XFIXNUM (TOP) != MOST_NEGATIVE_FIXNUM + ? make_fixnum (- XFIXNUM (TOP)) : Fminus (1, &TOP)) */ + + gcc_jit_lvalue *n = gcc_jit_param_as_lvalue (param[0]); + gcc_jit_rvalue *n_fixnum = emit_XFIXNUM (gcc_jit_lvalue_as_rvalue (n)); + gcc_jit_rvalue *sure_fixnum = + emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_OR, + comp.bool_type, + gcc_jit_param_as_rvalue (param[1]), + emit_FIXNUMP (gcc_jit_lvalue_as_rvalue (n))); + + emit_cond_jump (emit_binary_op (GCC_JIT_BINARY_OP_LOGICAL_AND, + comp.bool_type, + sure_fixnum, + gcc_jit_context_new_comparison ( + comp.ctxt, + NULL, + GCC_JIT_COMPARISON_NE, + n_fixnum, + emit_rvalue_from_emacs_int ( + MOST_NEGATIVE_FIXNUM))), + inline_block, + fcall_block); + + comp.block = inline_block; + gcc_jit_rvalue *inline_res = + gcc_jit_context_new_unary_op (comp.ctxt, + NULL, + GCC_JIT_UNARY_OP_MINUS, + comp.emacs_int_type, + n_fixnum); + + gcc_jit_block_end_with_return (inline_block, + NULL, + emit_make_fixnum (inline_res)); + + comp.block = fcall_block; + gcc_jit_rvalue *call_res = emit_call_ref (Qminus, 1, n, false); + gcc_jit_block_end_with_return (fcall_block, + NULL, + call_res); + comp.block = bb_orig; +} + +/* Define a substitute for PSEUDOVECTORP as always inlined function. */ + +static void +define_PSEUDOVECTORP (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.int_type, + "code") }; + + comp.pseudovectorp = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.bool_type, + "PSEUDOVECTORP", + 2, + param, + 0); + + DECL_BLOCK (entry_block, comp.pseudovectorp); + DECL_BLOCK (ret_false_b, comp.pseudovectorp); + DECL_BLOCK (call_pseudovector_typep_b, comp.pseudovectorp); + + comp.block = entry_block; + comp.func = comp.pseudovectorp; + + emit_cond_jump (emit_VECTORLIKEP (gcc_jit_param_as_rvalue (param[0])), + call_pseudovector_typep_b, + ret_false_b); + + comp.block = ret_false_b; + gcc_jit_block_end_with_return (ret_false_b, + NULL, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.bool_type, + false)); + + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (param[0]), + gcc_jit_param_as_rvalue (param[1]) }; + comp.block = call_pseudovector_typep_b; + /* FIXME use XUNTAG now that's available. */ + gcc_jit_block_end_with_return ( + call_pseudovector_typep_b, + NULL, + emit_call (intern_c_string ("helper_PSEUDOVECTOR_TYPEP_XUNTAG"), + comp.bool_type, 2, args, false)); +} + +static void +define_GET_SYMBOL_WITH_POSITION (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a") }; + + comp.get_symbol_with_position = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_symbol_with_position_ptr_type, + "GET_SYMBOL_WITH_POSITION", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.get_symbol_with_position); + + comp.block = entry_block; + comp.func = comp.get_symbol_with_position; + + gcc_jit_rvalue *args[] = + { gcc_jit_param_as_rvalue (param[0]) }; + /* FIXME use XUNTAG now that's available. */ + gcc_jit_block_end_with_return ( + entry_block, + NULL, + emit_call (intern_c_string ("helper_GET_SYMBOL_WITH_POSITION"), + comp.lisp_symbol_with_position_ptr_type, + 1, args, false)); +} + +static void define_SYMBOL_WITH_POS_SYM (void) +{ + gcc_jit_rvalue *tmpr, *swp; + gcc_jit_lvalue *tmpl; + + gcc_jit_param *param [] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "a") }; + comp.symbol_with_pos_sym = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + "SYMBOL_WITH_POS_SYM", + 1, + param, + 0); + + DECL_BLOCK (entry_block, comp.symbol_with_pos_sym); + comp.func = comp.symbol_with_pos_sym; + comp.block = entry_block; + + emit_CHECK_SYMBOL_WITH_POS (gcc_jit_param_as_rvalue (param [0])); + + gcc_jit_rvalue *args[] = { gcc_jit_param_as_rvalue (param [0]) }; + + swp = gcc_jit_context_new_call (comp.ctxt, + NULL, + comp.get_symbol_with_position, + 1, + args); + tmpl = gcc_jit_rvalue_dereference (swp, NULL); + tmpr = gcc_jit_lvalue_as_rvalue (tmpl); + gcc_jit_block_end_with_return (entry_block, + NULL, + gcc_jit_rvalue_access_field ( + tmpr, + NULL, + comp.lisp_symbol_with_position_sym)); +} + +static void +define_CHECK_IMPURE (void) +{ + gcc_jit_param *param[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_type, + "obj"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.void_ptr_type, + "ptr") }; + comp.check_impure = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.void_type, + "CHECK_IMPURE", + 2, + param, + 0); + + DECL_BLOCK (entry_block, comp.check_impure); + DECL_BLOCK (err_block, comp.check_impure); + DECL_BLOCK (ok_block, comp.check_impure); + + comp.block = entry_block; + comp.func = comp.check_impure; + + emit_cond_jump (emit_PURE_P (gcc_jit_param_as_rvalue (param[0])), /* FIXME */ + err_block, + ok_block); + gcc_jit_block_end_with_void_return (ok_block, NULL); + + gcc_jit_rvalue *pure_write_error_arg = + gcc_jit_param_as_rvalue (param[0]); + + comp.block = err_block; + gcc_jit_block_add_eval (comp.block, + NULL, + emit_call (intern_c_string ("pure_write_error"), + comp.void_type, 1,&pure_write_error_arg, + false)); + + gcc_jit_block_end_with_void_return (err_block, NULL); +} + +static void +define_maybe_gc_or_quit (void) +{ + + /* + void + maybe_gc_or_quit (void) + { + static unsigned quitcounter; + inc: + quitcounter++; + if (quitcounter >> 14) goto maybe_do_it else goto pass; + maybe_do_it: + quitcounter = 0; + maybe_gc (); + maybe_quit (); + return; + pass: + return; + } + */ + + gcc_jit_block *bb_orig = comp.block; + + gcc_jit_lvalue *quitcounter = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_INTERNAL, + comp.unsigned_type, + "quitcounter"); + + comp.func = comp.maybe_gc_or_quit = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.void_type, + "maybe_gc_quit", + 0, NULL, 0); + DECL_BLOCK (increment_block, comp.maybe_gc_or_quit); + DECL_BLOCK (maybe_do_it_block, comp.maybe_gc_or_quit); + DECL_BLOCK (pass_block, comp.maybe_gc_or_quit); + + comp.block = increment_block; + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + quitcounter, + emit_binary_op (GCC_JIT_BINARY_OP_PLUS, + comp.unsigned_type, + gcc_jit_lvalue_as_rvalue (quitcounter), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 1))); + emit_cond_jump ( + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.unsigned_type, + gcc_jit_lvalue_as_rvalue (quitcounter), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 9)), + /* 9 translates into checking for GC or quit every 512 calls to + 'maybe_gc_quit'. This is the smallest value I could find with + no performance impact running elisp-banechmarks and the same + used by the byte interpreter (see 'exec_byte_code'). */ + maybe_do_it_block, + pass_block); + + comp.block = maybe_do_it_block; + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + quitcounter, + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.unsigned_type, + 0)); + gcc_jit_block_add_eval (comp.block, NULL, + emit_call (intern_c_string ("maybe_gc"), + comp.void_type, 0, NULL, false)); + gcc_jit_block_add_eval (comp.block, NULL, + emit_call (intern_c_string ("maybe_quit"), + comp.void_type, 0, NULL, false)); + gcc_jit_block_end_with_void_return (comp.block, NULL); + + gcc_jit_block_end_with_void_return (pass_block, NULL); + + comp.block = bb_orig; +} + +/* Define a function to convert boolean into t or nil */ + +static void +define_bool_to_lisp_obj (void) +{ + /* x ? Qt : Qnil */ + gcc_jit_param *param = gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.bool_type, + "x"); + comp.bool_to_lisp_obj = + gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_INTERNAL, + comp.lisp_obj_type, + "bool_to_lisp_obj", + 1, + ¶m, + 0); + DECL_BLOCK (entry_block, comp.bool_to_lisp_obj); + DECL_BLOCK (ret_t_block, comp.bool_to_lisp_obj); + DECL_BLOCK (ret_nil_block, comp.bool_to_lisp_obj); + comp.block = entry_block; + comp.func = comp.bool_to_lisp_obj; + + emit_cond_jump (gcc_jit_param_as_rvalue (param), + ret_t_block, + ret_nil_block); + + comp.block = ret_t_block; + gcc_jit_block_end_with_return (ret_t_block, + NULL, + emit_lisp_obj_rval (Qt)); + + comp.block = ret_nil_block; + gcc_jit_block_end_with_return (ret_nil_block, + NULL, + emit_lisp_obj_rval (Qnil)); +} + +static gcc_jit_function * +declare_lex_function (Lisp_Object func) +{ + gcc_jit_function *res; + Lisp_Object c_name = CALL1I (comp-func-c-name, func); + Lisp_Object args = CALL1I (comp-func-l-args, func); + bool nargs = !NILP (CALL1I (comp-nargs-p, args)); + USE_SAFE_ALLOCA; + + if (!nargs) + { + EMACS_INT max_args = XFIXNUM (CALL1I (comp-args-max, args)); + eassert (max_args < INT_MAX); + gcc_jit_type **type = SAFE_ALLOCA (max_args * sizeof (*type)); + for (ptrdiff_t i = 0; i < max_args; i++) + type[i] = comp.lisp_obj_type; + + gcc_jit_param **params = SAFE_ALLOCA (max_args * sizeof (*params)); + for (int i = 0; i < max_args; ++i) + params[i] = gcc_jit_context_new_param (comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + res = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + SSDATA (c_name), + max_args, + params, + 0); + } + else + { + gcc_jit_param *params[] = + { gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.ptrdiff_type, + "nargs"), + gcc_jit_context_new_param (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "args") }; + res = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + SSDATA (c_name), + ARRAYELTS (params), params, 0); + } + SAFE_FREE (); + return res; +} + +/* Declare a function being compiled and add it to comp.exported_funcs_h. */ + +static void +declare_function (Lisp_Object func) +{ + gcc_jit_function *gcc_func = + !NILP (CALL1I (comp-func-l-p, func)) + ? declare_lex_function (func) + : gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + SSDATA (CALL1I (comp-func-c-name, func)), + 0, NULL, 0); + Fputhash (CALL1I (comp-func-c-name, func), + make_mint_ptr (gcc_func), + comp.exported_funcs_h); +} + +static void +compile_function (Lisp_Object func) +{ + USE_SAFE_ALLOCA; + comp.frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); + eassert (comp.frame_size < INT_MAX); + + comp.func = xmint_pointer (Fgethash (CALL1I (comp-func-c-name, func), + comp.exported_funcs_h, Qnil)); + + comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func)); + comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func)); + + comp.func_relocs_local = + gcc_jit_function_new_local (comp.func, + NULL, + comp.func_relocs_ptr_type, + "freloc"); + + comp.frame = SAFE_ALLOCA (comp.frame_size * sizeof (*comp.frame)); + if (comp.func_has_non_local || !comp.func_speed) + { + /* FIXME: See bug#42360. */ + gcc_jit_lvalue *arr = + gcc_jit_function_new_local ( + comp.func, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.lisp_obj_type, + comp.frame_size), + "frame"); + + for (ptrdiff_t i = 0; i < comp.frame_size; ++i) + comp.frame[i] = + gcc_jit_context_new_array_access ( + comp.ctxt, + NULL, + gcc_jit_lvalue_as_rvalue (arr), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.int_type, + i)); + } + else + for (ptrdiff_t i = 0; i < comp.frame_size; ++i) + comp.frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("slot_%td", i)); + + comp.scratch = NULL; + + comp.loc_handler = gcc_jit_function_new_local (comp.func, + NULL, + comp.handler_ptr_type, + "c"); + + comp.func_blocks_h = CALLN (Fmake_hash_table); + + /* Pre-declare all basic blocks to gcc. + The "entry" block must be declared as first. */ + declare_block (Qentry); + Lisp_Object blocks = CALL1I (comp-func-blocks, func); + struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++) + { + Lisp_Object block_name = HASH_KEY (ht, i); + if (!EQ (block_name, Qentry) + && !BASE_EQ (block_name, Qunbound)) + declare_block (block_name); + } + + gcc_jit_block_add_assignment (retrive_block (Qentry), + NULL, + comp.func_relocs_local, + gcc_jit_lvalue_as_rvalue (comp.func_relocs)); + + + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++) + { + Lisp_Object block_name = HASH_KEY (ht, i); + if (!BASE_EQ (block_name, Qunbound)) + { + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = CALL1I (comp-block-insns, block); + if (NILP (block) || NILP (insns)) + xsignal1 (Qnative_ice, + build_string ("basic block is missing or empty")); + + comp.block = retrive_block (block_name); + while (CONSP (insns)) + { + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); + } + } + } + const char *err = gcc_jit_context_get_first_error (comp.ctxt); + if (err) + xsignal3 (Qnative_ice, + build_string ("failing to compile function"), + CALL1I (comp-func-name, func), + build_string (err)); + SAFE_FREE (); +} + + +/**********************************/ +/* Entry points exposed to lisp. */ +/**********************************/ + +/* In use by Fcomp_el_to_eln_filename. */ +static Lisp_Object loadsearch_re_list; + +static Lisp_Object +make_directory_wrapper (Lisp_Object directory) +{ + CALL2I (make-directory, directory, Qt); + return Qnil; +} + +static Lisp_Object +make_directory_wrapper_1 (Lisp_Object ignore) +{ + return Qt; +} + +DEFUN ("comp-el-to-eln-rel-filename", Fcomp_el_to_eln_rel_filename, + Scomp_el_to_eln_rel_filename, 1, 1, 0, + doc: /* Return the relative name of the .eln file for FILENAME. +FILENAME must exist, and if it's a symlink, the target must exist. +If FILENAME is compressed, it must have the \".gz\" extension, +and Emacs must have been compiled with zlib; the file will be +uncompressed on the fly to hash its contents. +Value includes the original base name, followed by 2 hash values, +one for the file name and another for its contents, followed by .eln. */) + (Lisp_Object filename) +{ + CHECK_STRING (filename); + + /* Resolve possible symlinks in FILENAME, so that path_hash below + always compares equal. (Bug#44701). */ + filename = Fexpand_file_name (filename, Qnil); + char *file_normalized = realpath (SSDATA (ENCODE_FILE (filename)), NULL); + if (file_normalized) + { + filename = DECODE_FILE (make_unibyte_string (file_normalized, + strlen (file_normalized))); + xfree (file_normalized); + } + + if (NILP (Ffile_exists_p (filename))) + xsignal1 (Qfile_missing, filename); + +#ifdef WINDOWSNT + filename = Fw32_long_file_name (filename); +#endif + + Lisp_Object content_hash = comp_hash_source_file (filename); + + if (suffix_p (filename, ".gz")) + filename = Fsubstring (filename, Qnil, make_fixnum (-3)); + + /* We create eln filenames with an hash in order to look-up these + starting from the source filename, IOW have a relation + + /absolute/path/filename.el + content -> + eln-cache/filename-path_hash-content_hash.eln. + + 'dlopen' can return the same handle if two shared with the same + filename are loaded in two different times (even if the first was + deleted!). To prevent this scenario the source file content is + included in the hashing algorithm. + + As at any point in time no more then one file can exist with the + same filename, should be possible to clean up all + filename-path_hash-* except the most recent one (or the new one + being recompiled). + + As installing .eln files compiled during the build changes their + absolute path we need an hashing mechanism that is not sensitive + to that. For this we replace if match PATH_DUMPLOADSEARCH or + *PATH_REL_LOADSEARCH with '//' before computing the hash. */ + + if (NILP (loadsearch_re_list)) + { + Lisp_Object sys_re = + concat2 (build_string ("\\`[[:ascii:]]+"), + Fregexp_quote (build_string ("/" PATH_REL_LOADSEARCH "/"))); + Lisp_Object dump_load_search = + Fexpand_file_name (build_string (PATH_DUMPLOADSEARCH "/"), Qnil); +#ifdef WINDOWSNT + dump_load_search = Fw32_long_file_name (dump_load_search); +#endif + loadsearch_re_list = list2 (sys_re, Fregexp_quote (dump_load_search)); + } + + Lisp_Object lds_re_tail = loadsearch_re_list; + FOR_EACH_TAIL (lds_re_tail) + { + Lisp_Object match_idx = + Fstring_match (XCAR (lds_re_tail), filename, Qnil, Qnil); + if (BASE_EQ (match_idx, make_fixnum (0))) + { + filename = + Freplace_match (build_string ("//"), Qt, Qt, filename, Qnil); + break; + } + } + Lisp_Object separator = build_string ("-"); + Lisp_Object path_hash = comp_hash_string (filename); + filename = concat2 (Ffile_name_nondirectory (Fsubstring (filename, Qnil, + make_fixnum (-3))), + separator); + Lisp_Object hash = concat3 (path_hash, separator, content_hash); + return concat3 (filename, hash, build_string (NATIVE_ELISP_SUFFIX)); +} + +DEFUN ("comp-el-to-eln-filename", Fcomp_el_to_eln_filename, + Scomp_el_to_eln_filename, 1, 2, 0, + doc: /* Return the absolute .eln file name for source FILENAME. +The resulting .eln file name is intended to be used for natively +compiling FILENAME. FILENAME must exist and be readable, but other +than that, its leading directories are ignored when constructing +the name of the .eln file. +If BASE-DIR is non-nil, use it as the directory for the .eln file; +non-absolute BASE-DIR is interpreted as relative to `invocation-directory'. +If BASE-DIR is omitted or nil, look for the first writable directory +in `native-comp-eln-load-path', and use as BASE-DIR its subdirectory +whose name is given by `comp-native-version-dir'. +If FILENAME specifies a preloaded file, the directory for the .eln +file is the \"preloaded/\" subdirectory of the directory determined +as described above. FILENAME is considered to be a preloaded file if +the value of `comp-file-preloaded-p' is non-nil, or if FILENAME +appears in the value of the environment variable LISP_PRELOADED; +the latter is supposed to be used by the Emacs build procedure. */) + (Lisp_Object filename, Lisp_Object base_dir) +{ + Lisp_Object source_filename = filename; + filename = Fcomp_el_to_eln_rel_filename (filename); + + /* If base_dir was not specified search inside Vnative_comp_eln_load_path + for the first directory where we have write access. */ + if (NILP (base_dir)) + { + Lisp_Object eln_load_paths = Vnative_comp_eln_load_path; + FOR_EACH_TAIL (eln_load_paths) + { + Lisp_Object dir = XCAR (eln_load_paths); + if (!NILP (Ffile_exists_p (dir))) + { + if (!NILP (Ffile_writable_p (dir))) + { + base_dir = dir; + break; + } + } + else + { + /* Try to create the directory and if succeeds use it. */ + if (NILP (internal_condition_case_1 (make_directory_wrapper, + dir, Qt, + make_directory_wrapper_1))) + { + base_dir = dir; + break; + } + } + } + if (NILP (base_dir)) + error ("Cannot find suitable directory for output in " + "`native-comp-eln-load-path'."); + } + + if (!file_name_absolute_p (SSDATA (base_dir))) + base_dir = Fexpand_file_name (base_dir, Vinvocation_directory); + + /* In case the file being compiled is found in 'LISP_PRELOADED' or + `comp-file-preloaded-p' is non-nil target for output the + 'preloaded' subfolder. */ + Lisp_Object lisp_preloaded = + Fgetenv_internal (build_string ("LISP_PRELOADED"), Qnil); + base_dir = Fexpand_file_name (Vcomp_native_version_dir, base_dir); + if (comp_file_preloaded_p + || (!NILP (lisp_preloaded) + && !NILP (Fmember (CALL1I (file-name-base, source_filename), + Fmapcar (intern_c_string ("file-name-base"), + CALL1I (split-string, lisp_preloaded)))))) + base_dir = Fexpand_file_name (build_string ("preloaded"), base_dir); + + return Fexpand_file_name (filename, base_dir); +} + +DEFUN ("comp--install-trampoline", Fcomp__install_trampoline, + Scomp__install_trampoline, 2, 2, 0, + doc: /* Install a TRAMPOLINE for primitive SUBR-NAME. */) + (Lisp_Object subr_name, Lisp_Object trampoline) +{ + CHECK_SYMBOL (subr_name); + CHECK_SUBR (trampoline); + Lisp_Object orig_subr = Fsymbol_function (subr_name); + CHECK_SUBR (orig_subr); + + /* FIXME: add a post dump load trampoline machinery to remove this + check. */ + if (will_dump_p ()) + signal_error ("Trying to advice unexpected primitive before dumping", + subr_name); + + Lisp_Object subr_l = Vcomp_subr_list; + ptrdiff_t i = ARRAYELTS (helper_link_table); + FOR_EACH_TAIL (subr_l) + { + Lisp_Object subr = XCAR (subr_l); + if (EQ (subr, orig_subr)) + { + freloc.link_table[i] = XSUBR (trampoline)->function.a0; + Fputhash (subr_name, trampoline, Vcomp_installed_trampolines_h); + return Qt; + } + i++; + } + signal_error ("Trying to install trampoline for non existent subr", + subr_name); + return Qnil; +} + +DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt, + 0, 0, 0, + doc: /* Initialize the native compiler context. +Return t on success. */) + (void) +{ + load_gccjit_if_necessary (true); + + if (comp.ctxt) + { + xsignal1 (Qnative_ice, + build_string ("compiler context already taken")); + return Qnil; + } + + if (NILP (comp.emitter_dispatcher)) + { + /* Move this into syms_of_comp the day will be dumpable. */ + comp.emitter_dispatcher = CALLN (Fmake_hash_table); + register_emitter (Qset_internal, emit_set_internal); + register_emitter (Qhelper_unbind_n, emit_simple_limple_call_lisp_ret); + register_emitter (Qhelper_unwind_protect, + emit_simple_limple_call_void_ret); + register_emitter (Qrecord_unwind_current_buffer, + emit_simple_limple_call_lisp_ret); + register_emitter (Qrecord_unwind_protect_excursion, + emit_simple_limple_call_void_ret); + register_emitter (Qhelper_save_restriction, + emit_simple_limple_call_void_ret); + /* Inliners. */ + register_emitter (Qadd1, emit_add1); + register_emitter (Qsub1, emit_sub1); + register_emitter (Qconsp, emit_consp); + register_emitter (Qcar, emit_car); + register_emitter (Qcdr, emit_cdr); + register_emitter (Qsetcar, emit_setcar); + register_emitter (Qsetcdr, emit_setcdr); + register_emitter (Qnegate, emit_negate); + register_emitter (Qnumberp, emit_numperp); + register_emitter (Qintegerp, emit_integerp); + register_emitter (Qcomp_maybe_gc_or_quit, emit_maybe_gc_or_quit); + } + + comp.ctxt = gcc_jit_context_acquire (); + + comp.void_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID); + comp.void_ptr_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_VOID_PTR); + comp.bool_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_BOOL); + comp.char_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_CHAR); + comp.int_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_INT); + comp.unsigned_type = gcc_jit_context_get_type (comp.ctxt, + GCC_JIT_TYPE_UNSIGNED_INT); + comp.long_type = gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG); + comp.unsigned_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG); + comp.long_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_LONG_LONG); + comp.unsigned_long_long_type = + gcc_jit_context_get_type (comp.ctxt, GCC_JIT_TYPE_UNSIGNED_LONG_LONG); + comp.bool_ptr_type = gcc_jit_type_get_pointer (comp.bool_type); + comp.char_ptr_type = gcc_jit_type_get_pointer (comp.char_type); + comp.emacs_int_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (EMACS_INT), + true); + comp.emacs_uint_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (EMACS_UINT), + false); +#if LISP_WORDS_ARE_POINTERS + comp.lisp_word_type = + gcc_jit_type_get_pointer ( + gcc_jit_struct_as_type ( + gcc_jit_context_new_opaque_struct (comp.ctxt, + NULL, + "Lisp_X"))); +#else + comp.lisp_word_type = comp.emacs_int_type; +#endif + comp.lisp_word_tag_type + = gcc_jit_context_get_int_type (comp.ctxt, sizeof (Lisp_Word_tag), false); +#ifdef LISP_OBJECT_IS_STRUCT + comp.lisp_obj_i = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_word_type, + "i"); + comp.lisp_obj_s = gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "Lisp_Object", + 1, + &comp.lisp_obj_i); + comp.lisp_obj_type = gcc_jit_struct_as_type (comp.lisp_obj_s); +#else + comp.lisp_obj_type = comp.lisp_word_type; +#endif + comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); + comp.zero = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + 0); + comp.one = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + 1); + comp.inttypebits = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_uint_type, + INTTYPEBITS); + comp.lisp_int0 = + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.emacs_int_type, + Lisp_Int0); + comp.ptrdiff_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (void *), + true); + comp.uintptr_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (void *), + false); + comp.size_t_type = gcc_jit_context_get_int_type (comp.ctxt, + sizeof (size_t), + false); + + comp.exported_funcs_h = CALLN (Fmake_hash_table, QCtest, Qequal); + /* + Always reinitialize this cause old function definitions are garbage + collected by libgccjit when the ctxt is released. + */ + comp.imported_funcs_h = CALLN (Fmake_hash_table); + + define_memcpy (); + + /* Define data structures. */ + + define_lisp_cons (); + define_lisp_symbol_with_position (); + define_jmp_buf (); + define_handler_struct (); + define_thread_state_struct (); + define_cast_functions (); + + return Qt; +} + +DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, + 0, 0, 0, + doc: /* Release the native compiler context. */) + (void) +{ + load_gccjit_if_necessary (true); + + if (comp.ctxt) + gcc_jit_context_release (comp.ctxt); + + if (logfile) + fclose (logfile); + comp.ctxt = NULL; + + return Qt; +} + +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Waddress" +DEFUN ("comp-native-driver-options-effective-p", + Fcomp_native_driver_options_effective_p, + Scomp_native_driver_options_effective_p, + 0, 0, 0, + doc: /* Return t if `comp-native-driver-options' is effective. */) + (void) +{ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) + if (gcc_jit_context_add_driver_option) + return Qt; +#endif + return Qnil; +} +#pragma GCC diagnostic pop + +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Waddress" +DEFUN ("comp-native-compiler-options-effective-p", + Fcomp_native_compiler_options_effective_p, + Scomp_native_compiler_options_effective_p, + 0, 0, 0, + doc: /* Return t if `comp-native-compiler-options' is effective. */) + (void) +{ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) + if (gcc_jit_context_add_command_line_option) + return Qt; +#endif + return Qnil; +} +#pragma GCC diagnostic pop + +static void +add_driver_options (void) +{ + Lisp_Object options = Fsymbol_value (Qnative_comp_driver_options); + +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) + load_gccjit_if_necessary (true); + if (!NILP (Fcomp_native_driver_options_effective_p ())) + FOR_EACH_TAIL (options) + gcc_jit_context_add_driver_option (comp.ctxt, + /* FIXME: Need to encode + this, but how? either + ENCODE_FILE or + ENCODE_SYSTEM. */ + SSDATA (XCAR (options))); +#endif + if (CONSP (options)) + xsignal1 (Qnative_compiler_error, + build_string ("Customizing native compiler options" + " via `comp-native-driver-options' is" + " only available on libgccjit version 9" + " and above.")); + + /* Captured `comp-native-driver-options' because file-local. */ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) + options = comp.driver_options; + if (!NILP (Fcomp_native_driver_options_effective_p ())) + FOR_EACH_TAIL (options) + gcc_jit_context_add_driver_option (comp.ctxt, + /* FIXME: Need to encode + this, but how? either + ENCODE_FILE or + ENCODE_SYSTEM. */ + SSDATA (XCAR (options))); +#endif +} + +static void +add_compiler_options (void) +{ + Lisp_Object options = Fsymbol_value (Qnative_comp_compiler_options); + +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) + load_gccjit_if_necessary (true); + if (!NILP (Fcomp_native_compiler_options_effective_p ())) + FOR_EACH_TAIL (options) + gcc_jit_context_add_command_line_option (comp.ctxt, + /* FIXME: Need to encode + this, but how? either + ENCODE_FILE or + ENCODE_SYSTEM. */ + SSDATA (XCAR (options))); +#endif + if (CONSP (options)) + xsignal1 (Qnative_compiler_error, + build_string ("Customizing native compiler options" + " via `comp-native-compiler-options' is" + " only available on libgccjit version 9" + " and above.")); + + /* Captured `comp-native-compiler-options' because file-local. */ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) + options = comp.compiler_options; + if (!NILP (Fcomp_native_compiler_options_effective_p ())) + FOR_EACH_TAIL (options) + gcc_jit_context_add_command_line_option (comp.ctxt, + /* FIXME: Need to encode + this, but how? either + ENCODE_FILE or + ENCODE_SYSTEM. */ + SSDATA (XCAR (options))); +#endif +} + +DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, + Scomp__compile_ctxt_to_file, + 1, 1, 0, + doc: /* Compile the current context as native code to file FILENAME. */) + (Lisp_Object filename) +{ + load_gccjit_if_necessary (true); + + CHECK_STRING (filename); + Lisp_Object base_name = Fsubstring (filename, Qnil, make_fixnum (-4)); + Lisp_Object ebase_name = ENCODE_FILE (base_name); + + comp.func_relocs_local = NULL; + +#ifdef WINDOWSNT + ebase_name = ansi_encode_filename (ebase_name); + /* Tell libgccjit the actual file name of the loaded DLL, otherwise + it will use 'libgccjit.so', which is not useful. */ + Lisp_Object libgccjit_loaded_from = Fget (Qgccjit, QCloaded_from); + Lisp_Object libgccjit_fname; + + if (CONSP (libgccjit_loaded_from)) + { + /* Use the absolute file name if available, otherwise the name + we looked for in w32_delayed_load. */ + libgccjit_fname = XCDR (libgccjit_loaded_from); + if (NILP (libgccjit_fname)) + libgccjit_fname = XCAR (libgccjit_loaded_from); + /* Must encode to ANSI, as libgccjit will not be able to handle + UTF-8 encoded file names. */ + libgccjit_fname = ENCODE_FILE (libgccjit_fname); + libgccjit_fname = ansi_encode_filename (libgccjit_fname); + gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME, + SSDATA (libgccjit_fname)); + } + else /* this should never happen */ + gcc_jit_context_set_str_option (comp.ctxt, GCC_JIT_STR_OPTION_PROGNAME, + "libgccjit-0.dll"); +#endif + + comp.speed = XFIXNUM (CALL1I (comp-ctxt-speed, Vcomp_ctxt)); + eassert (comp.speed < INT_MAX); + comp.debug = XFIXNUM (CALL1I (comp-ctxt-debug, Vcomp_ctxt)); + eassert (comp.debug < INT_MAX); + comp.driver_options = CALL1I (comp-ctxt-driver-options, Vcomp_ctxt); + comp.compiler_options = CALL1I (comp-ctxt-compiler-options, Vcomp_ctxt); + + if (comp.debug) + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DEBUGINFO, + 1); + if (comp.debug >= 3) + { + logfile = emacs_fopen ("libgccjit.log", "w"); + gcc_jit_context_set_logfile (comp.ctxt, + logfile, + 0, 0); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_KEEP_INTERMEDIATES, + 1); + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DUMP_EVERYTHING, + 1); + } + + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + comp.speed < 0 ? 0 + : (comp.speed > 3 ? 3 : comp.speed)); + + /* On MacOS set a unique dylib ID. */ +#if defined (LIBGCCJIT_HAVE_gcc_jit_context_add_driver_option) \ + && defined (DARWIN_OS) + gcc_jit_context_add_driver_option (comp.ctxt, "-install_name"); + gcc_jit_context_add_driver_option ( + comp.ctxt, SSDATA (Ffile_name_nondirectory (filename))); +#endif + + comp.d_default_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt)); + comp.d_impure_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-impure, Vcomp_ctxt)); + comp.d_ephemeral_idx = + CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt)); + + emit_ctxt_code (); + + /* Define inline functions. */ + define_CAR_CDR (); + define_PSEUDOVECTORP (); + define_GET_SYMBOL_WITH_POSITION (); + define_CHECK_TYPE (); + define_SYMBOL_WITH_POS_SYM (); + define_CHECK_IMPURE (); + define_bool_to_lisp_obj (); + define_setcar_setcdr (); + define_add1_sub1 (); + define_negate (); + define_maybe_gc_or_quit (); + + struct Lisp_Hash_Table *func_h = + XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++) + if (!BASE_EQ (HASH_VALUE (func_h, i), Qunbound)) + declare_function (HASH_VALUE (func_h, i)); + /* Compile all functions. Can't be done before because the + relocation structs has to be already defined. */ + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++) + if (!BASE_EQ (HASH_VALUE (func_h, i), Qunbound)) + compile_function (HASH_VALUE (func_h, i)); + + /* Work around bug#46495 (GCC PR99126). */ +#if defined (WIDE_EMACS_INT) \ + && defined (LIBGCCJIT_HAVE_gcc_jit_context_add_command_line_option) + Lisp_Object version = Fcomp_libgccjit_version (); + if (NILP (version) + || XFIXNUM (XCAR (version)) < 11) + gcc_jit_context_add_command_line_option (comp.ctxt, + "-fdisable-tree-isolate-paths"); +#endif + + add_compiler_options (); + add_driver_options (); + + if (comp.debug > 1) + gcc_jit_context_dump_to_file (comp.ctxt, + format_string ("%s.c", SSDATA (ebase_name)), + 1); + if (!NILP (Fsymbol_value (Qcomp_libgccjit_reproducer))) + gcc_jit_context_dump_reproducer_to_file ( + comp.ctxt, + format_string ("%s_libgccjit_repro.c", SSDATA (ebase_name))); + + Lisp_Object tmp_file = + Fmake_temp_file_internal (base_name, Qnil, build_string (".eln.tmp"), Qnil); + Lisp_Object encoded_tmp_file = ENCODE_FILE (tmp_file); +#ifdef WINDOWSNT + encoded_tmp_file = ansi_encode_filename (encoded_tmp_file); +#endif + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, + SSDATA (encoded_tmp_file)); + + const char *err = gcc_jit_context_get_first_error (comp.ctxt); + if (err) + xsignal3 (Qnative_ice, + build_string ("failed to compile"), + filename, + build_string (err)); + + CALL1I (comp-clean-up-stale-eln, filename); + CALL2I (comp-delete-or-replace-file, filename, tmp_file); + + return filename; +} + +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Waddress" +DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, + Scomp_libgccjit_version, 0, 0, 0, + doc: /* Return libgccjit version in use. + +The return value has the form (MAJOR MINOR PATCHLEVEL) or nil if +unknown (before GCC version 10). */) + (void) +{ +#if defined (LIBGCCJIT_HAVE_gcc_jit_version) + load_gccjit_if_necessary (true); + + return gcc_jit_version_major + ? list3 (make_fixnum (gcc_jit_version_major ()), + make_fixnum (gcc_jit_version_minor ()), + make_fixnum (gcc_jit_version_patchlevel ())) + : Qnil; +#else + return Qnil; +#endif +} +#pragma GCC diagnostic pop + + +/******************************************************************************/ +/* Helper functions called from the run-time. */ +/* Note: this are all potentially definable directly to gcc and are here just */ +/* for laziness. Change this if a performance impact is measured. */ +/******************************************************************************/ + +static void +helper_unwind_protect (Lisp_Object handler) +{ + /* Support for a function here is new in 24.4. */ + record_unwind_protect (FUNCTIONP (handler) ? bcall0 : prog_ignore, + handler); +} + +static Lisp_Object +helper_unbind_n (Lisp_Object n) +{ + return unbind_to (specpdl_ref_add (SPECPDL_INDEX (), -XFIXNUM (n)), Qnil); +} + +static void +helper_save_restriction (void) +{ + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); +} + +static bool +helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) +{ + return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, + union vectorlike_header), + code); +} + +static struct Lisp_Symbol_With_Pos * +helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a) +{ + if (!SYMBOL_WITH_POS_P (a)) + wrong_type_argument (Qwrong_type_argument, a); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); +} + + +/* `native-comp-eln-load-path' clean-up support code. */ + +#ifdef WINDOWSNT +static Lisp_Object +return_nil (Lisp_Object arg) +{ + return Qnil; +} + +static Lisp_Object +directory_files_matching (Lisp_Object name, Lisp_Object match) +{ + return Fdirectory_files (name, Qt, match, Qnil, Qnil); +} +#endif + +/* Windows does not let us delete a .eln file that is currently loaded + by a process. The strategy is to rename .eln files into .old.eln + instead of removing them when this is not possible and clean-up + `native-comp-eln-load-path' when exiting. + + Any error is ignored because it may be due to the file being loaded + in another Emacs instance. */ +void +eln_load_path_final_clean_up (void) +{ +#ifdef WINDOWSNT + Lisp_Object dir_tail = Vnative_comp_eln_load_path; + FOR_EACH_TAIL (dir_tail) + { + Lisp_Object files_in_dir = + internal_condition_case_2 (directory_files_matching, + Fexpand_file_name (Vcomp_native_version_dir, + XCAR (dir_tail)), + build_string ("\\.eln\\.old\\'"), + Qt, return_nil); + FOR_EACH_TAIL (files_in_dir) + internal_delete_file (XCAR (files_in_dir)); + } +#endif +} + +/* This function puts the compilation unit in the + `Vcomp_loaded_comp_units_h` hashmap. */ +static void +register_native_comp_unit (Lisp_Object comp_u) +{ + Fputhash ( + XNATIVE_COMP_UNIT (comp_u)->file, comp_u, Vcomp_loaded_comp_units_h); +} + + +/***********************************/ +/* Deferred compilation mechanism. */ +/***********************************/ + +/* Queue an asynchronous compilation for the source file defining + FUNCTION_NAME and perform a late load. + + NOTE: ideally would be nice to move its call simply into Fload but + we need DEFINITION to guard against function redefinition while + async compilation happen. */ + +void +maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition) +{ +#if 0 +#include <sys/types.h> +#include <unistd.h> + if (!NILP (function_name) && + STRINGP (Vload_true_file_name)) + { + static FILE *f; + if (!f) + { + char str[128]; + sprintf (str, "log_%d", getpid ()); + f = fopen (str, "w"); + } + if (!f) + exit (1); + fprintf (f, "function %s file %s\n", + SSDATA (Fsymbol_name (function_name)), + SSDATA (Vload_true_file_name)); + fflush (f); + } +#endif + if (!load_gccjit_if_necessary (false)) + return; + + if (!native_comp_deferred_compilation + || noninteractive + || !NILP (Vpurify_flag) + || !COMPILEDP (definition) + || !STRINGP (Vload_true_file_name) + || !suffix_p (Vload_true_file_name, ".elc") + || !NILP (Fgethash (Vload_true_file_name, V_comp_no_native_file_h, Qnil))) + return; + + Lisp_Object src = + concat2 (CALL1I (file-name-sans-extension, Vload_true_file_name), + build_pure_c_string (".el")); + if (NILP (Ffile_exists_p (src))) + { + src = concat2 (src, build_pure_c_string (".gz")); + if (NILP (Ffile_exists_p (src))) + return; + } + + Fputhash (function_name, definition, Vcomp_deferred_pending_h); + + /* This is so deferred compilation is able to compile comp + dependencies breaking circularity. */ + if (comp__compilable) + { + /* Startup is done, comp is usable. */ + CALL0I (startup--require-comp-safely); + CALLN (Ffuncall, intern_c_string ("native--compile-async"), + src, Qnil, Qlate); + } + else + Vcomp__delayed_sources = Fcons (src, Vcomp__delayed_sources); +} + + +/**************************************/ +/* Functions used to load eln files. */ +/**************************************/ + +/* Fixup the system eln-cache directory, which is the last entry in + `native-comp-eln-load-path'. Argument is a .eln file in that directory. */ +void +fixup_eln_load_path (Lisp_Object eln_filename) +{ + Lisp_Object last_cell = Qnil; + Lisp_Object tem = Vnative_comp_eln_load_path; + FOR_EACH_TAIL (tem) + if (CONSP (tem)) + last_cell = tem; + + const char preloaded[] = "/preloaded/"; + Lisp_Object eln_cache_sys = Ffile_name_directory (eln_filename); + const char *p_preloaded = + SSDATA (eln_cache_sys) + SBYTES (eln_cache_sys) - sizeof (preloaded) + 1; + bool preloaded_p = strcmp (p_preloaded, preloaded) == 0; + + /* One or two directories up... */ + for (int i = 0; i < (preloaded_p ? 2 : 1); i++) + eln_cache_sys = + Ffile_name_directory (Fsubstring_no_properties (eln_cache_sys, Qnil, + make_fixnum (-1))); + Fsetcar (last_cell, eln_cache_sys); +} + +typedef char *(*comp_lit_str_func) (void); + +/* Deserialize read and return static object. */ +static Lisp_Object +load_static_obj (struct Lisp_Native_Comp_Unit *comp_u, const char *name) +{ + static_obj_t *blob = + dynlib_sym (comp_u->handle, format_string ("%s_blob", name)); + if (blob) + /* New blob format. */ + return Fread (make_string (blob->data, blob->len)); + + static_obj_t *(*f)(void) = dynlib_sym (comp_u->handle, name); + if (!f) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + + blob = f (); + return Fread (make_string (blob->data, blob->len)); + +} + +/* Return false when something is wrong or true otherwise. */ + +static bool +check_comp_unit_relocs (struct Lisp_Native_Comp_Unit *comp_u) +{ + dynlib_handle_ptr handle = comp_u->handle; + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + for (ptrdiff_t i = 0; i < d_vec_len; i++) + if (!EQ (data_relocs[i], AREF (comp_u->data_vec, i))) + return false; + + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); + for (ptrdiff_t i = 0; i < d_vec_len; i++) + { + Lisp_Object x = data_imp_relocs[i]; + if (EQ (x, Qlambda_fixup)) + return false; + else if (SUBR_NATIVE_COMPILEDP (x)) + { + if (NILP (Fgethash (x, comp_u->lambda_gc_guard_h, Qnil))) + return false; + } + else if (!EQ (data_imp_relocs[i], AREF (comp_u->data_impure_vec, i))) + return false; + } + return true; +} + +static void +unset_cu_load_ongoing (Lisp_Object comp_u) +{ + XNATIVE_COMP_UNIT (comp_u)->load_ongoing = false; +} + +Lisp_Object +load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, + bool late_load) +{ + Lisp_Object res = Qnil; + dynlib_handle_ptr handle = comp_u->handle; + Lisp_Object comp_u_lisp_obj; + XSETNATIVE_COMP_UNIT (comp_u_lisp_obj, comp_u); + + Lisp_Object *saved_cu = dynlib_sym (handle, COMP_UNIT_SYM); + if (!saved_cu) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + comp_u->loaded_once = !NILP (*saved_cu); + Lisp_Object *data_eph_relocs = + dynlib_sym (handle, DATA_RELOC_EPHEMERAL_SYM); + + /* While resurrecting from an image dump loading more than once the + same compilation unit does not make any sense. */ + eassert (!(loading_dump && comp_u->loaded_once)); + + if (comp_u->loaded_once) + /* 'dlopen' returns the same handle when trying to load two times + the same shared. In this case touching 'd_reloc' etc leads to + fails in case a frame with a reference to it in a live reg is + active (native-comp-speed > 0). + + We must *never* mess with static pointers in an already loaded + eln. */ + { + comp_u_lisp_obj = *saved_cu; + comp_u = XNATIVE_COMP_UNIT (comp_u_lisp_obj); + comp_u->loaded_once = true; + } + else + *saved_cu = comp_u_lisp_obj; + + /* Once we are sure to have the right compilation unit we want to + identify is we have at least another load active on it. */ + bool recursive_load = comp_u->load_ongoing; + comp_u->load_ongoing = true; + specpdl_ref count = SPECPDL_INDEX (); + if (!recursive_load) + record_unwind_protect (unset_cu_load_ongoing, comp_u_lisp_obj); + + freloc_check_fill (); + + Lisp_Object (*top_level_run)(Lisp_Object) + = dynlib_sym (handle, + late_load ? "late_top_level_run" : "top_level_run"); + + /* Always set data_imp_relocs pointer in the compilation unit (in can be + used in 'dump_do_dump_relocation'). */ + comp_u->data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + + if (!comp_u->loaded_once) + { + struct thread_state ***current_thread_reloc = + dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + bool **f_symbols_with_pos_enabled_reloc = + dynlib_sym (handle, F_SYMBOLS_WITH_POS_ENABLED_RELOC_SYM); + void **pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = comp_u->data_imp_relocs; + void **freloc_link_table = dynlib_sym (handle, FUNC_LINK_TABLE_SYM); + + if (!(current_thread_reloc + && f_symbols_with_pos_enabled_reloc + && pure_reloc + && data_relocs + && data_imp_relocs + && data_eph_relocs + && freloc_link_table + && top_level_run) + || NILP (Fstring_equal (load_static_obj (comp_u, LINK_TABLE_HASH_SYM), + Vcomp_abi_hash))) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + + *current_thread_reloc = ¤t_thread; + *f_symbols_with_pos_enabled_reloc = &symbols_with_pos_enabled; + *pure_reloc = pure; + + /* Imported functions. */ + *freloc_link_table = freloc.link_table; + + /* Imported data. */ + if (!loading_dump) + { + comp_u->optimize_qualities = + load_static_obj (comp_u, TEXT_OPTIM_QLY_SYM); + comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); + comp_u->data_impure_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + + if (!NILP (Vpurify_flag)) + /* Non impure can be copied into pure space. */ + comp_u->data_vec = Fpurecopy (comp_u->data_vec); + } + + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (comp_u->data_vec, i); + + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); + } + + if (!loading_dump) + { + /* Note: data_ephemeral_vec is not GC protected except than by + this function frame. After this functions will be + deactivated GC will be free to collect it, but it MUST + survive till 'top_level_run' has finished his job. We store + into the ephemeral allocation class only objects that we know + are necessary exclusively during the first load. Once these + are collected we don't have to maintain them in the heap + forever. */ + Lisp_Object volatile data_ephemeral_vec = Qnil; + /* In case another load of the same CU is active on the stack + all ephemeral data is hold by that frame. Re-writing + 'data_ephemeral_vec' would be not only a waste of cycles but + more importantly would lead to crashes if the contained data + is not cons hashed. */ + if (!recursive_load) + { + data_ephemeral_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_EPHEMERAL_SYM); + + EMACS_INT d_vec_len = XFIXNUM (Flength (data_ephemeral_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_eph_relocs[i] = AREF (data_ephemeral_vec, i); + } + /* Executing this will perform all the expected environment + modifications. */ + res = top_level_run (comp_u_lisp_obj); + /* Make sure data_ephemeral_vec still exists after top_level_run has run. + Guard against sibling call optimization (or any other). */ + data_ephemeral_vec = data_ephemeral_vec; + eassert (check_comp_unit_relocs (comp_u)); + } + + if (!recursive_load) + /* Clean-up the load ongoing flag in case. */ + unbind_to (count, Qnil); + + register_native_comp_unit (comp_u_lisp_obj); + + return res; +} + +void +unload_comp_unit (struct Lisp_Native_Comp_Unit *cu) +{ + if (cu->handle == NULL) + return; + + Lisp_Object *saved_cu = dynlib_sym (cu->handle, COMP_UNIT_SYM); + Lisp_Object this_cu; + XSETNATIVE_COMP_UNIT (this_cu, cu); + if (EQ (this_cu, *saved_cu)) + *saved_cu = Qnil; + dynlib_close (cu->handle); +} + +Lisp_Object +native_function_doc (Lisp_Object function) +{ + struct Lisp_Native_Comp_Unit *cu = + XNATIVE_COMP_UNIT (Fsubr_native_comp_unit (function)); + + if (NILP (cu->data_fdoc_v)) + cu->data_fdoc_v = load_static_obj (cu, TEXT_FDOC_SYM); + if (!VECTORP (cu->data_fdoc_v)) + xsignal2 (Qnative_lisp_file_inconsistent, cu->file, + build_string ("missing documentation vector")); + return AREF (cu->data_fdoc_v, XSUBR (function)->doc); +} + +static Lisp_Object +make_subr (Lisp_Object symbol_name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object type, Lisp_Object doc_idx, + Lisp_Object intspec, Lisp_Object command_modes, Lisp_Object comp_u) +{ + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); + dynlib_handle_ptr handle = cu->handle; + if (!handle) + xsignal0 (Qwrong_register_subr_call); + + void *func = dynlib_sym (handle, SSDATA (c_name)); + eassert (func); + union Aligned_Lisp_Subr *x = + (union Aligned_Lisp_Subr *) allocate_pseudovector ( + VECSIZE (union Aligned_Lisp_Subr), + 0, VECSIZE (union Aligned_Lisp_Subr), + PVEC_SUBR); + if (CONSP (minarg)) + { + /* Dynamic code. */ +#ifdef HAVE_NATIVE_COMP + x->s.lambda_list = maxarg; +#endif + maxarg = XCDR (minarg); + minarg = XCAR (minarg); + } + else + { +#ifdef HAVE_NATIVE_COMP + x->s.lambda_list = Qnil; +#endif + } + x->s.function.a0 = func; + x->s.min_args = XFIXNUM (minarg); + x->s.max_args = FIXNUMP (maxarg) ? XFIXNUM (maxarg) : MANY; + x->s.symbol_name = xstrdup (SSDATA (symbol_name)); + x->s.intspec.native = intspec; + x->s.command_modes = command_modes; + x->s.doc = XFIXNUM (doc_idx); +#ifdef HAVE_NATIVE_COMP + x->s.native_comp_u = comp_u; + x->s.native_c_name = xstrdup (SSDATA (c_name)); + x->s.type = type; +#endif + Lisp_Object tem; + XSETSUBR (tem, &x->s); + + return tem; +} + +DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, + 7, 7, 0, + doc: /* Register anonymous lambda. +This gets called by top_level_run during the load phase. */) + (Lisp_Object reloc_idx, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) +{ + Lisp_Object doc_idx = FIRST (rest); + Lisp_Object intspec = SECOND (rest); + Lisp_Object command_modes = THIRD (rest); + + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (comp_u); + if (cu->loaded_once) + return Qnil; + + Lisp_Object tem = + make_subr (c_name, minarg, maxarg, c_name, type, doc_idx, intspec, + command_modes, comp_u); + + /* We must protect it against GC because the function is not + reachable through symbols. */ + Fputhash (tem, Qt, cu->lambda_gc_guard_h); + /* This is for fixing up the value in d_reloc while resurrecting + from dump. See 'dump_do_dump_relocation'. */ + eassert (NILP (Fgethash (c_name, cu->lambda_c_name_idx_h, Qnil))); + Fputhash (c_name, reloc_idx, cu->lambda_c_name_idx_h); + /* Do the real relocation fixup. */ + cu->data_imp_relocs[XFIXNUM (reloc_idx)] = tem; + + return tem; +} + +DEFUN ("comp--register-subr", Fcomp__register_subr, Scomp__register_subr, + 7, 7, 0, + doc: /* Register exported subr. +This gets called by top_level_run during the load phase. */) + (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) +{ + Lisp_Object doc_idx = FIRST (rest); + Lisp_Object intspec = SECOND (rest); + Lisp_Object command_modes = THIRD (rest); + + Lisp_Object tem = + make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, type, doc_idx, + intspec, command_modes, comp_u); + + defalias (name, tem); + + return tem; +} + +DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, + Scomp__late_register_subr, 7, 7, 0, + doc: /* Register exported subr. +This gets called by late_top_level_run during the load phase. */) + (Lisp_Object name, Lisp_Object c_name, Lisp_Object minarg, + Lisp_Object maxarg, Lisp_Object type, Lisp_Object rest, + Lisp_Object comp_u) +{ + if (!NILP (Fequal (Fsymbol_function (name), + Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) + Fcomp__register_subr (name, c_name, minarg, maxarg, type, rest, comp_u); + Fremhash (name, Vcomp_deferred_pending_h); + return Qnil; +} + +static bool +file_in_eln_sys_dir (Lisp_Object filename) +{ + Lisp_Object eln_sys_dir = Qnil; + Lisp_Object tmp = Vnative_comp_eln_load_path; + FOR_EACH_TAIL (tmp) + eln_sys_dir = XCAR (tmp); + return !NILP (Fstring_match (Fregexp_quote (Fexpand_file_name (eln_sys_dir, + Qnil)), + Fexpand_file_name (filename, Qnil), + Qnil, Qnil)); +} + +/* Load related routines. */ +DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, + doc: /* Load native elisp code FILENAME. +LATE_LOAD has to be non-nil when loading for deferred compilation. */) + (Lisp_Object filename, Lisp_Object late_load) +{ + CHECK_STRING (filename); + if (NILP (Ffile_exists_p (filename))) + xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), + filename); + struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); + Lisp_Object encoded_filename = ENCODE_FILE (filename); + + if (!NILP (Fgethash (filename, Vcomp_loaded_comp_units_h, Qnil)) + && !file_in_eln_sys_dir (filename) + && !NILP (Ffile_writable_p (filename))) + { + /* If in this session there was ever a file loaded with this + name, rename it before loading, to make sure we always get a + new handle! */ + Lisp_Object tmp_filename = + Fmake_temp_file_internal (filename, Qnil, build_string (".eln.tmp"), + Qnil); + if (NILP (Ffile_writable_p (tmp_filename))) + comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename)); + else + { + Frename_file (filename, tmp_filename, Qt); + comp_u->handle = dynlib_open_for_eln (SSDATA (ENCODE_FILE (tmp_filename))); + Frename_file (tmp_filename, filename, Qnil); + } + } + else + comp_u->handle = dynlib_open_for_eln (SSDATA (encoded_filename)); + + if (!comp_u->handle) + xsignal2 (Qnative_lisp_load_failed, filename, + build_string (dynlib_error ())); + comp_u->file = filename; + comp_u->data_vec = Qnil; + comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); + comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal); + return load_comp_unit (comp_u, false, !NILP (late_load)); +} + +#endif /* HAVE_NATIVE_COMP */ + +DEFUN ("native-comp-available-p", Fnative_comp_available_p, + Snative_comp_available_p, 0, 0, 0, + doc: /* Return non-nil if native compilation support is built-in. */) + (void) +{ +#ifdef HAVE_NATIVE_COMP + return load_gccjit_if_necessary (false) ? Qt : Qnil; +#else + return Qnil; +#endif +} + + +void +syms_of_comp (void) +{ +#ifdef HAVE_NATIVE_COMP + DEFVAR_LISP ("comp--delayed-sources", Vcomp__delayed_sources, + doc: /* List of sources to be native-compiled when startup is finished. +For internal use. */); + DEFVAR_BOOL ("comp--compilable", + comp__compilable, + doc: /* Non-nil when comp.el can be native compiled. +For internal use. */); + /* Compiler control customizes. */ + DEFVAR_BOOL ("native-comp-deferred-compilation", + native_comp_deferred_compilation, + doc: /* If non-nil compile loaded .elc files asynchronously. + +After compilation, each function definition is updated to the native +compiled one. */); + native_comp_deferred_compilation = true; + + DEFSYM (Qnative_comp_speed, "native-comp-speed"); + DEFSYM (Qnative_comp_debug, "native-comp-debug"); + DEFSYM (Qnative_comp_driver_options, "native-comp-driver-options"); + DEFSYM (Qnative_comp_compiler_options, "native-comp-compiler-options"); + DEFSYM (Qcomp_libgccjit_reproducer, "comp-libgccjit-reproducer"); + + /* Limple instruction set. */ + DEFSYM (Qcomment, "comment"); + DEFSYM (Qjump, "jump"); + DEFSYM (Qcall, "call"); + DEFSYM (Qcallref, "callref"); + DEFSYM (Qdirect_call, "direct-call"); + DEFSYM (Qdirect_callref, "direct-callref"); + DEFSYM (Qassume, "assume"); + DEFSYM (Qsetimm, "setimm"); + DEFSYM (Qreturn, "return"); + DEFSYM (Qunreachable, "unreachable"); + DEFSYM (Qcomp_mvar, "comp-mvar"); + DEFSYM (Qcond_jump, "cond-jump"); + DEFSYM (Qphi, "phi"); + /* Ops in use for prologue emission. */ + DEFSYM (Qset_par_to_local, "set-par-to-local"); + DEFSYM (Qset_args_to_local, "set-args-to-local"); + DEFSYM (Qset_rest_args_to_local, "set-rest-args-to-local"); + DEFSYM (Qinc_args, "inc-args"); + DEFSYM (Qcond_jump_narg_leq, "cond-jump-narg-leq"); + /* Others. */ + DEFSYM (Qpush_handler, "push-handler"); + DEFSYM (Qpop_handler, "pop-handler"); + DEFSYM (Qfetch_handler, "fetch-handler"); + DEFSYM (Qcondition_case, "condition-case"); + /* call operands. */ + DEFSYM (Qcatcher, "catcher"); + DEFSYM (Qentry, "entry"); + DEFSYM (Qset_internal, "set_internal"); + DEFSYM (Qrecord_unwind_current_buffer, "record_unwind_current_buffer"); + DEFSYM (Qrecord_unwind_protect_excursion, "record_unwind_protect_excursion"); + DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); + DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); + DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + /* Inliners. */ + DEFSYM (Qadd1, "1+"); + DEFSYM (Qsub1, "1-"); + DEFSYM (Qconsp, "consp"); + DEFSYM (Qcar, "car"); + DEFSYM (Qcdr, "cdr"); + DEFSYM (Qsetcar, "setcar"); + DEFSYM (Qsetcdr, "setcdr"); + DEFSYM (Qnegate, "negate"); + DEFSYM (Qnumberp, "numberp"); + DEFSYM (Qintegerp, "integerp"); + DEFSYM (Qcomp_maybe_gc_or_quit, "comp-maybe-gc-or-quit"); + DEFSYM (Qsymbol_with_pos_p, "symbol-with-pos-p"); + + /* Allocation classes. */ + DEFSYM (Qd_default, "d-default"); + DEFSYM (Qd_impure, "d-impure"); + DEFSYM (Qd_ephemeral, "d-ephemeral"); + + /* Others. */ + DEFSYM (Qcomp, "comp"); + DEFSYM (Qfixnum, "fixnum"); + DEFSYM (Qscratch, "scratch"); + DEFSYM (Qlate, "late"); + DEFSYM (Qlambda_fixup, "lambda-fixup"); + DEFSYM (Qgccjit, "gccjit"); + DEFSYM (Qcomp_subr_trampoline_install, "comp-subr-trampoline-install"); + DEFSYM (Qnative_comp_warning_on_missing_source, + "native-comp-warning-on-missing-source"); + + /* To be signaled by the compiler. */ + DEFSYM (Qnative_compiler_error, "native-compiler-error"); + Fput (Qnative_compiler_error, Qerror_conditions, + pure_list (Qnative_compiler_error, Qerror)); + Fput (Qnative_compiler_error, Qerror_message, + build_pure_c_string ("Native compiler error")); + + DEFSYM (Qnative_ice, "native-ice"); + Fput (Qnative_ice, Qerror_conditions, + pure_list (Qnative_ice, Qnative_compiler_error, Qerror)); + Fput (Qnative_ice, Qerror_message, + build_pure_c_string ("Internal native compiler error")); + + /* By the load machinery. */ + DEFSYM (Qnative_lisp_load_failed, "native-lisp-load-failed"); + Fput (Qnative_lisp_load_failed, Qerror_conditions, + pure_list (Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_load_failed, Qerror_message, + build_pure_c_string ("Native elisp load failed")); + + DEFSYM (Qnative_lisp_wrong_reloc, "native-lisp-wrong-reloc"); + Fput (Qnative_lisp_wrong_reloc, Qerror_conditions, + pure_list (Qnative_lisp_wrong_reloc, Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_wrong_reloc, Qerror_message, + build_pure_c_string ("Primitive redefined or wrong relocation")); + + DEFSYM (Qwrong_register_subr_call, "wrong-register-subr-call"); + Fput (Qwrong_register_subr_call, Qerror_conditions, + pure_list (Qwrong_register_subr_call, Qnative_lisp_load_failed, Qerror)); + Fput (Qwrong_register_subr_call, Qerror_message, + build_pure_c_string ("comp--register-subr can only be called during " + "native lisp load phase.")); + + DEFSYM (Qnative_lisp_file_inconsistent, "native-lisp-file-inconsistent"); + Fput (Qnative_lisp_file_inconsistent, Qerror_conditions, + pure_list (Qnative_lisp_file_inconsistent, Qnative_lisp_load_failed, Qerror)); + Fput (Qnative_lisp_file_inconsistent, Qerror_message, + build_pure_c_string ("eln file inconsistent with current runtime " + "configuration, please recompile")); + + defsubr (&Scomp__subr_signature); + defsubr (&Scomp_el_to_eln_rel_filename); + defsubr (&Scomp_el_to_eln_filename); + defsubr (&Scomp_native_driver_options_effective_p); + defsubr (&Scomp_native_compiler_options_effective_p); + defsubr (&Scomp__install_trampoline); + defsubr (&Scomp__init_ctxt); + defsubr (&Scomp__release_ctxt); + defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp_libgccjit_version); + defsubr (&Scomp__register_lambda); + defsubr (&Scomp__register_subr); + defsubr (&Scomp__late_register_subr); + defsubr (&Snative_elisp_load); + + staticpro (&comp.exported_funcs_h); + comp.exported_funcs_h = Qnil; + staticpro (&comp.imported_funcs_h); + comp.imported_funcs_h = Qnil; + staticpro (&comp.func_blocks_h); + staticpro (&comp.emitter_dispatcher); + comp.emitter_dispatcher = Qnil; + staticpro (&loadsearch_re_list); + loadsearch_re_list = Qnil; + + DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt, + doc: /* The compiler context. */); + Vcomp_ctxt = Qnil; + + /* FIXME should be initialized but not here... Plus this don't have + to be necessarily exposed to lisp but can easy debug for now. */ + DEFVAR_LISP ("comp-subr-list", Vcomp_subr_list, + doc: /* List of all defined subrs. */); + DEFVAR_LISP ("comp-abi-hash", Vcomp_abi_hash, + doc: /* String signing the .eln files ABI. */); + Vcomp_abi_hash = Qnil; + DEFVAR_LISP ("comp-native-version-dir", Vcomp_native_version_dir, + doc: /* Directory in use to disambiguate eln compatibility. */); + Vcomp_native_version_dir = Qnil; + + DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h, + doc: /* Hash table symbol-name -> function-value. +For internal use. */); + Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); + + DEFVAR_LISP ("comp-eln-to-el-h", Vcomp_eln_to_el_h, + doc: /* Hash table eln-filename -> el-filename. */); + Vcomp_eln_to_el_h = CALLN (Fmake_hash_table, QCtest, Qequal); + + DEFVAR_LISP ("native-comp-eln-load-path", Vnative_comp_eln_load_path, + doc: /* List of eln cache directories. + +If a directory is non absolute it is assumed to be relative to +`invocation-directory'. +`comp-native-version-dir' value is used as a sub-folder name inside +each eln cache directory. +The last directory of this list is assumed to be the system one. */); + + /* Temporary value in use for bootstrap. We can't do better as + `invocation-directory' is still unset, will be fixed up during + dump reload. */ + Vnative_comp_eln_load_path = Fcons (build_string ("../native-lisp/"), Qnil); + + DEFVAR_BOOL ("comp-enable-subr-trampolines", comp_enable_subr_trampolines, + doc: /* If non-nil enable primitive trampoline synthesis. +This makes primitive functions redefinable or advisable effectively. */); + + DEFVAR_LISP ("comp-installed-trampolines-h", Vcomp_installed_trampolines_h, + doc: /* Hash table subr-name -> installed trampoline. +This is used to prevent double trampoline instantiation but also to +protect the trampolines against GC. */); + Vcomp_installed_trampolines_h = CALLN (Fmake_hash_table); + + DEFVAR_LISP ("comp-no-native-file-h", V_comp_no_native_file_h, + doc: /* Files for which no deferred compilation has to be performed. +These files' compilation should not be deferred because the bytecode +version was explicitly requested by the user during load. +For internal use. */); + V_comp_no_native_file_h = CALLN (Fmake_hash_table, QCtest, Qequal); + + DEFVAR_BOOL ("comp-file-preloaded-p", comp_file_preloaded_p, + doc: /* When non-nil assume the file being compiled to +be preloaded. */); + + DEFVAR_LISP ("comp-loaded-comp-units-h", Vcomp_loaded_comp_units_h, + doc: /* Hash table recording all loaded compilation units. +file -> CU. */); + Vcomp_loaded_comp_units_h = + CALLN (Fmake_hash_table, QCweakness, Qvalue, QCtest, Qequal); + + Fprovide (intern_c_string ("native-compile"), Qnil); +#endif /* #ifdef HAVE_NATIVE_COMP */ + + defsubr (&Snative_comp_available_p); +} +/* Local Variables: */ +/* c-file-offsets: ((arglist-intro . +)) */ +/* End: */ |