mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-13 09:32:47 +00:00
Code Issues Releases Activity

Introduce 'unreachable' LIMPLE operator

Browse Source 
Introduce 'unreachable' as LIMPLE operater so we can handle correctly
in the CFG functions throwing values or signaling errors.

	* src/comp.c (retrive_block): Better error diagnostic.
	(emit_limple_insn): Add `unreachable'.
	(compile_function): Fix block iteration.
	(syms_of_comp): Define 'Qunreachable'.
	* lisp/emacs-lisp/comp.el (comp-block): New variable.
	(comp-block-lap): Add `non-ret-insn' slot.
	(comp-branch-op-p): New predicate.
	(comp-limple-lock-keywords): Color `unreachable' as red.
	(comp-compute-edges): Add `unreachable'.
	(comp-fwprop-call): Store non returning function call.
	(comp-fwprop*): Update.
	(comp-clean-orphan-blocks, comp-rewrite-non-locals): New functions.
	(comp-fwprop): Call `comp-rewrite-non-locals'.
	* test/src/comp-tests.el (comp-tests-type-spec-tests): Add two
	tests.
	* test/src/comp-test-funcs.el (comp-test-non-local-1)
	(comp-test-non-local-2, comp-test-non-local-3)
	(comp-test-non-local-4): New functions.
This commit is contained in:
Andrea Corallo 2020-12-31 17:37:13 +01:00
parent e9f5fadb0e
commit 67c443adc1
4 changed files with 171 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
lisp/emacs-lisp/comp.el
View File

@ -537,6 +537,9 @@ Useful to hook into pass checkers.")
(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)
@ -637,13 +640,17 @@ Is in use to help the SSA rename pass."))
(: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))
@ -843,6 +850,10 @@ To be used by all entry points."
"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)))
@ -894,7 +905,7 @@ Assume allocation class 'd-default as default."
(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_")
@ -2581,6 +2592,7 @@ blocks."
(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"
@ -2936,6 +2948,9 @@ Fold the call in case."
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)
@ -2997,15 +3012,61 @@ Fold the call in case."
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)
@ -3024,6 +3085,7 @@ Return t if something was changed."
'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)))

47
src/comp.c
View File

@ -753,7 +753,7 @@ retrive_block (Lisp_Object block_name)
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);
}
@ -2282,6 +2282,13 @@ emit_limple_insn (Lisp_Object insn)
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,
@ -3910,13 +3917,13 @@ compile_function (Lisp_Object func)
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),
@ -3925,21 +3932,24 @@ compile_function (Lisp_Object func)
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);
@ -5098,6 +5108,7 @@ compiled one. */);
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");

16
test/src/comp-test-funcs.el
View File

@ -621,6 +621,22 @@
(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

88
test/src/comp-tests.el
View File

@ -949,50 +949,50 @@ Return a list of results."
;; 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
@ -1032,8 +1032,8 @@ Return a list of results."
;; 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
@ -1061,17 +1061,17 @@ Return a list of results."
;; 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
@ -1090,23 +1090,23 @@ Return a list of results."
;; 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
@ -1176,7 +1176,27 @@ Return a list of results."
((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)) ()