(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)))
(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
"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.
(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."
(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))))))
(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)))))
;; 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))))))
`(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."
(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)))
;; 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."
(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)))
(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))
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
(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
(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
#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 {
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)
{
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;
}
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);
}
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);
}
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)
{
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)
{
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,
#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];
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,
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);
}
}
else
{
- ice ("LIMPLE op inconsistent");
+ xsignal2 (Qnative_ice,
+ build_string ("LIMPLE op inconsistent"),
+ op);
}
}
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))
}
}
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 ();
}
{
if (comp.ctxt)
{
- ice ("compiler context already taken");
+ xsignal1 (Qnative_ice,
+ build_string ("compiler context already taken"));
return Qnil;
}
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));
projects / emacs.git / commitdiff