From adfcca38f76af3796fe8cc59684ed5e24987f24c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Nicol=C3=A1s=20B=C3=A9rtolo?= <nicolasbertolo@gmail.com>
Date: Tue, 19 May 2020 15:57:31 -0300
Subject: [PATCH] Improve handling of native compilation units still in use in
 Windows

When closing emacs will inspect all directories from which it loaded
native compilation units. If it finds a ".eln.old" file it will try to
delete it, if it fails that means that another Emacs instance is using it.

When compiling a file we rename the file that was in the output path
in case it has been loaded into another Emacs instance.

When deleting a package we move any ".eln" or ".eln.old" files in the
package folder that we can't delete to `package-user-dir`. Emacs will
check that directory when closing and delete them.

* lisp/emacs-lisp/comp.el (comp--replace-output-file): Function called
from C code to finish the compilation process. It performs renaming of
the old file if necessary.
* lisp/emacs-lisp/package.el (package--delete-directory): Function to
delete a package directory. It moves native compilation units that it
can't delete to `package-user-dir'.
* src/alloc.c (cleanup_vector): Call dispose_comp_unit().
  (garbage_collect): Call finish_delayed_disposal_of_comp_units().
* src/comp.c: Restore the signal mask using unwind-protect. Store
loaded native compilation units in a hash table for disposal on
close. Store filenames of native compilation units GC'd in a linked
list to finish their disposal when the GC is over.
* src/comp.h: Introduce cfile member in Lisp_Native_Comp_Unit.
Add declarations of functions that: clean directories of unused native
compilation units, handle disposal of native compilation units.
* src/emacs.c (kill-emacs): Dispose all remaining compilation units
right right before calling exit().
* src/eval.c (internal_condition_case_3, internal_condition_case_4):
Add functions.
* src/lisp.h (internal_condition_case_3, internal_condition_case_4):
Add functions.
* src/pdumper.c (dump_do_dump_relocation): Set cfile to a copy of the
Lisp string specifying the file path.
---
 lisp/emacs-lisp/comp.el    |  25 ++++++
 lisp/emacs-lisp/package.el |  27 +++++-
 src/alloc.c                |   5 +-
 src/comp.c                 | 174 ++++++++++++++++++++++++++++++++++---
 src/comp.h                 |  27 ++++++
 src/emacs.c                |   3 +
 src/eval.c                 |  55 ++++++++++++
 src/lisp.h                 |   2 +
 src/pdumper.c              |   3 +
 9 files changed, 308 insertions(+), 13 deletions(-)

diff --git a/lisp/emacs-lisp/comp.el b/lisp/emacs-lisp/comp.el
index 012baf2560..1fb4cd98c0 100644
--- a/lisp/emacs-lisp/comp.el
+++ b/lisp/emacs-lisp/comp.el
@@ -2183,6 +2183,31 @@ comp-hint-cons
 
 ;; Some entry point support code.
 
+(defun comp--replace-output-file (outfile tmpfile)
+  "Replace OUTFILE with TMPFILE taking the necessary steps when
+dealing with shared libraries that may be loaded into Emacs"
+  (cond ((eq 'windows-nt system-type)
+         (ignore-errors (delete-file outfile))
+         (let ((retry t))
+           (while retry
+             (setf retry nil)
+             (condition-case _
+                 (progn
+                   ;; outfile maybe recreated by another Emacs in
+                   ;; between the following two rename-file calls
+                   (if (file-exists-p outfile)
+                       (rename-file outfile (make-temp-file-internal
+                                             (file-name-sans-extension outfile)
+                                             nil ".eln.old" nil)
+                                    t))
+                   (rename-file tmpfile outfile nil))
+               (file-already-exists (setf retry t))))))
+        ;; Remove the old eln instead of copying the new one into it
+        ;; to get a new inode and prevent crashes in case the old one
+        ;; is currently loaded.
+        (t (delete-file outfile)
+           (rename-file tmpfile outfile))))
+
 (defvar comp-files-queue ()
   "List of Elisp files to be compiled.")
 
diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el
index 95659840ad..368057e955 100644
--- a/lisp/emacs-lisp/package.el
+++ b/lisp/emacs-lisp/package.el
@@ -2184,6 +2184,31 @@ package--newest-p
   (equal (cadr (assq (package-desc-name pkg) package-alist))
          pkg))
 
