From: Andrea Corallo Date: Thu, 21 Nov 2019 15:09:30 +0000 (+0100) Subject: error handling rework X-Git-Tag: emacs-28.0.90~2727^2~960 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=71b363e2b3c709e64f8ef8ab7446cc3a19573eeb;p=emacs.git error handling rework --- 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 . */ #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 { @@ -210,15 +202,6 @@ format_string (const char *format, ...) return scratch_area; } -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) { @@ -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));