From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Lynn Winebarger Newsgroups: gmane.emacs.devel Subject: define-inline-pure Date: Fri, 12 May 2023 21:02:54 -0400 Message-ID: Mime-Version: 1.0 Content-Type: text/plain; charset="UTF-8" Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="26686"; mail-complaints-to="usenet@ciao.gmane.io" To: emacs-devel Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Sat May 13 03:03:59 2023 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1pxdfz-0006lf-7j for ged-emacs-devel@m.gmane-mx.org; Sat, 13 May 2023 03:03:59 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1pxdfE-0006Yp-Oj; Fri, 12 May 2023 21:03:12 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pxdfD-0006Ye-78 for emacs-devel@gnu.org; Fri, 12 May 2023 21:03:11 -0400 Original-Received: from mail-pg1-x535.google.com ([2607:f8b0:4864:20::535]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pxdfB-00023D-2Q for emacs-devel@gnu.org; Fri, 12 May 2023 21:03:10 -0400 Original-Received: by mail-pg1-x535.google.com with SMTP id 41be03b00d2f7-51f6461af24so7414333a12.2 for ; Fri, 12 May 2023 18:03:07 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20221208; t=1683939786; x=1686531786; h=to:subject:message-id:date:from:mime-version:from:to:cc:subject :date:message-id:reply-to; bh=V2coFUrm/T+8LQSZCjdanKYJmnSLBOMEc/KMycZ/MUw=; b=qEW3XTcHNSGHnhFNAhrBTqTKowGp6VuJzRYCIApeqTjhDKfX+1zhfVq5PuaJ0M/7wF YVTtS/v/UY30IjvxSwOlD3bbiEp5g56Oc7dY64mI+1MTiId9tgcVa4wqiBEcODwkRTAu bQKl5c5IG39lMV8QtBGdO4v/nXcOAhZrK4lA+AXBU6Psx5N3yv4HI/69p8nhlivHxi3P fOsfPozku5Zc7n7MtPcVzrm7VPRcGK5S5OYp7A+NQL9Ux4vjzl0mjRAI+sAHg+snEwqi u4xhCzt2edIRgLgcDkEK1WGldXFF3CWYT02FuMN3297Vk1sntmIJTeJIjBaF9UHSf17H kApw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20221208; t=1683939786; x=1686531786; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=V2coFUrm/T+8LQSZCjdanKYJmnSLBOMEc/KMycZ/MUw=; b=CzE5BmTwLXLMMsDxO9q1e4CC/r+wKrCFRXbsNigcl7eqsBDN83vk3XzSGVd2JtFJ3S g7eMepNXI1hwvCxmn025Kd0v4zsAuiCbMOqkk9CqgQRarG2IiTFiAWTNT7GkoNgbF5fE YA7JLmIIHqHuUqKVBmCYf9dajcFpjYOgHfJsKA00hotxZ1LarIa4ao9edg+eLn2QfATC gU8xzlKJ/gMb01RlMY+zLSvExENgOeeZbCBkPgy76db8CyihmxRJT1dlofoG/CqQ/jKX GEf8Mob/ARG5aPE17COosFEBmxwUl4S3QYU+/B33/To+BYLR4ucnkLRetfCvpFvo7pJH I9ew== X-Gm-Message-State: AC+VfDyjU0UalkypA6QJod3ScE//Gsnikj896ZYTwQwmyo9B8YVdf76X LBKClDfqUqDT34CE5Sed8YwJUDEYlMyUZCHNcxHwIzK7+H0= X-Google-Smtp-Source: ACHHUZ5qKNiqTNOZTMeCWEW1SYal9WebS+wWcetBCQKYzV7jb7buYtCdstdVx40d7dUR+iTDqPM/jMeEuQiTyatzKZ0= X-Received: by 2002:a17:90a:31c6:b0:24e:26f4:4b22 with SMTP id j6-20020a17090a31c600b0024e26f44b22mr26194415pjf.16.1683939785495; Fri, 12 May 2023 18:03:05 -0700 (PDT) Received-SPF: pass client-ip=2607:f8b0:4864:20::535; envelope-from=owinebar@gmail.com; helo=mail-pg1-x535.google.com X-Spam_score_int: -20 X-Spam_score: -2.1 X-Spam_bar: -- X-Spam_report: (-2.1 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, FREEMAIL_FROM=0.001, RCVD_IN_DNSWL_NONE=-0.0001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001, T_SCC_BODY_TEXT_LINE=-0.01 autolearn=ham autolearn_force=no X-Spam_action: no action X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.devel:306099 Archived-At: 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)))))))