* define-inline-pure
@ 2023-05-13 1:02 Lynn Winebarger
2023-05-16 0:02 ` define-inline-pure Lynn Winebarger
0 siblings, 1 reply; 2+ messages in thread
From: Lynn Winebarger @ 2023-05-13 1:02 UTC (permalink / raw)
To: emacs-devel
I adapted the define-inline function to allow redefinition of existing
function names to be an inlining version that will evaluate constant
arguments during macroexpand-all, without involvement of the compiler.
The code is below this message.
For example, for a truly pure function
(define-inline-pure-subr + (&rest numbers-or-markers))
It can also be used for not-quite-pure functions that may still be
desirable to evaluate at compile-time using an explicit inline-*
variant:
(define-inline-pure-subr format (string &rest objects) inline-format)
There is code following the definition of define-inline-pure-subr to
find all function symbols declared pure and perform the redefinition
on them. Emacs doesn't immediately fail when I run it, but I haven't
recompiled emacs with the code added to inline.el.
At the bottom is a variant of define-inline, define-inline-pure, that
replicates define-inline, except it evaluates the function call during
macroexpansion if all arguments expand to constant expressions. I
have not tested it at all.
The envisioned use case is dispatching macros to generic functions to
get specialization at compile-time. Presumably the byte-compiler's
optimization code might be slightly simplified as well.
Lynn
;;; -*- lexical-binding: t; -*-
(defun inline-extract-arglist (fxn-name)
"Construct arglist based on FXN docstring if provided in help format."
(let* ((s (documentation fxn-name t))
(found (string-match "\n(fn \\([^\)]*\\))$" s))
(n (length "\n\(fn ")))
(if (not found)
;; punt
'(&rest args)
(let ((arglist-string
(format "\(%s"
(downcase (substring s (+ found n))))))
(with-temp-buffer
(insert arglist-string)
(goto-char (point-min))
(read (current-buffer)))))))
(defun inline-application-form (fxn args)
"Construct an application form for function FXN with argument list ARGS."
(let ((ls args)
(required 0)
params opt restp)
(while ls
(pcase ls
(`(&rest ,param)
(push param params)
(setq restp t)
(setq ls nil))
(`(&rest . ,ignored)
(error "argument list: %s: malformed &rest parameter %S" fxn args))
(`(&optional . ,ignored)
(when opt
(error "argument list: %s: multiple &optional markers %S"
fxn args))
(pop ls)
(setq opt 0))
(`(,param . ,ignored)
(push param params)
(pop ls)
(if opt
(setq opt (1+ opt))
(setq required (1+ required))))
(_
(error "malformed argument list: %s: %S" name args))))
(setq params (nreverse params))
(unless opt
(setq opt 0))
(if restp
`(apply ,fxn ,@params)
`(,fxn ,@params))))
;; Derived from inline.el
(defun inline--testconst-exp-p (exp)
(or (macroexp-const-p exp)
(eq (car-safe exp) 'function)))
(defmacro define-inline-pure-subr (name args &optional new-name)
"Define NEW-NAME to inline the subr currently bound to NAME.
The function must have the signature specified by ARGS.
This inlining enables compile-time evaluation during macroexpansion
rather than during the byte-compiler's optimization phase.
NEW-NAME defaults to NAME."
(declare (indent defun) (debug defun) (doc-string 3))
(when (and new-name (not (eq new-name name)))
(setplist new-name (seq-copy (symbol-plist name))))
(unless new-name
(setq new-name name))
(let ((doc (documentation name t))
(fxn (symbol-function name))
(cm-name (intern (format "%s--inliner" new-name)))
app-form)
(while (symbolp fxn)
(setq fxn (symbol-function fxn)))
(function-put new-name 'compiler-macro nil) ; see define-inline
(setq app-form (inline-application-form fxn args))
`(progn
(,(if (memq (get name 'byte-optimizer)
'(nil byte-compile-inline-expand))
'defsubst
'defun)
,new-name ,args ,doc
(declare (compiler-macro ,cm-name))
,app-form)
(eval-and-compile
(defun ,cm-name ,(cons 'inline--form args)
(let* ((rands (mapcar #'macroexpand-all (cdr inline--form)))
(expander-app-form `(,,fxn ,@rands)))
(if (seq-every-p #'inline--testconst-exp-p rands)
(let ((r
;; (eval expander-app-form)))
(apply fxn rands)))
(unless (macroexp-const-p r)
(setq r `(quote ,r)))
r)
expander-app-form)))))))
;; (define-inline-pure-subr + (&rest args))
;; (macroexpand '(+ 5 7))
;; (macroexpand-all '(+ 5 7))
(defvar inlined-primitives
(let (purefuncs)
(mapatoms (lambda (x)
(and (fboundp x) (get x 'pure)
(push `(,x . ,x) purefuncs))))
;; these are not truly pure
;; make inline-* variants available for explicit use
(push '(format . inline-format) purefuncs)
(push '(intern . inline-intern) purefuncs)
(setq purefuncs (nreverse purefuncs))
(mapcar (lambda (x)
`(,(car x) ,(cdr x) . ,(inline-extract-arglist (car x))))
purefuncs))
"Association list of pure functions and their argument lists for inlining.")
(mapc (lambda (pr)
(eval `(define-inline-pure-subr ,(car pr) ,(cddr pr) ,(cadr pr))))
inlined-primitives)
(defmacro define-inline-pure (name args &rest body)
"Define NAME as inlined pure function with signature ARGS.
BODY will be evaluated during macroexpansion if given constant arguments."
(declare (indent defun) (debug defun) (doc-string 3))
(let ((doc (if (stringp (car-safe body)) (list (pop body))))
(declares (if (eq (car-safe (car-safe body)) 'declare) (pop body)))
(cm-name (intern (format "%s--inliner" name)))
(bodyexp (macroexp-progn body))
expanded-ct-body ct-fxn app-form)
(function-put name 'compiler-macro nil) ; see define-inline
(setq app-form (inline-application-form fxn args))
(setq expanded-ct-body
`(catch 'inline--just-use
,(macroexpand-all
bodyexp
`((inline-quote . inline--do-quote)
;; (inline-\` . inline--do-quote)
(inline--leteval . inline--do-leteval)
(inline--letlisteval
. inline--do-letlisteval)
(inline-const-p . inline--testconst-p)
(inline-const-val . inline--getconst-val)
(inline-error . inline--warning)
,@macroexpand-all-environment))))
;; construct a function that should not have
;; circular dependency on the function symbol
;; being inlined
(setq ct-fxn
(let ((x (cl-gensym "x-"))
(expanded-body
`(catch 'inline--just-use
,expanded-ct-body)))
(byte-compile
`(lambda (,args)
(cl-labels ((,name ,args ,@expanded-ct-body))
,app-form)))))
`(progn
(defun ,name ,args
,@doc
(declare (compiler-macro ,cm-name) ,@declares)
,(macroexpand-all bodyexp
`((inline-quote . inline--dont-quote)
;; (inline-\` . inline--dont-quote)
(inline--leteval . inline--dont-leteval)
(inline--letlisteval . inline--dont-letlisteval)
(inline-const-p . inline--alwaysconst-p)
(inline-const-val . inline--alwaysconst-val)
(inline-error . inline--error)
,@macroexpand-all-environment)))
(eval-and-compile
(defun ,cm-name ,(cons 'inline--form args)
(let* ((rands (mapcar #'macroexpand-all (cdr inline--form)))
(expander-app-form `(,,fxn ,@rands)))
(if (seq-every-p #'inline--testconst-exp-p rands)
(let ((r
;; (eval expander-app-form)))
(apply ct-fxn rands)))
(unless (macroexp-const-p r)
(setq r `(quote ,r)))
r)
,@expanded-ct-body)))))))
^ permalink raw reply [flat|nested] 2+ messages in thread
* Re: define-inline-pure
2023-05-13 1:02 define-inline-pure Lynn Winebarger
@ 2023-05-16 0:02 ` Lynn Winebarger
0 siblings, 0 replies; 2+ messages in thread
From: Lynn Winebarger @ 2023-05-16 0:02 UTC (permalink / raw)
To: emacs-devel
[-- Attachment #1: Type: text/plain, Size: 2173 bytes --]
I have attached a patch to master that adds "define-inline-pure-subr"
to inline.el and converts all defined functions marked as pure to be
inlined. The approach in the patch reflects my intention to include
this feature in an external package. I'm sure the maintainers would
modify the source of the pure functions to use it directly, if they
were interested in the feature.
This version bootstraps and "make check" succeeds at least. It also
works as intended:
(require 'byte-opt)
(require 'inline)
(macroexpand-all '(+ 5 7)) => 12
(macroexpand-all '(cl-typep 5 'integer)) => t
So, the user can see the effects of "compile-time" evaluation of
constant expressions in the source code instead of disassembling the
generated byte-code.
Lynn
On Fri, May 12, 2023 at 9:02 PM Lynn Winebarger <owinebar@gmail.com> wrote:
>
> I adapted the define-inline function to allow redefinition of existing
> function names to be an inlining version that will evaluate constant
> arguments during macroexpand-all, without involvement of the compiler.
> The code is below this message.
>
> For example, for a truly pure function
> (define-inline-pure-subr + (&rest numbers-or-markers))
>
> It can also be used for not-quite-pure functions that may still be
> desirable to evaluate at compile-time using an explicit inline-*
> variant:
> (define-inline-pure-subr format (string &rest objects) inline-format)
>
> There is code following the definition of define-inline-pure-subr to
> find all function symbols declared pure and perform the redefinition
> on them. Emacs doesn't immediately fail when I run it, but I haven't
> recompiled emacs with the code added to inline.el.
>
> At the bottom is a variant of define-inline, define-inline-pure, that
> replicates define-inline, except it evaluates the function call during
> macroexpansion if all arguments expand to constant expressions. I
> have not tested it at all.
>
> The envisioned use case is dispatching macros to generic functions to
> get specialization at compile-time. Presumably the byte-compiler's
> optimization code might be slightly simplified as well.
>
> Lynn
[-- Attachment #2: inline-pure.diff --]
[-- Type: text/x-patch, Size: 10058 bytes --]
diff --git a/lisp/emacs-lisp/inline.el b/lisp/emacs-lisp/inline.el
index f761fda29a8..f31850dafad 100644
--- a/lisp/emacs-lisp/inline.el
+++ b/lisp/emacs-lisp/inline.el
@@ -266,5 +266,235 @@ inline--warning
;; inline--form)
inline--form))
+(defun inline-extract-arglist (fxn-name)
+ "Construct arglist based on FXN docstring if provided in help format."
+ (let* ((s (or (documentation fxn-name t) ""))
+ (found (string-match "\n(fn \\([^\)]*\\))$" s))
+ (n (length "\n\(fn ")))
+ (if (not found)
+ ;; punt
+ '(&rest args)
+ (let ((arglist-string
+ (format "\(%s"
+ (downcase (substring s (+ found n))))))
+ (with-temp-buffer
+ (insert arglist-string)
+ (goto-char (point-min))
+ (read (current-buffer)))))))
+
+
+(defun inline-application-form (fxn args &optional rands)
+ "Construct an application form for function FXN with argument list ARGS and operands RANDS."
+ (let ((ls args)
+ (required 0)
+ params opt restp)
+ (while ls
+ (pcase ls
+ (`(&rest ,param)
+ (push param params)
+ (setq restp t)
+ (setq ls nil))
+ (`(&rest . ,_ignored)
+ (error "argument list: %s: malformed &rest parameter %S" fxn args))
+ (`(&optional . ,_ignored)
+ (when opt
+ (error "argument list: %s: multiple &optional markers %S"
+ fxn args))
+ (pop ls)
+ (setq opt 0))
+ (`(,param . ,_ignored)
+ (push param params)
+ (pop ls)
+ (if opt
+ (setq opt (1+ opt))
+ (setq required (1+ required))))
+ (_
+ (error "malformed argument list: %s: %S" fxn args))))
+ (setq params (nreverse params))
+ (unless (or (subrp fxn)
+ (byte-code-function-p fxn)
+ (compiled-function-p fxn)
+ (symbolp fxn)
+ (and (consp fxn)
+ (eq (car fxn) 'function)))
+ (setq fxn (list 'function fxn)))
+ (unless opt
+ (setq opt 0))
+ (if rands
+ (progn
+ ;; (display-warning '(inline)
+ ;; (format "Source operands: %S %S" fxn rands))
+ `(,fxn ,@rands))
+ (if restp
+ `(apply ,(if (symbolp fxn) `#',fxn fxn) ,@params)
+ `(,fxn ,@params)))))
+
+;; Derived from inline.el
+(defun inline--testconst-exp-p (exp)
+ (or (macroexp-const-p exp)
+ (eq (car-safe exp) 'function)))
+
+;;;###autoload
+(defmacro define-inline-pure-subr (name args &optional new-name)
+ "Define NEW-NAME to inline the subr currently bound to NAME.
+The function must have the signature specified by ARGS.
+This inlining enables compile-time evaluation during macroexpansion
+rather than during the byte-compiler's optimization phase.
+NEW-NAME defaults to NAME."
+ (declare (indent defun) (debug defun) (doc-string 3))
+ ;; (message "Redefining as inline %s %S %s" name args new-name)
+ (when (and new-name (not (eq new-name name)))
+ (setplist new-name (seq-copy (symbol-plist name))))
+ (unless new-name
+ (setq new-name name))
+ (let ((doc (documentation name t))
+ (fxn (symbol-function name))
+ (fxn-sym (intern (format "inline-%s" new-name)))
+ (cm-name (intern (format "%s--inliner" new-name)))
+ app-form)
+ (while (symbolp fxn)
+ (setq fxn (symbol-function fxn)))
+ (unless (or (subrp fxn)
+ (byte-code-function-p fxn)
+ (compiled-function-p fxn)
+ (and (consp fxn)
+ (or (eq (car fxn) 'function)
+ (eq (car fxn) 'lambda))))
+ (setq fxn (list 'function fxn)))
+ (function-put new-name 'compiler-macro nil) ; see define-inline
+ (setq app-form (inline-application-form fxn-sym args))
+ (fset fxn-sym fxn)
+ `(progn
+ (fset ',fxn-sym ,fxn)
+ (defun ,new-name ,args
+ ,doc
+ (fset ',fxn-sym ,fxn)
+ ,(if (eq new-name name)
+ `(progn
+ (fset ',new-name ,fxn)
+ ;; see define-inline
+ (function-put ',new-name 'compiler-macro ',cm-name))
+ ;; first pass ensure definition of underlying function
+ ;; then redefine to bypass this trampoline
+ `(,(if (memq (get name 'byte-optimizer)
+ '(nil byte-compile-inline-expand))
+ 'defsubst
+ 'defun)
+ ,new-name ,args ,doc
+ (declare (compiler-macro ,cm-name))
+ ,app-form))
+ ,app-form)
+ (eval-and-compile
+ (defun ,cm-name ,(cons 'inline--form args)
+ (fset ',fxn-sym ,fxn)
+ (defun ,cm-name ,(cons 'inline--form args)
+ (let* ((rands (mapcar #'macroexpand-all (cdr inline--form)))
+ (expander-app-form
+ `(,',fxn-sym ,@rands)))
+ (if (seq-every-p #'inline--testconst-exp-p rands)
+ (progn
+ (let ((r (eval expander-app-form)))
+ (unless (macroexp-const-p r)
+ (setq r `(quote ,r)))
+ r))
+ inline--form)))
+ ,(inline-application-form cm-name (cons 'inline--form args))))
+ (function-put ',new-name 'compiler-macro ',cm-name))))
+
+;;;###autoload
+(defvar inline--inlined-primitives nil
+ "Association list of pure functions and their argument lists for inlining.")
+
+(defvar inline--defining-inlines nil)
+(defun inline-all-pure-functions ()
+ "Create macro-expansion evaluating versions of known pure functions.
+These inline versions reduce constant arguments at macro-expansion time without
+involvement of the byte-compiler."
+ (let ((inline--defining-inlines t))
+ (setq inline--inlined-primitives
+ (let (purefuncs)
+ (mapatoms (lambda (x)
+ (and (fboundp x) (get x 'pure)
+ (push `(,x . ,x) purefuncs))))
+ ;; these are not truly pure
+ ;; make inline-* variants available for explicit use
+ (push '(format . inline-format) purefuncs)
+ (push '(intern . inline-intern) purefuncs)
+ (setq purefuncs (nreverse purefuncs))
+ (mapcar (lambda (x)
+ `(,(car x) ,(cdr x) . ,(inline-extract-arglist (car x))))
+ purefuncs))))
+
+ (mapc (lambda (pr)
+ (eval `(define-inline-pure-subr ,(car pr) ,(cddr pr) ,(cadr pr))))
+ inline--inlined-primitives))
+
+(when (and (or (featurep 'bytecomp) (featurep 'byte-opt))
+ (fboundp 'function-documentation)
+ (not inline--defining-inlines))
+ (inline-all-pure-functions))
+
+;; (defmacro define-inline-pure (name args &rest body)
+;; "Define NAME as inlined pure function with signature ARGS.
+;; BODY will be evaluated during macroexpansion if given constant arguments."
+;; (declare (indent defun) (debug defun) (doc-string 3))
+;; (let ((doc (if (stringp (car-safe body)) (list (pop body))))
+;; (declares (if (eq (car-safe (car-safe body)) 'declare) (pop body)))
+;; (cm-name (intern (format "%s--inliner" name)))
+;; (bodyexp (macroexp-progn body))
+;; expanded-ct-body ct-fxn app-form)
+;; (function-put name 'compiler-macro nil) ; see define-inline
+;; (setq app-form (inline-application-form fxn args))
+;; (setq expanded-ct-body
+;; `(catch 'inline--just-use
+;; ,(macroexpand-all
+;; bodyexp
+;; `((inline-quote . inline--do-quote)
+;; ;; (inline-\` . inline--do-quote)
+;; (inline--leteval . inline--do-leteval)
+;; (inline--letlisteval
+;; . inline--do-letlisteval)
+;; (inline-const-p . inline--testconst-p)
+;; (inline-const-val . inline--getconst-val)
+;; (inline-error . inline--warning)
+;; ,@macroexpand-all-environment))))
+;; ;; construct a function that should not have
+;; ;; circular dependency on the function symbol
+;; ;; being inlined
+;; (setq ct-fxn
+;; (let ((x (cl-gensym "x-"))
+;; (expanded-body
+;; `(catch 'inline--just-use
+;; ,expanded-ct-body)))
+;; (byte-compile
+;; `(lambda (,args)
+;; (cl-labels ((,name ,args ,@expanded-ct-body))
+;; ,app-form)))))
+;; `(progn
+;; (defun ,name ,args
+;; ,@doc
+;; (declare (compiler-macro ,cm-name) ,@declares)
+;; ,(macroexpand-all bodyexp
+;; `((inline-quote . inline--dont-quote)
+;; ;; (inline-\` . inline--dont-quote)
+;; (inline--leteval . inline--dont-leteval)
+;; (inline--letlisteval . inline--dont-letlisteval)
+;; (inline-const-p . inline--alwaysconst-p)
+;; (inline-const-val . inline--alwaysconst-val)
+;; (inline-error . inline--error)
+;; ,@macroexpand-all-environment)))
+;; (eval-and-compile
+;; (defun ,cm-name ,(cons 'inline--form args)
+;; (let* ((rands (mapcar #'macroexpand-all (cdr inline--form)))
+;; (expander-app-form `(,,fxn ,@rands)))
+;; (if (seq-every-p #'inline--testconst-exp-p rands)
+;; (let ((r
+;; ;; (eval expander-app-form)))
+;; (apply ct-fxn rands)))
+;; (unless (macroexp-const-p r)
+;; (setq r `(quote ,r)))
+;; r)
+;; ,@expanded-ct-body)))))))
+
(provide 'inline)
;;; inline.el ends here
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el
index ddaa3f83fbb..f5cebb54faa 100644
--- a/lisp/ldefs-boot.el
+++ b/lisp/ldefs-boot.el
@@ -18249,6 +18249,18 @@ "informat"
(fn NAME ARGS &rest BODY)" nil t)
(function-put 'define-inline 'lisp-indent-function 'defun)
(function-put 'define-inline 'doc-string-elt 3)
+
+
+(autoload 'define-inline-pure-subr "inline" "\
+Define NEW-NAME to inline the subr currently bound to NAME.
+The function must have the signature specified by ARGS.
+This inlining enables compile-time evaluation during macroexpansion
+rather than during the byte-compiler's optimization phase.
+NEW-NAME defaults to NAME.")
+
+(defvar inline--inlined-primitives nil "\
+Association list of pure functions and their argument lists for inlining.")
+
(register-definition-prefixes "inline" '("inline-"))
\f
^ permalink raw reply related [flat|nested] 2+ messages in thread
end of thread, other threads:[~2023-05-16 0:02 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2023-05-13 1:02 define-inline-pure Lynn Winebarger
2023-05-16 0:02 ` define-inline-pure Lynn Winebarger
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).