add fetch-handler operator

lisp/emacs-lisp/comp.el

@@ -92,7 +92,7 @@ Can be used by code that wants to expand differently in this case.")
                              set-rest-args-to-local)
   "Limple set operators.")
 
-(defconst comp-limple-assignments `(push-handler
+(defconst comp-limple-assignments `(fetch-handler
                                     ,@comp-limple-sets)
   "Limple operators that clobbers the first mvar argument.")
 
@@ -217,7 +217,9 @@ structure.")
   (edge-cnt-gen (funcall #'comp-gen-counter) :type function
                 :documentation "Generates edges numbers.")
   (ssa-cnt-gen (funcall #'comp-gen-counter) :type function
-              :documentation "Counter to create ssa limple vars."))
+               :documentation "Counter to create ssa limple vars.")
+  (handler-cnt 0 :type number
+               :documentation "Number of non local handler buffers."))
 
 (defun comp-func-reset-generators (func)
   "Reset unique id generators for FUNC."
@@ -505,7 +507,8 @@ Restore the original value afterwards."
       (error "Can't find label %d" label)))
 
 (cl-defun comp-block-maybe-mark-pending (&rest args &key name sp &allow-other-keys)
-  "Create a basic block and mark it as pending."
+  "Create a basic block and mark it as pending.
+The basic block is returned."
   (if-let ((bb (gethash name (comp-func-blocks comp-func))))
       ;; If was already declared sanity check sp.
       (cl-assert (or (null sp) (= sp (comp-block-sp bb)))
@@ -514,8 +517,8 @@ Restore the original value afterwards."
     (unless (cl-find-if (lambda (bb)
                           (eq (comp-block-name bb) name))
                         (comp-limplify-pending-blocks comp-pass))
-      (push (apply #'make--comp-block args)
+      (car (push (apply #'make--comp-block args)
-            (comp-limplify-pending-blocks comp-pass)))))
+                 (comp-limplify-pending-blocks comp-pass))))))
 
 (defun comp-call (func &rest args)
   "Emit a call for function FUNC with ARGS."
@@ -545,10 +548,11 @@ Restore the original value afterwards."
            do (aset v i mvar)
            finally (return v)))
 
