bug#41242: Port feature/native-comp to Windows - Improve handling of native compilation...

[Andrea Corallo]

Hi Nicolas,

following some comments on - Improve handling of native compilation
etc.

Please review all the GNU code-style of this diff.  I've annotated some
to be fixed but there are quite a number more of fixes of the same kind
to be done.

> 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.

Please annotate in the changelog the new functions ex:
finish_delayed_disposal_of_comp_units, dispose_all_remaining_comp_units,
register_native_comp_unit are missing.

> * 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.

> 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)

Isn't better to just add .old? So we will have cases of foo.eln.old.old
instead of foo.eln.old.eln.old ?

> +                                    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..c1c54b3c9a 100644
> --- a/lisp/emacs-lisp/package.el
> +++ b/lisp/emacs-lisp/package.el
> @@ -2184,6 +2184,31 @@ If some packages are not installed propose to install 
> them."
>    (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'."

80 column lines limit.  I think also this should be transparent when
native-comp-available-p say native comp is not available (for now
compiler and load machinery are bundled).

> +  (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))))

I think would be good to destructure err using something like
cl-destructuring-bind or pcase or even just using a let + some naming to
make this more readable.

> +                    (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 @@ If NOSAVE is non-nil, the package is not removed from
>                    (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 d6ba4d9790..420168ec4d 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);
>      }
>  }
>
> @@ -6117,6 +6116,8 @@ garbage_collect (void)
>        if (tot_after < tot_before)
>       malloc_probe (min (tot_before - tot_after, SIZE_MAX));
>      }
> +
> +  finish_delayed_disposal_of_comp_units ();

Could you describe why we need to call this each garbage collection?
Isn't sufficient to do it when emacs is exiting?

>  }
>
>  DEFUN ("garbage-collect", Fgarbage_collect, Sgarbage_collect, 0, 0, "",
> diff --git a/src/comp.c b/src/comp.c
> index dd45599cc4..77c3006c56 100644
> --- a/src/comp.c
> +++ b/src/comp.c
> @@ -413,6 +413,10 @@ load_gccjit_if_necessary (bool mandatory)
>  #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))
> @@ -3828,6 +3832,14 @@ DEFUN ("comp--release-ctxt", Fcomp__release_ctxt, 
> Scomp__release_ctxt,
>    return Qt;
>  }
>
> +sigset_t oldset;

I think we have all static data at the top.

That said this is unclear to me because in comp--compile-ctxt-to-file
oldset is automatic and shadows this static, so I think we'll save in
the the automatic and later we just restore the (always zeroed) static
one.

> +static void restore_sigmask(void)
                             ^^^
                             space
> +{
> +  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,
> @@ -3849,6 +3861,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;
> @@ -3861,6 +3875,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);
                                  ^^^
                                  space

>      }
>    emit_ctxt_code ();
>
> @@ -3899,18 +3915,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);
          ^^^
          space
>
>    if (!noninteractive)
> -    {
> -      pthread_sigmask (SIG_SETMASK, &oldset, 0);
> -      unblock_input ();
> -    }
> +    unbind_to(count, Qnil);
>
>    return out_file;
>  }
> @@ -3972,6 +3980,138 @@ helper_PSEUDOVECTOR_TYPEP_XUNTAG (Lisp_Object a, enum 
> pvec_type code)
>  }
>
>  
> +/*********************************/
> +/* Disposal of compilation units */
> +/*********************************/
> +
> +#ifdef WINDOWSNT
> +#define OLD_ELN_SUFFIX_REGEXP build_string("\\.eln\\.old$")

I think instead of $  \\' is more correct.

> +static Lisp_Object all_loaded_comp_units;

All hash table in this files are postfixed as _h

> +struct delayed_comp_unit_disposal
> +{
> +  struct delayed_comp_unit_disposal * next;
                                       ^^^
                                     no space here
> +  char * filename;
          ^^
          likewise
> +};

Why an ad-hoc C structure and not a simple cons?  I think it would be
simpler and safer to use just a lisp list here.  Is it because we need
to add during GC?  If yes, comment :)

> +struct delayed_comp_unit_disposal * delayed_comp_unit_disposal_list;
                                     ^^
                                     likewise and the followings
> +
> +static Lisp_Object
> +returnQnil (Lisp_Object arg)

No camel case in function names.

> +{
> +  return Qnil;
> +}

I think each of the following functions really needs a comment line to
explain the scope of each of them + one preamble comment to explain all
the rename mechanism how is expected to work and the two datastructures
involved.

> +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);

80 columns

> +  FOR_EACH_TAIL(files_in_dir)
> +    {
> +      DeleteFile (SSDATA (XCAR (files_in_dir)));
> +    }
> +}
> +
> +void clean_package_user_dir_of_old_comp_units (void)
      ^^^
      new lines
> +{
> +  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)
      ^^^
      likewise
> +{
> +  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);

I think we need to comment here why when we dispose the compilation unit
we try to clean the full directory.

> +      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
> +}

Also, wasn't the plan to try to delete the file and in case of failure
to put it in a list?  Here when delay is true this goes directly in the
list.  Could you explain why and add comment?

> +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;

Given you are doing all of this just to get a key (we'll not use) I
think would be wise to just create the key using gensym.

> +  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. */
>  /***********************************/
> @@ -4192,6 +4332,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)
> @@ -4349,6 +4495,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;
>    comp_u->lambda_gc_guard = CALLN (Fmake_hash_table, QCtest, Qeq);
>    comp_u->lambda_c_name_idx_h = CALLN (Fmake_hash_table, QCtest, Qequal);
> @@ -4497,6 +4646,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 36e7cdf441..0b790fc7cb 100644
> --- a/src/comp.h
> +++ b/src/comp.h
> @@ -52,7 +52,15 @@ struct Lisp_Native_Comp_Unit
>    /* STUFFS WE DO NOT DUMP!!  */
>    Lisp_Object *data_imp_relocs;
>    bool loaded_once;
> +
>    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
> @@ -83,6 +91,14 @@ extern void syms_of_comp (void);
>
>  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
> @@ -92,6 +108,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)

Newline after ret type for this and the following definitions.

> +{
> +  emacs_abort();
> +}

emacs_abort is still not declared here so it does not compile.  Maybe we
can just put an eassert (false).

> +static inline void dispose_all_remaining_comp_units (void)
> +{}
> +
> +static inline void clean_package_user_dir_of_old_comp_units (void)
> +{}
> +


Thanks

  Andrea

--
akrl@sdf.org