Rework frame layout

Every function call by reference gets use one unique array of
arguments.

lisp/emacs-lisp/comp.el

@@ -274,7 +274,9 @@ structure.")
   (ssa-cnt-gen (funcall #'comp-gen-counter) :type function
                :documentation "Counter to create ssa limple vars.")
   (has-non-local nil :type boolean
-                 :documentation "t if non local jumps are present."))
+                 :documentation "t if non local jumps are present.")
+  (array-h (make-hash-table) :type hash-table
+           :documentation "array idx -> array length."))
 
 (defun comp-func-reset-generators (func)
   "Reset unique id generators for FUNC."
@@ -285,6 +287,8 @@ structure.")
   "A meta-variable being a slot in the meta-stack."
   (slot nil :type (or fixnum symbol)
         :documentation "Slot number if a number or 'scratch' for scratch slot.")
+  (array-idx 0 :type fixnum
+             :documentation "Array index.")
   (id nil :type (or null number)
      :documentation "SSA number when in SSA form.")
   (const-vld nil :type boolean
@@ -295,9 +299,6 @@ structure.")
   (type nil
         :documentation "When non nil indicates the type when known at compile
  time.")
-  (ref nil :type boolean
-       :documentation "When non nil the m-var is involved in a
- call where is passed by reference.")
   (impure nil :type boolean
           :documentation "When non nil can't be copied into pure space."))
 
@@ -466,6 +467,8 @@ Put PREFIX in front of it."
                 (comp-byte-frame-size (comp-func-byte-func func))))
         (setf (comp-ctxt-top-level-forms comp-ctxt)
               (list (make-byte-to-native-function :name function-name)))
+        ;; Create the default array.
+        (puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
         (list func))))
 
 (cl-defgeneric comp-spill-lap-function ((filename string))
@@ -491,7 +494,10 @@ Put PREFIX in front of it."
                               :args (comp-decrypt-arg-list (aref data 0) name)
                               :lap (alist-get name byte-to-native-lap)
                               :frame-size (comp-byte-frame-size data))
-   do (comp-log (format "Function %s:\n" name) 1)
+   do
+      ;; Create the default array.
+      (puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
+      (comp-log (format "Function %s:\n" name) 1)
       (comp-log lap 1)
    collect func))
 
@@ -1149,6 +1155,7 @@ into the C code forwarding the compilation unit."
     (comp-emit `(set-par-to-local ,(comp-slot-n 0) 0))
     (mapc #'comp-emit-for-top-level (comp-ctxt-top-level-forms comp-ctxt))
     (comp-emit `(return ,(make-comp-mvar :constant t)))
+    (puthash 0 (comp-func-frame-size func) (comp-func-array-h func))
     (comp-limplify-finalize-function func)))
 
 (defun comp-addr-to-bb-name (addr)
@@ -1564,14 +1571,38 @@ PRE-LAMBDA and POST-LAMBDA are called in pre or post-order if non nil."
         (copy-comp-mvar insn)
       insn)))
 
