error handling rework

2 files changed, 100 insertions, 70 deletions

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index e1f0e657864..666d467051e 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -389,7 +389,8 @@ Put PREFIX in front of it."
 (defun comp-decrypt-lambda-list (x)
   "Decript lambda list X."
   (unless (fixnump x)
-    (error "Can't native compile a non lexical scoped function"))
+    (signal 'native-compiler-error
+            "can't native compile a non lexical scoped function"))
   (let ((rest (not (= (logand x 128) 0)))
         (mandatory (logand x 127))
         (nonrest (ash x -8)))
@@ -409,7 +410,7 @@ Put PREFIX in front of it."
 
 (defun comp-spill-lap-function (_function-name)
   "Byte compile FUNCTION-NAME spilling data from the byte compiler."
-  (error "To be reimplemented")
+  (signal 'native-ice "to be reimplemented")
   ;; (let* ((f (symbol-function function-name))
   ;;        (func (make-comp-func :symbol-name function-name
   ;;                              :c-func-name (comp-c-func-name
@@ -435,7 +436,7 @@ Put PREFIX in front of it."
   "Byte compile FILENAME spilling data from the byte compiler."
   (byte-compile-file filename)
   (unless byte-to-native-top-level-forms
-    (error "Empty byte compiler output"))
+    (signal 'native-compiler-error "empty byte compiler output"))
   (setf (comp-ctxt-top-level-forms comp-ctxt) (reverse byte-to-native-top-level-forms))
   (cl-loop
    for f in (cl-loop for x in byte-to-native-top-level-forms ; All non anonymous.
@@ -538,7 +539,7 @@ Restore the original value afterwards."
 (defsubst comp-label-to-addr (label)
   "Find the address of LABEL."
   (or (gethash label (comp-limplify-label-to-addr comp-pass))
-      (error "Can't find label %d" label)))
+      (signal 'native-ice (list "label not found" label))))
 
 (defsubst comp-mark-curr-bb-closed ()
   "Mark the current basic block as closed."
@@ -556,8 +557,9 @@ The basic block is returned regardless it was already declared or not."
                             (comp-limplify-pending-blocks comp-pass)))))
     (if bb
         (progn
-          (cl-assert (or (null sp) (= sp (comp-block-sp bb)))
-                     (sp (comp-block-sp bb)) "sp %d %d differs")
+          (unless (or (null sp) (= sp (comp-block-sp bb)))
+            (signal 'native-ice (list "incoherent stack pointers"
+                                      sp (comp-block-sp bb))))
           bb)
       (car (push (make--comp-block lap-addr sp (comp-new-block-sym))
                  (comp-limplify-pending-blocks comp-pass))))))
@@ -607,7 +609,7 @@ If the callee function is known to have a return type propagate it."
 (defun comp-copy-slot (src-n &optional dst-n)
   "Set slot number DST-N to slot number SRC-N as source.
 If DST-N is specified use it otherwise assume it to be the current slot."
-  (comp-with-sp (if dst-n dst-n (comp-sp))
+  (comp-with-sp (or dst-n (comp-sp))
     (let ((src-slot (comp-slot-n src-n)))
       (cl-assert src-slot)
       (comp-emit `(set ,(comp-slot) ,src-slot)))))
@@ -749,28 +751,28 @@ Return value is the fall through block name."
            ;; All fall through are artificially created here except the last one.
            (puthash ff-bb-name ff-bb (comp-func-blocks comp-func))
            (setf (comp-limplify-curr-block comp-pass) ff-bb))))
-    (_ (error "Missing previous setimm while creating a switch"))))
+    (_ (signal 'native-ice
+               "missing previous setimm while creating a switch"))))
 
 (defun comp-emit-set-call-subr (subr-name sp-delta)
     "Emit a call for SUBR-NAME.
 SP-DELTA is the stack adjustment."
     (let ((subr (symbol-function subr-name))
-          (subr-str (symbol-name subr-name))
           (nargs (1+ (- sp-delta))))
-      (cl-assert (subrp subr) nil
-                 "%s not a subr" subr-str)
+      (unless (subrp subr)
+        (signal 'native-ice (list "not a subr" subr)))
       (let* ((arity (subr-arity subr))
              (minarg (car arity))
              (maxarg (cdr arity)))
-        (cl-assert (not (eq maxarg 'unevalled)) nil
-                   "%s contains unevalled arg" subr-name)
+        (when (eq maxarg 'unevalled)
+          (signal 'native-ice (list "subr contains  unevalled args" subr-name)))
         (if (eq maxarg 'many)
             ;; callref case.
             (comp-emit-set-call (comp-callref subr-name nargs (comp-sp)))
           ;; Normal call.
-          (cl-assert (and (>= maxarg nargs) (<= minarg nargs))
-                     (nargs maxarg minarg)
-                     "Incoherent stack adjustment %d, maxarg %d minarg %d")
+          (unless (and (>= maxarg nargs) (<= minarg nargs))
+            (signal 'native-ice
+                    (list "incoherent stack adjustment" nargs maxarg minarg)))
           (let* ((subr-name subr-name)
                  (slots (cl-loop for i from 0 below maxarg
                                  collect (comp-slot-n (+ i (comp-sp))))))
@@ -817,9 +819,9 @@ the annotation emission."
                              `(cl-incf (comp-sp) ,sp-delta))
                           ,@(comp-body-eff body op-name sp-delta))
                 else
-                collect `(',op (error ,(concat "Unsupported LAP op "
-                                               op-name))))
-     (_ (error "Unexpected LAP op %s" (symbol-name op)))))
+                collect `(',op (signal 'native-ice
+                                       (list "unsupported LAP op" ',op-name))))
+     (_ (signal 'native-ice (list "unexpected LAP op" (symbol-name op))))))
 
 (defun comp-limplify-lap-inst (insn)
   "Limplify LAP instruction INSN pushng it in the proper basic block."
@@ -1011,8 +1013,7 @@ the annotation emission."
        (cl-incf (comp-sp) (- 1 arg))
        (comp-emit-set-call (comp-callref 'insert arg (comp-sp))))
       (byte-stack-set
-       (comp-with-sp (1+ (comp-sp)) ;; FIXME!!
-         (comp-copy-slot (comp-sp) (- (comp-sp) arg))))
+       (comp-copy-slot (1+ (comp-sp)) (- (comp-sp) arg -1)))
       (byte-stack-set2 (cl-assert nil)) ;; TODO
       (byte-discardN
        (cl-incf (comp-sp) (- arg)))
@@ -1203,9 +1204,9 @@ Top level forms for the current context are rendered too."
 ;; This pass should be run every time basic blocks or mvar are shuffled.
 
 (cl-defun make-comp-ssa-mvar (&key slot (constant nil const-vld) type)
-  (make--comp-mvar  :id (funcall (comp-func-ssa-cnt-gen comp-func))
-                    :slot slot :const-vld const-vld :constant constant
-                    :type type))
+  (make--comp-mvar :id (funcall (comp-func-ssa-cnt-gen comp-func))
+                   :slot slot :const-vld const-vld :constant constant
+                   :type type))
 
 (defun comp-compute-edges ()
   "Compute the basic block edges for the current function."
@@ -1234,8 +1235,10 @@ Top level forms for the current context are rendered too."
                    (edge-add :src bb :dst (gethash forth blocks)))
                   (return)
                   (otherwise
-                   (error "Block %s does not end with a branch in func %s"
-                          bb (comp-func-symbol-name comp-func))))
+                   (signal 'native-ice
+                           (list "block does not end with a branch"
+                                 bb
+                                 (comp-func-symbol-name comp-func)))))
              finally (progn
                        (setf (comp-func-edges comp-func)
                              (nreverse (comp-func-edges comp-func)))
@@ -1280,7 +1283,7 @@ Top level forms for the current context are rendered too."
             (first-processed (l)
               (if-let ((p (cl-find-if (lambda (p) (comp-block-dom p)) l)))
                   p
-                (error "Cant't find first preprocessed"))))
+                (signal 'native-ice "cant't find first preprocessed"))))
 
     (when-let ((blocks (comp-func-blocks comp-func))
                (entry (gethash 'entry blocks))
@@ -1845,7 +1848,8 @@ If INPUT is a string, use it as the file path to be native compiled.
 Return the compilation unit filename."
   (unless (or (symbolp input)
               (stringp input))
-    (error "Trying to native compile something not a symbol function or file"))
+    (signal 'native-compiler-error
+          (list "not a symbol function or file" input)))
   (let ((data input)
         (comp-native-compiling t)
         (comp-ctxt (make-comp-ctxt
@@ -1858,7 +1862,12 @@ Return the compilation unit filename."
                 (comp-log (format "Running pass %s:\n" pass) 2)
                 (setq data (funcall pass data)))
               comp-passes)
-      (error (error "While compiling %s: %s" input (error-message-string err))))
+      (native-compiler-error
+       ;; Add source input.
+       (let ((err-val (cdr err)))
+         (signal (car err) (if (consp err-val)
+                               (cons input err-val)
+                             (list input err-val))))))
     data))
 
 ;;;###autoload
@@ -1874,7 +1883,8 @@ Follow folders RECURSIVELY if non nil."
                      (directory-files input t "\\.el$"))
                  (if (file-exists-p input)
                      (list input)
-                   (error "Input not a file nor directory")))))
+                   (signal 'native-compiler-error
+                           "input not a file nor directory")))))
     (with-mutex comp-src-pool-mutex
       (setf comp-src-pool (nconc files comp-src-pool)))
     (cl-loop repeat jobs
diff --git a/src/comp.c b/src/comp.c
index f7950bcc72c..61f297ea3d0 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -70,14 +70,6 @@ along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.  */
 #endif
 #define SETJMP_NAME STR (SETJMP)
 
-/* Raise an internal compiler error if test.
-   msg is evaluated only in that case.  */
-#define ICE_IF(test, msg)                       \
-  do {                                          \
-    if (test)                                   \
-      ice (msg);                                \
-  } while (0)
-
 /* C side of the compiler context.  */
 
 typedef struct {
@@ -211,15 +203,6 @@ format_string (const char *format, ...)
 }
 
 static void
-ice (const char* msg)
-{
-  if (msg)
-    xsignal1 (Qinternal_native_compiler_error, build_string (msg));
-  else
-    xsignal0 (Qinternal_native_compiler_error);
-}
-
-static void
 bcall0 (Lisp_Object f)
 {
   Ffuncall (1, &f);
@@ -273,7 +256,7 @@ type_to_cast_field (gcc_jit_type *type)
   else if (type == comp.lisp_obj_ptr_type)
     field = comp.cast_union_as_lisp_obj_ptr;
   else
-    ice ("unsupported cast");
+    xsignal1 (Qnative_ice, build_string ("unsupported cast"));
 
   return field;
 }
@@ -282,7 +265,9 @@ static gcc_jit_block *
 retrive_block (Lisp_Object block_name)
 {
   Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil);
-  ICE_IF (NILP (value), "missing basic block");
+
+  if (NILP (value))
+    xsignal1 (Qnative_ice, build_string ("missing basic block"));
 
   return (gcc_jit_block *) xmint_pointer (value);
 }
@@ -293,8 +278,10 @@ 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);
-  ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)),
-          "double basic block declaration");
+
+  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);
 }
 