-(defsubst comp-emit (insn)
+(defsubst comp-emit (insn &optional bb)
-  "Emit INSN into current basic block."
+  "Emit INSN in BB is specified or the current basic block otherwise."
-  (cl-assert (not (comp-block-closed (comp-limplify-curr-block comp-pass))))
+  (let ((bb (or bb (comp-limplify-curr-block comp-pass))))
-  (push insn (comp-block-insns (comp-limplify-curr-block comp-pass))))
+    (cl-assert (not (comp-block-closed bb)))
+    (push insn (comp-block-insns bb))))
 
 (defun comp-emit-set-call (call)
   "Emit CALL assigning the result the the current slot frame.
@@ -634,22 +638,26 @@ Return value is the fall through block name."
 (defun comp-emit-handler (lap-label handler-type)
   "Emit a non local exit handler to LAP-LABEL of type HANDLER-TYPE."
   (cl-destructuring-bind (label-num . label-sp) lap-label
-    (let ((guarded-bb (comp-new-block-sym))
+    (cl-assert (= (- label-sp 2) (comp-sp)))
-          (handler-bb (comp-lap-to-limple-bb label-num)))
+    (let* ((guarded-name (comp-new-block-sym))
-      (cl-assert (= (- label-sp 2) (comp-sp)))
+           (handler-name (comp-lap-to-limple-bb label-num))
-      (comp-block-maybe-mark-pending :name guarded-bb
+           (handler-buff-n (comp-func-handler-cnt comp-func))
+           (handler-bb (comp-block-maybe-mark-pending :name handler-name
+                                                      :sp (1+ (comp-sp))
+                                                      :addr
+                                                      (comp-label-to-addr label-num))))
+      (comp-block-maybe-mark-pending :name guarded-name
                                      :sp (comp-sp)
                                      :addr (1+ (comp-limplify-pc comp-pass)))
-      (comp-block-maybe-mark-pending :name handler-bb
-                                     :sp (1+ (comp-sp))
-                                     :addr (comp-label-to-addr label-num))
       (comp-emit (list 'push-handler
-                       (comp-slot+1)
-                       (comp-slot+1)
                        handler-type
-                       handler-bb
+                       (comp-slot+1)
-                       guarded-bb))
+                       handler-buff-n
-      (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t))))
+                       handler-name
+                       guarded-name))
+      (setf (comp-block-closed (comp-limplify-curr-block comp-pass)) t)
+      (comp-emit `(fetch-handler ,(comp-slot+1) ,handler-buff-n) handler-bb)
+      (cl-incf (comp-func-handler-cnt comp-func)))))
 
 (defun comp-limplify-listn (n)
   "Limplify list N."

src/comp.c

@@ -171,6 +171,7 @@ typedef struct {
   Lisp_Object func_blocks_h; /* blk_name -> gcc_block.  */
   Lisp_Object exported_funcs_h; /* subr_name -> gcc_jit_function *.  */
   Lisp_Object imported_funcs_h; /* subr_name -> reloc_field.  */
+  Lisp_Object buffer_handler_vec; /* All locals used to store non local exit values.   */
   Lisp_Object emitter_dispatcher;
   gcc_jit_rvalue *data_relocs; /* Synthesized struct holding data relocs.  */
   gcc_jit_lvalue *func_relocs; /* Synthesized struct holding func relocs.  */
@@ -280,7 +281,7 @@ retrive_block (Lisp_Object block_name)
 static void
 declare_block (Lisp_Object block_name)
 {
-  char *name_str = (char *) SDATA (SYMBOL_NAME (block_name));
+  char *name_str = SSDATA (SYMBOL_NAME (block_name));
   gcc_jit_block *block = gcc_jit_function_new_block (comp.func, name_str);
   Lisp_Object value = make_mint_ptr (block);
   ICE_IF (!NILP (Fgethash (block_name, comp.func_blocks_h, Qnil)),
@@ -1151,23 +1152,12 @@ emit_limple_call_ref (Lisp_Object insn, bool direct)
 
 static void
 emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type,
-			  gcc_jit_block *handler_bb, gcc_jit_block *guarded_bb,
+			  EMACS_UINT handler_buff_n, gcc_jit_block *handler_bb,
-			  Lisp_Object clobbered_mvar)
+			  gcc_jit_block *guarded_bb, Lisp_Object clobbered_mvar)
 {
-  /*
+   /* struct handler *c = push_handler (POP, type); */
-     Ex: (push-handler #s(comp-mvar 1 8 nil nil nil nil)
-                       #s(comp-mvar 1 7 t done symbol nil)
-		       catcher bb_2 bb_1).
-  */
-
-  static unsigned pushhandler_n; /* FIXME move at ctxt or func level.  */
-
-  /* struct handler *c = push_handler (POP, type); */
   gcc_jit_lvalue *c =
-    gcc_jit_function_new_local (comp.func,
+    xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n));
-				NULL,
-				comp.handler_ptr_type,
-				format_string ("c_%u", pushhandler_n));
 
   gcc_jit_rvalue *args[] = { handler, handler_type };
   gcc_jit_block_add_assignment (
@@ -1189,29 +1179,6 @@ emit_limple_push_handler (gcc_jit_rvalue *handler, gcc_jit_rvalue *handler_type,
   res =
     emit_call (intern_c_string (SETJMP_NAME), comp.int_type, 1, args, false);
   emit_cond_jump (res, handler_bb, guarded_bb);
-
-  /* This emit the handler part.  */
-
-  comp.block = handler_bb;
-  gcc_jit_lvalue *m_handlerlist =
-    gcc_jit_rvalue_dereference_field (comp.current_thread,
-				      NULL,
-				      comp.m_handlerlist);
-  gcc_jit_block_add_assignment (
-    comp.block,
-    NULL,
-    m_handlerlist,
-    gcc_jit_lvalue_as_rvalue(
-      gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c),
-					NULL,
-					comp.handler_next_field)));
-  emit_frame_assignment (
-    clobbered_mvar,
-    gcc_jit_lvalue_as_rvalue(
-      gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c),
-					NULL,
-					comp.handler_val_field)));
-  ++pushhandler_n;
 }
 
 static void
@@ -1222,6 +1189,16 @@ emit_limple_insn (Lisp_Object insn)
   Lisp_Object arg0 UNINIT;
   gcc_jit_rvalue *res;
 
+  Lisp_Object arg[6];
+  Lisp_Object p = XCDR (insn);
+  ptrdiff_t n_args = list_length (p);
+  unsigned i = 0;
+  FOR_EACH_TAIL (p)
+    {
+      eassert (i < n_args);
+      arg[i++] = XCAR (p);
+    }
+
   if (CONSP (args))
     arg0 = XCAR (args);
 
@@ -1269,9 +1246,11 @@ emit_limple_insn (Lisp_Object insn)
     }
   else if (EQ (op, Qpush_handler))
     {
-      gcc_jit_rvalue *handler = emit_mvar_val (arg0);
+      /* (push-handler condition-case #s(comp-mvar 0 3 t (arith-error) cons nil) 1 bb_2 bb_1) */
+      gcc_jit_rvalue *handler = emit_mvar_val (arg[1]);
       int h_num UNINIT;
-      Lisp_Object handler_spec = THIRD (args);
+      Lisp_Object handler_spec = arg[0];
+      EMACS_UINT handler_buff_n = XFIXNUM (arg[2]);
       if (EQ (handler_spec, Qcatcher))
 	h_num = CATCHER;
       else if (EQ (handler_spec, Qcondition_case))
@@ -1282,10 +1261,10 @@ emit_limple_insn (Lisp_Object insn)
 	gcc_jit_context_new_rvalue_from_int (comp.ctxt,
 					     comp.int_type,
 					     h_num);
-      gcc_jit_block *handler_bb = retrive_block (FORTH (args));
+      gcc_jit_block *handler_bb = retrive_block (arg[3]);
-      gcc_jit_block *guarded_bb = retrive_block (FIFTH (args));
+      gcc_jit_block *guarded_bb = retrive_block (arg[4]);
-      emit_limple_push_handler (handler, handler_type, handler_bb, guarded_bb,
+      emit_limple_push_handler (handler, handler_type, handler_buff_n,
-				arg0);
+				handler_bb, guarded_bb, arg0);
     }
   else if (EQ (op, Qpop_handler))
     {
@@ -1309,6 +1288,30 @@ emit_limple_insn (Lisp_Object insn)
 	    comp.handler_next_field)));
 
     }
+  else if (EQ (op, Qfetch_handler))
+    {
+      EMACS_UINT handler_buff_n = XFIXNUM (SECOND (args));
+      gcc_jit_lvalue *c =
+	xmint_pointer (AREF (comp.buffer_handler_vec, handler_buff_n));
+      gcc_jit_lvalue *m_handlerlist =
+        gcc_jit_rvalue_dereference_field (comp.current_thread,
+					  NULL,
+					  comp.m_handlerlist);
+      gcc_jit_block_add_assignment (
+        comp.block,
+        NULL,
+        m_handlerlist,
+        gcc_jit_lvalue_as_rvalue(
+          gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c),
+					    NULL,
+					    comp.handler_next_field)));
+      emit_frame_assignment (
+        arg0,
+        gcc_jit_lvalue_as_rvalue(
+          gcc_jit_rvalue_dereference_field (gcc_jit_lvalue_as_rvalue (c),
+					    NULL,
+					    comp.handler_val_field)));
+    }
   else if (EQ (op, Qcall))
     {
       gcc_jit_block_add_eval (comp.block, NULL,
@@ -2759,7 +2762,7 @@ compile_function (Lisp_Object func)
 				      frame_size),
       "local");
   comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame));
-  for (unsigned i = 0; i < frame_size; ++i)
+  for (EMACS_INT i = 0; i < frame_size; ++i)
     comp.frame[i] =
       gcc_jit_context_new_array_access (
         comp.ctxt,
@@ -2789,6 +2792,16 @@ compile_function (Lisp_Object func)
 				      format_string ("local%u", i));
     }
 
+  EMACS_UINT non_local_handlers = XFIXNUM (FUNCALL1 (comp-func-handler-cnt, func));
+  comp.buffer_handler_vec = make_vector (non_local_handlers, Qnil);
+  for (unsigned i = 0; i < non_local_handlers; ++i)
+    ASET (comp.buffer_handler_vec, i,
+	  make_mint_ptr (
+	    gcc_jit_function_new_local (comp.func,
+					NULL,
+					comp.handler_ptr_type,
+					format_string ("handler_%u", i))));
+
   comp.func_blocks_h = CALLN (Fmake_hash_table);
 
   /* Pre declare all basic blocks to gcc.
@@ -3304,6 +3317,7 @@ syms_of_comp (void)
   /* Others.  */
   DEFSYM (Qpush_handler, "push-handler");
   DEFSYM (Qpop_handler, "pop-handler");
+  DEFSYM (Qfetch_handler, "fetch-handler");
   DEFSYM (Qcondition_case, "condition-case");
   /* call operands.  */
   DEFSYM (Qcatcher, "catcher"); /* FIXME use these allover.  */