diff --git a/lisp/emacs-lisp/comp-run.el b/lisp/emacs-lisp/comp-run.el index afb46e3cd19..480f048777c 100644 --- a/lisp/emacs-lisp/comp-run.el +++ b/lisp/emacs-lisp/comp-run.el @@ -256,6 +256,7 @@ display a message." load-path backtrace-line-length byte-compile-warnings + comp-sanitizer-emit ;; package-load-list ;; package-user-dir ;; package-directory-list diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 9c2182092cb..6afb357bef2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -165,6 +165,7 @@ Can be one of: `d-default', `d-impure' or `d-ephemeral'. See `comp-ctxt'.") comp--tco comp--fwprop comp--remove-type-hints + comp--sanitizer comp--compute-function-types comp--final) "Passes to be executed in order.") @@ -3006,6 +3007,51 @@ These are substituted with a normal `set' op." (comp--log-func comp-func 3)))) (comp-ctxt-funcs-h comp-ctxt))) + +;;; Sanitizer pass specific code. + +;; This pass aims to verify compile time value type predictions during +;; execution. +;; The sanitizer pass injects a call to 'helper_sanitizer_assert' before +;; each conditional branch. 'helper_sanitizer_assert' will verify that +;; the variable tested by the conditional branch is of the predicted +;; value type and signal an error otherwise. + +(defvar comp-sanitizer-emit nil + "Gates the sanitizer pass. +In use for native compiler development and verification only.") + +(defun comp--sanitizer (_) + (when comp-sanitizer-emit + (cl-loop + for f being each hash-value of (comp-ctxt-funcs-h comp-ctxt) + for comp-func = f + unless (comp-func-has-non-local comp-func) + do + (cl-loop + for b being each hash-value of (comp-func-blocks f) + do + (cl-loop + named in-the-basic-block + for insns-seq on (comp-block-insns b) + do (pcase insns-seq + (`((cond-jump ,(and (pred comp-mvar-p) mvar-tested) + ,(pred comp-mvar-p) ,_bb1 ,_bb2)) + (let ((type (comp-cstr-to-type-spec mvar-tested)) + (insn (car insns-seq))) + ;; No need to check if type is t. + (unless (eq type t) + (comp--add-const-to-relocs type) + (setcar + insns-seq + (comp--call 'helper_sanitizer_assert + mvar-tested + (make--comp-mvar :constant type))) + (setcdr insns-seq (list insn))) + ;; (setf (comp-func-ssa-status comp-func) 'dirty) + (cl-return-from in-the-basic-block)))))) + do (comp--log-func comp-func 3)))) + ;;; Function types pass specific code. diff --git a/src/comp.c b/src/comp.c index 76cf1f3ab6e..5e4ca643072 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) \ @@ -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, @@ -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; @@ -4619,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); @@ -5082,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. */ @@ -5709,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-"); @@ -5779,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); @@ -5901,6 +5930,13 @@ 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: /* When non-nil enable sanitizer runtime execution. +To be effective Lisp Code must have been compiled with +`comp-sanitizer-emit' non-nil. +In use for native compiler development and verification only. */); + comp_sanitizer_active = false; + Fprovide (intern_c_string ("native-compile"), Qnil); #endif /* #ifdef HAVE_NATIVE_COMP */