feature/native-comp decced8 04/12: Allow per function speed declaration

[Andrea Corallo]

branch: feature/native-comp
commit decced8337278e3e21e9926819edd7eab003587a
Author: Andrea Corallo <akrl@sdf.org>
Commit: Andrea Corallo <akrl@sdf.org>

    Allow per function speed declaration
    
        * src/comp.c (COMP_SPEED): Rename.
        (comp_t): Add 'func_speed' field.
        (emit_mvar_lval, compile_function): Update for per function speed.
        (Fcomp__compile_ctxt_to_file): COMP_SPEED renamed.
    
        * lisp/emacs-lisp/comp.el (comp-speed): Doc update.
        (comp-func): New 'speed' slot.
        (comp-spill-speed): New function.
        (comp-spill-lap-function, comp-intern-func-in-ctxt): Fill 'speed'
        slot.
        (comp-spill-lap-function): Gate -1 speed functions for native
        compilation and emit bytecode instead.
        (comp-spill-lap): Close over `byte-to-native-plist-environment'.
        (comp-latch-make-fill): Update for per function speed.
        (comp-limplify-top-level): Fill speed.
        (comp-propagate1, comp-call-optim-form-call, comp-call-optim)
        (comp-dead-code, comp-tco, comp-remove-type-hints): Update for per
        function speed.
---
 lisp/emacs-lisp/byte-run.el |   8 ++-
 lisp/emacs-lisp/bytecomp.el |   8 ++-
 lisp/emacs-lisp/comp.el     | 129 ++++++++++++++++++++++++++------------------
 src/comp.c                  |  10 ++--
 4 files changed, 98 insertions(+), 57 deletions(-)

diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el
index 88e21b7..4c1dce2 100644
--- a/lisp/emacs-lisp/byte-run.el
+++ b/lisp/emacs-lisp/byte-run.el
@@ -143,6 +143,11 @@ The return value of this function is not used."
       (list 'function-put (list 'quote f)
             ''lisp-indent-function (list 'quote val))))
 
+(defalias 'byte-run--set-speed
+  #'(lambda (f _args val)
+      (list 'function-put (list 'quote f)
+            ''speed (list 'quote val))))
+
 ;; Add any new entries to info node `(elisp)Declare Form'.
 (defvar defun-declarations-alist
   (list
@@ -159,7 +164,8 @@ This may shift errors from run-time to compile-time.")
 If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
    (list 'compiler-macro #'byte-run--set-compiler-macro)
    (list 'doc-string #'byte-run--set-doc-string)
-   (list 'indent #'byte-run--set-indent))
+   (list 'indent #'byte-run--set-indent)
+   (list 'speed #'byte-run--set-speed))
   "List associating function properties to their macro expansion.
 Each element of the list takes the form (PROP FUN) where FUN is
 a function.  For each (PROP . VALUES) in a function's declaration,
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index c7d2344..7a56aa2 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -601,6 +601,8 @@ Each element is (INDEX . VALUE)")
   "List of top level forms.")
 (defvar byte-to-native-output-file nil
   "Temporary file containing the byte-compilation output.")
+(defvar byte-to-native-plist-environment nil
+  "To spill `overriding-plist-environment'.")
 
 
 ;;; The byte codes; this information is duplicated in bytecomp.c
@@ -1740,7 +1742,11 @@ extra args."
          ;;             byte-compile-generate-emacs19-bytecodes)
          (byte-compile-warnings byte-compile-warnings)
          )
-     ,@body))
+     (prog1
+         (progn ,@body)
+       (when byte-native-compiling
+         (setq byte-to-native-plist-environment
+               overriding-plist-environment)))))
 
 (defmacro displaying-byte-compile-warnings (&rest body)
   (declare (debug t))
diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 928fa51..3372400 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -49,10 +49,11 @@ the native compiled one."
   :group 'comp)
 
 (defcustom comp-speed 2
-  "Compiler optimization level.  From 0 to 3.
-- 0 no optimizations are performed, compile time is favored.
+  "Compiler optimization level.  From -1 to 3.
+- -1 functions are kept in bytecode form and no native compilation is 
performed.
+- 0 native compilation is performed with no optimizations.
 - 1 lite optimizations.
-- 2 heavy optimizations.
+- 2 max optimization level fully adherent to the language semantic.
 - 3 max optimization level, to be used only when necessary.
     Warning: the compiler is free to perform dangerous optimizations."
   :type 'number
@@ -369,7 +370,9 @@ structure.")
   (has-non-local nil :type boolean
                  :documentation "t if non local jumps are present.")
   (array-h (make-hash-table) :type hash-table
-           :documentation "array idx -> array length."))
+           :documentation "array idx -> array length.")
+  (speed nil :type number
+         :documentation "Optimization level (see `comp-speed')."))
 
 (cl-defstruct (comp-func-l (:include comp-func))
   "Lexical scoped function."
@@ -546,6 +549,12 @@ instruction."
   (and (byte-code-function-p f)
        (fixnump (aref f 0))))
 
