diff options
Diffstat (limited to 'src/comp.c')
| -rw-r--r-- | src/comp.c | 95 |
1 files changed, 63 insertions, 32 deletions
diff --git a/src/comp.c b/src/comp.c index 6cb35a8619a..99f51e07048 100644 --- a/src/comp.c +++ b/src/comp.c @@ -469,7 +469,7 @@ load_gccjit_if_necessary (bool mandatory) /* Increase this number to force a new Vcomp_abi_hash to be generated. */ -#define ABI_VERSION "5" +#define ABI_VERSION "6" /* Length of the hashes used for eln file naming. */ #define HASH_LENGTH 8 @@ -502,11 +502,9 @@ load_gccjit_if_necessary (bool mandatory) #define THIRD(x) \ XCAR (XCDR (XCDR (x))) -#if 0 /* unused for now */ /* Like call0 but stringify and intern. */ #define CALL0I(fun) \ CALLN (Ffuncall, intern_c_string (STR (fun))) -#endif /* Like call1 but stringify and intern. */ #define CALL1I(fun, arg) \ @@ -522,7 +520,7 @@ load_gccjit_if_necessary (bool mandatory) #define DECL_BLOCK(name, func) \ gcc_jit_block *(name) = \ - gcc_jit_function_new_block ((func), STR (name)) + gcc_jit_function_new_block (func, STR (name)) #ifndef WINDOWSNT # ifdef HAVE__SETJMP @@ -702,6 +700,8 @@ static void helper_save_restriction (void); static bool helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object, enum pvec_type); static struct Lisp_Symbol_With_Pos * helper_GET_SYMBOL_WITH_POSITION (Lisp_Object); +static Lisp_Object +helper_sanitizer_assert (Lisp_Object, Lisp_Object); /* Note: helper_link_table must match the list created by `declare_runtime_imported_funcs'. */ @@ -714,6 +714,7 @@ static void *helper_link_table[] = helper_unbind_n, helper_save_restriction, helper_GET_SYMBOL_WITH_POSITION, + helper_sanitizer_assert, record_unwind_current_buffer, set_internal, helper_unwind_protect, @@ -2442,7 +2443,7 @@ emit_limple_insn (Lisp_Object insn) { Lisp_Object arg1 = arg[1]; - if (EQ (Ftype_of (arg1), Qcomp_mvar)) + if (EQ (Fcl_type_of (arg1), Qcomp_mvar)) res = emit_mvar_rval (arg1); else if (EQ (FIRST (arg1), Qcall)) res = emit_limple_call (XCDR (arg1)); @@ -2975,6 +2976,10 @@ declare_runtime_imported_funcs (void) ADD_IMPORTED (helper_GET_SYMBOL_WITH_POSITION, comp.lisp_symbol_with_position_ptr_type, 1, args); + args[0] = comp.lisp_obj_type; + args[1] = comp.lisp_obj_type; + ADD_IMPORTED (helper_sanitizer_assert, comp.lisp_obj_type, 2, args); + ADD_IMPORTED (record_unwind_current_buffer, comp.void_type, 0, NULL); args[0] = args[1] = args[2] = comp.lisp_obj_type; @@ -4330,11 +4335,10 @@ compile_function (Lisp_Object func) declare_block (Qentry); Lisp_Object blocks = CALL1I (comp-func-blocks, func); struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks); - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++) + DOHASH_SAFE (ht, i) { Lisp_Object block_name = HASH_KEY (ht, i); - if (!EQ (block_name, Qentry) - && !BASE_EQ (block_name, Qunbound)) + if (!EQ (block_name, Qentry)) declare_block (block_name); } @@ -4344,24 +4348,21 @@ compile_function (Lisp_Object func) gcc_jit_lvalue_as_rvalue (comp.func_relocs)); - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++) + DOHASH_SAFE (ht, i) { Lisp_Object block_name = HASH_KEY (ht, i); - if (!BASE_EQ (block_name, Qunbound)) + Lisp_Object block = HASH_VALUE (ht, i); + Lisp_Object insns = CALL1I (comp-block-insns, block); + if (NILP (block) || NILP (insns)) + xsignal1 (Qnative_ice, + build_string ("basic block is missing or empty")); + + comp.block = retrive_block (block_name); + while (CONSP (insns)) { - Lisp_Object 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); - } + Lisp_Object insn = XCAR (insns); + emit_limple_insn (insn); + insns = XCDR (insns); } } const char *err = gcc_jit_context_get_first_error (comp.ctxt); @@ -4623,6 +4624,8 @@ Return t on success. */) emit_simple_limple_call_void_ret); register_emitter (Qhelper_save_restriction, emit_simple_limple_call_void_ret); + register_emitter (Qhelper_sanitizer_assert, + emit_simple_limple_call_lisp_ret); /* Inliners. */ register_emitter (Qadd1, emit_add1); register_emitter (Qsub1, emit_sub1); @@ -4863,8 +4866,8 @@ add_compiler_options (void) #endif } -DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, - Scomp__compile_ctxt_to_file, +DEFUN ("comp--compile-ctxt-to-file0", Fcomp__compile_ctxt_to_file0, + Scomp__compile_ctxt_to_file0, 1, 1, 0, doc: /* Compile the current context as native code to file FILENAME. */) (Lisp_Object filename) @@ -4965,14 +4968,12 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file, struct Lisp_Hash_Table *func_h = XHASH_TABLE (CALL1I (comp-ctxt-funcs-h, Vcomp_ctxt)); - for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (func_h); i++) - if (!BASE_EQ (HASH_VALUE (func_h, i), Qunbound)) - declare_function (HASH_VALUE (func_h, i)); + DOHASH_SAFE (func_h, 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 < HASH_TABLE_SIZE (func_h); i++) - if (!BASE_EQ (HASH_VALUE (func_h, i), Qunbound)) - compile_function (HASH_VALUE (func_h, i)); + DOHASH_SAFE (func_h, i) + compile_function (HASH_VALUE (func_h, i)); /* Work around bug#46495 (GCC PR99126). */ #if defined (WIDE_EMACS_INT) \ @@ -5088,6 +5089,21 @@ helper_GET_SYMBOL_WITH_POSITION (Lisp_Object a) return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Symbol_With_Pos); } +static Lisp_Object +helper_sanitizer_assert (Lisp_Object val, Lisp_Object type) +{ + if (!comp_sanitizer_active + || !NILP ((CALL2I (cl-typep, val, type)))) + return Qnil; + + AUTO_STRING (format, "Comp sanitizer FAIL for %s with type %s"); + CALLN (Fmessage, format, val, type); + CALL0I (backtrace); + xsignal2 (Qcomp_sanitizer_error, val, type); + + return Qnil; +} + /* `native-comp-eln-load-path' clean-up support code. */ @@ -5715,6 +5731,7 @@ natively-compiled one. */); DEFSYM (Qhelper_unbind_n, "helper_unbind_n"); DEFSYM (Qhelper_unwind_protect, "helper_unwind_protect"); DEFSYM (Qhelper_save_restriction, "helper_save_restriction"); + DEFSYM (Qhelper_sanitizer_assert, "helper_sanitizer_assert"); /* Inliners. */ DEFSYM (Qadd1, "1+"); DEFSYM (Qsub1, "1-"); @@ -5785,6 +5802,12 @@ natively-compiled one. */); build_pure_c_string ("eln file inconsistent with current runtime " "configuration, please recompile")); + DEFSYM (Qcomp_sanitizer_error, "comp-sanitizer-error"); + Fput (Qcomp_sanitizer_error, Qerror_conditions, + pure_list (Qcomp_sanitizer_error, Qerror)); + Fput (Qcomp_sanitizer_error, Qerror_message, + build_pure_c_string ("Native code sanitizer runtime error")); + DEFSYM (Qnative__compile_async, "native--compile-async"); defsubr (&Scomp__subr_signature); @@ -5795,7 +5818,7 @@ natively-compiled one. */); defsubr (&Scomp__install_trampoline); defsubr (&Scomp__init_ctxt); defsubr (&Scomp__release_ctxt); - defsubr (&Scomp__compile_ctxt_to_file); + defsubr (&Scomp__compile_ctxt_to_file0); defsubr (&Scomp_libgccjit_version); defsubr (&Scomp__register_lambda); defsubr (&Scomp__register_subr); @@ -5907,6 +5930,14 @@ subr-name -> arity For internal use. */); Vcomp_subr_arities_h = CALLN (Fmake_hash_table, QCtest, Qequal); + DEFVAR_BOOL ("comp-sanitizer-active", comp_sanitizer_active, + doc: /* If non-nil, enable runtime execution of native-compiler sanitizer. +For this to be effective, Lisp code must be compiled +with `comp-sanitizer-emit' non-nil. +This is intended to be used only for development and +verification of the native compiler. */); + comp_sanitizer_active = false; + Fprovide (intern_c_string ("native-compile"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */ |