(defvar comp-func nil
"Bound to the current function by most passes.")
+(defvar comp-block nil
+ "Bound to the current basic block by some pass.")
+
(define-error 'native-compiler-error-dyn-func
"can't native compile a non-lexically-scoped function"
'native-compiler-error)
(:include comp-block)
(:constructor make--comp-block-lap
(addr sp name))) ; Positional
- "A basic block created from lap."
+ "A basic block created from lap (real code)."
;; These two slots are used during limplification.
(sp nil :type number
:documentation "When non-nil indicates the sp value while entering
into it.")
(addr nil :type number
- :documentation "Start block LAP address."))
+ :documentation "Start block LAP address.")
+ (non-ret-insn nil :type list
+ :documentation "Non returning basic blocks.
+`comp-fwprop' may identify and store here basic blocks performing
+non local exits."))
(cl-defstruct (comp-latch (:copier nil)
(:include comp-block))
"Call predicate for OP."
(when (memq op comp-limple-calls) t))
+(defun comp-branch-op-p (op)
+ "Branch predicate for OP."
+ (when (memq op comp-limple-branches) t))
+
(defsubst comp-limple-insn-call-p (insn)
"Limple INSN call predicate."
(comp-call-op-p (car-safe insn)))
(1 font-lock-function-name-face))
(,(rx bol "(" (group-n 1 "phi"))
(1 font-lock-variable-name-face))
- (,(rx bol "(" (group-n 1 "return"))
+ (,(rx bol "(" (group-n 1 (or "return" "unreachable")))
(1 font-lock-warning-face))
(,(rx (group-n 1 (or "entry"
(seq (or "entry_" "entry_fallback_" "bb_")
(make-comp-edge :src bb :dst (gethash third blocks))
(make-comp-edge :src bb :dst (gethash forth blocks)))
(return)
+ (unreachable)
(otherwise
(signal 'native-ice
(list "block does not end with a branch"
args (cdr args)))
(when-let ((cstr-f (gethash f comp-known-func-cstr-h)))
(let ((cstr (comp-cstr-f-ret cstr-f)))
+ (when (comp-cstr-empty-p cstr)
+ ;; Store it to be rewrittein as non local exit.
+ (setf (comp-block-lap-non-ret-insn comp-block) insn))
(setf (comp-mvar-range lval) (comp-cstr-range cstr)
(comp-mvar-valset lval) (comp-cstr-valset cstr)
(comp-mvar-typeset lval) (comp-cstr-typeset cstr)
Return t if something was changed."
(cl-loop with modified = nil
for b being each hash-value of (comp-func-blocks comp-func)
- do (cl-loop for insn in (comp-block-insns b)
- for orig-insn = (unless modified
- ;; Save consing after 1th change.
- (comp-copy-insn insn))
- do (comp-fwprop-insn insn)
- when (and (null modified) (not (equal insn orig-insn)))
- do (setf modified t))
+ do (cl-loop
+ with comp-block = b
+ for insn in (comp-block-insns b)
+ for orig-insn = (unless modified
+ ;; Save consing after 1th change.
+ (comp-copy-insn insn))
+ do (comp-fwprop-insn insn)
+ when (and (null modified) (not (equal insn orig-insn)))
+ do (setf modified t))
finally return modified))
+(defun comp-clean-orphan-blocks (block)
+ "Iterativelly remove all non reachable blocks orphaned by BLOCK."
+ (while
+ (cl-loop
+ with repeat = nil
+ with blocks = (comp-func-blocks comp-func)
+ for bb being each hash-value of blocks
+ when (and (not (eq (comp-block-name bb) 'entry))
+ (cl-notany (lambda (ed)
+ (and (gethash (comp-block-name (comp-edge-src ed))
+ blocks)
+ (not (eq (comp-edge-src ed) block))))
+ (comp-block-in-edges bb)))
+ do
+ (comp-log (format "Removing block: %s" (comp-block-name bb)) 1)
+ (remhash (comp-block-name bb) blocks)
+ (setf repeat t)
+ finally return repeat)))
+
+(defun comp-rewrite-non-locals ()
+ "Make explicit in LIMPLE non-local exits if identified."
+ (cl-loop
+ for bb being each hash-value of (comp-func-blocks comp-func)
+ for non-local-insn = (and (comp-block-lap-p bb)
+ (comp-block-lap-non-ret-insn bb))
+ when non-local-insn
+ do
+ (cl-loop
+ for ed in (comp-block-out-edges bb)
+ for dst-bb = (comp-edge-dst ed)
+ ;; Remove one or more block if necessary.
+ when (length= (comp-block-in-edges dst-bb) 1)
+ do
+ (comp-log (format "Removing block: %s" (comp-block-name dst-bb)) 1)
+ (remhash (comp-block-name dst-bb) (comp-func-blocks comp-func))
+ (comp-clean-orphan-blocks bb))
+ ;; Rework the current block.
+ (let* ((insn-seq (memq non-local-insn (comp-block-insns bb))))
+ (setf (comp-block-lap-non-ret-insn bb) ()
+ (comp-block-out-edges bb) ()
+ ;; Prune unnecessary insns!
+ (cdr insn-seq) '((unreachable))
+ (comp-func-ssa-status comp-func) 'dirty))))
+
(defun comp-fwprop (_)
"Forward propagate types and consts within the lattice."
(comp-ssa)
'comp
(format "fwprop pass jammed into %s?" (comp-func-name f))))
(comp-log (format "Propagation run %d times\n" i) 2))
+ (comp-rewrite-non-locals)
(comp-log-func comp-func 3))))
(comp-ctxt-funcs-h comp-ctxt)))
Lisp_Object value = Fgethash (block_name, comp.func_blocks_h, Qnil);
if (NILP (value))
- xsignal1 (Qnative_ice, build_string ("missing basic block"));
+ xsignal2 (Qnative_ice, build_string ("missing basic block"), block_name);
return (gcc_jit_block *) xmint_pointer (value);
}
NULL,
emit_mvar_rval (arg[0]));
}
+ else if (EQ (op, Qunreachable))
+ {
+ /* Libgccjit has no __builtin_unreachable. */
+ gcc_jit_block_end_with_return (comp.block,
+ NULL,
+ emit_lisp_obj_rval (Qnil));
+ }
else
{
xsignal2 (Qnative_ice,
The "entry" block must be declared as first. */
declare_block (Qentry);
Lisp_Object blocks = CALL1I (comp-func-blocks, func);
- Lisp_Object entry_block = Fgethash (Qentry, blocks, Qnil);
struct Lisp_Hash_Table *ht = XHASH_TABLE (blocks);
- for (ptrdiff_t i = 0; i < ht->count; i++)
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
{
- Lisp_Object block = HASH_VALUE (ht, i);
- if (!EQ (block, entry_block))
- declare_block (HASH_KEY (ht, i));
+ Lisp_Object block_name = HASH_KEY (ht, i);
+ if (!EQ (block_name, Qentry)
+ && !EQ (block_name, Qunbound))
+ declare_block (block_name);
}
gcc_jit_block_add_assignment (retrive_block (Qentry),
gcc_jit_lvalue_as_rvalue (comp.func_relocs));
- for (ptrdiff_t i = 0; i < ht->count; i++)
+ for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (ht); i++)
{
Lisp_Object block_name = HASH_KEY (ht, i);
- Lisp_Object block = HASH_VALUE (ht, i);
- Lisp_Object insns = CALL1I (comp-block-insns, block);
- 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))
+ if (!EQ (block_name, Qunbound))
{
- Lisp_Object insn = XCAR (insns);
- emit_limple_insn (insn);
- insns = XCDR (insns);
+ Lisp_Object block = HASH_VALUE (ht, i);
+ Lisp_Object insns = CALL1I (comp-block-insns, block);
+ 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))
+ {
+ Lisp_Object insn = XCAR (insns);
+ emit_limple_insn (insn);
+ insns = XCDR (insns);
+ }
}
}
const char *err = gcc_jit_context_get_first_error (comp.ctxt);
DEFSYM (Qassume, "assume");
DEFSYM (Qsetimm, "setimm");
DEFSYM (Qreturn, "return");
+ DEFSYM (Qunreachable, "unreachable");
DEFSYM (Qcomp_mvar, "comp-mvar");
DEFSYM (Qcond_jump, "cond-jump");
DEFSYM (Qphi, "phi");
(load (if (file-exists-p dest) dest filename)))
'no-byte-compile)))
+(defun comp-test-no-return-1 (x)
+ (while x
+ (error "foo")))
+
+(defun comp-test-no-return-2 (x)
+ (cond
+ ((eql x '2) t)
+ ((error "bar") nil)))
+
+(defun comp-test-no-return-3 ())
+(defun comp-test-no-return-4 (x)
+ (when x
+ (error "foo")
+ (while (comp-test-no-return-3)
+ (comp-test-no-return-3))))
+
(provide 'comp-test-funcs)
;;; comp-test-funcs.el ends here
;; 22
((defun comp-tests-ret-type-spec-f (x)
- (when (> x 3)
- x))
+ (when (> x 3)
+ x))
(or null float (integer 4 *)))
;; 23
((defun comp-tests-ret-type-spec-f (x)
- (when (>= x 3)
- x))
+ (when (>= x 3)
+ x))
(or null float (integer 3 *)))
;; 24
((defun comp-tests-ret-type-spec-f (x)
- (when (< x 3)
- x))
+ (when (< x 3)
+ x))
(or null float (integer * 2)))
;; 25
((defun comp-tests-ret-type-spec-f (x)
- (when (<= x 3)
- x))
+ (when (<= x 3)
+ x))
(or null float (integer * 3)))
;; 26
((defun comp-tests-ret-type-spec-f (x)
- (when (> 3 x)
- x))
+ (when (> 3 x)
+ x))
(or null float (integer * 2)))
;; 27
((defun comp-tests-ret-type-spec-f (x)
- (when (>= 3 x)
- x))
+ (when (>= 3 x)
+ x))
(or null float (integer * 3)))
;; 28
((defun comp-tests-ret-type-spec-f (x)
- (when (< 3 x)
- x))
+ (when (< 3 x)
+ x))
(or null float (integer 4 *)))
;; 29
((defun comp-tests-ret-type-spec-f (x)
- (when (<= 3 x)
- x))
+ (when (<= 3 x)
+ x))
(or null float (integer 3 *)))
;; 30
;; 35 No float range support.
((defun comp-tests-ret-type-spec-f (x)
- (when (> x 1.0)
- x))
+ (when (> x 1.0)
+ x))
(or null marker number))
;; 36
;; 39
;; SBCL gives: (OR REAL NULL)
((defun comp-tests-ret-type-spec-f (x y)
- (when (and (<= 1 x 10)
- (<= 2 y 3))
- (+ x y)))
+ (when (and (<= 1 x 10)
+ (<= 2 y 3))
+ (+ x y)))
(or null float (integer 3 13)))
;; 40
;; SBCL: (OR REAL NULL)
((defun comp-tests-ret-type-spec-f (x y)
- (when (and (<= 1 x 10)
- (<= 2 y 3))
- (- x y)))
+ (when (and (<= 1 x 10)
+ (<= 2 y 3))
+ (- x y)))
(or null float (integer -2 8)))
;; 41
;; 43
((defun comp-tests-ret-type-spec-f (x y)
- (when (and (<= x 10)
- (<= 2 y))
- (- x y)))
+ (when (and (<= x 10)
+ (<= 2 y))
+ (- x y)))
(or null float (integer * 8)))
;; 44
((defun comp-tests-ret-type-spec-f (x y)
- (when (and (<= x 10)
- (<= y 3))
- (- x y)))
+ (when (and (<= x 10)
+ (<= y 3))
+ (- x y)))
(or null float integer))
;; 45
((defun comp-tests-ret-type-spec-f (x y)
- (when (and (<= 2 x)
- (<= 3 y))
- (- x y)))
+ (when (and (<= 2 x)
+ (<= 3 y))
+ (- x y)))
(or null float integer))
;; 46
((defun comp-tests-ret-type-spec-f (x)
(unless (integerp x)
x))
- (not integer))))
+ (not integer))
+
+ ;; 56
+ ((defun comp-tests-ret-type-spec-f (x)
+ (cl-ecase x
+ (1 (message "one"))
+ (5 (message "five")))
+ x)
+ t
+ ;; FIXME improve `comp-cond-cstrs-target-mvar' to cross block
+ ;; boundary if necessary as this should return:
+ ;; (or (integer 1 1) (integer 5 5))
+ )
+
+ ;; 57
+ ((defun comp-tests-ret-type-spec-f (x)
+ (unless (or (eq x 'foo)
+ (= x 3))
+ (error "Not foo or 3"))
+ x)
+ (or (member foo) (integer 3 3)))))
(defun comp-tests-define-type-spec-test (number x)
`(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()
projects / emacs.git / commitdiff