From 67c443adc1ef8a03d27c6172247e792421bb0e13 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Thu, 31 Dec 2020 17:37:13 +0100 Subject: [PATCH] Introduce 'unreachable' LIMPLE operator 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. --- lisp/emacs-lisp/comp.el | 82 +++++++++++++++++++++++++++++----- src/comp.c | 47 ++++++++++++-------- test/src/comp-test-funcs.el | 16 +++++++ test/src/comp-tests.el | 88 +++++++++++++++++++++++-------------- 4 files changed, 171 insertions(+), 62 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index a6704e8c180..3ef9a6be739 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -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))) diff --git a/src/comp.c b/src/comp.c index 04bf9973d26..da4361030b1 100644 --- a/src/comp.c +++ b/src/comp.c @@ -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"); diff --git a/test/src/comp-test-funcs.el b/test/src/comp-test-funcs.el index 49e80763bee..1c2fb3d3c0b 100644 --- a/test/src/comp-test-funcs.el +++ b/test/src/comp-test-funcs.el @@ -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 diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index 4546eccb622..9801136152a 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -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)) () -- 2.39.5