+(defun comp-spill-speed (fuction-name)
+  "Return the speed for SYMBOL-FUNCTION."
+  (or (plist-get (cdr (assq fuction-name byte-to-native-plist-environment))
+                 'speed)
+      comp-speed))
+
 (defun comp-c-func-name (name prefix)
   "Given NAME return a name suitable for the native code.
 Put PREFIX in front of it."
@@ -612,7 +621,8 @@ Put PREFIX in front of it."
          (func (make-comp-func-l :name function-name
                                  :c-name c-name
                                  :doc (documentation f)
-                                 :int-spec (interactive-form f))))
+                                 :int-spec (interactive-form f)
+                                 :speed (comp-spill-speed function-name))))
       (when (byte-code-function-p f)
         (signal 'native-compiler-error
                 "can't native compile an already bytecompiled function"))
@@ -661,7 +671,8 @@ Put PREFIX in front of it."
             (comp-func-int-spec func) (interactive-form byte-func)
             (comp-func-c-name func) c-name
             (comp-func-lap func) lap
-            (comp-func-frame-size func) (comp-byte-frame-size byte-func))
+            (comp-func-frame-size func) (comp-byte-frame-size byte-func)
+            (comp-func-speed func) (comp-spill-speed name))
 
       ;; Store the c-name to have it retrivable from
       ;; `comp-ctxt-top-level-forms'.
@@ -681,7 +692,21 @@ Put PREFIX in front of it."
   (unless byte-to-native-top-level-forms
     (signal 'native-compiler-error-empty-byte filename))
   (setf (comp-ctxt-top-level-forms comp-ctxt)
-        (reverse byte-to-native-top-level-forms))
+        (cl-loop
+         for form in (reverse byte-to-native-top-level-forms)
+         collect
+         (if (and (byte-to-native-func-def-p form)
+                  (eq -1
+                      (comp-spill-speed (byte-to-native-func-def-name form))))
+             (let ((byte-code (byte-to-native-func-def-byte-func form)))
+               (remhash byte-code byte-to-native-lambdas-h)
+               (make-byte-to-native-top-level
+                :form `(defalias
+                         ',(byte-to-native-func-def-name form)
+                         ,byte-code
+                         nil)
+                :lexical (comp-lex-byte-func-p byte-code)))
+           form)))
   (maphash #'comp-intern-func-in-ctxt byte-to-native-lambdas-h))
 
 (defun comp-spill-lap (input)
@@ -690,7 +715,8 @@ If INPUT is a symbol this is the function-name to be 
compiled.
 If INPUT is a string this is the file path to be compiled."
   (let ((byte-native-compiling t)
         (byte-to-native-lambdas-h (make-hash-table :test #'eq))
-        (byte-to-native-top-level-forms ()))
+        (byte-to-native-top-level-forms ())
+        (byte-to-native-plist-environment ()))
     (comp-spill-lap-function input)))
 
 
@@ -867,7 +893,7 @@ Return the created latch"
         (curr-bb (comp-limplify-curr-block comp-pass)))
     ;; See `comp-make-curr-block'.
     (setf (comp-limplify-curr-block comp-pass) latch)
-    (when (< comp-speed 3)
+    (when (< (comp-func-speed comp-func) 3)
       ;; At speed 3 the programmer is responsible to manually
       ;; place `comp-maybe-gc-or-quit'.
       (comp-emit '(call comp-maybe-gc-or-quit)))
@@ -1429,7 +1455,8 @@ into the C code forwarding the compilation unit."
                                              "late_top_level_run"
                                            "top_level_run")
                                  :args (make-comp-args :min 1 :max 1)
-                                 :frame-size 1))
+                                 :frame-size 1
+                                 :speed comp-speed))
          (comp-func func)
          (comp-pass (make-comp-limplify
                      :curr-block (make--comp-block-lap -1 0 'top-level)
@@ -2029,18 +2056,18 @@ Return t if something was changed."
 
 (defun comp-propagate1 (backward)
   (comp-ssa)
-  (when (>= comp-speed 2)
-    (maphash (lambda (_ f)
-               ;; FIXME remove the following condition when tested.
-               (unless (comp-func-has-non-local f)
-                 (let ((comp-func f))
-                   (comp-propagate-prologue backward)
-                   (cl-loop
-                    for i from 1
-                    while (comp-propagate*)
-                    finally (comp-log (format "Propagation run %d times\n" i) 
2))
-                   (comp-log-func comp-func 3))))
-             (comp-ctxt-funcs-h comp-ctxt))))
+  (maphash (lambda (_ f)
+             (when (and (>= (comp-func-speed f) 2)
+                        ;; FIXME remove the following condition when tested.
+                        (not (comp-func-has-non-local f)))
+               (let ((comp-func f))
+                 (comp-propagate-prologue backward)
+                 (cl-loop
+                  for i from 1
+                  while (comp-propagate*)
+                  finally (comp-log (format "Propagation run %d times\n" i) 2))
+                 (comp-log-func comp-func 3))))
+           (comp-ctxt-funcs-h comp-ctxt)))
 
 (defun comp-propagate (_)
   "Forward propagate types and consts within the lattice."
@@ -2110,9 +2137,9 @@ FUNCTION can be a function-name or byte compiled 
function."
          ;; Intra compilation unit procedure call optimization.
          ;; Attention speed 3 triggers this for non self calls too!!
          ((and comp-func-callee
-               (or (and (>= comp-speed 3)
+               (or (and (>= (comp-func-speed comp-func) 3)
                         (comp-func-unique-in-cu-p callee))
-                   (and (>= comp-speed 2)
+                   (and (>= (comp-func-speed comp-func) 2)
                         ;; Anonymous lambdas can't be redefined so are
                         ;; always safe to optimize.
                         (byte-code-function-p callee))))
@@ -2145,12 +2172,12 @@ FUNCTION can be a function-name or byte compiled 
function."
 
 (defun comp-call-optim (_)
   "Try to optimize out funcall trampoline usage when possible."
-  (when (>= comp-speed 2)
-    (maphash (lambda (_ f)
+  (maphash (lambda (_ f)
+             (when (and (>= (comp-func-speed f) 2)
+                        (comp-func-l-p f))
                (let ((comp-func f))
-                 (when (comp-func-l-p f)
-                   (comp-call-optim-func))))
-             (comp-ctxt-funcs-h comp-ctxt))))
+                 (comp-call-optim-func))))
+           (comp-ctxt-funcs-h comp-ctxt)))
 
 
 ;;; Dead code elimination pass specific code.
@@ -2209,17 +2236,17 @@ Return the list of m-var ids nuked."
 
 (defun comp-dead-code (_)
   "Dead code elimination."
-  (when (>= comp-speed 2)
-    (maphash (lambda (_ f)
-               (let ((comp-func f))
-                 ;; FIXME remove the following condition when tested.
-                 (unless (comp-func-has-non-local comp-func)
-                   (cl-loop
-                    for i from 1
-                    while (comp-dead-assignments-func)
-                    finally (comp-log (format "dead code rm run %d times\n" i) 
2)
-                            (comp-log-func comp-func 3)))))
-             (comp-ctxt-funcs-h comp-ctxt))))
+  (maphash (lambda (_ f)
+             (when (and (>= (comp-func-speed f) 2)
+                        ;; FIXME remove the following condition when tested.
+                        (not (comp-func-has-non-local f)))
+               (cl-loop
+                for comp-func = f
+                for i from 1
+                while (comp-dead-assignments-func)
+                finally (comp-log (format "dead code rm run %d times\n" i) 2)
+                (comp-log-func comp-func 3))))
+           (comp-ctxt-funcs-h comp-ctxt)))
 
 
 ;;; Tail Call Optimization pass specific code.
@@ -2252,14 +2279,14 @@ Return the list of m-var ids nuked."
 
 (defun comp-tco (_)
   "Simple peephole pass performing self TCO."
-  (when (>= comp-speed 3)
-    (maphash (lambda (_ f)
+  (maphash (lambda (_ f)
+             (when (and (>= (comp-func-speed f) 3)
+                        (comp-func-l-p f)
+                        (not (comp-func-has-non-local f)))
                (let ((comp-func f))
-                 (when (and (comp-func-l-p f)
-                            (not (comp-func-has-non-local comp-func)))
-                   (comp-tco-func)
-                   (comp-log-func comp-func 3))))
-             (comp-ctxt-funcs-h comp-ctxt))))
+                 (comp-tco-func)
+                 (comp-log-func comp-func 3))))
+           (comp-ctxt-funcs-h comp-ctxt)))
 
 
 ;;; Type hint removal pass specific code.
@@ -2279,12 +2306,12 @@ These are substituted with a normal 'set' op."
 
 (defun comp-remove-type-hints (_)
   "Dead code elimination."
-  (when (>= comp-speed 2)
-    (maphash (lambda (_ f)
+  (maphash (lambda (_ f)
+             (when (>= (comp-func-speed f) 2)
                (let ((comp-func f))
                  (comp-remove-type-hints-func)
-                 (comp-log-func comp-func 3)))
-             (comp-ctxt-funcs-h comp-ctxt))))
+                 (comp-log-func comp-func 3))))
+           (comp-ctxt-funcs-h comp-ctxt)))
 
 
 ;;; Final pass specific code.