@@ -343,8 +330,10 @@ declare_imported_func (Lisp_Object subr_sym, gcc_jit_type *ret_type,
                        int nargs, gcc_jit_type **types)
 {
   /* Don't want to declare the same function two times.  */
-  ICE_IF (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)),
-          "unexpected double function declaration");
+  if (!NILP (Fgethash (subr_sym, comp.imported_funcs_h, Qnil)))
+    xsignal2 (Qnative_ice,
+              build_string ("unexpected double function declaration"),
+              subr_sym);
 
   if (nargs == MANY)
     {
@@ -396,7 +385,10 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs,
   Lisp_Object func =
     Fgethash (subr_sym, direct ? comp.exported_funcs_h: comp.imported_funcs_h,
               Qnil);
-  ICE_IF (NILP (func), "missing function declaration");
+  if (NILP (func))
+      xsignal2 (Qnative_ice,
+                build_string ("missing function declaration"),
+                subr_sym);
 
   if (direct)
     {
@@ -414,7 +406,10 @@ emit_call (Lisp_Object subr_sym, gcc_jit_type *ret_type, ptrdiff_t nargs,
         gcc_jit_lvalue_access_field (comp.func_relocs,
                                      NULL,
                                      (gcc_jit_field *) xmint_pointer (func));
-      ICE_IF (!f_ptr, "undeclared function relocation");
+      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,
@@ -1092,7 +1087,11 @@ emit_set_internal (Lisp_Object args)
               #s(comp-mvar 6 1 t 3 nil))
   */
   /* TODO: Inline the most common case.  */
-  ICE_IF (list_length (args) != 3, "unexpected arg length for insns");
+  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];
@@ -1272,7 +1271,7 @@ emit_limple_insn (Lisp_Object insn)
       else if (EQ (handler_spec, Qcondition_case))
         h_num = CONDITION_CASE;
       else
-        ice ("incoherent insn");
+        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,
@@ -1372,9 +1371,13 @@ emit_limple_insn (Lisp_Object insn)
       else if (EQ (FIRST (arg1), Qdirect_callref))
         res = emit_limple_call_ref (XCDR (arg1), true);
       else
-        ice ("LIMPLE inconsistent arg1 for op =");
+        xsignal2 (Qnative_ice,
+                  build_string ("LIMPLE inconsistent arg1 for insn"),
+                  insn);
 
-      ICE_IF (!res, gcc_jit_context_get_first_error (comp.ctxt));
+      if (!res)
+        xsignal1 (Qnative_ice,
+                  build_string (gcc_jit_context_get_first_error (comp.ctxt)));
 
       emit_frame_assignment (arg[0], res);
     }
@@ -1480,7 +1483,9 @@ emit_limple_insn (Lisp_Object insn)
     }
   else
     {
-      ice ("LIMPLE op inconsistent");
+      xsignal2 (Qnative_ice,
+                build_string ("LIMPLE op inconsistent"),
+                op);
     }
 }
 
