diff --git a/etc/NEWS b/etc/NEWS index 6e57adcd052..6107ee153f5 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -3879,6 +3879,12 @@ coding mistakes. For example, may return either nil or t. +--- +** Native compilation now uses declared function parameter types more. +At native compilation speed 2 and above, declared function types are +used for type propagation, value prediction, and optimization within +function bodies. + ** Nested backquotes are not supported any more in Pcase patterns. --- diff --git a/etc/TODO b/etc/TODO index 2ee6b0e8eb1..b93236d3759 100644 --- a/etc/TODO +++ b/etc/TODO @@ -1010,12 +1010,6 @@ libgccjit. Two simple first candidates are probably 'maybe_quit' and *** Features to be improved or missing -**** Make use of function type declaration - -The native compiler should make use of function type declarations (when -available) to propagate parameter types inside the function for better -value/type predictions. - **** Fix portable dumping so that you can redump without using -batch ***** Redumps and native compiler "preloaded" sub-folder. diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el index 247e2f0900f..ec95dfdb8b2 100644 --- a/lisp/emacs-lisp/comp.el +++ b/lisp/emacs-lisp/comp.el @@ -843,7 +843,9 @@ clashes." (comp-func-frame-size func) (comp--byte-frame-size byte-func) (comp-func-speed func) (comp--spill-speed name) (comp-func-safety func) (comp--spill-safety name) - (comp-func-declared-type func) (comp--spill-decl-spec name 'function-type) + (comp-func-declared-type func) + (or (comp--spill-decl-spec name 'function-type) + (and name (function-get name 'function-type))) (comp-func-pure func) (comp--spill-decl-spec name 'pure)) ;; Store the c-name to have it retrievable from @@ -1516,17 +1518,46 @@ and the annotation emission." (incf (comp--sp) (- arg)) (comp--copy-slot (+ arg (comp--sp))))))) -(defun comp--emit-narg-prologue (minarg nonrest rest) +(defun comp--declared-arg-type-gen (func) + "Return a generator over FUNC declared argument types." + (when-let* (((>= (comp-func-speed func) 2)) + (declared-type (comp-func-declared-type func)) + (cstr-f (comp-type-spec-to-cstr declared-type))) + (cl-assert (comp-cstr-f-p cstr-f)) + (comp--lambda-list-gen (comp-cstr-f-args cstr-f)))) + +(defun comp--emit-declared-arg-type-assumption (mvar declared-arg-type-gen + &optional optional) + "Emit a declared argument type assumption for MVAR. +When OPTIONAL is non-nil, account for omitted optional arguments by +allowing nil as well." + (when-let* ((declared-arg-type-gen declared-arg-type-gen) + (cstr (funcall declared-arg-type-gen))) + (when (comp-cstr-p cstr) + (when optional + (setf cstr (comp--cstr-union-make cstr (comp--value-to-cstr nil)))) + (unless (equal cstr comp-cstr-t) + (let ((target (make--comp-mvar :slot (comp-mvar-slot mvar)))) + (comp--emit `(assume ,target (and ,target ,cstr)))))))) + +(defun comp--emit-narg-prologue (minarg nonrest rest + &optional declared-arg-type-gen) "Emit the prologue for a narg function." (cl-loop for i below minarg - do (comp--emit `(set-args-to-local ,(comp--slot-n i))) + for target = (comp--slot-n i) + do (comp--emit `(set-args-to-local ,target)) + (comp--emit-declared-arg-type-assumption + target declared-arg-type-gen) (comp--emit '(inc-args))) (cl-loop for i from minarg below nonrest for bb = (intern (format "entry_%s" i)) for fallback = (intern (format "entry_fallback_%s" i)) do (comp--emit `(cond-jump-narg-leq ,i ,fallback ,bb)) (comp--make-curr-block bb (comp--sp)) - (comp--emit `(set-args-to-local ,(comp--slot-n i))) + (let ((target (comp--slot-n i))) + (comp--emit `(set-args-to-local ,target)) + (comp--emit-declared-arg-type-assumption + target declared-arg-type-gen)) (comp--emit '(inc-args)) finally (comp--emit '(jump entry_rest_args))) (when (/= minarg nonrest) @@ -1752,14 +1783,20 @@ into the C code forwarding the compilation unit." (symbol-name (comp-func-name func)))) ;; Dynamic functions have parameters bound by the trampoline. (when (comp-func-l-p func) - (let ((args (comp-func-l-args func))) + (let ((args (comp-func-l-args func)) + (declared-arg-type-gen (comp--declared-arg-type-gen func))) (if (comp-args-p args) (cl-loop for i below (comp-args-max args) do (incf (comp--sp)) - (comp--emit `(set-par-to-local ,(comp--slot) ,i))) + (let ((target (comp--slot))) + (comp--emit `(set-par-to-local ,target ,i)) + (comp--emit-declared-arg-type-assumption + target declared-arg-type-gen + (>= i (comp-args-base-min args))))) (comp--emit-narg-prologue (comp-args-base-min args) (comp-nargs-nonrest args) - (comp-nargs-rest args))))) + (comp-nargs-rest args) + declared-arg-type-gen)))) (comp--emit '(jump bb_0)) ;; Body (comp--bb-maybe-add 0 (comp--sp)) diff --git a/test/src/comp-tests.el b/test/src/comp-tests.el index a4186dba7ba..e322bdb057e 100644 --- a/test/src/comp-tests.el +++ b/test/src/comp-tests.el @@ -940,15 +940,31 @@ Return a list of results." (comp-tests--types-equal (nth 2 t1) (nth 2 t2)))) (t (comp-tests--type-lists-equal (cdr t1) (cdr t2))))))) -(defun comp-tests-check-ret-type-spec (func-form ret-type) +(defun comp-tests-check-ret-type-spec (func-form ret-type &optional speed) (let ((lexical-binding t) - (native-comp-speed 2) - (f-name (cl-second func-form))) - (eval func-form t) - (native-compile f-name) - (should (comp-tests--types-equal - (cl-third (subr-type (symbol-function f-name))) - ret-type)))) + (native-comp-speed (or speed 2)) + (f-name (cl-second func-form)) + (old-function-type nil)) + (when (symbolp f-name) + (setq old-function-type (function-get f-name 'function-type))) + (unwind-protect + (progn + (eval func-form t) + (native-compile f-name) + (should (comp-tests--types-equal + (cl-third (subr-type (symbol-function f-name))) + ret-type))) + (when (symbolp f-name) + (function-put f-name 'function-type old-function-type))))) + +(comp-deftest speed-1-declared-param-type () + (let ((comp-ctxt (make-comp-cstr-ctxt))) + (comp-tests-check-ret-type-spec + '(defun comp-tests-ret-type-spec-f (x) + (declare (ftype (function (string) t))) + x) + 't + 1))) (cl-eval-when (compile eval load) (cl-defstruct comp-foo a b) @@ -1526,7 +1542,17 @@ Return a list of results." ((defun comp-tests-ret-type-spec-f (x) (print (comp-foo-p x)) (comp-foo-p x)) - 'boolean))) + 'boolean) + ;; 82 + ((defun comp-tests-ret-type-spec-f (x) + (declare (ftype (function (string) t))) + x) + 'string) + ;; 83 + ((defun comp-tests-ret-type-spec-f (&optional x) + (declare (ftype (function (&optional string) t))) + x) + '(or null string)))) (defun comp-tests-define-type-spec-test (number x) `(comp-deftest ,(intern (format "ret-type-spec-%d" number)) ()