adding conditionals

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 20ea3d2fb337c88e8bf380ab4f110901eac7efee..e2c8fe427e3573eefb2ca2d78dadfcd345f6f347 100644 (file)
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -21,8 +21,8 @@
 ;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
 
 ;;; Commentary:
-;; This code is an attempt to make a Carrera out of a turbocharged VW Bug.
-;; Or, to put it another way to make the pig fly.
+;; This code is an attempt to make the pig fly.
+;; Or, to put it another way to make a Carrera out of a turbocharged VW Bug.
 
 ;;; Code:
 
@@ -90,6 +90,9 @@ To be used when ncall-conv is nil.")
   (frame-size nil :type 'number)
   (blocks () :type list
           :documentation "List of basic block")
+  (lap-block (make-hash-table :test #'equal) :type 'hash-table
+             :documentation "Key value to convert from LAP label number to
+LIMPLE basic block")
   (limple-cnt -1 :type 'number
               :documentation "Counter to create ssa limple vars"))
 
@@ -108,11 +111,13 @@ To be used when ncall-conv is nil.")
         :documentation "When non nil is used for type propagation"))
 
 (cl-defstruct (comp-limple-frame (:copier nil))
-  "A LIMPLE func."
+  "This structure is used during the limplify pass."
   (sp 0 :type 'fixnum
       :documentation "Current stack pointer")
   (frame nil :type 'vector
-         :documentation "Meta-stack used to flat LAP"))
+         :documentation "Meta-stack used to flat LAP")
+  (block-sp (make-hash-table) :type 'hash-table
+            :documentation "Key is the basic block value is the stack pointer"))
 
 (defun comp-limple-frame-new-frame (size)
   "Return a clean frame of meta variables of size SIZE."
@@ -195,13 +200,14 @@ To be used when ncall-conv is nil.")
 
 (defmacro comp-with-sp (sp &rest body)
   "Execute BODY setting the stack pointer to SP.
-Restore the original value afterwads."
+Restore the original value afterwards."
   (declare (debug (form body))
-           (indent 1))
-  `(let ((orig-sp (comp-sp)))
-     (setf (comp-sp) ,sp)
-     (progn ,@body)
-     (setf (comp-sp) orig-sp)))
+           (indent defun))
+  (let ((sym (gensym)))
+    `(let ((,sym (comp-sp)))
+       (setf (comp-sp) ,sp)
+       (progn ,@body)
+       (setf (comp-sp) ,sym))))
 
 (defmacro comp-slot-n (n)
   "Slot N into the meta-stack."
@@ -235,6 +241,7 @@ If the calle function is known to have a return type propagate it."
   "Set current slot with slot number N as source."
   (let ((src-slot (comp-slot-n n)))
     (cl-assert src-slot)
+    ;; FIXME should the id increase?
     (setf (comp-slot)
           (copy-sequence src-slot))
     (setf (comp-mvar-slot (comp-slot)) (comp-sp))
@@ -252,14 +259,26 @@ If the calle function is known to have a return type propagate it."
   (comp-emit (list 'setimm (comp-slot) val)))
 
 (defun comp-emit-block (bblock)
-  "Push basic block BBLOCK."
-  (push bblock (comp-func-blocks comp-func))
+  "Emit basic block BBLOCK."
+  (cl-pushnew bblock (comp-func-blocks comp-func) :test #'eq)
   ;; Every new block we are forced to wipe out all the frame.
-  ;; This will be superseded by proper flow analysis.
+  ;; This will be optimized by proper flow analysis.
   (setf (comp-limple-frame-frame comp-frame)
         (comp-limple-frame-new-frame (comp-func-frame-size comp-func)))
+  ;; If we are landing here form a recorded branch adjust sp accordingly.
+  (if-let ((new-sp (gethash bblock (comp-limple-frame-block-sp comp-frame))))
+      (setf (comp-sp) new-sp))
   (comp-emit `(block ,bblock)))
 
+(defmacro comp-with-fall-through-block (bb &rest body)
+  "Create a basic block BB that is used to fall through after executing BODY."
+  (declare (debug (form body))
+           (indent defun))
+  `(let ((,bb (comp-new-block-sym)))
+         (push ,bb (comp-func-blocks comp-func))
+         (progn ,@body)
+         (comp-emit-block ,bb)))
+
 (defun comp-stack-adjust (n)
   "Move sp by N."
   (cl-incf (comp-sp) n))
@@ -277,8 +296,22 @@ If the calle function is known to have a return type propagate it."
                                            ,(comp-slot)
                                            ,(comp-slot-next))))))
 
+(defun comp-new-block-sym ()
+  "Return a symbol naming the next new basic block."
+  (intern (format "bb_%s" (length (comp-func-blocks comp-func)))))
+
+(defun comp-lap-to-limple-bb (n)
+  "Given the LAP label N return the limple basic block."
+  (let ((hash (comp-func-lap-block comp-func)))
+    (if-let ((bb (gethash n hash)))
+        ;; If was already created return it.
+        bb
+      (let ((name (comp-new-block-sym)))
+        (puthash n name hash)
+        name))))
+
 (defmacro comp-op-case (&rest cases)
-  "Expand CASES to the corresponding pcase."
+  "Expand CASES into the corresponding pcase."
   (declare (debug (body))
            (indent defun))
   `(pcase op
@@ -287,8 +320,11 @@ If the calle function is known to have a return type propagate it."
                 for op-name = (symbol-name op)
                if body
                  collect `(',op
-                            (comp-emit-annotation ,(concat "LAP op " op-name))
-                           (comp-stack-adjust ,(if sp-delta sp-delta 0))
+                            ,(unless (eq op 'TAG)
+                               `(comp-emit-annotation
+                                 ,(concat "LAP op " op-name)))
+                            ,(when sp-delta
+                              `(comp-stack-adjust ,sp-delta))
                            (progn ,@body))
                 else
                  collect `(',op (error ,(concat "Unsupported LAP op "
@@ -302,6 +338,8 @@ If the calle function is known to have a return type propagate it."
                  (cadr inst)
                (cdr inst))))
     (comp-op-case
+      (TAG
+       (comp-emit-block (comp-lap-to-limple-bb arg)))
       (byte-stack-ref
        (comp-copy-slot-n (- (comp-sp) (cdr inst) 1)))
       (byte-varref
@@ -413,11 +451,46 @@ If the calle function is known to have a return type propagate it."
       (byte-widen)
       (byte-end-of-line)
       (byte-constant2)
-      (byte-goto)
-      (byte-goto-if-nil)
-      (byte-goto-if-not-nil)
-      (byte-goto-if-nil-else-pop)
-      (byte-goto-if-not-nil-else-pop)
+      (byte-goto
+       (comp-with-fall-through-block bb
+         (let ((target (comp-lap-to-limple-bb (cl-third inst))))
+           (comp-emit (list 'jump target))
+           (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)))
+         ))
+      (byte-goto-if-nil
+       (comp-with-fall-through-block bb
+         (let ((target (comp-lap-to-limple-bb (cl-third inst))))
+           (comp-emit (list 'cond-jump
+                            (comp-slot)
+                            bb
+                            target))
+           (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)))))
+      (byte-goto-if-not-nil
+       (comp-with-fall-through-block bb
+         (let ((target (comp-lap-to-limple-bb (cl-third inst))))
+           (comp-emit (list 'cond-jump
+                            (comp-slot)
+                            target
+                            bb))
+           (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame)))))
+      (byte-goto-if-nil-else-pop
+       (comp-with-fall-through-block bb
+         (let ((target (comp-lap-to-limple-bb (cl-third inst))))
+           (comp-emit (list 'cond-jump
+                            (comp-slot)
+                            bb
+                            target))
+           (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))
+           (comp-stack-adjust -1))))
+      (byte-goto-if-not-nil-else-pop
+       (comp-with-fall-through-block bb
+         (let ((target (comp-lap-to-limple-bb (cl-third inst))))
+           (comp-emit (list 'cond-jump
+                            (comp-slot)
+                            target
+                            bb))
+           (puthash target (comp-sp) (comp-limple-frame-block-sp comp-frame))
+           (comp-stack-adjust -1))))
       (byte-return
        (comp-emit (list 'return (comp-slot-next))))
       (byte-discard t)

diff --git a/src/comp.c b/src/comp.c
index f164bf892a5ab293302528274d548675214ae468..e407c079b63f722868c3f013fb74738d3112abe7 100644 (file)
--- a/src/comp.c
+++ b/src/comp.c
@@ -1046,6 +1046,15 @@ emit_limple_inst (Lisp_Object inst)
       gcc_jit_block_end_with_jump (comp.block, NULL, target);
       comp.block = target;
     }
+  else if (EQ (op, Qcond_jump))
+    {
+      /* Conditional branch.   */
+      gcc_jit_rvalue *test = emit_mvar_val (arg0);
+      gcc_jit_block *target1 = retrive_block (THIRD (inst));
+      gcc_jit_block *target2 = retrive_block (FORTH (inst));
+
+      emit_cond_jump (emit_NILP (test), target2, target1);
+    }
   else if (EQ (op, Qcall))
     {
       gcc_jit_block_add_eval (comp.block,
@@ -2091,6 +2100,7 @@ syms_of_comp (void)
   DEFSYM (Qsetimm, "setimm");
   DEFSYM (Qreturn, "return");
   DEFSYM (Qcomp_mvar, "comp-mvar");
+  DEFSYM (Qcond_jump, "cond-jump");
 
   defsubr (&Scomp_init_ctxt);
   defsubr (&Scomp_release_ctxt);