+(defun package--delete-directory (dir)
+  "Delete DIR recursively.
+In Windows move .eln and .eln.old files that can not be deleted to `package-user-dir'."
+  (cond ((eq 'windows-nt system-type)
+         (let ((retry t))
+           (while retry
+             (setf retry nil)
+             (condition-case err
+                 (delete-directory dir t)
+               (file-error
+                (if (and (string= "Removing old name" (cadr err))
+                         (string= "Permission denied" (caddr err))
+                         (or (string-suffix-p ".eln" (cadddr err))
+                             (string-suffix-p ".eln.old" (cadddr err))))
+                    (progn
+                      (rename-file (cadddr err)
+                                   (make-temp-file-internal
+                                    (concat package-user-dir
+                                            (file-name-base (cadddr err)))
+                                    nil ".eln.old" nil)
+                                   t)
+                      (setf retry t))
+                  (signal (car err) (cdr err))))))))
+        (t (delete-directory dir t)))
+
 (defun package-delete (pkg-desc &optional force nosave)
   "Delete package PKG-DESC.
 
@@ -2236,7 +2261,7 @@ package-delete
                   (package-desc-name pkg-used-elsewhere-by)))
           (t
            (add-hook 'post-command-hook #'package-menu--post-refresh)
-           (delete-directory dir t)
+           (package--delete-directory dir)
            ;; Remove NAME-VERSION.signed and NAME-readme.txt files.
            ;;
            ;; NAME-readme.txt files are no longer created, but they
diff --git a/src/alloc.c b/src/alloc.c
index f2b80fac88..17f5e15b35 100644
--- a/src/alloc.c
+++ b/src/alloc.c
@@ -3119,8 +3119,7 @@ cleanup_vector (struct Lisp_Vector *vector)
     {
       struct Lisp_Native_Comp_Unit *cu =
 	PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit);
-      eassert (cu->handle);
-      dynlib_close (cu->handle);
+      dispose_comp_unit (cu, true);
     }
 }
 
@@ -6119,6 +6118,8 @@ garbage_collect (void)
       if (tot_after < tot_before)
 	malloc_probe (min (tot_before - tot_after, SIZE_MAX));
     }
+
+  finish_delayed_disposal_of_comp_units ();
 }
 
 DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
diff --git a/src/comp.c b/src/comp.c
index b43d3eddb3..35e1ec0da3 100644
--- a/src/comp.c
+++ b/src/comp.c
@@ -413,6 +413,10 @@ #define THIRD(x)				\
 #define CALL1I(fun, arg)				\
   CALLN (Ffuncall, intern_c_string (STR (fun)), arg)
 
+/* Like call2 but stringify and intern.  */
+#define CALL2I(fun, arg1, arg2)				\
+  CALLN (Ffuncall, intern_c_string (STR (fun)), arg1, arg2)
+
 #define DECL_BLOCK(name, func)				\
   gcc_jit_block *(name) =				\
     gcc_jit_function_new_block ((func), STR (name))
@@ -3830,6 +3834,14 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, Scomp__release_ctxt,
   return Qt;
 }
 
+sigset_t oldset;
+
+static void restore_sigmask(void)
+{
+  pthread_sigmask (SIG_SETMASK, &oldset, 0);
+  unblock_input ();
+}
+
 DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
        Scomp__compile_ctxt_to_file,
        1, 1, 0,
@@ -3851,6 +3863,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
     CALL1I (comp-data-container-idx, CALL1I (comp-ctxt-d-ephemeral, Vcomp_ctxt));
 
   sigset_t oldset;
+  ptrdiff_t count;
+
   if (!noninteractive)
     {
       sigset_t blocked;
@@ -3863,6 +3877,8 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
       sigaddset (&blocked, SIGIO);
 #endif
       pthread_sigmask (SIG_BLOCK, &blocked, &oldset);
+      count = SPECPDL_INDEX ();
+      record_unwind_protect_void(restore_sigmask);
     }
   emit_ctxt_code ();
 
@@ -3902,18 +3918,10 @@ DEFUN ("comp--compile-ctxt-to-file", Fcomp__compile_ctxt_to_file,
 				   GCC_JIT_OUTPUT_KIND_DYNAMIC_LIBRARY,
 				   SSDATA (tmp_file));
 
-  /* Remove the old eln instead of copying the new one into it to get
-     a new inode and prevent crashes in case the old one is currently
-     loaded.  */
-  if (!NILP (Ffile_exists_p (out_file)))
-    Fdelete_file (out_file, Qnil);
-  Frename_file (tmp_file, out_file, Qnil);
+  CALL2I(comp--replace-output-file, out_file, tmp_file);
 
   if (!noninteractive)
-    {
-      pthread_sigmask (SIG_SETMASK, &oldset, 0);
-      unblock_input ();
-    }
+    unbind_to(count, Qnil);
 
   return out_file;
 }
@@ -3974,6 +3982,138 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum pvec_type code)
 			     code);
 }
 
+
+/*********************************/
+/* Disposal of compilation units */
+/*********************************/
+
+#ifdef WINDOWSNT
+#define OLD_ELN_SUFFIX_REGEXP build_string("\\.eln\\.old$")
+
+static Lisp_Object all_loaded_comp_units;
+
+struct delayed_comp_unit_disposal
+{
+  struct delayed_comp_unit_disposal * next;
+  char * filename;
+};
+
+struct delayed_comp_unit_disposal * delayed_comp_unit_disposal_list;
+
+static Lisp_Object
+returnQnil (Lisp_Object arg)
+{
+  return Qnil;
+}
+
+static void
+clean_comp_unit_directory (Lisp_Object filepath)
+{
+  if (NILP (filepath))
+    return;
+  Lisp_Object files_in_dir;
+  files_in_dir = internal_condition_case_4(Fdirectory_files, filepath, Qt,
+                                           OLD_ELN_SUFFIX_REGEXP, Qnil, Qt, returnQnil);
+  FOR_EACH_TAIL(files_in_dir)
+    {
+      DeleteFile (SSDATA (XCAR (files_in_dir)));
+    }
+}
+
+void clean_package_user_dir_of_old_comp_units (void)
+{
+  Lisp_Object package_user_dir = find_symbol_value (intern ("package-user-dir"));
+  if (EQ(package_user_dir, Qunbound) || !STRINGP(package_user_dir))
+    return;
+
+  clean_comp_unit_directory(package_user_dir);
+}
+
+#endif
+
+void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle, bool delay)
+{
+  eassert (comp_handle->handle);
+  dynlib_close (comp_handle->handle);
+#ifdef WINDOWSNT
+  if (!delay)
+    {
+      Lisp_Object dirname = internal_condition_case_1(Ffile_name_directory,
+                                                      build_string (comp_handle->cfile),
+                                                      Qt,
+                                                      returnQnil);
+      if (!NILP(dirname))
+        clean_comp_unit_directory (dirname);
+      xfree (comp_handle->cfile);
+      comp_handle->cfile = NULL;
+    }
+  else
+    {
+      struct delayed_comp_unit_disposal * head;
+      head = xmalloc (sizeof (struct delayed_comp_unit_disposal));
+      head->next = delayed_comp_unit_disposal_list;
+      head->filename = comp_handle->cfile;
+      comp_handle->cfile = NULL;
+      delayed_comp_unit_disposal_list = head;
+    }
+#else
+  xfree (comp_handle->file);
+#endif
+}
+
+static void
+register_native_comp_unit (Lisp_Object comp_u)
+{
+#ifdef WINDOWSNT
+  static EMACS_UINT count;
+
+  if (XFIXNUM(Fhash_table_count(all_loaded_comp_units)) >= MOST_POSITIVE_FIXNUM)
+    return;
+
+  while (!NILP(Fgethash(make_fixnum(count), all_loaded_comp_units, Qnil)))
+    count = (count + 1) % MOST_POSITIVE_FIXNUM;
+
+  Fputhash(make_fixnum(count), comp_u, all_loaded_comp_units);
+#endif
+}
+
+void dispose_all_remaining_comp_units (void)
+{
+#ifdef WINDOWSNT
+  struct Lisp_Hash_Table *h = XHASH_TABLE (all_loaded_comp_units);
+
+  for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i)
+    {
+      Lisp_Object k = HASH_KEY (h, i);
+      if (!EQ (k, Qunbound))
+        {
+          Lisp_Object val = HASH_VALUE (h, i);
+          struct Lisp_Native_Comp_Unit * cu = XNATIVE_COMP_UNIT(val);
+          dispose_comp_unit(cu, false);
+        }
+    }
+#endif
+}
+
+void finish_delayed_disposal_of_comp_units (void)
+{
+#ifdef WINDOWSNT
+  for (struct delayed_comp_unit_disposal * item = delayed_comp_unit_disposal_list;
+       delayed_comp_unit_disposal_list;
+       item = delayed_comp_unit_disposal_list)
+    {
+      delayed_comp_unit_disposal_list = item->next;
+      Lisp_Object dirname
+        = internal_condition_case_1 (Ffile_name_directory,
+                                     build_string (item->filename), Qt,
+                                     returnQnil);
+      clean_comp_unit_directory (dirname);
+      xfree(item->filename);
+      xfree(item);
+    }
+#endif
+}
+
 
 /***********************************/
 /* Deferred compilation mechanism. */
@@ -4160,6 +4300,12 @@ load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u, bool loading_dump,
       d_vec_len = XFIXNUM (Flength (comp_u->data_impure_vec));
       for (EMACS_INT i = 0; i < d_vec_len; i++)
 	data_imp_relocs[i] = AREF (comp_u->data_impure_vec, i);
+
+      /* If we register them while dumping we will get some entries in
+         the hash table that will be duplicated when pdumper calls
+         load_comp_unit. */
+      if (!will_dump_p())
+        register_native_comp_unit (comp_u_lisp_obj);
     }
 
   if (!loading_dump)
@@ -4273,6 +4419,9 @@ DEFUN ("native-elisp-load", Fnative_elisp_load, Snative_elisp_load, 1, 2, 0,
   if (!comp_u->handle)
     xsignal2 (Qnative_lisp_load_failed, file, build_string (dynlib_error ()));
   comp_u->file = file;
+#ifdef WINDOWSNT
+  comp_u->cfile = xlispstrdup(file);
+#endif
   comp_u->data_vec = Qnil;
   load_comp_unit (comp_u, false, !NILP (late_load));
 
@@ -4417,6 +4566,11 @@ syms_of_comp (void)
   staticpro (&delayed_sources);
   delayed_sources = Qnil;
 
+#ifdef WINDOWSNT
+  staticpro (&all_loaded_comp_units);
+  all_loaded_comp_units = CALLN(Fmake_hash_table, QCweakness, Qvalue);
+#endif
+
   DEFVAR_LISP ("comp-ctxt", Vcomp_ctxt,
 	       doc: /* The compiler context.  */);
   Vcomp_ctxt = Qnil;
diff --git a/src/comp.h b/src/comp.h
index e6ab32ff8e..89ef740fe6 100644
--- a/src/comp.h
+++ b/src/comp.h
@@ -44,7 +44,15 @@ #define COMP_H
   /* Same but for data that cannot be moved to pure space.
      Must be the last lisp object here.   */
   Lisp_Object data_impure_vec;
+
   dynlib_handle_ptr handle;
+#ifdef WINDOWSNT
+  /* We need to store a copy of the original file name in memory that
+     is not subject to GC because the function to dispose native
+     compilation units is called by the GC. By that time the `file'
+     string may have been sweeped. */
+  char * cfile;
+#endif
 };
 
 #ifdef HAVE_NATIVE_COMP