diff --git a/src/comp.c b/src/comp.c
index 781ad3e..82a092a 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -411,7 +411,7 @@ load_gccjit_if_necessary (bool mandatory)
 #define TEXT_FDOC_SYM "text_data_fdoc"
 
 
-#define SPEED XFIXNUM (Fsymbol_value (Qcomp_speed))
+#define COMP_SPEED XFIXNUM (Fsymbol_value (Qcomp_speed))
 #define COMP_DEBUG XFIXNUM (Fsymbol_value (Qcomp_debug))
 
 #define STR_VALUE(s) #s
@@ -536,6 +536,7 @@ typedef struct {
   size_t cast_union_field_biggest_type;
   gcc_jit_function *func; /* Current function being compiled.  */
   bool func_has_non_local; /* From comp-func has-non-local slot.  */
+  EMACS_INT func_speed; /* From comp-func speed slot.  */
   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).  */
@@ -734,7 +735,7 @@ emit_mvar_lval (Lisp_Object mvar)
 
   EMACS_INT arr_idx = XFIXNUM (CALL1I (comp-mvar-array-idx, mvar));
   EMACS_INT slot_n = XFIXNUM (mvar_slot);
-  if (comp.func_has_non_local || (SPEED < 2))
+  if (comp.func_has_non_local || (comp.func_speed < 2))
     return comp.arrays[arr_idx][slot_n];
   else
     {
@@ -3736,6 +3737,7 @@ compile_function (Lisp_Object func)
                                       comp.exported_funcs_h, Qnil));
 
   comp.func_has_non_local = !NILP (CALL1I (comp-func-has-non-local, func));
+  comp.func_speed = XFIXNUM (CALL1I (comp-func-speed, func));
 
   struct Lisp_Hash_Table *array_h =
     XHASH_TABLE (CALL1I (comp-func-array-h, func));
@@ -3775,7 +3777,7 @@ compile_function (Lisp_Object func)
     - Allow gcc to trigger other optimizations that are prevented by memory
     referencing.
   */
-  if (SPEED >= 2)
+  if (comp.func_speed >= 2)
     {
       comp.f_frame = SAFE_ALLOCA (frame_size * sizeof (*comp.f_frame));
       for (ptrdiff_t i = 0; i < frame_size; ++i)
@@ -4030,7 +4032,7 @@ DEFUN ("comp--compile-ctxt-to-file", 
Fcomp__compile_ctxt_to_file,
 
   gcc_jit_context_set_int_option (comp.ctxt,
                                  GCC_JIT_INT_OPTION_OPTIMIZATION_LEVEL,
-                                 SPEED);
+                                 COMP_SPEED);
   comp.d_default_idx =
     CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-default, Vcomp_ctxt));
   comp.d_impure_idx =