diff options
Diffstat (limited to 'src/comp.c')
| -rw-r--r-- | src/comp.c | 3909 |
1 files changed, 3909 insertions, 0 deletions
diff --git a/src/comp.c b/src/comp.c new file mode 100644 index 00000000000..d021be479b0 --- /dev/null +++ b/src/comp.c @@ -0,0 +1,3909 @@ +/* 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> + +#ifdef HAVE_NATIVE_COMP + +#include <stdlib.h> +#include <stdio.h> +#include <signal.h> +#include <libgccjit.h> + +#include "lisp.h" +#include "puresize.h" +#include "window.h" +#include "dynlib.h" +#include "buffer.h" +#include "blockinput.h" +#include "sha512.h" + +/* 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 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) + +#define DECL_BLOCK(name, func) \ + gcc_jit_block *(name) = \ + gcc_jit_function_new_block ((func), STR (name)) + +#ifdef HAVE__SETJMP +#define SETJMP _setjmp +#else +#define SETJMP setjmp +#endif +#define SETJMP_NAME SETJMP + +/* Max number function importable by native compiled code. */ +#define F_RELOC_MAX_SIZE 1500 + +typedef struct { + void *link_table[F_RELOC_MAX_SIZE]; + ptrdiff_t size; +} f_reloc_t; + +static f_reloc_t freloc; + +/* 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 *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_ref; + /* libgccjit has really limited support for casting therefore this union will + be used for the scope. */ + gcc_jit_type *cast_union_type; + gcc_jit_field *cast_union_as_ll; + gcc_jit_field *cast_union_as_ull; + gcc_jit_field *cast_union_as_l; + gcc_jit_field *cast_union_as_ul; + gcc_jit_field *cast_union_as_u; + gcc_jit_field *cast_union_as_i; + gcc_jit_field *cast_union_as_b; + gcc_jit_field *cast_union_as_uintptr; + gcc_jit_field *cast_union_as_ptrdiff; + gcc_jit_field *cast_union_as_c_p; + gcc_jit_field *cast_union_as_v_p; + gcc_jit_field *cast_union_as_lisp_cons_ptr; + gcc_jit_field *cast_union_as_lisp_obj; + gcc_jit_field *cast_union_as_lisp_obj_ptr; + gcc_jit_function *func; /* Current function being compiled. */ + bool func_has_non_local; /* From comp-func has-non-local slot. */ + gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function. */ + 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 ***arrays; /* Array index -> gcc_jit_lvalue **. */ + 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; + 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; + 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. +*/ +Lisp_Object helper_save_window_excursion (Lisp_Object v1); +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 }; + + +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_field * +type_to_cast_field (gcc_jit_type *type) +{ + gcc_jit_field *field; + + if (type == comp.long_long_type) + field = comp.cast_union_as_ll; + else if (type == comp.unsigned_long_long_type) + field = comp.cast_union_as_ull; + else if (type == comp.long_type) + field = comp.cast_union_as_l; + else if (type == comp.unsigned_long_type) + field = comp.cast_union_as_ul; + else if (type == comp.unsigned_type) + field = comp.cast_union_as_u; + else if (type == comp.int_type) + field = comp.cast_union_as_i; + else if (type == comp.bool_type) + field = comp.cast_union_as_b; + else if (type == comp.void_ptr_type) + field = comp.cast_union_as_v_p; + else if (type == comp.uintptr_type) + field = comp.cast_union_as_uintptr; + else if (type == comp.ptrdiff_type) + field = comp.cast_union_as_ptrdiff; + else if (type == comp.char_ptr_type) + field = comp.cast_union_as_c_p; + else if (type == comp.lisp_cons_ptr_type) + field = comp.cast_union_as_lisp_cons_ptr; + else if (type == comp.lisp_obj_type) + field = comp.cast_union_as_lisp_obj; + else if (type == comp.lisp_obj_ptr_type) + field = comp.cast_union_as_lisp_obj_ptr; + else + xsignal1 (Qnative_ice, build_string ("unsupported cast")); + + return field; +} + +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_access (Lisp_Object mvar) +{ + Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar); + + if (EQ (mvar_slot, Qscratch)) + { + if (!comp.scratch) + comp.scratch = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "scratch"); + return comp.scratch; + } + + EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar)); + EMACS_INT slot_n = XFIXNUM (mvar_slot); + if (comp.func_has_non_local || (SPEED < 2)) + return comp.arrays[arr_idx][slot_n]; + else + { + if (arr_idx) + return comp.arrays[arr_idx][slot_n]; + else + return comp.f_frame[slot_n]; + } +} + +static void +register_emitter (Lisp_Object key, void *func) +{ + Lisp_Object value = make_mint_ptr (func); + Fputhash (key, value, comp.emitter_dispatcher); +} + +static imm_reloc_t +obj_to_reloc (Lisp_Object obj) +{ + imm_reloc_t reloc; + Lisp_Object idx; + + idx = Fgethash (obj, comp.d_default_idx, Qnil); + if (!NILP (idx)) { + reloc.array = comp.data_relocs; + goto found; + } + + idx = Fgethash (obj, comp.d_impure_idx, Qnil); + if (!NILP (idx)) + { + reloc.array = comp.data_relocs_impure; + goto found; + } + + idx = Fgethash (obj, comp.d_ephemeral_idx, Qnil); + if (!NILP (idx)) + { + reloc.array = comp.data_relocs_ephemeral; + goto found; + } + + xsignal1 (Qnative_ice, + build_string ("cant't find data in relocation containers")); + assume (false); + found: + 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 subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs, + gcc_jit_rvalue **args, bool direct) +{ + Lisp_Object func; + if (direct) + { + Lisp_Object c_name = + Fgethash (subr_sym, + CALL1I (comp-ctxt-sym-to-c-name-h, Vcomp_ctxt), + Qnil); + func = Fgethash (c_name, comp.exported_funcs_h, Qnil); + } + else + func = Fgethash (subr_sym, comp.imported_funcs_h, Qnil); + + if (NILP (func)) + xsignal2 (Qnative_ice, + build_string ("missing function declaration"), + subr_sym); + + if (direct) + { + emit_comment (format_string ("direct call to subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + return gcc_jit_context_new_call (comp.ctxt, + NULL, + xmint_pointer (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 (func)); + + if (!f_ptr) + xsignal2 (Qnative_ice, + build_string ("missing function relocation"), + subr_sym); + emit_comment (format_string ("calling subr: %s", + SSDATA (SYMBOL_NAME (subr_sym)))); + 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 subr_sym, 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 (subr_sym, 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 gcc_jit_rvalue * +emit_coerce (gcc_jit_type *new_type, gcc_jit_rvalue *obj) +{ + static ptrdiff_t i; + + gcc_jit_type *old_type = gcc_jit_rvalue_get_type (obj); + + if (new_type == old_type) + return obj; + + gcc_jit_field *orig_field = + type_to_cast_field (old_type); + gcc_jit_field *dest_field = type_to_cast_field (new_type); + + gcc_jit_lvalue *tmp_u = + gcc_jit_function_new_local (comp.func, + NULL, + comp.cast_union_type, + format_string ("union_cast_%td", i++)); + gcc_jit_block_add_assignment (comp.block, + NULL, + gcc_jit_lvalue_access_field (tmp_u, + NULL, + orig_field), + obj); + + return gcc_jit_rvalue_access_field ( gcc_jit_lvalue_as_rvalue (tmp_u), + NULL, + dest_field); +} + +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 (long long n) +{ +#ifndef WIDE_EMACS_INT + xsignal1 (Qnative_ice, + build_string ("emit_rvalue_from_long_long called in non wide int" + " configuration")); +#endif + + 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 (comp.long_long_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_most_positive_fixnum (void) +{ +#if EMACS_INT_MAX > LONG_MAX + return emit_rvalue_from_long_long (MOST_POSITIVE_FIXNUM); +#else + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, + MOST_POSITIVE_FIXNUM); +#endif +} + +static gcc_jit_rvalue * +emit_most_negative_fixnum (void) +{ +#if EMACS_INT_MAX > LONG_MAX + return emit_rvalue_from_long_long (MOST_NEGATIVE_FIXNUM); +#else + return gcc_jit_context_new_rvalue_from_long (comp.ctxt, + comp.emacs_int_type, + MOST_NEGATIVE_FIXNUM); +#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 obj; +} + +static gcc_jit_lvalue * +emit_lval_XLI (gcc_jit_lvalue *obj) +{ + emit_comment ("lval_XLI"); + return obj; +} + +/* +static gcc_jit_rvalue * +emit_XLP (gcc_jit_rvalue *obj) +{ + emit_comment ("XLP"); + + return gcc_jit_rvalue_access_field (obj, + NULL, + comp.lisp_obj_as_ptr); +} + +static gcc_jit_lvalue * +emit_lval_XLP (gcc_jit_lvalue *obj) +{ + emit_comment ("lval_XLP"); + + return gcc_jit_lvalue_access_field (obj, + NULL, + comp.lisp_obj_as_ptr); +} */ +static gcc_jit_rvalue * +emit_XUNTAG (gcc_jit_rvalue *a, gcc_jit_type *type, long long lisp_word_tag) +{ + /* #define XUNTAG(a, type, ctype) ((ctype *) + ((char *) XLP (a) - LISP_WORD_TAG (type))) */ + emit_comment ("XUNTAG"); + +#ifndef WIDE_EMACS_INT + return emit_coerce ( + gcc_jit_type_get_pointer (type), + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.emacs_int_type, + emit_XLI (a), + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_int_type, + lisp_word_tag))); +#else + return emit_coerce ( + gcc_jit_type_get_pointer (type), + emit_binary_op ( + GCC_JIT_BINARY_OP_MINUS, + comp.unsigned_long_long_type, + /* FIXME Should be XLP. */ + emit_XLI (a), + emit_rvalue_from_long_long (lisp_word_tag))); +#endif +} + +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, ptrdiff_t 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)); + + if (!USE_LSB_TAG) + { + i = emit_binary_op (GCC_JIT_BINARY_OP_LSHIFT, + comp.emacs_uint_type, + i, + comp.inttypebits); + + return emit_coerce (comp.emacs_int_type, + emit_binary_op (GCC_JIT_BINARY_OP_RSHIFT, + comp.emacs_uint_type, + i, + comp.inttypebits)); + } + else + /* FIXME: Implementation dependent (wants arithmetic shift). */ + 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); + + gcc_jit_lvalue *res = gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + "lisp_obj_fixnum"); + + gcc_jit_block_add_assignment (comp.block, + NULL, + emit_lval_XLI (res), + tmp); + + return gcc_jit_lvalue_as_rvalue (res); +} + +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_coerce (comp.emacs_uint_type, + emit_rvalue_from_long_long ((EMACS_INT_MAX + >> (INTTYPEBITS - 1)))); + 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, + gcc_jit_context_new_rvalue_from_int ( + comp.ctxt, + comp.emacs_uint_type, + VALBITS)), + n); + return emit_XLI (emit_coerce (comp.emacs_int_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_rvalue * +emit_const_lisp_obj (Lisp_Object obj) +{ + emit_comment (format_string ("const lisp obj: %s", + SSDATA (Fprin1_to_string (obj, Qnil)))); + + if (NIL_IS_ZERO && EQ (obj, Qnil)) + { + gcc_jit_rvalue *n; +#ifdef WIDE_EMACS_INT + eassert (NIL_IS_ZERO); + n = emit_rvalue_from_long_long (0); +#else + n = gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + NULL); +#endif + return emit_coerce (comp.lisp_obj_type, n); + } + + imm_reloc_t reloc = obj_to_reloc (obj); + return + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_array_access (comp.ctxt, + NULL, + reloc.array, + reloc.idx)); +} + +static gcc_jit_rvalue * +emit_NILP (gcc_jit_rvalue *x) +{ + emit_comment ("NILP"); + return emit_EQ (x, emit_const_lisp_obj (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_const_lisp_obj (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, + gcc_jit_lvalue_as_rvalue ( + gcc_jit_rvalue_dereference (comp.pure_ref, NULL))), + 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_val (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 (FIXNUMP (constant)) + { + /* We can still emit directly objects that are self-contained in a + word (read fixnums). */ + emit_comment (SSDATA (Fprin1_to_string (constant, Qnil))); + gcc_jit_rvalue *word; +#ifdef WIDE_EMACS_INT + word = emit_rvalue_from_long_long (constant); +#else + word = + gcc_jit_context_new_rvalue_from_ptr (comp.ctxt, + comp.void_ptr_type, + constant); +#endif + return emit_coerce (comp.lisp_obj_type, word); + } + /* Other const objects are fetched from the reloc array. */ + return emit_const_lisp_obj (constant); + } + + return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar)); +} + +static void +emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val) +{ + + gcc_jit_block_add_assignment ( + comp.block, + NULL, + emit_mvar_access (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_val (XCAR (args)); + gcc_args[2] = emit_const_lisp_obj (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_val (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)). */ + + Lisp_Object callee = FIRST (insn); + EMACS_INT nargs = XFIXNUM (Flength (CDR (insn))); + + if (!nargs) + return emit_call_ref (callee, + nargs, + comp.arrays[0][0], + direct); + + Lisp_Object first_arg = SECOND (insn); + Lisp_Object arr_idx = CALL1I (comp-mvar-array-idx, first_arg); + + /* Make sure all the arguments are layout-ed into the same array. */ + Lisp_Object p = XCDR (XCDR (insn)); + FOR_EACH_TAIL (p) + if (!EQ (arr_idx, CALL1I (comp-mvar-array-idx, XCAR (p)))) + xsignal2 (Qnative_ice, build_string ("incoherent array idx for insn"), + insn); + + EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg)); + return emit_call_ref (callee, + nargs, + comp.arrays[XFIXNUM (arr_idx)][first_slot], + direct); +} + +/* 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_call (intern_c_string (STR (SETJMP_NAME)), comp.int_type, 1, args, false); + 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_val (arg[0]); + gcc_jit_rvalue *b = emit_mvar_val (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_val (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_val (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_val (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_val (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_val (SECOND (insn)), + emit_mvar_val (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_val (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_val (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_val (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); +} + +/* 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 relay 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 */ + + Lisp_Object str = Fprin1_to_string (obj, 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); + + /* NOTE this truncates if the data has some zero byte before termination. */ + gcc_jit_block_add_comment (block, NULL, p); + + gcc_jit_lvalue *arr = + gcc_jit_lvalue_access_field (data_struct, NULL, fields[1]); + + for (ptrdiff_t i = 0; i < len; i++, p++) + { + gcc_jit_block_add_assignment ( + block, + NULL, + 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.ptrdiff_type, + i)), + gcc_jit_context_new_rvalue_from_int (comp.ctxt, + comp.char_type, + *p)); + } + 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); + + 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); + + 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); + +#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)) }; + emit_static_object (TEXT_OPTIM_QLY_SYM, Flist (2, 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_ref = + gcc_jit_lvalue_as_rvalue ( + gcc_jit_context_new_global ( + comp.ctxt, + NULL, + GCC_JIT_GLOBAL_EXPORTED, + gcc_jit_type_get_pointer (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 (jmp_buf)), + "stuff"); + comp.jmp_buf_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_jmp_buf", + 1, &field); +} + +/* struct handler definition */ + +static void +define_handler_struct (void) +{ + comp.handler_s = + gcc_jit_context_new_opaque_struct (comp.ctxt, NULL, "comp_handler"); + comp.handler_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.handler_s)); + + comp.handler_jmp_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + gcc_jit_struct_as_type ( + comp.jmp_buf_s), + "jmp"); + comp.handler_val_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "val"); + comp.handler_next_field = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "next"); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, val)), + "pad0"), + comp.handler_val_field, + comp.handler_next_field, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct handler, jmp) + - offsetof (struct handler, next) + - sizeof (((struct handler *) 0)->next)), + "pad1"), + comp.handler_jmp_field, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + sizeof (struct handler) + - offsetof (struct handler, jmp) + - sizeof (((struct handler *) 0)->jmp)), + "pad2") }; + gcc_jit_struct_set_fields (comp.handler_s, + NULL, + ARRAYELTS (fields), + fields); + +} + +static void +define_thread_state_struct (void) +{ + /* Partially opaque definition for `thread_state'. + Because we need to access just m_handlerlist hopefully this is requires + less manutention then the full deifnition. */ + + comp.m_handlerlist = gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.handler_ptr_type, + "m_handlerlist"); + gcc_jit_field *fields[] = + { gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type (comp.ctxt, + NULL, + comp.char_type, + offsetof (struct thread_state, + m_handlerlist)), + "pad0"), + comp.m_handlerlist, + gcc_jit_context_new_field ( + comp.ctxt, + NULL, + gcc_jit_context_new_array_type ( + comp.ctxt, + NULL, + comp.char_type, + sizeof (struct thread_state) + - offsetof (struct thread_state, + m_handlerlist) + - sizeof (((struct thread_state *) 0)->m_handlerlist)), + "pad1") }; + + comp.thread_state_s = + gcc_jit_context_new_struct_type (comp.ctxt, + NULL, + "comp_thread_state", + ARRAYELTS (fields), + fields); + comp.thread_state_ptr_type = + gcc_jit_type_get_pointer (gcc_jit_struct_as_type (comp.thread_state_s)); +} + +static void +define_cast_union (void) +{ + + comp.cast_union_as_ll = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_long_type, + "ll"); + comp.cast_union_as_ull = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_long_long_type, + "ull"); + comp.cast_union_as_l = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.long_type, + "l"); + comp.cast_union_as_ul = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_long_type, + "ul"); + comp.cast_union_as_u = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.unsigned_type, + "u"); + comp.cast_union_as_i = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.int_type, + "i"); + comp.cast_union_as_b = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.bool_type, + "b"); + comp.cast_union_as_uintptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.uintptr_type, + "uintptr"); + comp.cast_union_as_ptrdiff = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.ptrdiff_type, + "ptrdiff"); + comp.cast_union_as_c_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.char_ptr_type, + "c_p"); + comp.cast_union_as_v_p = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.void_ptr_type, + "v_p"); + comp.cast_union_as_lisp_cons_ptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_cons_ptr_type, + "cons_ptr"); + comp.cast_union_as_lisp_obj = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_type, + "lisp_obj"); + comp.cast_union_as_lisp_obj_ptr = + gcc_jit_context_new_field (comp.ctxt, + NULL, + comp.lisp_obj_ptr_type, + "lisp_obj_ptr"); + + + gcc_jit_field *cast_union_fields[] = + { comp.cast_union_as_ll, + comp.cast_union_as_ull, + comp.cast_union_as_l, + comp.cast_union_as_ul, + comp.cast_union_as_u, + comp.cast_union_as_i, + comp.cast_union_as_b, + comp.cast_union_as_uintptr, + comp.cast_union_as_ptrdiff, + comp.cast_union_as_c_p, + comp.cast_union_as_v_p, + comp.cast_union_as_lisp_cons_ptr, + comp.cast_union_as_lisp_obj, + comp.cast_union_as_lisp_obj_ptr }; + comp.cast_union_type = + gcc_jit_context_new_union_type (comp.ctxt, + NULL, + "cast_union", + ARRAYELTS (cast_union_fields), + cast_union_fields); +} + +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_const_lisp_obj (Qnil)); + + comp.block = not_nil_b; + gcc_jit_rvalue *wrong_type_args[] = + { emit_const_lisp_obj (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_const_lisp_obj (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_most_positive_fixnum () + : emit_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_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); +} + +/* 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_const_lisp_obj (Qt)); + + comp.block = ret_nil_block; + gcc_jit_block_end_with_return (ret_nil_block, + NULL, + emit_const_lisp_obj (Qnil)); +} + +/* 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; + char *c_name = SSDATA (CALL1I (comp-func-c-name, func)); + Lisp_Object args = CALL1I (comp-func-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 **param = SAFE_ALLOCA (max_args * sizeof (*param)); + for (int i = 0; i < max_args; ++i) + param[i] = gcc_jit_context_new_param (comp.ctxt, + NULL, + type[i], + format_string ("par_%d", i)); + gcc_func = gcc_jit_context_new_function (comp.ctxt, NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, + max_args, + param, + 0); + } + else + { + gcc_jit_param *param[] = + { 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") }; + gcc_func = + gcc_jit_context_new_function (comp.ctxt, + NULL, + GCC_JIT_FUNCTION_EXPORTED, + comp.lisp_obj_type, + c_name, 2, param, 0); + } + + Fputhash (CALL1I (comp-func-c-name, func), + make_mint_ptr (gcc_func), + comp.exported_funcs_h); + + SAFE_FREE (); +} + +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)); + + struct Lisp_Hash_Table *array_h = + XHASH_TABLE (CALL1I (comp-func-array-h, func)); + comp.arrays = SAFE_ALLOCA (array_h->count * sizeof (*comp.arrays)); + for (ptrdiff_t i = 0; i < array_h->count; i++) + { + EMACS_INT array_len = XFIXNUM (HASH_VALUE (array_h, i)); + comp.arrays[i] = SAFE_ALLOCA (array_len * sizeof (**comp.arrays)); + + 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, + array_len), + format_string ("arr_%td", i)); + + for (ptrdiff_t j = 0; j < array_len; j++) + comp.arrays[i][j] = + 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, + j)); + } + + /* + The floating frame is a copy of the normal frame that can be used to store + locals if the are not going to be used in a nargs call. + This has two advantages: + - Enable gcc for better reordering (frame array is clobbered every time is + passed as parameter being involved into an nargs function call). + - Allow gcc to trigger other optimizations that are prevented by memory + referencing. + */ + if (SPEED >= 2) + { + comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame)); + for (ptrdiff_t i = 0; i < frame_size; ++i) + comp.f_frame[i] = + gcc_jit_function_new_local (comp.func, + NULL, + comp.lisp_obj_type, + format_string ("local%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) +{ + 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); + } + + 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 > 1) + { + 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); + /* No XLP is emitted for now so lets define this always as integer + disregarding LISP_WORDS_ARE_POINTERS value. */ + comp.lisp_obj_type = comp.emacs_int_type; + comp.lisp_obj_ptr_type = gcc_jit_type_get_pointer (comp.lisp_obj_type); + 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.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 data structures. */ + + define_lisp_cons (); + define_jmp_buf (); + define_handler_struct (); + define_thread_state_struct (); + define_cast_union (); + + return Qt; +} + +DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt, + 0, 0, 0, + doc: /* Release the native compiler context. */) + (void) +{ + if (comp.ctxt) + gcc_jit_context_release (comp.ctxt); + + if (logfile) + fclose (logfile); + comp.ctxt = NULL; + + return Qt; +} + +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) +{ + CHECK_STRING (base_name); + + gcc_jit_context_set_int_option (comp.ctxt, + GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL, + 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; + if (!noninteractive) + { + sigset_t blocked; + /* Gcc doesn't like being interrupted at all. */ + block_input (); + sigemptyset (&blocked); + sigaddset (&blocked, SIGALRM); + sigaddset (&blocked, SIGINT); + sigaddset (&blocked, SIGIO); + pthread_sigmask (SIG_BLOCK, &blocked, &oldset); + } + 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 (); + + 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)); + + /* Remove the old eln instead of copying the new one into it to get + a new inode and prevent crashes in case the old one is currently + loaded. */ + if (!NILP (Ffile_exists_p (out_file))) + Fdelete_file (out_file, Qnil); + Frename_file (tmp_file, out_file, Qnil); + + if (!noninteractive) + { + pthread_sigmask (SIG_SETMASK, &oldset, 0); + unblock_input (); + } + + return out_file; +} + + +/******************************************************************************/ +/* 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. */ +/******************************************************************************/ + +Lisp_Object +helper_save_window_excursion (Lisp_Object v1) +{ + ptrdiff_t count1 = SPECPDL_INDEX (); + record_unwind_protect (restore_window_configuration, + Fcurrent_window_configuration (Qnil)); + v1 = Fprogn (v1); + unbind_to (count1, v1); + return v1; +} + +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); +} + + +/***********************************/ +/* 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; + +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 (!comp_deferred_compilation + || noninteractive + || !NILP (Vpurify_flag) + || !COMPILEDP (definition) + || !FIXNUMP (AREF (definition, COMPILED_ARGLIST)) + || !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)); +} + +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); + bool reloading_cu = *saved_cu ? true : false; + 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 && reloading_cu)); + + if (reloading_cu) + /* '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); + } + else + *saved_cu = comp_u_lisp_obj; + + freloc_check_fill (); + + void (*top_level_run)(Lisp_Object) + = dynlib_sym (handle, + late_load ? "late_top_level_run" : "top_level_run"); + + if (!reloading_cu) + { + struct thread_state ***current_thread_reloc = + dynlib_sym (handle, CURRENT_THREAD_RELOC_SYM); + EMACS_INT ***pure_reloc = dynlib_sym (handle, PURE_RELOC_SYM); + Lisp_Object *data_relocs = dynlib_sym (handle, DATA_RELOC_SYM); + Lisp_Object *data_imp_relocs = dynlib_sym (handle, DATA_RELOC_IMPURE_SYM); + 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 = (EMACS_INT **)&pure; + + /* Imported functions. */ + *freloc_link_table = freloc.link_table; + + /* Imported data. */ + if (!loading_dump) + { + comp_u->optimize_qualities = + load_static_obj (comp_u, TEXT_OPTIM_QLY_SYM); + comp_u->data_vec = load_static_obj (comp_u, TEXT_DATA_RELOC_SYM); + comp_u->data_impure_vec = + load_static_obj (comp_u, TEXT_DATA_RELOC_IMPURE_SYM); + + if (!NILP (Vpurify_flag)) + /* Non impure can be copied into pure space. */ + comp_u->data_vec = Fpurecopy (comp_u->data_vec); + } + + EMACS_INT d_vec_len = XFIXNUM (Flength (comp_u->data_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_relocs[i] = AREF (comp_u->data_vec, i); + + d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec)); + for (EMACS_INT i = 0; i < d_vec_len; i++) + data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i); + } + + if (!loading_dump) + { + /* Note: data_ephemeral_vec is not GC protected except than by + this function frame. After this functions will be + deactivated GC will be free to collect it, but it MUST + survive till 'top_level_run' has finished his job. We store + into the ephemeral allocation class only objects that we know + are necessary exclusively during the first load. Once these + are collected we don't have to maintain them in the heap + forever. */ + + Lisp_Object volatile data_ephemeral_vec = + 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; + } + + 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); +} + +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) +{ + dynlib_handle_ptr handle = XNATIVE_COMP_UNIT (comp_u)->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); + 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 (Fsymbol_name (name))); + x->s.native_intspec = intspec; + x->s.doc = XFIXNUM (doc_idx); + x->s.native_comp_u[0] = comp_u; + Lisp_Object tem; + XSETSUBR (tem, &x->s); + set_symbol_function (name, tem); + + Fputhash (name, c_name, Vcomp_sym_subr_c_name_h); + LOADHIST_ATTACH (Fcons (Qdefun, name)); + + return Qnil; +} + +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; + comp_u->data_vec = Qnil; + load_comp_unit (comp_u, false, !NILP (late_load)); + + return Qt; +} + + +void +syms_of_comp (void) +{ + /* 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"); + + /* 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"); + + /* 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__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; + + 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-sym-subr-c-name-h", Vcomp_sym_subr_c_name_h, + doc: /* Hash table symbol-function -> function-c-name. For + internal use during */); + Vcomp_sym_subr_c_name_h = CALLN (Fmake_hash_table); + 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 /* HAVE_NATIVE_COMP */ |