From bebe5a9791f7db3f088e0c07b2fd68e1d21bb161 Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Sat, 3 Aug 2019 17:08:55 +0200 Subject: [PATCH] add limple switch support --- lisp/emacs-lisp/comp.el | 33 +++++++++++++++++++++++---------- src/comp.c | 9 +++++---- test/src/comp-tests.el | 25 +++++++++++++------------ 3 files changed, 41 insertions(+), 26 deletions(-) diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 69f43822948..4841753172f 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -355,11 +355,11 @@ If DST-N is specified use it otherwise assume it to be the current slot." (comp-block-sp (gethash block-name blocks))) (setf (comp-limplify-block-name comp-pass) block-name))) -(defun comp-emit-cond-jump (target-offset lap-label negated) - "Emit a conditional jump to LAP-LABEL. +(defun comp-emit-cond-jump (a b target-offset lap-label negated) + "Emit a conditional jump to LAP-LABEL when A and B satisfy EQ. TARGET-OFFSET is the positive offset on the SP when branching to the target block. -If NEGATED non nil negate the test condition." +If NEGATED non nil negate the tested condition." (let ((blocks (comp-func-blocks comp-func)) (bb (comp-new-block-sym))) ;; Fall through block (puthash bb @@ -367,8 +367,8 @@ If NEGATED non nil negate the test condition." blocks) (let ((target (comp-lap-to-limple-bb lap-label))) (comp-emit (if negated - (list 'cond-jump (comp-slot-next) target bb) - (list 'cond-jump (comp-slot-next) bb target))) + (list 'cond-jump a b target bb) + (list 'cond-jump a b bb target))) (puthash target (make-comp-block :sp (+ target-offset (comp-sp))) blocks) @@ -423,6 +423,14 @@ If NEGATED non nil negate the test condition." (comp-mark-block-closed) (comp-emit-block guarded-bb)))) +(defun comp-emit-switch (var m-hash) + "Emit a limple for a lap jump table given VAR and M-HASH." + (cl-assert (comp-mvar-const-vld m-hash)) + (cl-loop for test being each hash-keys of (comp-mvar-constant m-hash) + using (hash-value target-label) + for m-test = (make-comp-mvar :constant test) + do (comp-emit-cond-jump var m-test 0 target-label nil))) + (defmacro comp-op-case (&rest cases) "Expand CASES into the corresponding pcase. This is responsible for generating the proper stack adjustment when known and @@ -583,13 +591,17 @@ the annotation emission." (byte-goto (comp-emit-jump (comp-lap-to-limple-bb (cl-third insn)))) (byte-goto-if-nil - (comp-emit-cond-jump 0 (cl-third insn) nil)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (cl-third insn) nil)) (byte-goto-if-not-nil - (comp-emit-cond-jump 0 (cl-third insn) t)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 0 + (cl-third insn) t)) (byte-goto-if-nil-else-pop - (comp-emit-cond-jump 1 (cl-third insn) nil)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (cl-third insn) nil)) (byte-goto-if-not-nil-else-pop - (comp-emit-cond-jump 1 (cl-third insn) t)) + (comp-emit-cond-jump (comp-slot-next) (make-comp-mvar :constant nil) 1 + (cl-third insn) t)) (byte-return (comp-emit (list 'return (comp-slot-next))) (comp-mark-block-closed)) @@ -642,7 +654,8 @@ the annotation emission." (byte-stack-set2) (byte-discardN (comp-stack-adjust (- arg))) - (byte-switch) + (byte-switch + (comp-emit-switch (comp-slot-next) (comp-slot-n (+ 2 (comp-sp))))) (byte-constant (comp-emit-set-const arg)) (byte-discardN-preserve-tos diff --git a/src/comp.c b/src/comp.c index 6436a5db712..e4483ea4206 100644 --- a/src/comp.c +++ b/src/comp.c @@ -1128,11 +1128,12 @@ emit_limple_insn (Lisp_Object insn) else if (EQ (op, Qcond_jump)) { /* Conditional branch. */ - gcc_jit_rvalue *test = emit_mvar_val (arg0); - gcc_jit_block *target1 = retrive_block (SECOND (args)); - gcc_jit_block *target2 = retrive_block (THIRD (args)); + gcc_jit_rvalue *a = emit_mvar_val (arg0); + gcc_jit_rvalue *b = emit_mvar_val (SECOND (args)); + gcc_jit_block *target1 = retrive_block (THIRD (args)); + gcc_jit_block *target2 = retrive_block (FORTH (args)); - emit_cond_jump (emit_NILP (test), target2, target1); + emit_cond_jump (emit_EQ (a, b), target2, target1); } else if (EQ (op, Qpush_handler)) { diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index ed3a9b2f9d0..58846ed50d0 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -200,18 +200,19 @@ (should (= (comp-tests-ffuncall-lambda-f 1) 2))) -;; (ert-deftest comp-tests-jump-table () -;; "Testing jump tables" -;; (defun comp-tests-jump-table-1-f (x) -;; (pcase x -;; ('x 'a) -;; ('y 'b) -;; (_ 'c))) - - -;; (should (eq (comp-tests-jump-table-1-f 'x) 'a)) -;; (should (eq (comp-tests-jump-table-1-f 'y) 'b)) -;; (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) +(ert-deftest comp-tests-jump-table () + "Testing jump tables" + (defun comp-tests-jump-table-1-f (x) + (pcase x + ('x 'a) + ('y 'b) + (_ 'c))) + + (native-compile #'comp-tests-jump-table-1-f) + + (should (eq (comp-tests-jump-table-1-f 'x) 'a)) + (should (eq (comp-tests-jump-table-1-f 'y) 'b)) + (should (eq (comp-tests-jump-table-1-f 'xxx) 'c))) (ert-deftest comp-tests-conditionals () "Testing conditionals." -- 2.39.5