@@ -2860,7 +2865,10 @@ compile_function (Lisp_Object func)
       Lisp_Object block_name = HASH_KEY (ht, i);
       Lisp_Object block = HASH_VALUE (ht, i);
       Lisp_Object insns = CALL1I (comp-block-insns, block);
-      ICE_IF (NILP (block) || NILP (insns), "basic block is missing or empty");
+      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))
@@ -2871,10 +2879,12 @@ compile_function (Lisp_Object func)
         }
     }
   const char *err =  gcc_jit_context_get_first_error (comp.ctxt);
-  ICE_IF (err,
-          format_string ("failing to compile function %s with error: %s",
-                         SSDATA (SYMBOL_NAME (CALL1I (comp-func-symbol-name, func))),
-                         err));
+  if (err)
+    xsignal3 (Qnative_ice,
+              build_string ("failing to compile function"),
+              CALL1I (comp-func-symbol-name, func),
+              build_string (err));
+
   SAFE_FREE ();
 }
 
@@ -2890,7 +2900,8 @@ DEFUN ("comp--init-ctxt", Fcomp__init_ctxt, Scomp__init_ctxt,
 {
   if (comp.ctxt)
     {
-      ice ("compiler context already taken");
+      xsignal1 (Qnative_ice,
+                build_string ("compiler context already taken"));
       return Qnil;
     }
 
@@ -3396,12 +3407,21 @@ syms_of_comp (void)
   DEFSYM (Qadvice, "advice");
 
   /* To be signaled.  */
-  DEFSYM (Qinternal_native_compiler_error, "internal-native-compiler-error");
-  Fput (Qinternal_native_compiler_error, Qerror_conditions,
-        pure_list (Qinternal_native_compiler_error, Qerror));
-  Fput (Qinternal_native_compiler_error, Qerror_message,
+
+  /* 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));