-(defun comp-basic-const-propagate ()
+(defun comp-ref-args-to-array (args)
-  "Propagate simple constants for setimm operands.
+  "Given ARGS assign them to a dedicated array."
-This can run just once."
+  (when (and args
+             ;; Never rename an already renamed array index.
+             (= (comp-mvar-array-idx (car args)) 0))
+    (cl-loop with array-h = (comp-func-array-h comp-func)
+             with arr-idx = (hash-table-count array-h)
+             for i from 0
+             for arg in args
+             initially
+               (puthash arr-idx (length args) array-h)
+             do
+               ;; Just check that all args have zeroed arr-idx.
+               ;; (arrays must be used once).
+               (cl-assert (= (comp-mvar-array-idx arg) 0))
+               (setf (comp-mvar-slot arg) i)
+               (setf (comp-mvar-array-idx arg) arr-idx))))
+
+(defun comp-propagate-once ()
+  "Prologue for the propagate pass.
+Here goes everything that can be done not iteratively (read once).
+- Forward propagate immediate involed in assignments
+- Backward propagate placement into arrays"
   (cl-loop
    for b being each hash-value of (comp-func-blocks comp-func)
    do (cl-loop
        for insn in (comp-block-insns b)
        do (pcase insn
+            (`(set ,_lval (,(or 'callref 'direct-callref) ,_f . ,args))
+             (comp-ref-args-to-array args))
+            (`(,(or 'callref 'direct-callref) ,_f . ,args)
+             (comp-ref-args-to-array args))
             (`(setimm ,lval ,_ ,v)
              (setf (comp-mvar-const-vld lval) t
                    (comp-mvar-constant lval) v
@@ -1628,13 +1659,13 @@ This can run just once."
        (_
         (comp-mvar-propagate lval rval))))
     (`(phi ,lval . ,rest)
-     ;; Const prop here.
+     ;; Forward const prop here.
      (when-let* ((vld (cl-every #'comp-mvar-const-vld rest))
                  (consts (mapcar #'comp-mvar-constant rest))
                  (x (car consts))
                  (equals (cl-every (lambda (y) (equal x y)) consts)))
        (setf (comp-mvar-constant lval) x))
-     ;; Type propagation.
+     ;; Forward type propagation.
      ;; FIXME: checking for type equality is not sufficient cause does not
      ;; account type hierarchy!
      (when-let* ((types (mapcar #'comp-mvar-type rest))
@@ -1642,10 +1673,14 @@ This can run just once."
                  (x (car types))
                  (eqs (cl-every (lambda (y) (eq x y)) types)))
        (setf (comp-mvar-type lval) x))
-     ;; Reference propagation.
+     ;; Backward propagate array index and slot.
-     (let ((operands (cons lval rest)))
+     (let ((arr-idx (comp-mvar-array-idx lval)))
-       (when (cl-some #'comp-mvar-ref operands)
+       (when (> arr-idx 0)
-         (mapc (lambda (x) (setf (comp-mvar-ref x) t)) operands))))))
+         (cl-loop with slot = (comp-mvar-slot lval)
+                  for arg in rest
+                  do
+                  (setf (comp-mvar-array-idx arg) arr-idx)
+                  (setf (comp-mvar-slot arg) slot)))))))
 
 (defun comp-propagate* ()
   "Propagate for set* and phi operands.
@@ -1666,7 +1701,7 @@ Return t if something was changed."
                ;; FIXME remove the following condition when tested.
                (unless (comp-func-has-non-local f)
                  (let ((comp-func f))
-                   (comp-basic-const-propagate)
+                   (comp-propagate-once)
                    (cl-loop
                     for i from 1
                     while (comp-propagate*)
@@ -1695,13 +1730,7 @@ Return t if something was changed."
   (cl-flet ((fill-args (args total)
               ;; Fill missing args to reach TOTAL
               (append args (cl-loop repeat (- total (length args))
-                                    collect (make-comp-mvar :constant nil))))
+                                    collect (make-comp-mvar :constant nil)))))
-            (clean-args-ref (args)
-              ;; Clean-up the ref slot in all args
-              (mapc (lambda (arg)
-                      (setf (comp-mvar-ref arg) nil))
-                    args)
-              args))
     (when (and (symbolp callee)  ; Do nothing if callee is a byte compiled func.
                (not (memq callee comp-never-optimize-functions)))
       (let* ((f (symbol-function callee))
@@ -1721,7 +1750,7 @@ Return t if something was changed."
                  (args (if (eq call-type 'callref)
                            args
                          (fill-args args maxarg))))
-            `(,call-type ,callee ,@(clean-args-ref args))))
+            `(,call-type ,callee ,@args)))
          ;; Intra compilation unit procedure call optimization.
          ;; Attention speed 3 triggers that for non self calls too!!
          ((or (eq callee self)
@@ -1733,7 +1762,7 @@ Return t if something was changed."
                  (args (if (eq call-type 'direct-callref)
                            args
                          (fill-args args (comp-args-max func-args)))))
-            `(,call-type ,callee ,@(clean-args-ref args))))
+            `(,call-type ,callee ,@args)))
          ((comp-type-hint-p callee)
           `(call ,callee ,@args)))))))
 

src/comp.c

@@ -150,10 +150,10 @@ typedef struct {
   gcc_jit_field *cast_union_as_lisp_obj_ptr;
   gcc_jit_function *func; /* Current function being compiled.  */
   bool func_has_non_local; /* From comp-func has-non-local slot.  */
-  gcc_jit_block *block;  /* Current basic block being compiled.  */
-  gcc_jit_lvalue **frame; /* Frame for the current function.  */
   gcc_jit_lvalue **f_frame; /* "Floating" frame for the current function.  */
+  gcc_jit_block *block;  /* Current basic block being compiled.  */
   gcc_jit_lvalue *scratch; /* Used as scratch slot for some code sequence (switch).  */
+  gcc_jit_lvalue ***arrays;  /* Array index -> gcc_jit_lvalue **. */
   gcc_jit_rvalue *most_positive_fixnum;
   gcc_jit_rvalue *most_negative_fixnum;
   gcc_jit_rvalue *one;
@@ -348,7 +348,7 @@ declare_block (Lisp_Object block_name)
 }
 
 static gcc_jit_lvalue *
-get_slot (Lisp_Object mvar)
+emit_mvar_access (Lisp_Object mvar)
 {
   Lisp_Object mvar_slot = CALL1I (comp-mvar-slot, mvar);
 
@@ -361,15 +361,18 @@ get_slot (Lisp_Object mvar)
 						   "scratch");
       return comp.scratch;
     }
+
+  EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar));
   EMACS_INT slot_n = XFIXNUM (mvar_slot);
-  gcc_jit_lvalue **frame =
+  if (comp.func_has_non_local || !SPEED)
-    /* Disable floating frame for functions with non local jumps.
+    return comp.arrays[arr_idx][slot_n];
-       This is probably overkill cause we could do it just for blocks
+  else
-       dominated by push-handler.  */
+    {
-    comp.func_has_non_local
+      if (arr_idx)
-    || (CALL1I (comp-mvar-ref, mvar) || SPEED < 2)
+	return comp.arrays[arr_idx][slot_n];
-    ? comp.frame : comp.f_frame;
+      else
-  return frame[slot_n];
+	return comp.f_frame[slot_n];
+    }
 }
 
 static void
@@ -1140,7 +1143,7 @@ emit_mvar_val (Lisp_Object mvar)
       return emit_const_lisp_obj (constant, CALL1I (comp-mvar-impure, mvar));
     }
 
-  return gcc_jit_lvalue_as_rvalue (get_slot (mvar));
+  return gcc_jit_lvalue_as_rvalue (emit_mvar_access (mvar));
 }
 
 static void
@@ -1150,7 +1153,7 @@ emit_frame_assignment (Lisp_Object dst_mvar, gcc_jit_rvalue *val)
   gcc_jit_block_add_assignment (
     comp.block,
     NULL,
-    get_slot (dst_mvar),
+    emit_mvar_access (dst_mvar),
     val);
 }
 
@@ -1239,10 +1242,28 @@ emit_limple_call_ref (Lisp_Object insn, bool direct)
 
   Lisp_Object callee = FIRST (insn);
   EMACS_INT nargs = XFIXNUM (Flength (CDR (insn)));
-  EMACS_INT base_ptr = 0;
+
-  if (nargs)
+  if (!nargs)
-    base_ptr = XFIXNUM (CALL1I (comp-mvar-slot, SECOND (insn)));
+    return emit_call_ref (callee,
-  return emit_call_ref (callee, nargs, comp.frame[base_ptr], direct);
+			  nargs,
+			  comp.arrays[0][0],
+			  direct);
+
+  Lisp_Object first_arg = SECOND (insn);
+  Lisp_Object arr_idx = CALL1I (comp-mvar-array-idx, first_arg);
+
+  /* Make sure all the arguments are layout-ed into the same array.  */
+  Lisp_Object p = XCDR (XCDR (insn));
+  FOR_EACH_TAIL (p)
+    if (!EQ (arr_idx, CALL1I (comp-mvar-array-idx, XCAR (p))))
+      xsignal2 (Qnative_ice, build_string ("incoherent array idx for insn"),
+		insn);
+
+  EMACS_INT first_slot = XFIXNUM (CALL1I (comp-mvar-slot, first_arg));
+  return emit_call_ref (callee,
+			nargs,
+			comp.arrays[XFIXNUM (arr_idx)][first_slot],
+			direct);
 }
 
 /* Register an handler for a non local exit.  */
@@ -2867,34 +2888,43 @@ compile_function (Lisp_Object func)
 
   comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func));
 
-  gcc_jit_lvalue *frame_array =
+  struct Lisp_Hash_Table *array_h =
-    gcc_jit_function_new_local (
+    XHASH_TABLE (CALL1I (comp-func-array-h, func));
-      comp.func,
+  comp.arrays = SAFE_ALLOCA (array_h->count * sizeof (*comp.arrays));
-      NULL,
+  for (ptrdiff_t i = 0; i < array_h->count; i++)
-      gcc_jit_context_new_array_type (comp.ctxt,
+    {
-				      NULL,
+      EMACS_INT array_len = XFIXNUM (HASH_VALUE (array_h, i));
-				      comp.lisp_obj_type,
+      comp.arrays[i] = SAFE_ALLOCA (array_len * sizeof (**comp.arrays));
-				      frame_size),
+
-      "local");
+      gcc_jit_lvalue *arr =
-  comp.frame = SAFE_ALLOCA (frame_size * sizeof (*comp.frame));
+	gcc_jit_function_new_local (
-  for (EMACS_INT i = 0; i < frame_size; ++i)
+	  comp.func,
-    comp.frame[i] =
+	  NULL,
-      gcc_jit_context_new_array_access (
+	  gcc_jit_context_new_array_type (comp.ctxt,
-        comp.ctxt,
+					  NULL,
-	NULL,
+					  comp.lisp_obj_type,
-	gcc_jit_lvalue_as_rvalue (frame_array),
+					  array_len),
-	gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+	  format_string ("arr_%td", i));
-					     comp.int_type,
+
-					     i));
+      for (ptrdiff_t j = 0; j < array_len; j++)
+	comp.arrays[i][j] =
+	  gcc_jit_context_new_array_access (
+	    comp.ctxt,
+	    NULL,
+	    gcc_jit_lvalue_as_rvalue (arr),
+	    gcc_jit_context_new_rvalue_from_int (comp.ctxt,
+						 comp.int_type,
+						 j));
+    }
 
   /*
-     The floating frame is a copy of the normal frame that can be used to store
+    The floating frame is a copy of the normal frame that can be used to store
-     locals if the are not going to be used in a nargs call.
+    locals if the are not going to be used in a nargs call.
-     This has two advantages:
+    This has two advantages:
-     - Enable gcc for better reordering (frame array is clobbered every time is
+    - Enable gcc for better reordering (frame array is clobbered every time is
-       passed as parameter being involved into an nargs function call).
+    passed as parameter being involved into an nargs function call).
-     - Allow gcc to trigger other optimizations that are prevented by memory
+    - Allow gcc to trigger other optimizations that are prevented by memory
-       referencing.
+    referencing.
   */
   if (SPEED >= 2)
     {
@@ -2952,7 +2982,6 @@ compile_function (Lisp_Object func)
 	      build_string ("failing to compile function"),
 	      CALL1I (comp-func-name, func),
 	      build_string (err));
-
   SAFE_FREE ();
 }