master d0c4765: Faster, more compact, and readable closure creation

[Mattias Engdegård]

branch: master
commit d0c47652e527397cae96444c881bf60455c763c1
Author: Mattias Engdegård <mattiase@acm.org>
Commit: Mattias Engdegård <mattiase@acm.org>

    Faster, more compact, and readable closure creation
    
    Simplify closure creation by calling a single function at run time
    instead of putting it together from small pieces.  This is faster
    (by about a factor 2), takes less space on disk and in memory, and
    makes internal functions somewhat readable in disassembly listings again.
    
    This is done by creating a prototype function at compile-time whose
    closure variables are placeholder values V0, V1... which can be seen
    in the disassembly.  The prototype is then cloned at run time using
    the new make-closure function that replaces the placeholders with
    the actual closure variables.
    
    * lisp/emacs-lisp/bytecomp.el (byte-compile-make-closure):
    Generate call to make-closure from a prototype function.
    * src/alloc.c (Fmake_closure): New function.
    (syms_of_alloc): Defsubr it.
    * src/data.c (syms_of_data): Defsym byte-code-function-p.
---
 lisp/emacs-lisp/bytecomp.el | 24 +++++++++++++++---------
 src/alloc.c                 | 33 +++++++++++++++++++++++++++++++++
 src/data.c                  |  2 ++
 3 files changed, 50 insertions(+), 9 deletions(-)

diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el
index 1b0906b..69a63b1 100644
--- a/lisp/emacs-lisp/bytecomp.el
+++ b/lisp/emacs-lisp/bytecomp.el
@@ -3817,15 +3817,21 @@ discarding."
       (cl-assert (or (> (length env) 0)
                     docstring-exp))    ;Otherwise, we don't need a closure.
       (cl-assert (byte-code-function-p fun))
-      (byte-compile-form `(make-byte-code
-                           ',(aref fun 0) ',(aref fun 1)
-                           (vconcat (vector . ,env) ',(aref fun 2))
-                           ,@(let ((rest (nthcdr 3 (mapcar (lambda (x) `',x) 
fun))))
-                               (if docstring-exp
-                                   `(,(car rest)
-                                     ,docstring-exp
-                                     ,@(cddr rest))
-                                 rest)))))))
+      (byte-compile-form
+       ;; Use symbols V0, V1 ... as placeholders for closure variables:
+       ;; they should be short (to save space in the .elc file), yet
+       ;; distinct when disassembled.
+       (let* ((dummy-vars (mapcar (lambda (i) (intern (format "V%d" i)))
+                                  (number-sequence 0 (1- (length env)))))
+              (proto-fun
+               (apply #'make-byte-code
+                      (aref fun 0) (aref fun 1)
+                      ;; Prepend dummy cells to the constant vector,
+                      ;; to get the indices right when disassembling.
+                      (vconcat dummy-vars (aref fun 2))
+                      (mapcar (lambda (i) (aref fun i))
+                              (number-sequence 3 (1- (length fun)))))))
+         `(make-closure ,proto-fun ,@env))))))
 
 (defun byte-compile-get-closed-var (form)
   "Byte-compile the special `internal-get-closed-var' form."
diff --git a/src/alloc.c b/src/alloc.c
index b86ed4e..e72fc4c 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3498,6 +3498,38 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH 
&optional DOCSTRING INT
   return val;
 }
 
+DEFUN ("make-closure", Fmake_closure, Smake_closure, 1, MANY, 0,
+       doc: /* Create a byte-code closure from PROTOTYPE and CLOSURE-VARS.
+Return a copy of PROTOTYPE, a byte-code object, with CLOSURE-VARS
+replacing the elements in the beginning of the constant-vector.
+usage: (make-closure PROTOTYPE &rest CLOSURE-VARS) */)
+  (ptrdiff_t nargs, Lisp_Object *args)
+{
+  Lisp_Object protofun = args[0];
+  CHECK_TYPE (COMPILEDP (protofun), Qbyte_code_function_p, protofun);
+
+  /* Create a copy of the constant vector, filling it with the closure
+     variables in the beginning.  (The overwritten part should just
+     contain placeholder values.) */
+  Lisp_Object proto_constvec = AREF (protofun, COMPILED_CONSTANTS);
+  ptrdiff_t constsize = ASIZE (proto_constvec);
+  ptrdiff_t nvars = nargs - 1;
+  if (nvars > constsize)
+    error ("Closure vars do not fit in constvec");
+  Lisp_Object constvec = make_uninit_vector (constsize);
+  memcpy (XVECTOR (constvec)->contents, args + 1, nvars * word_size);
+  memcpy (XVECTOR (constvec)->contents + nvars,
+         XVECTOR (proto_constvec)->contents + nvars,
+         (constsize - nvars) * word_size);
+
+  /* Return a copy of the prototype function with the new constant vector. */
+  ptrdiff_t protosize = PVSIZE (protofun);
+  struct Lisp_Vector *v = allocate_vectorlike (protosize, false);
+  v->header = XVECTOR (protofun)->header;
+  memcpy (v->contents, XVECTOR (protofun)->contents, protosize * word_size);
+  v->contents[COMPILED_CONSTANTS] = constvec;
+  return make_lisp_ptr (v, Lisp_Vectorlike);
+}
 
 
 /***********************************************************************
@@ -7573,6 +7605,7 @@ N should be nonnegative.  */);
   defsubr (&Srecord);
   defsubr (&Sbool_vector);
   defsubr (&Smake_byte_code);
+  defsubr (&Smake_closure);
   defsubr (&Smake_list);
   defsubr (&Smake_vector);
   defsubr (&Smake_record);
diff --git a/src/data.c b/src/data.c
index 9af9131..0fa491b 100644
--- a/src/data.c
+++ b/src/data.c
@@ -3989,6 +3989,8 @@ syms_of_data (void)
   DEFSYM (Qinteractive_form, "interactive-form");
   DEFSYM (Qdefalias_fset_function, "defalias-fset-function");
 
+  DEFSYM (Qbyte_code_function_p, "byte-code-function-p");
+
   defsubr (&Sindirect_variable);
   defsubr (&Sinteractive_form);
   defsubr (&Scommand_modes);