Add native compiler sanitizer

* src/comp.c (ABI_VERSION): Bump new version.
(CALL0I): Uncomment.
(helper_link_table, declare_runtime_imported_funcs): Add
'helper_sanitizer_assert'.
(Fcomp__init_ctxt): Register emitter for
'helper_sanitizer_assert'.
(helper_sanitizer_assert): New function.
(syms_of_comp): 'helper_sanitizer_assert' defsym.
(syms_of_comp): 'comp-sanitizer-error' define error.
(syms_of_comp): 'comp-sanitizer-active' defvar.

* lisp/emacs-lisp/comp.el (comp-passes): Add 'comp--sanitizer'.
(comp-sanitizer-emit): Define var.
(comp--sanitizer): Define function.

* lisp/emacs-lisp/comp-run.el (comp-run-async-workers): Forward
'comp-sanitizer-emit'.

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

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.
 

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 */