From decced8337278e3e21e9926819edd7eab003587a Mon Sep 17 00:00:00 2001 From: Andrea Corallo Date: Mon, 15 Jun 2020 20:26:00 +0200 Subject: [PATCH] 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 88e21b73fed..4c1dce264a7 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 c7d2344dbd2..7a56aa2df29 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 928fa516ed5..3372400a6d3 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 781ad3e08e4..82a092ad356 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 = -- 2.39.5