@@ -75,6 +83,14 @@ XNATIVE_COMP_UNIT (Lisp_Object a)
 
 extern void maybe_defer_native_compilation (Lisp_Object function_name,
 					    Lisp_Object definition);
+
+extern void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_unit, bool delay);
+
+extern void finish_delayed_disposal_of_comp_units (void);
+
+extern void dispose_all_remaining_comp_units (void);
+
+extern void clean_package_user_dir_of_old_comp_units (void);
 #else
 
 static inline void
@@ -84,6 +100,17 @@ maybe_defer_native_compilation (Lisp_Object function_name,
 
 extern void syms_of_comp (void);
 
+static inline void dispose_comp_unit (struct Lisp_Native_Comp_Unit * comp_handle)
+{
+  emacs_abort();
+}
+
+static inline void dispose_all_remaining_comp_units (void)
+{}
+
+static inline void clean_package_user_dir_of_old_comp_units (void)
+{}
+
 #endif
 
 #endif
diff --git a/src/emacs.c b/src/emacs.c
index e75cb58834..b7c89b44ec 100644
--- a/src/emacs.c
+++ b/src/emacs.c
@@ -2393,6 +2393,9 @@ DEFUN ("kill-emacs", Fkill_emacs, Skill_emacs, 0, 1, "P",
       unlink (SSDATA (listfile));
     }
 
+  dispose_all_remaining_comp_units();
+  clean_package_user_dir_of_old_comp_units();
+
   if (FIXNUMP (arg))
     exit_code = (XFIXNUM (arg) < 0
 		 ? XFIXNUM (arg) | INT_MIN
diff --git a/src/eval.c b/src/eval.c
index 1091b08255..a68fc90285 100644
--- a/src/eval.c
+++ b/src/eval.c
@@ -1419,6 +1419,61 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object),
     }
 }
 
