diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Makefile.in | 18 | ||||
| -rw-r--r-- | src/alloc.c | 36 | ||||
| -rw-r--r-- | src/comp.c | 5021 | ||||
| -rw-r--r-- | src/comp.h | 133 | ||||
| -rw-r--r-- | src/data.c | 53 | ||||
| -rw-r--r-- | src/doc.c | 12 | ||||
| -rw-r--r-- | src/dynlib.c | 4 | ||||
| -rw-r--r-- | src/emacs.c | 92 | ||||
| -rw-r--r-- | src/eval.c | 92 | ||||
| -rw-r--r-- | src/lisp.h | 58 | ||||
| -rw-r--r-- | src/lread.c | 302 | ||||
| -rw-r--r-- | src/pdumper.c | 239 | ||||
| -rw-r--r-- | src/pdumper.h | 3 | ||||
| -rw-r--r-- | src/print.c | 13 | ||||
| -rw-r--r-- | src/w32.c | 4 | ||||
| -rw-r--r-- | src/w32common.h | 8 |
16 files changed, 5957 insertions, 131 deletions
diff --git a/src/Makefile.in b/src/Makefile.in index 72d69fb7a3e..2f373d3eb7f 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -241,7 +241,7 @@ LIBZ = @LIBZ@ ## system-specific libs for dynamic modules, else empty LIBMODULES = @LIBMODULES@ -## dynlib.o emacs-module.o if modules enabled, else empty +## emacs-module.o if modules enabled, else empty MODULES_OBJ = @MODULES_OBJ@ XRANDR_LIBS = @XRANDR_LIBS@ @@ -325,6 +325,11 @@ GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ LIB_GMP = @LIB_GMP@ +LIBGCCJIT = @LIBGCCJIT_LIB@ + +## dynlib.o if necessary, else empty +DYNLIB_OBJ = @DYNLIB_OBJ@ + RUN_TEMACS = ./temacs # Whether builds should contain details. '--no-build-details' or empty. @@ -413,7 +418,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \ cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \ alloc.o pdumper.o data.o doc.o editfns.o callint.o \ eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \ - syntax.o $(UNEXEC_OBJ) bytecode.o \ + syntax.o $(UNEXEC_OBJ) bytecode.o comp.o $(DYNLIB_OBJ) \ process.o gnutls.o callproc.o \ region-cache.o sound.o timefns.o atimer.o \ doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \ @@ -530,7 +535,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(LIB_GMP) + $(JSON_LIBS) $(LIB_GMP) $(LIBGCCJIT) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, @@ -580,7 +585,8 @@ endif ifeq ($(DUMPING),pdumper) $(pdmp): emacs$(EXEEXT) - LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump + LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \ + --bin-dest $(BIN_DESTDIR) --lisp-dest $(LISP_DESTDIR) cp -f $@ $(bootstrap_pdmp) endif @@ -783,6 +789,10 @@ tags: TAGS ../lisp/TAGS $(lwlibdir)/TAGS @$(MAKE) $(AM_V_NO_PD) -C ../lisp EMACS="$(bootstrap_exe)"\ THEFILE=$< $<c +%.eln: %.el | bootstrap-emacs$(EXEEXT) $(bootstrap_pdmp) + @$(MAKE) $(AM_V_NO_PD) -C ../lisp EMACS="$(bootstrap_exe)"\ + THEFILE=$< $<n + ## VCSWITNESS points to the file that holds info about the current checkout. ## We use it as a heuristic to decide when to rebuild loaddefs.el. ## If empty it is ignored; the parent makefile can set it to some other value. diff --git a/src/alloc.c b/src/alloc.c index ed30c449785..a31b4a045e2 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3149,6 +3149,26 @@ cleanup_vector (struct Lisp_Vector *vector) module_finalize_function (function); } #endif + else if (NATIVE_COMP_FLAG + && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT)) + { + struct Lisp_Native_Comp_Unit *cu = + PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit); + dispose_comp_unit (cu, true); + } + else if (NATIVE_COMP_FLAG + && PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR)) + { + struct Lisp_Subr *subr = + PSEUDOVEC_STRUCT (vector, Lisp_Subr); + if (!NILP (subr->native_comp_u[0])) + { + /* FIXME Alternative and non invasive solution to this + cast? */ + xfree ((char *)subr->symbol_name); + xfree (subr->native_c_name[0]); + } + } } /* Reclaim space used by unmarked vectors. */ @@ -6697,6 +6717,14 @@ mark_object (Lisp_Object arg) break; case PVEC_SUBR: + if (SUBR_NATIVE_COMPILEDP (obj)) + { + set_vector_marked (ptr); + struct Lisp_Subr *subr = XSUBR (obj); + mark_object (subr->native_intspec); + mark_object (subr->native_comp_u[0]); + mark_object (subr->lambda_list[0]); + } break; case PVEC_FREE: @@ -6841,7 +6869,9 @@ survives_gc_p (Lisp_Object obj) break; case Lisp_Vectorlike: - survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj)); + survives_p = + (SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) || + vector_marked_p (XVECTOR (obj)); break; case Lisp_Cons: @@ -7583,14 +7613,14 @@ N should be nonnegative. */); static union Aligned_Lisp_Subr Swatch_gc_cons_threshold = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_threshold }, - 4, 4, "watch_gc_cons_threshold", 0, 0}}; + 4, 4, "watch_gc_cons_threshold", {0}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_threshold.s); Fadd_variable_watcher (Qgc_cons_threshold, watcher); static union Aligned_Lisp_Subr Swatch_gc_cons_percentage = {{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) }, { .a4 = watch_gc_cons_percentage }, - 4, 4, "watch_gc_cons_percentage", 0, 0}}; + 4, 4, "watch_gc_cons_percentage", {0}, 0}}; XSETSUBR (watcher, &Swatch_gc_cons_percentage.s); Fadd_variable_watcher (Qgc_cons_percentage, watcher); } diff --git a/src/comp.c b/src/comp.c new file mode 100644 index 00000000000..704bd4b6b35 --- /dev/null +++ b/src/comp.c @@ -0,0 +1,5021 @@ +/* Compile elisp into native code. + Copyright (C) 2019-2020 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 "puresize.h" +#include "window.h" +#include "dynlib.h" +#include "buffer.h" +#include "blockinput.h" +#include "sha512.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_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_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_function_get_param +#undef gcc_jit_function_new_block +#undef gcc_jit_function_new_local +#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_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 (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)); +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_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)); +DEF_DLL_FN (gcc_jit_rvalue *, gcc_jit_context_new_rvalue_from_ptr, + (gcc_jit_context *ctxt, gcc_jit_type *pointer_type, void *value)); +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_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_struct_set_fields, + (gcc_jit_struct *struct_type, gcc_jit_location *loc, int num_fields, + gcc_jit_field **fields)); +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)); + +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_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); + LOAD_DLL_FN (library, gcc_jit_context_new_rvalue_from_ptr); + 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_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_pointer); + 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); + + 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_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_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 +#define gcc_jit_context_new_rvalue_from_ptr fn_gcc_jit_context_new_rvalue_from_ptr +#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_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 +#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_pointer fn_gcc_jit_type_get_pointer +#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 + +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 +} + + +/* C symbols emitted for the load relocation mechanism. */ +#define CURRENT_THREAD_RELOC_SYM "current_thread_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 COMP_SPEED XFIXNUM (Fsymbol_value (Qcomp_speed)) +#define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug)) + +#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 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; + +sigset_t saved_sigset; + +static f_reloc_t freloc; + +#define NUM_CAST_TYPES 15 + +enum cast_kind_of_type + { + kind_unsigned, + kind_signed, + kind_pointer + }; + +/* C side of the compiler context. */ + +typedef struct { + 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 *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 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]; + /* We add one to make space for the last member which is the "biggest_type" + member. */ + gcc_jit_type *cast_types[NUM_CAST_TYPES + 1]; + size_t cast_type_sizes[NUM_CAST_TYPES + 1]; + enum cast_kind_of_type cast_type_kind[NUM_CAST_TYPES + 1]; + const char *cast_type_names[NUM_CAST_TYPES + 1]; + gcc_jit_field *cast_union_fields[NUM_CAST_TYPES + 1]; + size_t cast_union_field_biggest_type; + 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). */ + 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. */ + gcc_jit_rvalue *data_relocs; + /* Same as before but can't go in pure space. */ + gcc_jit_rvalue *data_relocs_impure; + /* Same as before but content does not survive load phase. */ + gcc_jit_rvalue *data_relocs_ephemeral; + /* Synthesized struct holding func relocs. */ + gcc_jit_lvalue *func_relocs; + 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; + +FILE *logfile = NULL; + +/* This is used for serialized objects by the reload mechanism. */ +typedef struct { + ptrdiff_t len; + const char data[]; +} static_obj_t; + +typedef struct { + gcc_jit_rvalue *array; + gcc_jit_rvalue *idx; +} imm_reloc_t; + + +/* + Helper functions called by the run-time. +*/ + +void helper_unwind_protect (Lisp_Object handler); +Lisp_Object helper_temp_output_buffer_setup (Lisp_Object x); +Lisp_Object helper_unbind_n (Lisp_Object n); +void helper_save_restriction (void); +bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code); + +void *helper_link_table[] = + { wrong_type_argument, + helper_PSEUDOVECTOR_TYPEP_XUNTAG, + pure_write_error, + push_handler, + SETJMP_NAME, + record_unwind_protect_excursion, + helper_unbind_n, + helper_save_restriction, + 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; +} + +/* Produce a key hashing Vcomp_subr_list. */ + +void +hash_native_abi (void) +{ + Lisp_Object string = Fmapconcat (intern_c_string ("subr-name"), + Vcomp_subr_list, build_string (" ")); + Lisp_Object digest = make_uninit_string (SHA512_DIGEST_SIZE * 2); + + sha512_buffer (SSDATA (string), SCHARS (string), SSDATA (digest)); + hexbuf_digest (SSDATA (digest), SDATA (digest), SHA512_DIGEST_SIZE); + + /* Check runs once. */ + eassert (NILP (Vcomp_abi_hash)); + Vcomp_abi_hash = digest; + /* If 10 characters are usually sufficient for git I guess 16 are + fine for us here. */ + Vcomp_native_path_postfix = + concat3 (make_string ("eln-", 4), + Vsystem_configuration, + concat2 (make_string ("-", 1), + Fsubstring_no_properties (Vcomp_abi_hash, + make_fixnum (0), + make_fixnum (16)))); +} + +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)) + xsignal1 (Qnative_ice, build_string ("missing basic block")); + + 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; + } + + return comp.frame[XFIXNUM (mvar_slot)]; +} + +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: + 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_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 + { + gcc_jit_lvalue *f_ptr = + gcc_jit_rvalue_dereference_field ( + gcc_jit_lvalue_as_rvalue (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); + + if (comp.cast_type_sizes[old_index] < comp.cast_type_sizes[new_index] + && comp.cast_type_kind[new_index] == kind_signed) + xsignal3 (Qnative_ice, + build_string ("FIXME: sign extension not implemented"), + build_string (comp.cast_type_names[old_index]), + build_string (comp.cast_type_names[new_index])); + + /* 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_unsigned_long_long (gcc_jit_type *type, unsigned long long n) +{ + emit_comment (format_string ("emit unsigned long long: %llu", n)); + + gcc_jit_rvalue *high = + gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.unsigned_long_long_type, + 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) +{ + if (val != (long) val) + return emit_rvalue_from_unsigned_long_long (comp.emacs_uint_type, val); + else + 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) val) + 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) +{ + if (val != (long) val) + return emit_rvalue_from_unsigned_long_long (comp.lisp_word_tag_type, val); + else + 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) val) + return emit_rvalue_from_unsigned_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_EQ (gcc_jit_rvalue *x, gcc_jit_rvalue *y) +{ + emit_comment ("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_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_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 arithmetics). */ + + 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)))); + + imm_reloc_t reloc = obj_to_reloc (obj); + return gcc_jit_context_new_array_access (comp.ctxt, + NULL, + reloc.array, + 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)))); + + if (EQ (obj, Qnil)) + { + 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_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 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-mvar-const-vld, mvar); + Lisp_Object constant = CALL1I (comp-mvar-constant, mvar); + + if (!NILP (const_vld)) + { + if (COMP_DEBUG > 1) + { + Lisp_Object func = + Fgethash (constant, + CALL1I (comp-ctxt-byte-func-to-func-h, Vcomp_ctxt), + Qnil); + + emit_comment ( + SSDATA ( + Fprin1_to_string ( + NILP (func) ? constant : CALL1I (comp-func-c-name, func), + Qnil))); + } + if (FIXNUMP (constant)) + { + /* We can still emit directly objects that are self-contained in a + word (read fixnums). */ + return emit_rvalue_from_lisp_obj (constant); + } + /* Other const objects are fetched from the reloc array. */ + return emit_lisp_obj_rval (constant); + } + + 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}; + return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, + false); +#else + /* _setjmp (buf, __builtin_frame_address (0)) */ + 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; + return emit_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 2, args, + false); +#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]); + + emit_cond_jump (emit_EQ (a, b), target2, target1); + } + 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)); + 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, target2, target1); + } + else if (EQ (op, Qphi)) + { + /* Nothing to do for phis into 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]); + 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])); + 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))); + 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, + 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 + { + 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 type_hint = EQ (CALL1I (comp-mvar-type, SECOND (insn)), type); + gcc_jit_rvalue *args[] = + { emit_mvar_rval (SECOND (insn)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.bool_type, + type_hint) }; + + 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 type_hint = EQ (CALL1I (comp-mvar-type, 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, + type_hint) }; + + 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. */ +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 */ + + ptrdiff_t 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); + unbind_to (count, Qnil); + + ptrdiff_t len = SBYTES (str); + const char *p = SSDATA (str); + + 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), + 2, 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); +} + +static gcc_jit_rvalue * +declare_imported_data_relocs (Lisp_Object container, const char *code_symbol, + const char *text_symbol) +{ + /* Imported objects. */ + EMACS_INT d_reloc_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); + + gcc_jit_rvalue *reloc_struct = + 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, + d_reloc_len), + code_symbol)); + + emit_static_object (text_symbol, d_reloc); + + return reloc_struct; +} + +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. +*/ +static Lisp_Object +declare_runtime_imported_funcs (void) +{ + Lisp_Object field_list = Qnil; + +#define ADD_IMPORTED(f_name, ret_type, nargs, args) \ + { \ + 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); + +#ifndef WINDOWSNT + args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); + ADD_IMPORTED (SETJMP_NAME, comp.int_type, 1, args); +#else + args[0] = gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.jmp_buf_s)); + args[1] = comp.void_ptr_type; + ADD_IMPORTED (SETJMP_NAME, comp.int_type, 2, args); +#endif + + 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); + + 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 (Qcomp_speed, + Fsymbol_value (Qcomp_speed)), + Fcons (Qcomp_debug, + Fsymbol_value (Qcomp_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.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, + gcc_jit_type_get_pointer (comp.lisp_obj_ptr_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 = + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (f_reloc_struct)), + 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); + +} + +/* 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)); +} + +struct cast_type +{ + gcc_jit_type *type; + const char *name; + size_t bytes_size; + enum cast_kind_of_type kind; +}; + +static gcc_jit_function * +define_cast_from_to (struct cast_type from, int from_index, struct cast_type to, + int to_index) +{ + /* FIXME: sign extension not implemented. */ + if (comp.cast_type_sizes[from_index] < comp.cast_type_sizes[to_index] + && comp.cast_type_kind[to_index] == kind_signed) + return NULL; + + 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_lvalue *tmp_union + = gcc_jit_function_new_local (result, + NULL, + comp.cast_union_type, + "union_cast"); + + /* Zero the union first. */ + gcc_jit_block_add_assignment (entry_block, NULL, + gcc_jit_lvalue_access_field (tmp_union, NULL, + comp.cast_union_fields[NUM_CAST_TYPES]), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.cast_types[NUM_CAST_TYPES], + 0)); + + gcc_jit_block_add_assignment (entry_block, NULL, + gcc_jit_lvalue_access_field (tmp_union, NULL, + comp.cast_union_fields[from_index]), + 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, + comp.cast_union_fields[to_index])); + + return result; +} + +static void +define_cast_functions (void) +{ + struct cast_type cast_types[NUM_CAST_TYPES] + = { { comp.bool_type, "bool", sizeof (bool), kind_unsigned }, + { comp.char_ptr_type, "char_ptr", sizeof (char *), kind_pointer }, + { comp.int_type, "int", sizeof (int), kind_signed }, + { comp.lisp_cons_ptr_type, "cons_ptr", sizeof (struct Lisp_Cons *), + kind_pointer }, + { comp.lisp_obj_ptr_type, "lisp_obj_ptr", sizeof (Lisp_Object *), + kind_pointer }, + { comp.lisp_word_tag_type, "lisp_word_tag", sizeof (Lisp_Word_tag), + kind_unsigned }, + { comp.lisp_word_type, "lisp_word", sizeof (Lisp_Word), + LISP_WORDS_ARE_POINTERS ? kind_pointer : kind_signed }, + { comp.long_long_type, "long_long", sizeof (long long), kind_signed }, + { comp.long_type, "long", sizeof (long), kind_signed }, + { comp.ptrdiff_type, "ptrdiff", sizeof (ptrdiff_t), kind_signed }, + { comp.uintptr_type, "uintptr", sizeof (uintptr_t), kind_unsigned }, + { comp.unsigned_long_long_type, "unsigned_long_long", + sizeof (unsigned long long), kind_unsigned }, + { comp.unsigned_long_type, "unsigned_long", sizeof (unsigned long), + kind_unsigned }, + { comp.unsigned_type, "unsigned", sizeof (unsigned), kind_unsigned }, + { comp.void_ptr_type, "void_ptr", sizeof (void*), kind_pointer } }; + + /* Find the biggest size. It should be unsigned long long, but to be + sure we find it programmatically. */ + size_t biggest_size = 0; + for (int i = 0; i < NUM_CAST_TYPES; ++i) + biggest_size = max (biggest_size, cast_types[i].bytes_size); + + /* Define the union used for casting. */ + for (int i = 0; i < NUM_CAST_TYPES; ++i) + { + comp.cast_types[i] = cast_types[i].type; + comp.cast_union_fields[i] = gcc_jit_context_new_field (comp.ctxt, + NULL, + cast_types[i].type, + cast_types[i].name); + comp.cast_type_names[i] = cast_types[i].name; + comp.cast_type_sizes[i] = cast_types[i].bytes_size; + comp.cast_type_kind[i] = cast_types[i].kind; + } + + gcc_jit_type *biggest_type = gcc_jit_context_get_int_type (comp.ctxt, + biggest_size, + false); + comp.cast_types[NUM_CAST_TYPES] = biggest_type; + comp.cast_union_fields[NUM_CAST_TYPES] = + gcc_jit_context_new_field (comp.ctxt, NULL, biggest_type, "biggest_type"); + comp.cast_type_names[NUM_CAST_TYPES] = "biggest_type"; + comp.cast_type_sizes[NUM_CAST_TYPES] = biggest_size; + comp.cast_type_kind[NUM_CAST_TYPES] = kind_unsigned; + + comp.cast_union_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + NUM_CAST_TYPES + 1, + comp.cast_union_fields); + + /* 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], i, cast_types[j], 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_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 intepreter (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; + char *c_name = SSDATA (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)); + 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, + 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, + 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; + EMACS_INT frame_size = XFIXNUM (CALL1I (comp-func-frame-size, func)); + + 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.frame = SAFE_ALLOCA (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, + frame_size), + "frame"); + + for (ptrdiff_t i = 0; i < 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 < 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); + Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil); + struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block = HASH_VALUE (ht, i); + if (!EQ (block, entry_block)) + declare_block (HASH_KEY (ht, i)); + } + + for (ptrdiff_t i = 0; i < ht->count; i++) + { + Lisp_Object block_name = HASH_KEY (ht, i); + 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. */ +/**********************************/ + +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 (); + + if (COMP_DEBUG) + { + gcc_jit_context_set_bool_option (comp.ctxt, + GCC_JIT_BOOL_OPTION_DEBUGINFO, + 1); + } + if (COMP_DEBUG > 2) + { + logfile = 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); + } + + 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.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_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; +} + +static void +restore_sigmask (void) +{ + pthread_sigmask (SIG_SETMASK, &saved_sigset, 0); + unblock_input (); +} + +DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, + Scomp__compile_ctxt_to_file, + 1, 1, 0, + doc: /* Compile as native code the current context to file. */) + (Lisp_Object base_name) +{ + load_gccjit_if_necessary (true); + + CHECK_STRING (base_name); + + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + COMP_SPEED < 0 ? 0 + : (COMP_SPEED > 3 ? 3 : COMP_SPEED)); + 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)); + + sigset_t oldset; + ptrdiff_t count = 0; + + if (!noninteractive) + { + sigset_t blocked; + /* Gcc doesn't like being interrupted at all. */ + block_input (); + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); +#ifdef USABLE_SIGIO + sigaddset (&blocked, SIGIO); +#endif + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + count = SPECPDL_INDEX (); + record_unwind_protect_void (restore_sigmask); + } + emit_ctxt_code (); + + /* Define inline functions. */ + define_CAR_CDR (); + define_PSEUDOVECTORP (); + define_CHECK_TYPE (); + 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 < func_h->count; i++) + 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 < func_h->count; i++) + compile_function (HASH_VALUE (func_h, i)); + + if (COMP_DEBUG) + gcc_jit_context_dump_to_file (comp.ctxt, + format_string ("%s.c", SSDATA (base_name)), + 1); + if (COMP_DEBUG > 2) + gcc_jit_context_dump_reproducer_to_file (comp.ctxt, "comp_reproducer.c"); + + AUTO_STRING (dot_so, NATIVE_ELISP_SUFFIX); + + Lisp_Object out_file = CALLN (Fconcat, base_name, dot_so); + Lisp_Object tmp_file = + Fmake_temp_file_internal (base_name, Qnil, dot_so, Qnil); + gcc_jit_context_compile_to_file (comp.ctxt, + GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY, + SSDATA (tmp_file)); + + CALL2I (comp--replace-output-file, out_file, tmp_file); + + if (!noninteractive) + unbind_to (count, Qnil); + + return out_file; +} + +DEFUN ("comp-libgccjit-version", Fcomp_libgccjit_version, + Scomp_libgccjit_version, 0, 0, 0, + doc: /* Return the libgccjit version in use in the form +(MAJOR MINOR PATCHLEVEL) or nil if unknown (pre GCC10). */) + (void) +{ +#if defined (LIBGCCJIT_HAVE_gcc_jit_version) || defined (WINDOWSNT) + load_gccjit_if_necessary (true); + + /* FIXME this kludge is quite bad. Can we dynamically load on all + operating systems? */ +#pragma GCC diagnostic ignored "-Waddress" + 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; +#pragma GCC diagnostic pop +#else + return Qnil; +#endif +} + + +/******************************************************************************/ +/* Helper functions called from the run-time. */ +/* These can't be statics till shared mechanism is used to solve relocations. */ +/* Note: this are all potentially definable directly to gcc and are here just */ +/* for laziness. Change this if a performance impact is measured. */ +/******************************************************************************/ + +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); +} + +Lisp_Object +helper_temp_output_buffer_setup (Lisp_Object x) +{ + CHECK_STRING (x); + temp_output_buffer_setup (SSDATA (x)); + return Vstandard_output; +} + +Lisp_Object +helper_unbind_n (Lisp_Object n) +{ + return unbind_to (SPECPDL_INDEX () - XFIXNUM (n), Qnil); +} + +void +helper_save_restriction (void) +{ + record_unwind_protect (save_restriction_restore, + save_restriction_save ()); +} + +bool +helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code) +{ + return PSEUDOVECTOR_TYPEP (XUNTAG (a, Lisp_Vectorlike, + union vectorlike_header), + code); +} + + +/*********************************/ +/* Disposal of compilation units */ +/*********************************/ + +/* + The problem: Windows does not let us delete an .eln file that has + been loaded by a process. This has two implications in Emacs: + + 1) It is not possible to recompile a lisp file if the corresponding + .eln file has been loaded. This is because we'd like to use the same + filename, but we can't delete the old .eln file. + + 2) It is not possible to delete a package using `package-delete' + if an .eln file has been loaded. + + * General idea + + The solution to these two problems is to move the foo.eln file + somewhere else and have the last Emacs instance using it delete it. + To make it easy to find what files need to be removed we use two approaches. + + In the 1) case we rename foo.eln to fooXXXXXX.eln.old in the same + folder. When Emacs is unloading "foo" (either GC'd the native + compilation unit or Emacs is closing (see below)) we delete all the + .eln.old files in the folder where the original foo.eln was stored. + + Ideally we'd figure out the new name of foo.eln and delete it if it + ends in .eln.old. There is no simple API to do this in Windows. + GetModuleFileName () returns the original filename, not the current + one. This forces us to put .eln.old files in an agreed upon path. + We cannot use %TEMP% because it may be in another drive and then the + rename operation would fail. + + In the 2) case we can't use the same folder where the .eln file + resided, as we are trying to completely remove the package. Since we + are removing packages we can safely move the .eln.old file to + `package-user-dir' as we are sure that that would not mean changing + drives. + + * Implementation details + + The concept of disposal of a native compilation unit refers to + unloading the shared library and deleting all the .eln.old files in + the directory. These are two separate steps. We'll call them + early-disposal and late-disposal. + + There are two data structures used: + + - The `all_loaded_comp_units_h` hashtable. + + This hashtable is used like an array of weak references to native + compilation units. This hash table is filled by load_comp_unit () + and dispose_all_remaining_comp_units () iterates over all values + that were not disposed by the GC and performs all disposal steps + when Emacs is closing. + + - The `delayed_comp_unit_disposal_list` list. + + This is were the dispose_comp_unit () function, when called by the + GC sweep stage, stores the original filenames of the disposed native + compilation units. This is an ad-hoc C structure instead of a Lisp + cons because we need to allocate instances of this structure during + the GC. + + The finish_delayed_disposal_of_comp_units () function will iterate + over this list and perform the late-disposal step when Emacs is + closing. + +*/ + +#ifdef WINDOWSNT +#define OLD_ELN_SUFFIX_REGEXP build_string ("\\.eln\\.old\\'") + +static Lisp_Object all_loaded_comp_units_h; + +/* We need to allocate instances of this struct during a GC sweep. + This is why it can't be transformed into a simple cons. */ +struct delayed_comp_unit_disposal +{ + struct delayed_comp_unit_disposal *next; + char *filename; +}; + +struct delayed_comp_unit_disposal *delayed_comp_unit_disposal_list; + +static Lisp_Object +return_nil (Lisp_Object arg) +{ + return Qnil; +} + +/* Tries to remove all *.eln.old files in DIRNAME. + + Any error is ignored because it may be due to the file being loaded + in another Emacs instance. */ +static void +clean_comp_unit_directory (Lisp_Object dirpath) +{ + if (NILP (dirpath)) + return; + Lisp_Object files_in_dir; + files_in_dir = internal_condition_case_4 (Fdirectory_files, dirpath, Qt, + OLD_ELN_SUFFIX_REGEXP, Qnil, Qt, + return_nil); + FOR_EACH_TAIL (files_in_dir) { DeleteFile (SSDATA (XCAR (files_in_dir))); } +} + +/* Tries to remove all *.eln.old files in `package-user-dir'. + + This is called when Emacs is closing to clean any *.eln left from a + deleted package. */ +void +clean_package_user_dir_of_old_comp_units (void) +{ + Lisp_Object package_user_dir + = find_symbol_value (intern ("package-user-dir")); + if (EQ (package_user_dir, Qunbound) || !STRINGP (package_user_dir)) + return; + + clean_comp_unit_directory (package_user_dir); +} + +/* This function disposes all compilation units that are still loaded. + + It is important that this function is called only right before + Emacs is closed, otherwise we risk running a subr that is + implemented in an unloaded dynamic library. */ +void +dispose_all_remaining_comp_units (void) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (all_loaded_comp_units_h); + + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + { + Lisp_Object k = HASH_KEY (h, i); + if (!EQ (k, Qunbound)) + { + Lisp_Object val = HASH_VALUE (h, i); + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (val); + dispose_comp_unit (cu, false); + } + } +} + +/* This function finishes the disposal of compilation units that were + passed to `dispose_comp_unit` with DELAY == true. + + This function is called when Emacs is idle and when it is about to + close. */ +void +finish_delayed_disposal_of_comp_units (void) +{ + for (struct delayed_comp_unit_disposal *item + = delayed_comp_unit_disposal_list; + delayed_comp_unit_disposal_list; item = delayed_comp_unit_disposal_list) + { + delayed_comp_unit_disposal_list = item->next; + Lisp_Object dirname = internal_condition_case_1 ( + Ffile_name_directory, build_string (item->filename), Qt, return_nil); + clean_comp_unit_directory (dirname); + xfree (item->filename); + xfree (item); + } +} +#endif + +/* This function puts the compilation unit in the + `all_loaded_comp_units_h` hashmap. */ +static void +register_native_comp_unit (Lisp_Object comp_u) +{ +#ifdef WINDOWSNT + /* We have to do this since we can't use `gensym'. This function is + called early when loading a dump file and subr.el may not have + been loaded yet. */ + static intmax_t count; + + Fputhash (make_int (count++), comp_u, all_loaded_comp_units_h); +#endif +} + +/* This function disposes compilation units. It is called during the GC sweep + stage and when Emacs is closing. + + On Windows the the DELAY parameter specifies whether the native + compilation file will be deleted right away (if necessary) or put + on a list. That list will be dealt with by + `finish_delayed_disposal_of_comp_units`. */ +void +dispose_comp_unit (struct Lisp_Native_Comp_Unit *comp_handle, bool delay) +{ + eassert (comp_handle->handle); + dynlib_close (comp_handle->handle); +#ifdef WINDOWSNT + if (!delay) + { + Lisp_Object dirname = internal_condition_case_1 ( + Ffile_name_directory, build_string (comp_handle->cfile), Qt, + return_nil); + if (!NILP (dirname)) + clean_comp_unit_directory (dirname); + xfree (comp_handle->cfile); + comp_handle->cfile = NULL; + } + else + { + struct delayed_comp_unit_disposal *head; + head = xmalloc (sizeof (struct delayed_comp_unit_disposal)); + head->next = delayed_comp_unit_disposal_list; + head->filename = comp_handle->cfile; + comp_handle->cfile = NULL; + delayed_comp_unit_disposal_list = head; + } +#endif +} + + +/***********************************/ +/* Deferred compilation mechanism. */ +/***********************************/ + +/* List of sources we'll compile and load after having conventionally + loaded the compiler and its dependencies. */ +static Lisp_Object delayed_sources; + + +/* Queue an asyncronous 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 (!comp_deferred_compilation + || noninteractive + || !NILP (Vpurify_flag) + || !COMPILEDP (definition) + || !STRINGP (Vload_true_file_name) + || !suffix_p (Vload_true_file_name, ".elc")) + 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))) + return; + + /* This is to have deferred compilaiton able to compile comp + dependecies breaking circularity. */ + if (!NILP (Ffeaturep (Qcomp, Qnil))) + { + /* Comp already loaded. */ + if (!NILP (delayed_sources)) + { + CALLN (Ffuncall, intern_c_string ("native-compile-async"), + delayed_sources, Qnil, Qlate); + delayed_sources = Qnil; + } + Fputhash (function_name, definition, Vcomp_deferred_pending_h); + CALLN (Ffuncall, intern_c_string ("native-compile-async"), src, Qnil, + Qlate); + } + else + { + delayed_sources = Fcons (src, delayed_sources); + /* Require comp only once. */ + static bool comp_required = false; + if (!comp_required) + { + comp_required = true; + Frequire (Qcomp, Qnil, Qnil); + } + } +} + + +/**************************************/ +/* Functions used to load eln files. */ +/**************************************/ + +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 *(*f)(void) = dynlib_sym (comp_u->handle, name); + if (!f) + xsignal1 (Qnative_lisp_file_inconsistent, comp_u->file); + + static_obj_t *res = f (); + return Fread (make_string (res->data, res->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 (EMACS_INT 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 (EMACS_INT 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; +} + +void +load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump, + bool late_load) +{ + 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 (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; + ptrdiff_t 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); + 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 + && 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; + *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 we register them while dumping we will get some entries in + the hash table that will be duplicated when pdumper calls + load_comp_unit. */ + if (!will_dump_p ()) + register_native_comp_unit (comp_u_lisp_obj); + } + + 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; + /* 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 importanly would lead to crashed if the contained data + is not cons hashed. */ + if (!recursive_load) + { + Lisp_Object volatile 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. */ + 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); + + return; +} + +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 doc_idx, Lisp_Object intspec, + 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. */ + x->s.lambda_list[0] = maxarg; + maxarg = XCDR (minarg); + minarg = XCAR (minarg); + } + else + x->s.lambda_list[0] = Qnil; + 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.native_intspec = intspec; + x->s.doc = XFIXNUM (doc_idx); + x->s.native_comp_u[0] = comp_u; + x->s.native_c_name[0] = xstrdup (SSDATA (c_name)); + Lisp_Object tem; + XSETSUBR (tem, &x->s); + + return tem; +} + +DEFUN ("comp--register-lambda", Fcomp__register_lambda, Scomp__register_lambda, + 7, 7, 0, + doc: /* This gets called by top_level_run during load phase to register + anonymous lambdas. */) + (Lisp_Object reloc_idx, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) +{ + 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, doc_idx, intspec, 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: /* This gets called by top_level_run during load phase to register + each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc_idx, Lisp_Object intspec, + Lisp_Object comp_u) +{ + Lisp_Object tem = + make_subr (SYMBOL_NAME (name), minarg, maxarg, c_name, doc_idx, intspec, + comp_u); + + LOADHIST_ATTACH (Fcons (Qdefun, name)); + + { /* Handle automatic advice activation (bug#42038). + See `defalias'. */ + Lisp_Object hook = Fget (name, Qdefalias_fset_function); + if (!NILP (hook)) + call2 (hook, name, tem); + else + Ffset (name, tem); + } + + return tem; +} + +DEFUN ("comp--late-register-subr", Fcomp__late_register_subr, + Scomp__late_register_subr, 7, 7, 0, + doc: /* This gets called by late_top_level_run during load + phase to register each exported subr. */) + (Lisp_Object name, Lisp_Object minarg, Lisp_Object maxarg, + Lisp_Object c_name, Lisp_Object doc, Lisp_Object intspec, + Lisp_Object comp_u) +{ + if (!NILP (Fequal (Fsymbol_function (name), + Fgethash (name, Vcomp_deferred_pending_h, Qnil)))) + Fcomp__register_subr (name, minarg, maxarg, c_name, doc, intspec, comp_u); + Fremhash (name, Vcomp_deferred_pending_h); + return Qnil; +} + +/* Load related routines. */ +DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0, + doc: /* Load native elisp code FILE. + LATE_LOAD has to be non nil when loading for deferred + compilation. */) + (Lisp_Object file, Lisp_Object late_load) +{ + CHECK_STRING (file); + if (NILP (Ffile_exists_p (file))) + xsignal2 (Qnative_lisp_load_failed, build_string ("file does not exists"), + file); + struct Lisp_Native_Comp_Unit *comp_u = allocate_native_comp_unit (); + comp_u->handle = dynlib_open (SSDATA (file)); + if (!comp_u->handle) + xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ())); + comp_u->file = file; +#ifdef WINDOWSNT + comp_u->cfile = xlispstrdup (file); +#endif + 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); + load_comp_unit (comp_u, false, !NILP (late_load)); + + return Qt; +} + +#endif /* HAVE_NATIVE_COMP */ + +DEFUN ("native-comp-available-p", Fnative_comp_available_p, + Snative_comp_available_p, 0, 0, 0, + doc: /* Returns t if native compilation of Lisp files is available in +this instance of Emacs. */) + (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 + /* Compiler control customizes. */ + DEFVAR_BOOL ("comp-deferred-compilation", comp_deferred_compilation, + doc: /* If t compile asyncronously every .elc file loaded. */); + DEFSYM (Qcomp_speed, "comp-speed"); + DEFSYM (Qcomp_debug, "comp-debug"); + + /* 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 (Qsetimm, "setimm"); + DEFSYM (Qreturn, "return"); + 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"); + + /* 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"); + + /* 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__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 (&delayed_sources); + delayed_sources = Qnil; + +#ifdef WINDOWSNT + staticpro (&all_loaded_comp_units_h); + all_loaded_comp_units_h = CALLN (Fmake_hash_table, QCweakness, Qvalue); +#endif + + 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 ABI exposed to .eln files. */); + Vcomp_abi_hash = Qnil; + DEFVAR_LISP ("comp-native-path-postfix", Vcomp_native_path_postfix, + doc: /* Postifix to be added to the .eln compilation path. */); + Vcomp_native_path_postfix = Qnil; + + DEFVAR_LISP ("comp-deferred-pending-h", Vcomp_deferred_pending_h, + doc: /* Hash table symbol-name -> function-value. For + internal use during */); + Vcomp_deferred_pending_h = CALLN (Fmake_hash_table, QCtest, Qeq); + +#endif /* #ifdef HAVE_NATIVE_COMP */ + + defsubr (&Snative_comp_available_p); +} diff --git a/src/comp.h b/src/comp.h new file mode 100644 index 00000000000..687e426b1ef --- /dev/null +++ b/src/comp.h @@ -0,0 +1,133 @@ +/* Elisp native compiler definitions +Copyright (C) 2019-2020 Free Software Foundation, Inc. + +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/>. */ + +#ifndef COMP_H +#define COMP_H + +/* To keep ifdefs under control. */ +enum { + NATIVE_COMP_FLAG = +#ifdef HAVE_NATIVE_COMP + 1 +#else + 0 +#endif +}; + +#include <dynlib.h> + +struct Lisp_Native_Comp_Unit +{ + union vectorlike_header header; + /* Original eln file loaded. */ + Lisp_Object file; + Lisp_Object optimize_qualities; + /* Guard anonymous lambdas against Garbage Collection and serve + sanity checks. */ + Lisp_Object lambda_gc_guard_h; + /* Hash c_name -> d_reloc_imp index. */ + Lisp_Object lambda_c_name_idx_h; + /* Hash doc-idx -> function documentaiton. */ + Lisp_Object data_fdoc_v; + /* Analogous to the constant vector but per compilation unit. */ + Lisp_Object data_vec; + /* 'data_impure_vec' must be last (see allocate_native_comp_unit). + Same as data_vec but for data that cannot be moved to pure space. */ + Lisp_Object data_impure_vec; + /* STUFFS WE DO NOT DUMP!! */ + Lisp_Object *data_imp_relocs; + bool loaded_once; + bool load_ongoing; + dynlib_handle_ptr handle; +#ifdef WINDOWSNT + /* We need to store a copy of the original file name in memory that + is not subject to GC because the function to dispose native + compilation units is called by the GC. By that time the `file' + string may have been sweeped. */ + char *cfile; +#endif +} GCALIGNED_STRUCT; + +#ifdef HAVE_NATIVE_COMP + +INLINE bool +NATIVE_COMP_UNITP (Lisp_Object a) +{ + return PSEUDOVECTORP (a, PVEC_NATIVE_COMP_UNIT); +} + +INLINE struct Lisp_Native_Comp_Unit * +XNATIVE_COMP_UNIT (Lisp_Object a) +{ + eassert (NATIVE_COMP_UNITP (a)); + return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Comp_Unit); +} + +/* Defined in comp.c. */ + +extern void hash_native_abi (void); + +extern void load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, + bool loading_dump, bool late_load); + +extern Lisp_Object native_function_doc (Lisp_Object function); + +extern void syms_of_comp (void); + +extern void maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition); + +extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, + bool delay); + +extern void finish_delayed_disposal_of_comp_units (void); + +extern void dispose_all_remaining_comp_units (void); + +extern void clean_package_user_dir_of_old_comp_units (void); + +#else /* #ifdef HAVE_NATIVE_COMP */ + +static inline void +maybe_defer_native_compilation (Lisp_Object function_name, + Lisp_Object definition) +{} + +extern void syms_of_comp (void); + +static inline void +dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle, bool delay) +{ + eassert (false); +} + +static inline void +dispose_all_remaining_comp_units (void) +{} + +static inline void +clean_package_user_dir_of_old_comp_units (void) +{} + +static inline void +finish_delayed_disposal_of_comp_units (void) +{} + +#endif /* #ifdef HAVE_NATIVE_COMP */ + +#endif /* #ifndef COMP_H */ diff --git a/src/data.c b/src/data.c index 1db0a983b49..3088487c60c 100644 --- a/src/data.c +++ b/src/data.c @@ -259,6 +259,8 @@ for example, (type-of 1) returns `integer'. */) } case PVEC_MODULE_FUNCTION: return Qmodule_function; + case PVEC_NATIVE_COMP_UNIT: + return Qnative_comp_unit; case PVEC_XWIDGET: return Qxwidget; case PVEC_XWIDGET_VIEW: @@ -824,6 +826,8 @@ The return value is undefined. */) Ffset (symbol, definition); } + maybe_defer_native_compilation (symbol, definition); + if (!NILP (docstring)) Fput (symbol, Qfunction_documentation, docstring); /* We used to return `definition', but now that `defun' and `defmacro' expand @@ -870,6 +874,45 @@ SUBR must be a built-in function. */) return build_string (name); } +DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1, + 0, doc: /* Return t if the object is native compiled lisp function, +nil otherwise. */) + (Lisp_Object object) +{ + return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil; +} + +#ifdef HAVE_NATIVE_COMP +DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit, + Ssubr_native_comp_unit, 1, 1, 0, + doc: /* Return the native compilation unit. */) + (Lisp_Object subr) +{ + CHECK_SUBR (subr); + return XSUBR (subr)->native_comp_u[0]; +} + +DEFUN ("native-comp-unit-file", Fnative_comp_unit_file, + Snative_comp_unit_file, 1, 1, 0, + doc: /* Return the file of the native compilation unit. */) + (Lisp_Object comp_unit) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + return XNATIVE_COMP_UNIT (comp_unit)->file; +} + +DEFUN ("native-comp-unit-set-file", Fnative_comp_unit_set_file, + Snative_comp_unit_set_file, 2, 2, 0, + doc: /* Return the file of the native compilation unit. */) + (Lisp_Object comp_unit, Lisp_Object new_file) +{ + CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit); + XNATIVE_COMP_UNIT (comp_unit)->file = new_file; + return comp_unit; +} + +#endif + DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0, doc: /* Return the interactive form of CMD or nil if none. If CMD is not a command, the return value is nil. @@ -895,6 +938,9 @@ Value, if non-nil, is a list (interactive SPEC). */) if (SUBRP (fun)) { + if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->native_intspec)) + return XSUBR (fun)->native_intspec; + const char *spec = XSUBR (fun)->intspec; if (spec) return list2 (Qinteractive, @@ -3857,6 +3903,7 @@ syms_of_data (void) DEFSYM (Qoverlay, "overlay"); DEFSYM (Qfinalizer, "finalizer"); DEFSYM (Qmodule_function, "module-function"); + DEFSYM (Qnative_comp_unit, "native-comp-unit"); DEFSYM (Quser_ptr, "user-ptr"); DEFSYM (Qfloat, "float"); DEFSYM (Qwindow_configuration, "window-configuration"); @@ -3978,6 +4025,12 @@ syms_of_data (void) defsubr (&Sbyteorder); defsubr (&Ssubr_arity); defsubr (&Ssubr_name); + defsubr (&Ssubr_native_elisp_p); +#ifdef HAVE_NATIVE_COMP + defsubr (&Ssubr_native_comp_unit); + defsubr (&Snative_comp_unit_file); + defsubr (&Snative_comp_unit_set_file); +#endif #ifdef HAVE_MODULES defsubr (&Suser_ptrp); #endif diff --git a/src/doc.c b/src/doc.c index 285c0dbbbee..31ccee8079b 100644 --- a/src/doc.c +++ b/src/doc.c @@ -335,6 +335,11 @@ string is passed through `substitute-command-keys'. */) xsignal1 (Qvoid_function, function); if (CONSP (fun) && EQ (XCAR (fun), Qmacro)) fun = XCDR (fun); +#ifdef HAVE_NATIVE_COMP + if (!NILP (Fsubr_native_elisp_p (fun))) + doc = native_function_doc (fun); + else +#endif if (SUBRP (fun)) doc = make_fixnum (XSUBR (fun)->doc); #ifdef HAVE_MODULES @@ -505,10 +510,11 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset) XSETCAR (tem, make_fixnum (offset)); } } - /* Lisp_Subrs have a slot for it. */ - else if (SUBRP (fun)) - XSUBR (fun)->doc = offset; + else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun)) + { + XSUBR (fun)->doc = offset; + } /* Bytecode objects sometimes have slots for it. */ else if (COMPILEDP (fun)) diff --git a/src/dynlib.c b/src/dynlib.c index 4919d5cc726..b3fd815e68c 100644 --- a/src/dynlib.c +++ b/src/dynlib.c @@ -301,15 +301,11 @@ dynlib_error (void) return dlerror (); } -/* FIXME: Currently there is no way to unload a module, so this - function is never used. */ -#if false int dynlib_close (dynlib_handle_ptr h) { return dlclose (h) == 0; } -#endif #else diff --git a/src/emacs.c b/src/emacs.c index 45a215b66e2..228ac293370 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -411,34 +411,35 @@ terminate_due_to_signal (int sig, int backtrace_limit) /* This shouldn't be executed, but it prevents a warning. */ exit (1); } - -/* Code for dealing with Lisp access to the Unix command line. */ -static void -init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) +/* Set `invocation-name' `invocation-directory'. */ + +void +set_invocation_vars (char *argv0, char const *original_pwd) { - int i; - Lisp_Object name, dir, handler; - ptrdiff_t count = SPECPDL_INDEX (); - Lisp_Object raw_name; + /* This function can be called from within pdumper or later during + boot. No need to run it twice. */ + static bool double_run_guard; + if (double_run_guard) + return; + double_run_guard = true; + + Lisp_Object raw_name, handler; AUTO_STRING (slash_colon, "/:"); - initial_argv = argv; - initial_argc = argc; - #ifdef WINDOWSNT - /* Must use argv[0] converted to UTF-8, as it begets many standard + /* Must use argv0 converted to UTF-8, as it begets many standard file and directory names. */ { - char argv0[MAX_UTF8_PATH]; + char argv0_1[MAX_UTF8_PATH]; - if (filename_from_ansi (argv[0], argv0) == 0) - raw_name = build_unibyte_string (argv0); + if (filename_from_ansi (argv0, argv0_1) == 0) + raw_name = build_unibyte_string (argv0_1); else - raw_name = build_unibyte_string (argv[0]); + raw_name = build_unibyte_string (argv0); } #else - raw_name = build_unibyte_string (argv[0]); + raw_name = build_unibyte_string (argv0); #endif /* Add /: to the front of the name @@ -450,7 +451,7 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) Vinvocation_name = Ffile_name_nondirectory (raw_name); Vinvocation_directory = Ffile_name_directory (raw_name); - /* If we got no directory in argv[0], search PATH to find where + /* If we got no directory in argv0, search PATH to find where Emacs actually came from. */ if (NILP (Vinvocation_directory)) { @@ -478,6 +479,21 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) Vinvocation_directory = Fexpand_file_name (Vinvocation_directory, odir); } +} + + +/* Code for dealing with Lisp access to the Unix command line. */ +static void +init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd) +{ + int i; + Lisp_Object name, dir; + ptrdiff_t count = SPECPDL_INDEX (); + + initial_argv = argv; + initial_argc = argc; + + set_invocation_vars (argv[0], original_pwd); Vinstallation_directory = Qnil; @@ -766,7 +782,7 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size) } static void -load_pdump (int argc, char **argv) +load_pdump (int argc, char **argv, char const *original_pwd) { const char *const suffix = ".pdmp"; int result; @@ -801,7 +817,7 @@ load_pdump (int argc, char **argv) if (dump_file) { - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result != PDUMPER_LOAD_SUCCESS) fatal ("could not load dump file \"%s\": %s", @@ -850,7 +866,7 @@ load_pdump (int argc, char **argv) if (bufsize < needed) dump_file = xpalloc (dump_file, &bufsize, needed - bufsize, -1, 1); strcpy (dump_file + exenamelen, suffix); - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result == PDUMPER_LOAD_SUCCESS) goto out; @@ -881,7 +897,7 @@ load_pdump (int argc, char **argv) } sprintf (dump_file, "%s%c%s%s", path_exec, DIRECTORY_SEP, argv0_base, suffix); - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); if (result == PDUMPER_LOAD_FILE_NOT_FOUND) { @@ -916,7 +932,7 @@ load_pdump (int argc, char **argv) #endif sprintf (dump_file, "%s%c%s%s", path_exec, DIRECTORY_SEP, argv0_base, suffix); - result = pdumper_load (dump_file); + result = pdumper_load (dump_file, argv[0], original_pwd); } if (result != PDUMPER_LOAD_SUCCESS) @@ -937,7 +953,6 @@ main (int argc, char **argv) /* Variable near the bottom of the stack, and aligned appropriately for pointers. */ void *stack_bottom_variable; - bool no_loadup = false; char *junk = 0; char *dname_arg = 0; @@ -1056,9 +1071,10 @@ main (int argc, char **argv) w32_init_main_thread (); #endif + emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (attempt_load_pdump) - load_pdump (argc, argv); + load_pdump (argc, argv, emacs_wd); #endif argc = maybe_disable_address_randomization (argc, argv); @@ -1130,7 +1146,6 @@ main (int argc, char **argv) exit (0); } - emacs_wd = emacs_get_current_dir_name (); #ifdef HAVE_PDUMPER if (dumped_with_pdumper_p ()) pdumper_record_wd (emacs_wd); @@ -1599,6 +1614,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_json (); #endif + if (!initialized) + syms_of_comp (); + no_loadup = argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args); @@ -1951,6 +1969,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem keys_of_keyboard (); keys_of_keymap (); keys_of_window (); + +#ifdef HAVE_NATIVE_COMP + /* Must be after the last defsubr has run. */ + hash_native_abi (); +#endif } else { @@ -2378,6 +2401,12 @@ all of which are called before Emacs is actually killed. */ unlink (SSDATA (listfile)); } +#if defined (HAVE_NATIVE_COMP) && defined (WINDOWSNT) + finish_delayed_disposal_of_comp_units (); + dispose_all_remaining_comp_units (); + clean_package_user_dir_of_old_comp_units (); +#endif + if (FIXNUMP (arg)) exit_code = (XFIXNUM (arg) < 0 ? XFIXNUM (arg) | INT_MIN @@ -3026,7 +3055,18 @@ because they do not depend on external libraries and are always available. Also note that this is not a generic facility for accessing external libraries; only those already known by Emacs will be loaded. */); +#ifdef WINDOWSNT + /* We may need to load libgccjit when dumping before term/w32-win.el + defines `dynamic-library-alist`. This will fail if that variable + is empty, so add libgccjit.dll to it. */ + if (will_dump_p ()) + Vdynamic_library_alist = list1 (list2 (Qgccjit, + build_string ("libgccjit.dll"))); + else + Vdynamic_library_alist = Qnil; +#else Vdynamic_library_alist = Qnil; +#endif Fput (intern_c_string ("dynamic-library-alist"), Qrisky_local_variable, Qt); #ifdef WINDOWSNT diff --git a/src/eval.c b/src/eval.c index 9daae92e55a..f9a1a28f004 100644 --- a/src/eval.c +++ b/src/eval.c @@ -219,8 +219,17 @@ void init_eval_once (void) { /* Don't forget to update docs (lispref node "Local Variables"). */ - max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ - max_lisp_eval_depth = 800; + if (!NATIVE_COMP_FLAG) + { + max_specpdl_size = 1600; /* 1500 is not enough for cl-generic.el. */ + max_lisp_eval_depth = 800; + } + else + { + /* Original values increased for comp.el. */ + max_specpdl_size = 2500; + max_lisp_eval_depth = 1600; + } Vrun_hooks = Qnil; pdumper_do_now_and_after_load (init_eval_once_for_pdumper); } @@ -1411,6 +1420,61 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), } } +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as + its arguments. */ + +Lisp_Object +internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + +/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as + its arguments. */ + +Lisp_Object +internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object), + Lisp_Object arg1, Lisp_Object arg2, + Lisp_Object arg3, Lisp_Object arg4, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, CONDITION_CASE); + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (arg1, arg2, arg3, arg4); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + /* Like internal_condition_case but call BFUN with NARGS as first, and ARGS as second argument. */ @@ -2212,7 +2276,7 @@ eval_sub (Lisp_Object form) else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) fun = indirect_function (fun); - if (SUBRP (fun)) + if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) { Lisp_Object args_left = original_args; ptrdiff_t numargs = list_length (args_left); @@ -2315,7 +2379,9 @@ eval_sub (Lisp_Object form) } } } - else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun)) + else if (COMPILEDP (fun) + || SUBR_NATIVE_COMPILED_DYNP (fun) + || MODULE_FUNCTIONP (fun)) return apply_lambda (fun, original_args, count); else { @@ -2791,9 +2857,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun))) fun = indirect_function (fun); - if (SUBRP (fun)) + if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun)) val = funcall_subr (XSUBR (fun), numargs, args + 1); - else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun)) + else if (COMPILEDP (fun) + || SUBR_NATIVE_COMPILED_DYNP (fun) + || MODULE_FUNCTIONP (fun)) val = funcall_lambda (fun, numargs, args + 1); else { @@ -3003,6 +3071,11 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, else if (MODULE_FUNCTIONP (fun)) return funcall_module (fun, nargs, arg_vector); #endif + else if (SUBR_NATIVE_COMPILED_DYNP (fun)) + { + syms_left = XSUBR (fun)->lambda_list[0]; + lexenv = Qnil; + } else emacs_abort (); @@ -3063,6 +3136,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); + else if (SUBR_NATIVE_COMPILEDP (fun)) + { + eassert (SUBR_NATIVE_COMPILED_DYNP (fun)); + /* No need to use funcall_subr as we have zero arguments by + construction. */ + val = XSUBR (fun)->function.a0 (); + } else val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL); diff --git a/src/lisp.h b/src/lisp.h index 7b4f484b9b7..54ade65443f 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -294,12 +294,12 @@ DEFINE_GDB_SYMBOL_END (VALMASK) /* Lisp_Word is a scalar word suitable for holding a tagged pointer or integer. Usually it is a pointer to a deliberately-incomplete type - 'union Lisp_X'. However, it is EMACS_INT when Lisp_Objects and + 'struct Lisp_X'. However, it is EMACS_INT when Lisp_Objects and pointers differ in width. */ #define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX) #if LISP_WORDS_ARE_POINTERS -typedef union Lisp_X *Lisp_Word; +typedef struct Lisp_X *Lisp_Word; #else typedef EMACS_INT Lisp_Word; #endif @@ -568,6 +568,7 @@ enum Lisp_Fwd_Type #ifdef CHECK_LISP_OBJECT_TYPE typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object; +# define LISP_OBJECT_IS_STRUCT # define LISP_INITIALLY(w) {w} # undef CHECK_LISP_OBJECT_TYPE enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true }; @@ -1098,6 +1099,7 @@ enum pvec_type PVEC_MUTEX, PVEC_CONDVAR, PVEC_MODULE_FUNCTION, + PVEC_NATIVE_COMP_UNIT, /* These should be last, for internal_equal and sxhash_obj. */ PVEC_COMPILED, @@ -1343,6 +1345,7 @@ dead_object (void) #define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD)) #define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX)) #define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR)) +#define XSETNATIVE_COMP_UNIT(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_NATIVE_COMP_UNIT)) /* Efficiently convert a pointer to a Lisp object and back. The pointer is represented as a fixnum, so the garbage collector @@ -2064,6 +2067,8 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val) char_table_set (ct, idx, val); } +#include "comp.h" + /* This structure describes a built-in function. It is generated by the DEFUN macro only. defsubr makes it into a Lisp object. */ @@ -2086,8 +2091,14 @@ struct Lisp_Subr } function; short min_args, max_args; const char *symbol_name; - const char *intspec; + union { + const char *intspec; + Lisp_Object native_intspec; + }; EMACS_INT doc; + Lisp_Object native_comp_u[NATIVE_COMP_FLAG]; + char *native_c_name[NATIVE_COMP_FLAG]; + Lisp_Object lambda_list[NATIVE_COMP_FLAG]; } GCALIGNED_STRUCT; union Aligned_Lisp_Subr { @@ -3064,7 +3075,7 @@ CHECK_INTEGER (Lisp_Object x) static union Aligned_Lisp_Subr sname = \ {{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \ { .a ## maxargs = fnname }, \ - minargs, maxargs, lname, intspec, 0}}; \ + minargs, maxargs, lname, {intspec}, 0}}; \ Lisp_Object fnname /* defsubr (Sname); @@ -4081,6 +4092,7 @@ LOADHIST_ATTACH (Lisp_Object x) if (initialized) Vcurrent_load_list = Fcons (x, Vcurrent_load_list); } +extern bool suffix_p (Lisp_Object, const char *); extern Lisp_Object save_match_data_load (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); extern int openp (Lisp_Object, Lisp_Object, Lisp_Object, @@ -4154,6 +4166,8 @@ extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_ extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); @@ -4431,6 +4445,7 @@ extern bool display_arg; extern Lisp_Object decode_env_path (const char *, const char *, bool); extern Lisp_Object empty_unibyte_string, empty_multibyte_string; extern AVOID terminate_due_to_signal (int, int); +extern void set_invocation_vars (char *argv0, char const *original_pwd); #ifdef WINDOWSNT extern Lisp_Object Vlibrary_cache; #endif @@ -4735,12 +4750,45 @@ extern bool profiler_memory_running; extern void malloc_probe (size_t); extern void syms_of_profiler (void); - #ifdef DOS_NT /* Defined in msdos.c, w32.c. */ extern char *emacs_root_dir (void); #endif /* DOS_NT */ +#ifdef HAVE_NATIVE_COMP +INLINE bool +SUBR_NATIVE_COMPILEDP (Lisp_Object a) +{ + return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]); +} + +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return SUBR_NATIVE_COMPILEDP (a) && !NILP (XSUBR (a)->lambda_list[0]); +} + +INLINE struct Lisp_Native_Comp_Unit * +allocate_native_comp_unit (void) +{ + return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit, + data_impure_vec, PVEC_NATIVE_COMP_UNIT); +} +#else +INLINE bool +SUBR_NATIVE_COMPILEDP (Lisp_Object a) +{ + return false; +} + +INLINE bool +SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a) +{ + return false; +} + +#endif + /* Defined in lastfile.c. */ extern char my_edata[]; extern char my_endbss[]; diff --git a/src/lread.c b/src/lread.c index 8064bf4d0eb..f5a7d44a1e0 100644 --- a/src/lread.c +++ b/src/lread.c @@ -1056,14 +1056,31 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */) { Lisp_Object exts = Vload_file_rep_suffixes; Lisp_Object suffix = XCAR (suffixes); - FOR_EACH_TAIL (exts) - lst = Fcons (concat2 (suffix, XCAR (exts)), lst); + bool native_code_suffix = + NATIVE_COMP_FLAG + && strcmp (NATIVE_ELISP_SUFFIX, SSDATA (suffix)) == 0; + +#ifdef HAVE_MODULES + native_code_suffix = + native_code_suffix || strcmp (MODULES_SUFFIX, SSDATA (suffix)) == 0; +#ifdef MODULES_SECONDARY_SUFFIX + native_code_suffix = + native_code_suffix + || strcmp (MODULES_SECONDARY_SUFFIX, SSDATA (suffix)) == 0; +#endif +#endif + + if (native_code_suffix) + lst = Fcons (suffix, lst); + else + FOR_EACH_TAIL (exts) + lst = Fcons (concat2 (suffix, XCAR (exts)), lst); } return Fnreverse (lst); } /* Return true if STRING ends with SUFFIX. */ -static bool +bool suffix_p (Lisp_Object string, const char *suffix) { ptrdiff_t suffix_len = strlen (suffix); @@ -1082,6 +1099,14 @@ close_infile_unwind (void *arg) infile = prev_infile; } +static Lisp_Object +parent_directory (Lisp_Object directory) +{ + return Ffile_name_directory (Fsubstring (directory, + make_fixnum (0), + Fsub1 (Flength (directory)))); +} + DEFUN ("load", Fload, Sload, 1, 5, 0, doc: /* Execute a file of Lisp code named FILE. First try FILE with `.elc' appended, then try with `.el', then try @@ -1189,7 +1214,7 @@ Return t if the file exists and loads successfully. */) || suffix_p (file, MODULES_SECONDARY_SUFFIX) #endif #endif - ) + || (NATIVE_COMP_FLAG && suffix_p (file, NATIVE_ELISP_SUFFIX))) must_suffix = Qnil; /* Don't insist on adding a suffix if the argument includes a directory name. */ @@ -1206,7 +1231,8 @@ Return t if the file exists and loads successfully. */) suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes); } - fd = openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer); + fd = + openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer); } if (fd == -1) @@ -1267,6 +1293,9 @@ Return t if the file exists and loads successfully. */) bool is_module = false; #endif + bool is_native_elisp = + NATIVE_COMP_FLAG && suffix_p (found, NATIVE_ELISP_SUFFIX) ? true : false; + /* Check if we're stuck in a recursive load cycle. 2000-09-21: It's not possible to just check for the file loaded @@ -1361,7 +1390,7 @@ Return t if the file exists and loads successfully. */) } /* !load_prefer_newer */ } } - else if (!is_module) + else if (!is_module && !is_native_elisp) { /* We are loading a source file (*.el). */ if (!NILP (Vload_source_file_function)) @@ -1388,7 +1417,7 @@ Return t if the file exists and loads successfully. */) stream = NULL; errno = EINVAL; } - else if (!is_module) + else if (!is_module && !is_native_elisp) { #ifdef WINDOWSNT emacs_close (fd); @@ -1404,7 +1433,7 @@ Return t if the file exists and loads successfully. */) might be accessed by the unbind_to call below. */ struct infile input; - if (is_module) + if (is_module || is_native_elisp) { /* `module-load' uses the file name, so we can close the stream now. */ @@ -1431,6 +1460,8 @@ Return t if the file exists and loads successfully. */) { if (is_module) message_with_string ("Loading %s (module)...", file, 1); + else if (is_native_elisp) + message_with_string ("Loading %s (native compiled elisp)...", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...", file, 1); else if (newer) @@ -1440,7 +1471,20 @@ Return t if the file exists and loads successfully. */) message_with_string ("Loading %s...", file, 1); } - specbind (Qload_file_name, found); + if (is_native_elisp) + { + /* Many packages use `load-file-name' as a way to obtain the + package location (see bug#40099). .eln files are not in the + same folder of their respective sources therfore not to break + packages we fake `load-file-name' here. The non faked + version of it is `load-true-file-name'. */ + specbind (Qload_file_name, + concat2 (parent_directory (Ffile_name_directory (found)), + Ffile_name_nondirectory (found))); + } + else + specbind (Qload_file_name, found); + specbind (Qload_true_file_name, found); specbind (Qinhibit_file_name_operation, Qnil); specbind (Qload_in_progress, Qt); @@ -1456,6 +1500,26 @@ Return t if the file exists and loads successfully. */) emacs_abort (); #endif } + else if (is_native_elisp) + { +#ifdef HAVE_NATIVE_COMP + specbind (Qcurrent_load_list, Qnil); + if (!NILP (Vpurify_flag)) + { + Lisp_Object base = concat2 (parent_directory (Vinvocation_directory), + build_string ("lisp/")); + Lisp_Object offset = Flength (base); + hist_file_name = Fsubstring (found, offset, Qnil); + } + LOADHIST_ATTACH (hist_file_name); + Fnative_elisp_load (found, Qnil); + build_load_history (hist_file_name, true); +#else + /* This cannot happen. */ + emacs_abort (); +#endif + + } else { if (lisp_file_lexically_bound_p (Qget_file_char)) @@ -1491,6 +1555,8 @@ Return t if the file exists and loads successfully. */) { if (is_module) message_with_string ("Loading %s (module)...done", file, 1); + else if (is_native_elisp) + message_with_string ("Loading %s (native compiled elisp)...done", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...done", file, 1); else if (newer) @@ -1542,6 +1608,120 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */) return file; } +/* This function turns a list of suffixes into a list of middle dirs + and suffixes. If the suffix is not NATIVE_ELISP_SUFFIX then its + suffix is nil and it is added to the list as is. Instead, if it + suffix is NATIVE_ELISP_SUFFIX then two elements are added to the + list. The first one has middledir equal to nil and the second uses + comp-native-path-postfix as middledir. This is because we'd like + to search for dir/foo.eln before dir/middledir/foo.eln. + +For example, it turns this: + +(".eln" ".elc" ".elc.gz" ".el" ".el.gz") + + into this: + +((nil . ".eln") + (comp-native-path-postfix . ".eln") + (nil . ".elc") + (nil . ".elc.gz") + (nil . ".el") + (nil . ".el.gz")) +*/ +static Lisp_Object +openp_add_middle_dir_to_suffixes (Lisp_Object suffixes) +{ + Lisp_Object tail = suffixes; + Lisp_Object extended_suf = Qnil; + FOR_EACH_TAIL_SAFE (tail) + { + /* suffixes may be a stack-based cons pointing to stack-based + strings. We must copy the suffix if we are putting it into + a heap-based cons to avoid a dangling reference. This would + lead to crashes during the GC. */ + CHECK_STRING_CAR (tail); + char * suf = SSDATA (XCAR (tail)); + Lisp_Object copied_suffix = build_string (suf); +#ifdef HAVE_NATIVE_COMP + if (strcmp (NATIVE_ELISP_SUFFIX, suf) == 0) + { + CHECK_STRING (Vcomp_native_path_postfix); + /* Here we add them in the opposite order so that nreverse + corrects it. */ + extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); + extended_suf = Fcons (Fcons (Vcomp_native_path_postfix, + copied_suffix), + extended_suf); + } + else +#endif + extended_suf = Fcons (Fcons (Qnil, copied_suffix), extended_suf); + } + + suffixes = Fnreverse (extended_suf); + return suffixes; +} + +/* This function takes a list of middledirs and suffixes and returns + the maximum buffer space that this part of the filename will + need. */ +static ptrdiff_t +openp_max_middledir_and_suffix_len (Lisp_Object middledir_and_suffixes) +{ + ptrdiff_t max_extra_len = 0; + Lisp_Object tail = middledir_and_suffixes; + FOR_EACH_TAIL_SAFE (tail) + { + Lisp_Object middledir_and_suffix = XCAR (tail); + Lisp_Object middledir = XCAR (middledir_and_suffix); + Lisp_Object suffix = XCDR (middledir_and_suffix); + ptrdiff_t len = SBYTES (suffix); + if (!NILP (middledir)) + len += 2 + SBYTES (middledir); /* Add two slashes. */ + max_extra_len = max (max_extra_len, len); + } + return max_extra_len; +} + +/* This function completes the FN buffer with the middledir, + basenameme, and suffix. It takes the directory length in DIRNAME, + but it requires that it has been copied already to the start of + the buffer. + + After this function the FN buffer will be (depending on middledir) + dirname/middledir/basename.suffix + or + dirname/basename.suffix +*/ +static ptrdiff_t +openp_fill_filename_buffer (char *fn, ptrdiff_t dirnamelen, + Lisp_Object basenamewext, + Lisp_Object middledir_and_suffix) +{ + Lisp_Object middledir = XCAR (middledir_and_suffix); + Lisp_Object suffix = XCDR (middledir_and_suffix); + ptrdiff_t basenamewext_len = SBYTES (basenamewext); + ptrdiff_t fnlen, lsuffix = SBYTES (suffix); + ptrdiff_t lmiddledir = 0; + if (!NILP (middledir)) + { + /* Add 1 for the slash. */ + lmiddledir = SBYTES (middledir) + 1; + memcpy (fn + dirnamelen, SDATA (middledir), + lmiddledir - 1); + fn[dirnamelen + (lmiddledir - 1)] = '/'; + } + + memcpy (fn + dirnamelen + lmiddledir, SDATA (basenamewext), + basenamewext_len); + /* Make complete filename by appending SUFFIX. */ + memcpy (fn + dirnamelen + lmiddledir + basenamewext_len, + SDATA (suffix), lsuffix + 1); + fnlen = dirnamelen + lmiddledir + basenamewext_len + lsuffix; + return fnlen; +} + /* Search for a file whose name is STR, looking in directories in the Lisp list PATH, and trying suffixes from SUFFIX. On success, return a file descriptor (or 1 or -2 as described below). @@ -1579,7 +1759,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, ptrdiff_t want_length; Lisp_Object filename; Lisp_Object string, tail, encoded_fn, save_string; - ptrdiff_t max_suffix_len = 0; + Lisp_Object middledir_and_suffixes; + ptrdiff_t max_extra_len = 0; int last_errno = ENOENT; int save_fd = -1; USE_SAFE_ALLOCA; @@ -1590,13 +1771,9 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, CHECK_STRING (str); - tail = suffixes; - FOR_EACH_TAIL_SAFE (tail) - { - CHECK_STRING_CAR (tail); - max_suffix_len = max (max_suffix_len, - SBYTES (XCAR (tail))); - } + middledir_and_suffixes = openp_add_middle_dir_to_suffixes (suffixes); + + max_extra_len = openp_max_middledir_and_suffix_len (middledir_and_suffixes); string = filename = encoded_fn = save_string = Qnil; @@ -1613,7 +1790,7 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, executable. */ FOR_EACH_TAIL_SAFE (path) { - ptrdiff_t baselen, prefixlen; + ptrdiff_t dirnamelen, prefixlen; if (EQ (path, just_use_str)) filename = str; @@ -1630,35 +1807,40 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes, continue; } + /* Calculate maximum length of any filename made from this path element/specified file name and any possible suffix. */ - want_length = max_suffix_len + SBYTES (filename); + want_length = max_extra_len + SBYTES (filename); if (fn_size <= want_length) { fn_size = 100 + want_length; fn = SAFE_ALLOCA (fn_size); } + Lisp_Object dirnamewslash = Ffile_name_directory (filename); + Lisp_Object basenamewext = Ffile_name_nondirectory (filename); + /* Copy FILENAME's data to FN but remove starting /: if any. */ - prefixlen = ((SCHARS (filename) > 2 - && SREF (filename, 0) == '/' - && SREF (filename, 1) == ':') + prefixlen = ((SCHARS (dirnamewslash) > 2 + && SREF (dirnamewslash, 0) == '/' + && SREF (dirnamewslash, 1) == ':') ? 2 : 0); - baselen = SBYTES (filename) - prefixlen; - memcpy (fn, SDATA (filename) + prefixlen, baselen); + dirnamelen = SBYTES (dirnamewslash) - prefixlen; + memcpy (fn, SDATA (dirnamewslash) + prefixlen, dirnamelen); - /* Loop over suffixes. */ - AUTO_LIST1 (empty_string_only, empty_unibyte_string); - tail = NILP (suffixes) ? empty_string_only : suffixes; + /* Loop over middledir_and_suffixes. */ + AUTO_LIST1 (empty_string_only, Fcons (Qnil, empty_unibyte_string)); + tail = NILP (middledir_and_suffixes) ? empty_string_only + : middledir_and_suffixes; FOR_EACH_TAIL_SAFE (tail) { - Lisp_Object suffix = XCAR (tail); - ptrdiff_t fnlen, lsuffix = SBYTES (suffix); + Lisp_Object middledir_and_suffix = XCAR (tail); + Lisp_Object suffix = XCDR (middledir_and_suffix); Lisp_Object handler; - /* Make complete filename by appending SUFFIX. */ - memcpy (fn + baselen, SDATA (suffix), lsuffix + 1); - fnlen = baselen + lsuffix; + ptrdiff_t fnlen = openp_fill_filename_buffer (fn, dirnamelen, + basenamewext, + middledir_and_suffix); /* Check that the file exists and is not a directory. */ /* We used to only check for handlers on non-absolute file names: @@ -1886,8 +2068,8 @@ readevalloop_1 (int old) static AVOID end_of_file_error (void) { - if (STRINGP (Vload_file_name)) - xsignal1 (Qend_of_file, Vload_file_name); + if (STRINGP (Vload_true_file_name)) + xsignal1 (Qend_of_file, Vload_true_file_name); xsignal0 (Qend_of_file); } @@ -3138,7 +3320,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) goto retry; } if (c == '$') - return Vload_file_name; + return Vload_true_file_name; if (c == '\'') return list2 (Qfunction, read0 (readcharfun)); /* #:foo is the uninterned symbol named foo. */ @@ -3939,7 +4121,7 @@ read_list (bool flag, Lisp_Object readcharfun) first_in_list = 0; /* While building, if the list starts with #$, treat it specially. */ - if (EQ (elt, Vload_file_name) + if (EQ (elt, Vload_true_file_name) && ! NILP (elt) && !NILP (Vpurify_flag)) { @@ -3960,7 +4142,7 @@ read_list (bool flag, Lisp_Object readcharfun) elt = concat2 (dot_dot_lisp, Ffile_name_nondirectory (elt)); } } - else if (EQ (elt, Vload_file_name) + else if (EQ (elt, Vload_true_file_name) && ! NILP (elt) && load_force_doc_strings) doc_reference = 2; @@ -4145,10 +4327,14 @@ intern_c_string_1 (const char *str, ptrdiff_t len) if (!SYMBOLP (tem)) { - /* Creating a non-pure string from a string literal not implemented yet. - We could just use make_string here and live with the extra copy. */ - eassert (!NILP (Vpurify_flag)); - tem = intern_driver (make_pure_c_string (str, len), obarray, tem); + Lisp_Object string; + + if (NILP (Vpurify_flag)) + string = make_string (str, len); + else + string = make_pure_c_string (str, len); + + tem = intern_driver (string, obarray, tem); } return tem; } @@ -4408,6 +4594,10 @@ defsubr (union Aligned_Lisp_Subr *aname) XSETPVECTYPE (sname, PVEC_SUBR); XSETSUBR (tem, sname); set_symbol_function (sym, tem); +#ifdef HAVE_NATIVE_COMP + eassert (NILP (Vcomp_abi_hash)); + Vcomp_subr_list = Fpurecopy (Fcons (tem, Vcomp_subr_list)); +#endif } #ifdef NOTDEF /* Use fset in subr.el now! */ @@ -4708,6 +4898,7 @@ init_lread (void) load_in_progress = 0; Vload_file_name = Qnil; + Vload_true_file_name = Qnil; Vstandard_input = Qt; Vloads_in_progress = Qnil; } @@ -4831,21 +5022,19 @@ This list includes suffixes for both compiled and source Emacs Lisp files. This list should not include the empty string. `load' and related functions try to append these suffixes, in order, to the specified file name if a suffix is allowed or required. */); + Vload_suffixes = list2 (build_pure_c_string (".elc"), + build_pure_c_string (".el")); #ifdef HAVE_MODULES + Vload_suffixes = Fcons (build_pure_c_string (MODULES_SUFFIX), Vload_suffixes); #ifdef MODULES_SECONDARY_SUFFIX - Vload_suffixes = list4 (build_pure_c_string (".elc"), - build_pure_c_string (".el"), - build_pure_c_string (MODULES_SUFFIX), - build_pure_c_string (MODULES_SECONDARY_SUFFIX)); -#else - Vload_suffixes = list3 (build_pure_c_string (".elc"), - build_pure_c_string (".el"), - build_pure_c_string (MODULES_SUFFIX)); + Vload_suffixes = + Fcons (build_pure_c_string (MODULES_SECONDARY_SUFFIX), Vload_suffixes); #endif -#else - Vload_suffixes = list2 (build_pure_c_string (".elc"), - build_pure_c_string (".el")); #endif +#ifdef HAVE_NATIVE_COMP + Vload_suffixes = Fcons (build_pure_c_string (NATIVE_ELISP_SUFFIX), Vload_suffixes); +#endif + DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix, doc: /* Suffix of loadable module file, or nil if modules are not supported. */); #ifdef HAVE_MODULES @@ -4911,9 +5100,15 @@ directory. These file names are converted to absolute at startup. */); Vload_history = Qnil; DEFVAR_LISP ("load-file-name", Vload_file_name, - doc: /* Full name of file being loaded by `load'. */); + doc: /* Full name of file being loaded by `load'. +In case a .eln file is being loaded this is unreliable and `load-true-file-name' +should be used instead. */); Vload_file_name = Qnil; + DEFVAR_LISP ("load-true-file-name", Vload_true_file_name, + doc: /* Full name of file being loaded by `load'. */); + Vload_true_file_name = Qnil; + DEFVAR_LISP ("user-init-file", Vuser_init_file, doc: /* File name, including directory, of user's initialization file. If the file loaded had extension `.elc', and the corresponding source file @@ -5055,6 +5250,7 @@ that are loaded before your customizations are read! */); DEFSYM (Qfunction, "function"); DEFSYM (Qload, "load"); DEFSYM (Qload_file_name, "load-file-name"); + DEFSYM (Qload_true_file_name, "load-true-file-name"); DEFSYM (Qeval_buffer_list, "eval-buffer-list"); DEFSYM (Qdir_ok, "dir-ok"); DEFSYM (Qdo_after_load_evaluation, "do-after-load-evaluation"); diff --git a/src/pdumper.c b/src/pdumper.c index 7f6876666be..2bda3a85cd1 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -197,6 +197,8 @@ enum dump_reloc_type /* dump_ptr = dump_ptr + dump_base */ RELOC_DUMP_TO_DUMP_PTR_RAW, /* dump_mpz = [rebuild bignum] */ + RELOC_NATIVE_COMP_UNIT, + RELOC_NATIVE_SUBR, RELOC_BIGNUM, /* dump_lv = make_lisp_ptr (dump_lv + dump_base, type - RELOC_DUMP_TO_DUMP_LV) @@ -341,6 +343,20 @@ dump_fingerprint (char const *label, fprintf (stderr, "%s: %.*s\n", label, hexbuf_size, hexbuf); } +/* To be used if some order in the relocation process has to be enforced. */ +enum reloc_phase + { + /* First to run. Place here every relocation with no dependecy. */ + EARLY_RELOCS, + /* Late and very late relocs are relocated at the very last after + all hooks has been run. All lisp machinery is at disposal + (memory allocation allowed too). */ + LATE_RELOCS, + VERY_LATE_RELOCS, + /* Fake, must be last. */ + RELOC_NUM_PHASES + }; + /* Format of an Emacs dump file. All offsets are relative to the beginning of the file. An Emacs dump file is coupled to exactly the Emacs binary that produced it, so details of @@ -368,7 +384,7 @@ struct dump_header /* Relocation table for the dump file; each entry is a struct dump_reloc. */ - struct dump_table_locator dump_relocs; + struct dump_table_locator dump_relocs[RELOC_NUM_PHASES]; /* "Relocation" table we abuse to hold information about the location and type of each lisp object in the dump. We need for @@ -446,6 +462,7 @@ enum cold_op COLD_OP_CHARSET, COLD_OP_BUFFER, COLD_OP_BIGNUM, + COLD_OP_NATIVE_SUBR, }; /* This structure controls what operations we perform inside @@ -545,7 +562,7 @@ struct dump_context Lisp_Object cold_queue; /* Relocations in the dump. */ - Lisp_Object dump_relocs; + Lisp_Object dump_relocs[RELOC_NUM_PHASES]; /* Object starts. */ Lisp_Object object_starts; @@ -939,7 +956,7 @@ dump_note_reachable (struct dump_context *ctx, Lisp_Object object) static void * dump_object_emacs_ptr (Lisp_Object lv) { - if (SUBRP (lv)) + if (SUBRP (lv) && !SUBR_NATIVE_COMPILEDP (lv)) return XSUBR (lv); if (dump_builtin_symbol_p (lv)) return XSYMBOL (lv); @@ -1429,7 +1446,7 @@ dump_reloc_dump_to_emacs_ptr_raw (struct dump_context *ctx, dump_off dump_offset) { if (ctx->flags.dump_object_contents) - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (RELOC_DUMP_TO_EMACS_PTR_RAW), dump_off_to_lisp (dump_offset))); } @@ -1462,7 +1479,7 @@ dump_reloc_dump_to_dump_lv (struct dump_context *ctx, emacs_abort (); } - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (reloc_type), dump_off_to_lisp (dump_offset))); } @@ -1478,7 +1495,7 @@ dump_reloc_dump_to_dump_ptr_raw (struct dump_context *ctx, dump_off dump_offset) { if (ctx->flags.dump_object_contents) - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (RELOC_DUMP_TO_DUMP_PTR_RAW), dump_off_to_lisp (dump_offset))); } @@ -1511,7 +1528,7 @@ dump_reloc_dump_to_emacs_lv (struct dump_context *ctx, emacs_abort (); } - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (reloc_type), dump_off_to_lisp (dump_offset))); } @@ -2228,7 +2245,7 @@ dump_bignum (struct dump_context *ctx, Lisp_Object object) Lisp_Bignum instead of the actual mpz field so that the relocation offset is aligned. The relocation-application code knows to actually advance past the header. */ - dump_push (&ctx->dump_relocs, + dump_push (&ctx->dump_relocs[EARLY_RELOCS], list2 (make_fixnum (RELOC_BIGNUM), dump_off_to_lisp (bignum_offset))); } @@ -2920,20 +2937,72 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v) static dump_off dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_594AB72B54) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_35CE99B716) # error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h." #endif struct Lisp_Subr out; dump_object_start (ctx, &out, sizeof (out)); DUMP_FIELD_COPY (&out, subr, header.size); - dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); + if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0])) + out.function.a0 = NULL; + else + dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0); DUMP_FIELD_COPY (&out, subr, min_args); DUMP_FIELD_COPY (&out, subr, max_args); - dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); - dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); + if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0])) + { + dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name); + dump_remember_cold_op (ctx, + COLD_OP_NATIVE_SUBR, + make_lisp_ptr ((void *) subr, Lisp_Vectorlike)); + dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL); + } + else + { + dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name); + dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec); + } DUMP_FIELD_COPY (&out, subr, doc); - return dump_object_finish (ctx, &out, sizeof (out)); + if (NATIVE_COMP_FLAG) + { + dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL); + if (!NILP (subr->native_comp_u[0])) + dump_field_fixup_later (ctx, &out, subr, &subr->native_c_name[0]); + + dump_field_lv (ctx, &out, subr, &subr->lambda_list[0], WEIGHT_NORMAL); + } + dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out)); + if (NATIVE_COMP_FLAG + && ctx->flags.dump_object_contents + && !NILP (subr->native_comp_u[0])) + /* We'll do the final addr relocation during VERY_LATE_RELOCS time + after the compilation units has been loaded. */ + dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS], + list2 (make_fixnum (RELOC_NATIVE_SUBR), + dump_off_to_lisp (subr_off))); + return subr_off; +} + +#ifdef HAVE_NATIVE_COMP +static dump_off +dump_native_comp_unit (struct dump_context *ctx, + struct Lisp_Native_Comp_Unit *comp_u) +{ + /* Have function documentation always lazy loaded to optimize load-time. */ + comp_u->data_fdoc_v = Qnil; + START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out); + dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header); + out->handle = NULL; + + dump_off comp_u_off = finish_dump_pvec (ctx, &out->header); + if (ctx->flags.dump_object_contents) + /* We'll do the real elf load during LATE_RELOCS relocation time. */ + dump_push (&ctx->dump_relocs[LATE_RELOCS], + list2 (make_fixnum (RELOC_NATIVE_COMP_UNIT), + dump_off_to_lisp (comp_u_off))); + return comp_u_off; } +#endif static void fill_pseudovec (union vectorlike_header *header, Lisp_Object item) @@ -2959,7 +3028,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_A4A6E9984D +#if CHECK_STRUCTS && !defined HASH_pvec_type_F5BA506141 # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); @@ -3012,6 +3081,11 @@ dump_vectorlike (struct dump_context *ctx, case PVEC_BIGNUM: offset = dump_bignum (ctx, lv); break; +#ifdef HAVE_NATIVE_COMP + case PVEC_NATIVE_COMP_UNIT: + offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv)); + break; +#endif case PVEC_WINDOW_CONFIGURATION: error_unsupported_dump_object (ctx, lv, "window configuration"); case PVEC_OTHER: @@ -3411,6 +3485,31 @@ dump_cold_bignum (struct dump_context *ctx, Lisp_Object object) } static void +dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr) +{ + /* Dump subr contents. */ + dump_off subr_offset = dump_recall_object (ctx, subr); + eassert (subr_offset > 0); + dump_remember_fixup_ptr_raw + (ctx, + subr_offset + dump_offsetof (struct Lisp_Subr, symbol_name), + ctx->offset); + const char *symbol_name = XSUBR (subr)->symbol_name; + ALLOW_IMPLICIT_CONVERSION; + dump_write (ctx, symbol_name, 1 + strlen (symbol_name)); + DISALLOW_IMPLICIT_CONVERSION; + + dump_remember_fixup_ptr_raw + (ctx, + subr_offset + dump_offsetof (struct Lisp_Subr, native_c_name[0]), + ctx->offset); + const char *c_name = XSUBR (subr)->native_c_name[0]; + ALLOW_IMPLICIT_CONVERSION; + dump_write (ctx, c_name, 1 + strlen (c_name)); + DISALLOW_IMPLICIT_CONVERSION; +} + +static void dump_drain_cold_data (struct dump_context *ctx) { Lisp_Object cold_queue = Fnreverse (ctx->cold_queue); @@ -3453,6 +3552,9 @@ dump_drain_cold_data (struct dump_context *ctx) case COLD_OP_BIGNUM: dump_cold_bignum (ctx, data); break; + case COLD_OP_NATIVE_SUBR: + dump_cold_native_subr (ctx, data); + break; default: emacs_abort (); } @@ -3871,7 +3973,7 @@ dump_do_fixup (struct dump_context *ctx, /* Dump wants a pointer to a Lisp object. If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in the dump; otherwise, a Lisp_Object. */ - if (SUBRP (arg)) + if (SUBRP (arg) && !SUBR_NATIVE_COMPILEDP (arg)) { dump_value = emacs_offset (XSUBR (arg)); if (type == DUMP_FIXUP_LISP_OBJECT) @@ -4052,7 +4154,8 @@ types. */) ctx->symbol_aux = Qnil; ctx->copied_queue = Qnil; ctx->cold_queue = Qnil; - ctx->dump_relocs = Qnil; + for (int i = 0; i < RELOC_NUM_PHASES; ++i) + ctx->dump_relocs[i] = Qnil; ctx->object_starts = Qnil; ctx->emacs_relocs = Qnil; ctx->bignum_data = make_eq_hash_table (); @@ -4207,8 +4310,9 @@ types. */) /* Emit instructions for Emacs to execute when loading the dump. Note that this relocation information ends up in the cold section of the dump. */ - drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger, - &ctx->dump_relocs, &ctx->header.dump_relocs); + for (int i = 0; i < RELOC_NUM_PHASES; ++i) + drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger, + &ctx->dump_relocs[i], &ctx->header.dump_relocs[i]); unsigned number_hot_relocations = ctx->number_hot_relocations; ctx->number_hot_relocations = 0; unsigned number_discardable_relocations = ctx->number_discardable_relocations; @@ -4226,7 +4330,8 @@ types. */) eassert (NILP (ctx->deferred_symbols)); eassert (NILP (ctx->deferred_hash_tables)); eassert (NILP (ctx->fixups)); - eassert (NILP (ctx->dump_relocs)); + for (int i = 0; i < RELOC_NUM_PHASES; ++i) + eassert (NILP (ctx->dump_relocs[i])); eassert (NILP (ctx->emacs_relocs)); /* Dump is complete. Go back to the header and write the magic @@ -5202,6 +5307,83 @@ dump_do_dump_relocation (const uintptr_t dump_base, dump_write_word_to_dump (dump_base, reloc_offset, value); break; } +#ifdef HAVE_NATIVE_COMP + case RELOC_NATIVE_COMP_UNIT: + { + static enum { UNKNOWN, LOCAL_BUILD, INSTALLED } installation_state; + struct Lisp_Native_Comp_Unit *comp_u = + dump_ptr (dump_base, reloc_offset); + comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq); + if (!CONSP (comp_u->file)) + error ("Trying to load incoherent dumped .eln"); + + /* Check just once if this is a local build or Emacs was installed. */ + if (installation_state == UNKNOWN) + { + char *fname = SSDATA (concat2 (Vinvocation_directory, + XCAR (comp_u->file))); + FILE *file; + if ((file = fopen (fname, "r"))) + { + fclose (file); + installation_state = INSTALLED; + } + else + installation_state = LOCAL_BUILD; + } + + comp_u->file = + concat2 (Vinvocation_directory, + installation_state == INSTALLED + ? XCAR (comp_u->file) : XCDR (comp_u->file)); +#ifdef WINDOWSNT + comp_u->cfile = xlispstrdup (comp_u->file); +#endif + comp_u->handle = dynlib_open (SSDATA (comp_u->file)); + if (!comp_u->handle) + error ("%s", dynlib_error ()); + load_comp_unit (comp_u, true, false); + break; + } + case RELOC_NATIVE_SUBR: + { + if (!NATIVE_COMP_FLAG) + /* This cannot happen. */ + emacs_abort (); + + /* When resurrecting from a dump given non all the original + native compiled subrs may be still around we can't rely on + a 'top_level_run' mechanism, we revive them one-by-one + here. */ + struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset); + struct Lisp_Native_Comp_Unit *comp_u = + XNATIVE_COMP_UNIT (subr->native_comp_u[0]); + if (!comp_u->handle) + error ("can't relocate native subr with not loaded compilation unit"); + const char *c_name = subr->native_c_name[0]; + eassert (c_name); + void *func = dynlib_sym (comp_u->handle, c_name); + if (!func) + error ("can't find function in compilation unit"); + subr->function.a0 = func; + Lisp_Object lambda_data_idx = + Fgethash (build_string (c_name), comp_u->lambda_c_name_idx_h, Qnil); + if (!NILP (lambda_data_idx)) + { + /* This is an anonymous lambda. + We must fixup d_reloc_imp so the lambda can be referenced + by code. */ + Lisp_Object tem; + XSETSUBR (tem, subr); + Lisp_Object *fixup = + &(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]); + eassert (EQ (*fixup, Qlambda_fixup)); + *fixup = tem; + Fputhash (tem, Qt, comp_u->lambda_gc_guard_h); + } + break; + } +#endif case RELOC_BIGNUM: { struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset); @@ -5224,11 +5406,12 @@ dump_do_dump_relocation (const uintptr_t dump_base, } static void -dump_do_all_dump_relocations (const struct dump_header *const header, - const uintptr_t dump_base) +dump_do_all_dump_reloc_for_phase (const struct dump_header *const header, + const uintptr_t dump_base, + const enum reloc_phase phase) { - struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs.offset); - dump_off nr_entries = header->dump_relocs.nr_entries; + struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs[phase].offset); + dump_off nr_entries = header->dump_relocs[phase].nr_entries; for (dump_off i = 0; i < nr_entries; ++i) dump_do_dump_relocation (dump_base, r[i]); } @@ -5306,7 +5489,7 @@ enum dump_section N.B. We run very early in initialization, so we can't use lisp, unwinding, xmalloc, and so on. */ int -pdumper_load (const char *dump_filename) +pdumper_load (const char *dump_filename, char *argv0, char const *original_pwd) { intptr_t dump_size; struct stat stat; @@ -5440,7 +5623,7 @@ pdumper_load (const char *dump_filename) dump_public.start = dump_base; dump_public.end = dump_public.start + dump_size; - dump_do_all_dump_relocations (header, dump_base); + dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS); dump_do_all_emacs_relocations (header, dump_base); dump_mmap_discard_contents (§ions[DS_DISCARDABLE]); @@ -5451,6 +5634,12 @@ pdumper_load (const char *dump_filename) initialization. */ for (int i = 0; i < nr_dump_hooks; ++i) dump_hooks[i] (); + + /* Once we can allocate and before loading .eln files we must set + Vinvocation_directory (.eln paths are relative to it). */ + set_invocation_vars (argv0, original_pwd); + dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS); + dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS); initialized = true; struct timespec load_timespec = diff --git a/src/pdumper.h b/src/pdumper.h index 6a99b511f2f..b92958e12bc 100644 --- a/src/pdumper.h +++ b/src/pdumper.h @@ -127,7 +127,8 @@ enum pdumper_load_result PDUMPER_LOAD_ERROR /* Must be last, as errno may be added. */ }; -int pdumper_load (const char *dump_filename); +int pdumper_load (const char *dump_filename, char *argv0, + char const *original_pwd); struct pdumper_loaded_dump { diff --git a/src/print.c b/src/print.c index bd1769144e0..c5f4bbeef80 100644 --- a/src/print.c +++ b/src/print.c @@ -1833,7 +1833,18 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, } break; #endif - +#ifdef HAVE_NATIVE_COMP + case PVEC_NATIVE_COMP_UNIT: + { + struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj); + print_c_string ("#<native compilation unit: ", printcharfun); + print_string (cu->file, printcharfun); + printchar (' ', printcharfun); + print_object (cu->optimize_qualities, printcharfun, escapeflag); + printchar ('>', printcharfun); + } + break; +#endif default: emacs_abort (); } diff --git a/src/w32.c b/src/w32.c index f391f5e26eb..38bbc496563 100644 --- a/src/w32.c +++ b/src/w32.c @@ -10596,6 +10596,10 @@ globals_of_w32 (void) #endif w32_crypto_hprov = (HCRYPTPROV)0; + + /* We need to forget about libraries that were loaded during the + dumping process (e.g. libgccjit) */ + Vlibrary_cache = Qnil; } /* For make-serial-process */ diff --git a/src/w32common.h b/src/w32common.h index eb7faa1939a..bd01fd40401 100644 --- a/src/w32common.h +++ b/src/w32common.h @@ -81,6 +81,14 @@ get_proc_addr (HINSTANCE handle, LPCSTR fname) } \ while (false) +/* Load a function from the DLL, and don't fail if it does not exist. */ +#define LOAD_DLL_FN_OPT(lib, func) \ + do \ + { \ + fn_##func = (W32_PFN_##func) get_proc_addr (lib, #func); \ + } \ + while (false) + #ifdef HAVE_HARFBUZZ extern bool hbfont_init_w32_funcs (HMODULE); #endif |