+/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3 as
+   its arguments.  */
+
+Lisp_Object
+internal_condition_case_3 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
+                                                Lisp_Object),
+                           Lisp_Object arg1, Lisp_Object arg2, Lisp_Object arg3,
+                           Lisp_Object handlers,
+                           Lisp_Object (*hfun) (Lisp_Object))
+{
+  struct handler *c = push_handler (handlers, CONDITION_CASE);
+  if (sys_setjmp (c->jmp))
+    {
+      Lisp_Object val = handlerlist->val;
+      clobbered_eassert (handlerlist == c);
+      handlerlist = handlerlist->next;
+      return hfun (val);
+    }
+  else
+    {
+      Lisp_Object val = bfun (arg1, arg2, arg3);
+      eassert (handlerlist == c);
+      handlerlist = c->next;
+      return val;
+    }
+}
+
+/* Like internal_condition_case_1 but call BFUN with ARG1, ARG2, ARG3, ARG4 as
+   its arguments.  */
+
+Lisp_Object
+internal_condition_case_4 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
+                                                Lisp_Object, Lisp_Object),
+                           Lisp_Object arg1, Lisp_Object arg2,
+                           Lisp_Object arg3, Lisp_Object arg4,
+                           Lisp_Object handlers,
+                           Lisp_Object (*hfun) (Lisp_Object))
+{
+  struct handler *c = push_handler (handlers, CONDITION_CASE);
+  if (sys_setjmp (c->jmp))
+    {
+      Lisp_Object val = handlerlist->val;
+      clobbered_eassert (handlerlist == c);
+      handlerlist = handlerlist->next;
+      return hfun (val);
+    }
+  else
+    {
+      Lisp_Object val = bfun (arg1, arg2, arg3, arg4);
+      eassert (handlerlist == c);
+      handlerlist = c->next;
+      return val;
+    }
+}
+
 /* Like internal_condition_case but call BFUN with NARGS as first,
    and ARGS as second argument.  */
 
diff --git a/src/lisp.h b/src/lisp.h
index e242546d10..eeac20598c 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -4138,6 +4138,8 @@ xsignal (Lisp_Object error_symbol, Lisp_Object data)
 extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object));
 extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
 extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
+extern Lisp_Object internal_condition_case_3 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
+extern Lisp_Object internal_condition_case_4 (Lisp_Object (*) (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object));
 extern Lisp_Object internal_condition_case_n
     (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *,
      Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *));
diff --git a/src/pdumper.c b/src/pdumper.c
index f837dfc38d..9b0bd472d6 100644
--- a/src/pdumper.c
+++ b/src/pdumper.c
@@ -5312,6 +5312,9 @@ dump_do_dump_relocation (const uintptr_t dump_base,
 	  concat2 (Vinvocation_directory,
 		   installation_state == LOCAL_BUILD
 		   ? XCDR (comp_u->file) : XCAR (comp_u->file));
+#ifdef WINDOWSNT
+        comp_u->cfile = xlispstrdup(comp_u->file);
+#endif
 	comp_u->handle = dynlib_open (SSDATA (comp_u->file));
 	if (!comp_u->handle)
 	  error ("%s", dynlib_error ());
-- 
2.25.1.windows.1

