procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'feature/native-comp' into into trunk

Browse source
This commit is contained in:
Andrea Corallo 2021-04-25 20:06:22 +02:00
commit 289000eee7
77 changed files with 15419 additions and 255 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.gitignore vendored
View file

@ -135,6 +135,7 @@ src/gl-stamp
*.dll
*.core
*.elc
*.eln
*.o
*.res
*.so

31
Makefile.in
View file

@ -96,6 +96,8 @@ NTDIR=@NTDIR@
top_builddir = @top_builddir@
-include ${top_builddir}/src/verbose.mk
HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
# ==================== Where To Install Things ====================
# Location to install Emacs.app under GNUstep / macOS.
@ -206,6 +208,10 @@ iconsrcdir=$(srcdir)/etc/images/icons
# These variables hold the values Emacs will actually use. They are
# based on the values of the standard Make variables above.
# Where lisp files are installed in a distributed with Emacs (relative
# path to the installation directory).
lispdirrel=@lispdirrel@
# Where to install the lisp files distributed with Emacs.
# This includes the Emacs version, so that the lisp files for different
# versions of Emacs will install themselves in separate directories.
@ -315,6 +321,14 @@ CONFIG_STATUS_FILES_IN = \
COPYDIR = ${srcdir}/etc ${srcdir}/lisp
COPYDESTS = "$(DESTDIR)${etcdir}" "$(DESTDIR)${lispdir}"
ifeq (${ns_self_contained},no)
BIN_DESTDIR='$(DESTDIR)${bindir}/'
ELN_DESTDIR = $(DESTDIR)${libdir}/emacs/${version}/
else
BIN_DESTDIR='${ns_appbindir}/'
ELN_DESTDIR = ${ns_appresdir}/
endif
all: ${SUBDIR} info
.PHONY: all ${SUBDIR} blessmail epaths-force epaths-force-w32 etc-emacsver
@ -349,6 +363,7 @@ epaths-force:
@(gamedir='${gamedir}'; \
sed < ${srcdir}/src/epaths.in > epaths.h.$$$$ \
-e 's;\(#.*PATH_LOADSEARCH\).*$$;\1 "${standardlisppath}";' \
-e 's;\(#.*PATH_REL_LOADSEARCH\).*$$;\1 "${lispdirrel}";' \
-e 's;\(#.*PATH_SITELOADSEARCH\).*$$;\1 "${locallisppath}";' \
-e 's;\(#.*PATH_DUMPLOADSEARCH\).*$$;\1 "${buildlisppath}";' \
-e '/^#define PATH_[^ ]*SEARCH /s/\([":]\):*/\1/g' \
@ -379,6 +394,7 @@ epaths-force-w32:
w32locallisppath=$${w32locallisppath//$${w32prefix}/"%emacs_dir%"} ; \
sed < ${srcdir}/nt/epaths.nt > epaths.h.$$$$ \
-e 's;\(#.*PATH_SITELOADSEARCH\).*$$;\1 "'"$${w32locallisppath//;/\\;}"'";' \
-e 's;\(#.*PATH_REL_LOADSEARCH\).*$$;\1 "${lispdirrel}";' \
-e '/^.*#/s/@VER@/${version}/g' \
-e '/^.*#/s/@CFG@/${configuration}/g' \
-e "/^.*#/s|@SRC@|$${w32srcdir}|g") && \
@ -406,7 +422,8 @@ lib lib-src lisp nt: Makefile
dirstate = .git/logs/HEAD
VCSWITNESS = $(if $(wildcard $(srcdir)/$(dirstate)),$$(srcdir)/../$(dirstate))
src: Makefile
$(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' all
$(MAKE) -C $@ VCSWITNESS='$(VCSWITNESS)' BIN_DESTDIR='$(BIN_DESTDIR)' \
ELN_DESTDIR='$(ELN_DESTDIR)' all
blessmail: Makefile src
$(MAKE) -C lib-src maybe-blessmail
@ -446,14 +463,14 @@ $(srcdir)/configure: $(srcdir)/configure.ac $(srcdir)/m4/*.m4
# ==================== Installation ====================
.PHONY: install install-arch-dep install-arch-indep install-etcdoc install-info
.PHONY: install-man install-etc install-strip install-$(NTDIR)
.PHONY: install-man install-etc install-strip install-$(NTDIR) install-eln
.PHONY: uninstall uninstall-$(NTDIR)
## If we let lib-src do its own installation, that means we
## don't have to duplicate the list of utilities to install in
## this Makefile as well.
install: all install-arch-indep install-etcdoc install-arch-dep install-$(NTDIR) blessmail
install: all install-arch-indep install-etcdoc install-arch-dep install-$(NTDIR) blessmail install-eln
@true
## Ensure that $subdir contains a subdirs.el file.
@ -733,6 +750,13 @@ install-etc:
done ; \
done
### Install native compiled Lisp files.
install-eln:
ifeq ($(HAVE_NATIVE_COMP),yes)
find native-lisp -type d -exec $(MKDIR_P) "$(ELN_DESTDIR){}" \; ; \
find native-lisp -type f -exec ${INSTALL_DATA} "{}" "$(ELN_DESTDIR){}" \;
endif
### Build Emacs and install it, stripping binaries while installing them.
install-strip:
$(MAKE) INSTALL_STRIP=-s install
@ -842,6 +866,7 @@ clean: $(clean_dirs:=_clean)
[ ! -d test ] || $(MAKE) -C test $@
-rm -f ./*.tmp etc/*.tmp*
-rm -rf info-dir.*
-rm -rf native-lisp
### 'bootclean'
### Delete all files that need to be remade for a clean bootstrap.

7
admin/MAINTAINERS
View file

@ -131,6 +131,13 @@ Amin Bandali
lisp/erc/*
doc/misc/erc.texi
Andrea Corallo
Lisp native compiler
src/comp.c
lisp/emacs-lisp/comp.el
lisp/emacs-lisp/comp-cstr.el
test/src/comp-*.el
==============================================================================
2. Areas that someone is willing to maintain, although he would not
necessarily mind if someone else was the official maintainer.

133
configure.ac
View file

@ -187,7 +187,8 @@ dnl It is important that variables on the RHS not be expanded here,
dnl hence the single quotes. This is per the GNU coding standards, see
dnl (autoconf) Installation Directory Variables
dnl See also epaths.h below.
lispdir='${datadir}/emacs/${version}/lisp'
lispdirrel='${version}/lisp'
lispdir='${datadir}/emacs/'${lispdirrel}
standardlisppath='${lispdir}'
locallisppath='${datadir}/emacs/${version}/site-lisp:'\
'${datadir}/emacs/site-lisp'
@ -483,6 +484,7 @@ OPTION_DEFAULT_ON([gnutls],[don't use -lgnutls for SSL/TLS support])
OPTION_DEFAULT_ON([zlib],[don't compile with zlib decompression support])
OPTION_DEFAULT_ON([modules],[don't compile with dynamic modules support])
OPTION_DEFAULT_ON([threads],[don't compile with elisp threading support])
OPTION_DEFAULT_OFF([native-compilation],[compile with Emacs Lisp native compiler support])
AC_ARG_WITH([file-notification],[AS_HELP_STRING([--with-file-notification=LIB],
[use a file notification library (LIB one of: yes, inotify, kqueue, gfile, w32, no)])],
@ -1889,6 +1891,7 @@ if test "${with_ns}" != no; then
# so avoid NS_IMPL_COCOA if macuvs.h is absent.
# Even a headless Emacs can build macuvs.h, so this should let you bootstrap.
if test "${opsys}" = darwin && test -f "$srcdir/src/macuvs.h"; then
lispdirrel=Contents/Resources/lisp
NS_IMPL_COCOA=yes
ns_appdir=`pwd`/nextstep/Emacs.app
ns_appbindir=${ns_appdir}/Contents/MacOS
@ -3660,6 +3663,7 @@ AC_SUBST(LIBZ)
LIBMODULES=
HAVE_MODULES=no
MODULES_OBJ=
NEED_DYNLIB=no
case $opsys in
cygwin|mingw32) MODULES_SUFFIX=".dll" ;;
darwin) MODULES_SUFFIX=".dylib" ;;
@ -3695,7 +3699,8 @@ if test "${with_modules}" != "no"; then
fi
if test "${HAVE_MODULES}" = yes; then
MODULES_OBJ="dynlib.o emacs-module.o"
MODULES_OBJ="emacs-module.o"
NEED_DYNLIB=yes
AC_DEFINE(HAVE_MODULES, 1, [Define to 1 if dynamic modules are enabled])
AC_DEFINE_UNQUOTED(MODULES_SUFFIX, "$MODULES_SUFFIX",
[System extension for dynamic libraries])
@ -3722,6 +3727,124 @@ module_env_snippet_28="$srcdir/src/module-env-28.h"
emacs_major_version="${PACKAGE_VERSION%%.*}"
AC_SUBST(emacs_major_version)
### Emacs Lisp native compiler support
AC_DEFUN([libgccjit_smoke_test], [
AC_LANG_SOURCE(
[[#include <libgccjit.h>
#include <stdlib.h>
#include <stdio.h>
int
main (int argc, char **argv)
{
gcc_jit_context *ctxt;
gcc_jit_result *result;
ctxt = gcc_jit_context_acquire ();
if (!ctxt)
exit (1);
gcc_jit_type *int_type =
gcc_jit_context_get_type (ctxt, GCC_JIT_TYPE_INT);
gcc_jit_function *func =
gcc_jit_context_new_function (ctxt, NULL,
GCC_JIT_FUNCTION_EXPORTED,
int_type, "foo", 0, NULL, 0);
gcc_jit_block *block = gcc_jit_function_new_block (func, "foo");
gcc_jit_block_end_with_return (
block,
NULL,
gcc_jit_context_new_rvalue_from_int (ctxt, int_type, 1));
result = gcc_jit_context_compile (ctxt);
if (!result)
exit (1);
typedef int (*fn_type) (void);
fn_type foo =
(fn_type)gcc_jit_result_get_code (result, "foo");
if (!foo)
exit (1);
if (foo () != 1)
exit (1);
gcc_jit_context_release (ctxt);
gcc_jit_result_release (result);
return 0;
}]])])
AC_DEFUN([libgccjit_not_found], [
AC_MSG_ERROR([elisp native compiler requested but libgccjit not found.
Please try installing libgccjit or similar package.
If you are sure you want Emacs compiled without elisp native compiler, pass
--without-native-compilation
to configure.])])
AC_DEFUN([libgccjit_dev_not_found], [
AC_MSG_ERROR([elisp native compiler requested but libgccjit header files were
not found.
Please try installing libgccjit-dev or similar package.
If you are sure you want Emacs compiled without elisp native compiler, pass
--without-nativecomp
to configure.])])
AC_DEFUN([libgccjit_broken], [
AC_MSG_ERROR([Installed libgccjit has failed passing the smoke test.
You can verify it yourself compiling:
<https://gcc.gnu.org/onlinedocs/jit/intro/tutorial01.html>.
Please report the issue to your distribution if libgccjit was installed through
that.
Here instructions on how to compile and install libgccjit from source:
<https://gcc.gnu.org/wiki/JIT>.])])
HAVE_NATIVE_COMP=no
LIBGCCJIT_LIB=
if test "${with_native_compilation}" != "no"; then
if test "${HAVE_PDUMPER}" = no; then
AC_MSG_ERROR(['--with-nativecomp' requires '--with-dumping=pdumper'])
fi
if test "${HAVE_ZLIB}" = no; then
AC_MSG_ERROR(['--with-nativecomp' requires zlib])
fi
# Ensure libgccjit installed by Homebrew can be found.
if test -n "$BREW"; then
BREW_LIBGCCJIT_PREFIX=`$BREW --prefix --installed libgccjit 2>/dev/null`
if test "$BREW_LIBGCCJIT_PREFIX"; then
brew_libdir=`find ${BREW_LIBGCCJIT_PREFIX}/ -name \*.so \
| sed -e '1!d;s|/[[^/]]*\.so$||'`
CFLAGS="$CFLAGS -I${BREW_LIBGCCJIT_PREFIX}/include"
LDFLAGS="$LDFLAGS -L${brew_libdir} -I${BREW_LIBGCCJIT_PREFIX}/include"
fi
fi
# Check if libgccjit is available.
AC_CHECK_LIB(gccjit, gcc_jit_context_acquire, [], [libgccjit_not_found])
AC_CHECK_HEADERS(libgccjit.h, [], [libgccjit_dev_not_found])
emacs_save_LIBS=$LIBS
LIBS="-lgccjit"
# Check if libgccjit really works.
AC_RUN_IFELSE([libgccjit_smoke_test], [], [libgccjit_broken])
LIBS=$emacs_save_LIBS
HAVE_NATIVE_COMP=yes
case "${opsys}" in
# mingw32 loads the library dynamically.
mingw32) ;;
# OpenBSD doesn't have libdl, all the functions are in libc
netbsd|openbsd)
LIBGCCJIT_LIB="-lgccjit" ;;
*)
LIBGCCJIT_LIB="-lgccjit -ldl" ;;
esac
NEED_DYNLIB=yes
AC_DEFINE(HAVE_NATIVE_COMP, 1, [Define to 1 if native compiler is available.])
fi
AC_DEFINE_UNQUOTED(NATIVE_ELISP_SUFFIX, ".eln",
[System extension for native compiled elisp])
AC_SUBST(HAVE_NATIVE_COMP)
AC_SUBST(LIBGCCJIT_LIB)
DYNLIB_OBJ=
if test "${NEED_DYNLIB}" = yes; then
DYNLIB_OBJ="dynlib.o"
fi
AC_SUBST(DYNLIB_OBJ)
### Use -lpng if available, unless '--with-png=no'.
HAVE_PNG=no
LIBPNG=
@ -5258,6 +5381,7 @@ AC_SUBST(sharedstatedir)
AC_SUBST(libexecdir)
AC_SUBST(mandir)
AC_SUBST(infodir)
AC_SUBST(lispdirrel)
AC_SUBST(lispdir)
AC_SUBST(standardlisppath)
AC_SUBST(locallisppath)
@ -5701,8 +5825,8 @@ optsep=
emacs_config_features=
for opt in ACL CAIRO DBUS FREETYPE GCONF GIF GLIB GMP GNUTLS GPM GSETTINGS \
HARFBUZZ IMAGEMAGICK JPEG JSON LCMS2 LIBOTF LIBSELINUX LIBSYSTEMD LIBXML2 \
M17N_FLT MODULES NOTIFY NS OLDXMENU PDUMPER PNG RSVG SECCOMP SOUND \
THREADS TIFF \
M17N_FLT MODULES NATIVE_COMP NOTIFY NS OLDXMENU PDUMPER PNG RSVG SECCOMP \
SOUND THREADS TIFF \
TOOLKIT_SCROLL_BARS UNEXEC X11 XAW3D XDBE XFT XIM XPM XWIDGETS X_TOOLKIT \
ZLIB; do
@ -5778,6 +5902,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D
Does Emacs support the portable dumper? ${with_pdumper}
Does Emacs support legacy unexec dumping? ${with_unexec}
Which dumping strategy does Emacs use? ${with_dumping}
Does Emacs have native lisp compiler? ${HAVE_NATIVE_COMP}
"])
if test -n "${EMACSDATA}"; then

18
etc/NEWS
View file

@ -24,6 +24,11 @@ applies, and please also update docstrings as needed.
* Installation Changes in Emacs 28.1
** Emacs now optionally supports native compilation of Lisp files.
To enable, configure Emacs with the '--with-native-compilation' option
to the 'configure' script. This requires to have the libgccjit
library to be installed and functional.
---
** Support for building with Motif has been removed.
@ -1282,6 +1287,14 @@ key binding
/ u package-menu-filter-upgradable
/ / package-menu-filter-clear
*** Option to automatically native-compile packages upon installation.
Customize the user option 'package-native-compile' to enable automatic
native compilation of packages when they are installed. That option
is nil by default; if set non-nil, and if your Emacs was built with
native-compilation support, each package will be natively compiled
when it is installed, by invoking an asynchronous Emacs subprocess to
run the native-compilation of the package files.
---
*** Column widths in 'list-packages' display can now be customized.
See the new user options 'package-name-column-width',
@ -2634,6 +2647,11 @@ the Emacs Lisp reference manual for background.
* Lisp Changes in Emacs 28.1
+++
** New function 'sxhash-equal-including-properties'.
This is identical to 'sxhash-equal' but accounting also for string
properties.
+++
** 'unlock-buffer' displays warnings instead of signaling.
Instead of signaling 'file-error' conditions for file system level

7
etc/TODO
View file

@ -500,6 +500,13 @@ access in cases which need more than Lisp.
** Fix portable dumping so that you can redump without using -batch
*** Redumps and native compiler "preloaded" sub-folder.
In order to depose new .eln files being compiled into the "preloaded"
sub-folder the native compiler needs to know in advance if this file
will be preloaded or not. As .eln files are not moved afterwards
subsequent redumps might refer to .eln file out of the "preloaded"
sub-folder.
** Imenu could be extended into a file-structure browsing mechanism
This could use code like that of customize-groups.

6
lib/Makefile.in
View file

@ -31,12 +31,18 @@ all:
-include ${top_builddir}/src/verbose.mk
HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
ALL_CFLAGS= \
$(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) $(DEPFLAGS) \
$(GNULIB_WARN_CFLAGS) $(WERROR_CFLAGS) $(PROFILING_CFLAGS) $(CFLAGS) \
-I. -I../src -I$(srcdir) -I$(srcdir)/../src \
$(if $(patsubst e-%,,$(notdir $<)),,-Demacs)
ifeq ($(HAVE_NATIVE_COMP),yes)
ALL_CFLAGS += -DGL_COMPILE_CRYPTO_STREAM
endif
SYSTEM_TYPE = @SYSTEM_TYPE@
ifeq ($(SYSTEM_TYPE),windows-nt)
include $(srcdir)/../nt/gnulib-cfg.mk

115
lib/af_alg.h Normal file
View file

@ -0,0 +1,115 @@
/* af_alg.h - Compute message digests from file streams and buffers.
Copyright (C) 2018-2020 Free Software Foundation, Inc.
This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 2, or (at your option) any
later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, see <https://www.gnu.org/licenses/>. */
/* Written by Matteo Croce <mcroce@redhat.com>, 2018.
Documentation by Bruno Haible <bruno@clisp.org>, 2018. */
/* Declare specific functions for computing message digests
using the Linux kernel crypto API, if available. This kernel API gives
access to specialized crypto instructions (that would also be available
in user space) or to crypto devices (not directly available in user space).
For a more complete set of facilities that use the Linux kernel crypto API,
look at libkcapi. */
#ifndef AF_ALG_H
# define AF_ALG_H 1
# include <stdio.h>
# include <errno.h>
# ifdef __cplusplus
extern "C" {
# endif
# if USE_LINUX_CRYPTO_API
/* Compute a message digest of a memory region.
The memory region starts at BUFFER and is LEN bytes long.
ALG is the message digest algorithm; see the file /proc/crypto.
RESBLOCK points to a block of HASHLEN bytes, for the result.
HASHLEN must be the length of the message digest, in bytes, in particular:
alg | hashlen
-------+--------
md5 | 16
sha1 | 20
sha224 | 28
sha256 | 32
sha384 | 48
sha512 | 64
If successful, fill RESBLOCK and return 0.
Upon failure, return a negated error number. */
int
afalg_buffer (const char *buffer, size_t len, const char *alg,
void *resblock, ssize_t hashlen);
/* Compute a message digest of data read from STREAM.
STREAM is an open file stream. The last operation on STREAM should
not be 'ungetc', and if STREAM is also open for writing it should
have been fflushed since its last write. Read from the current
position to the end of STREAM. Handle regular files efficiently.
ALG is the message digest algorithm; see the file /proc/crypto.
RESBLOCK points to a block of HASHLEN bytes, for the result.
HASHLEN must be the length of the message digest, in bytes, in particular:
alg | hashlen
-------+--------
md5 | 16
sha1 | 20
sha224 | 28
sha256 | 32
sha384 | 48
sha512 | 64
If successful, fill RESBLOCK and return 0.
Upon failure, return a negated error number.
Unless returning 0 or -EIO, restore STREAM's file position so that
the caller can fall back on some other method. */
int
afalg_stream (FILE *stream, const char *alg,
void *resblock, ssize_t hashlen);
# else
static inline int
afalg_buffer (const char *buffer, size_t len, const char *alg,
void *resblock, ssize_t hashlen)
{
return -EAFNOSUPPORT;
}
static inline int
afalg_stream (FILE *stream, const char *alg,
void *resblock, ssize_t hashlen)
{
return -EAFNOSUPPORT;
}
# endif
# ifdef __cplusplus
}
# endif
#endif /* AF_ALG_H */

41
lisp/Makefile.in
View file

@ -30,6 +30,13 @@ EXEEXT = @EXEEXT@
# limitation.
XARGS_LIMIT = @XARGS_LIMIT@
HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
ifeq ($(HAVE_NATIVE_COMP),yes)
ifndef NATIVE_FULL_AOT
NATIVE_SKIP_NONDUMP = 1
endif
endif
-include ${top_builddir}/src/verbose.mk
FIND_DELETE = @FIND_DELETE@
@ -82,8 +89,12 @@ COMPILE_FIRST = \
$(lisp)/emacs-lisp/macroexp.elc \
$(lisp)/emacs-lisp/cconv.elc \
$(lisp)/emacs-lisp/byte-opt.elc \
$(lisp)/emacs-lisp/bytecomp.elc \
$(lisp)/emacs-lisp/autoload.elc
$(lisp)/emacs-lisp/bytecomp.elc
ifeq ($(HAVE_NATIVE_COMP),yes)
COMPILE_FIRST += $(lisp)/emacs-lisp/comp.elc
COMPILE_FIRST += $(lisp)/emacs-lisp/comp-cstr.elc
endif
COMPILE_FIRST += $(lisp)/emacs-lisp/autoload.elc
# Files to compile early in compile-main. Works around bug#25556.
MAIN_FIRST = ./emacs-lisp/eieio.el ./emacs-lisp/eieio-base.el \
@ -260,9 +271,15 @@ TAGS: ${ETAGS} ${tagsfiles}
THEFILE = no-such-file
.PHONY: $(THEFILE)c
$(THEFILE)c:
ifeq ($(HAVE_NATIVE_COMP),yes)
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l comp -f byte-compile-refresh-preloaded \
-f batch-byte-native-compile-for-bootstrap $(THEFILE)
else
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l bytecomp -f byte-compile-refresh-preloaded \
-f batch-byte-compile $(THEFILE)
endif
# Files MUST be compiled one by one. If we compile several files in a
# row (i.e., in the same instance of Emacs) we can't make sure that
@ -275,8 +292,14 @@ $(THEFILE)c:
# An old-fashioned suffix rule, which, according to the GNU Make manual,
# cannot have prerequisites.
ifeq ($(HAVE_NATIVE_COMP),yes)
.el.elc:
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) \
-l comp -f batch-byte-native-compile-for-bootstrap $<
else
.el.elc:
$(AM_V_ELC)$(emacs) $(BYTE_COMPILE_FLAGS) -f batch-byte-compile $<
endif
.PHONY: compile-first compile-main compile compile-always
@ -294,7 +317,13 @@ compile-first: $(COMPILE_FIRST)
.PHONY: compile-targets
# TARGETS is set dynamically in the recursive call from 'compile-main'.
# Do not build comp.el unless necessary not to exceed max-specpdl-size and
# max-lisp-eval-depth in normal builds.
ifneq ($(HAVE_NATIVE_COMP),yes)
compile-targets: $(filter-out ./emacs-lisp/comp-cstr.elc,$(filter-out ./emacs-lisp/comp.elc,$(TARGETS)))
else
compile-targets: $(TARGETS)
endif
# Compile all the Elisp files that need it. Beware: it approximates
# 'no-byte-compile', so watch out for false-positives!
@ -307,9 +336,11 @@ compile-main: gen-lisp compile-clean
GREP_OPTIONS= grep '^;.*[^a-zA-Z]no-byte-compile: *t' $$el > /dev/null && \
continue; \
echo "$${el}c"; \
done | xargs $(XARGS_LIMIT) echo) | \
while read chunk; do \
$(MAKE) compile-targets TARGETS="$$chunk"; \
done | xargs $(XARGS_LIMIT) echo) | \
while read chunk; do \
$(MAKE) compile-targets \
NATIVE_DISABLED=$(NATIVE_SKIP_NONDUMP) \
TARGETS="$$chunk"; \
done
.PHONY: compile-clean

1
lisp/cus-dep.el
View file

@ -109,6 +109,7 @@ Usage: emacs -batch -l ./cus-dep.el -f custom-make-dependencies DIRS"
(string-match "\\`\\(.*\\)\\.el\\'" file)
(let ((name (or generated-autoload-load-name ; see bug#5277
(file-name-nondirectory (match-string 1 file))))
(load-true-file-name file)
(load-file-name file))
(if (save-excursion
(re-search-forward

5
lisp/emacs-lisp/advice.el
View file

@ -2051,6 +2051,8 @@ in that CLASS."
function class name)))
(error "ad-remove-advice: `%s' is not advised" function)))
(declare-function comp-subr-trampoline-install "comp")
;;;###autoload
(defun ad-add-advice (function advice class position)
"Add a piece of ADVICE to FUNCTION's list of advices in CLASS.
@ -2074,6 +2076,9 @@ mapped to the closest extremal position).
If FUNCTION was not advised already, its advice info will be
initialized. Redefining a piece of advice whose name is part of
the cache-id will clear the cache."
(when (and (featurep 'nativecomp)
(subr-primitive-p (symbol-function function)))
(comp-subr-trampoline-install function))
(cond ((not (ad-is-advised function))
(ad-initialize-advice-info function)
(ad-set-advice-info-field

4
lisp/emacs-lisp/autoload.el
View file

@ -170,7 +170,9 @@ expression, in which case we want to handle forms differently."
define-inline cl-defun cl-defmacro cl-defgeneric
cl-defstruct pcase-defmacro))
(macrop car)
(setq expand (let ((load-file-name file)) (macroexpand form)))
(setq expand (let ((load-true-file-name file)
(load-file-name file))
(macroexpand form)))
(memq (car expand) '(progn prog1 defalias)))
(make-autoload expand file 'expansion)) ;Recurse on the expansion.

1
lisp/emacs-lisp/byte-opt.el
View file

@ -2356,6 +2356,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
(eval-when-compile
(or (byte-code-function-p (symbol-function 'byte-optimize-form))
(subr-native-elisp-p (symbol-function 'byte-optimize-form))
(assq 'byte-code (symbol-function 'byte-optimize-form))
(let ((byte-optimize nil)
(byte-compile-warnings nil))

10
lisp/emacs-lisp/byte-run.el
View file

@ -146,6 +146,11 @@ The return value of this function is not used."
(list 'function-put (list 'quote f)
''lisp-indent-function (list 'quote val))))
(defalias 'byte-run--set-speed
#'(lambda (f _args val)
(list 'function-put (list 'quote f)
''speed (list 'quote val))))
(defalias 'byte-run--set-completion
#'(lambda (f _args val)
(list 'function-put (list 'quote f)
@ -173,6 +178,7 @@ If `error-free', drop calls even if `byte-compile-delete-errors' is nil.")
(list 'compiler-macro #'byte-run--set-compiler-macro)
(list 'doc-string #'byte-run--set-doc-string)
(list 'indent #'byte-run--set-indent)
(list 'speed #'byte-run--set-speed)
(list 'completion #'byte-run--set-completion)
(list 'modes #'byte-run--set-modes))
"List associating function properties to their macro expansion.
@ -381,6 +387,10 @@ You don't need this. (See bytecomp.el commentary for more details.)
`(prog1
(defun ,name ,arglist ,@body)
(eval-and-compile
;; Never native-compile defsubsts as we need the byte
;; definition in `byte-compile-unfold-bcf' to perform the
;; inlining (Bug#42664, Bug#43280, Bug#44209).
,(byte-run--set-speed name nil -1)
(put ',name 'byte-optimizer 'byte-compile-inline-expand))))
(defvar advertised-signature-table (make-hash-table :test 'eq :weakness 'key))

180
lisp/emacs-lisp/bytecomp.el
View file

@ -577,6 +577,50 @@ Each element is (INDEX . VALUE)")
(defvar byte-compile-depth 0 "Current depth of execution stack.")
(defvar byte-compile-maxdepth 0 "Maximum depth of execution stack.")
;; The following is used by comp.el to spill data out of here.
;;
;; Spilling is done in 3 places:
;;
;; - `byte-compile-lapcode' to obtain the map bytecode -> LAP for any
;; code assembled.
;;
;; - `byte-compile-lambda' to obtain arglist doc and interactive spec
;; af any lambda compiled (including anonymous).
;;
;; - `byte-compile-file-form-defmumble' to obtain the list of
;; top-level forms as they would be outputted in the .elc file.
;;
(cl-defstruct byte-to-native-lambda
byte-func lap)
;; Top level forms:
(cl-defstruct byte-to-native-func-def
"Named function defined at top-level."
name c-name byte-func)
(cl-defstruct byte-to-native-top-level
"All other top-level forms."
form lexical)
(defvar byte-native-compiling nil
"Non nil while native compiling.")
(defvar byte-native-qualities nil
"To spill default qualities from the compiled file.")
(defvar byte-native-for-bootstrap nil
"Non nil while compiling for bootstrap."
;; During bootstrap we produce both the .eln and the .elc together.
;; Because the make target is the later this has to be produced as
;; last to be resilient against build interruptions.
)
(defvar byte-to-native-lambdas-h nil
"Hash byte-code -> byte-to-native-lambda.")
(defvar byte-to-native-top-level-forms nil
"List of top level forms.")
(defvar byte-to-native-output-file nil
"Temporary file containing the byte-compilation output.")
(defvar byte-to-native-plist-environment nil
"To spill `overriding-plist-environment'.")
;;; The byte codes; this information is duplicated in bytecomp.c
@ -973,7 +1017,12 @@ CONST2 may be evaluated multiple times."
;; it within 2 bytes in the byte string).
(puthash value pc hash-table))
hash-table))
(apply 'unibyte-string (nreverse bytes))))
(let ((bytecode (apply 'unibyte-string (nreverse bytes))))
(when byte-native-compiling
;; Spill LAP for the native compiler here.
(puthash bytecode (make-byte-to-native-lambda :lap lap)
byte-to-native-lambdas-h))
bytecode)))
;;; compile-time evaluation
@ -1702,7 +1751,11 @@ It is too wide if it has any lines longer than the largest of
;; cause macro calls in B to think they come from A.
(current-load-list (list nil))
)
,@body))
(prog1
(progn ,@body)
(when byte-native-compiling
(setq byte-to-native-plist-environment
overriding-plist-environment)))))
(defmacro displaying-byte-compile-warnings (&rest body)
(declare (debug t))
@ -2018,15 +2071,16 @@ See also `emacs-lisp-byte-compile-and-load'."
(insert "\n") ; aaah, unix.
(cond
((null target-file) nil) ;We only wanted the warnings!
((and (file-writable-p target-file)
;; We attempt to create a temporary file in the
;; target directory, so the target directory must be
;; writable.
(file-writable-p
(file-name-directory
;; Need to expand in case TARGET-FILE doesn't
;; include a directory (Bug#45287).
(expand-file-name target-file))))
((or byte-native-compiling
(and (file-writable-p target-file)
;; We attempt to create a temporary file in the
;; target directory, so the target directory must be
;; writable.
(file-writable-p
(file-name-directory
;; Need to expand in case TARGET-FILE doesn't
;; include a directory (Bug#45287).
(expand-file-name target-file)))))
;; We must disable any code conversion here.
(let* ((coding-system-for-write 'no-conversion)
;; Write to a tempfile so that if another Emacs
@ -2034,7 +2088,8 @@ See also `emacs-lisp-byte-compile-and-load'."
;; parallel bootstrap), it does not risk getting a
;; half-finished file. (Bug#4196)
(tempfile
(make-temp-file (expand-file-name target-file)))
(make-temp-file (when (file-writable-p target-file)
(expand-file-name target-file))))
(default-modes (default-file-modes))
(temp-modes (logand default-modes #o600))
(desired-modes (logand default-modes #o666))
@ -2053,8 +2108,16 @@ See also `emacs-lisp-byte-compile-and-load'."
;; emacs-lisp files in the build tree are
;; recompiled). Previously this was accomplished by
;; deleting target-file before writing it.
(rename-file tempfile target-file t))
(or noninteractive (message "Wrote %s" target-file)))
(if byte-native-compiling
(if byte-native-for-bootstrap
;; Defer elc final renaming.
(setf byte-to-native-output-file
(cons tempfile target-file))
(delete-file tempfile))
(rename-file tempfile target-file t)))
(or noninteractive
byte-native-compiling
(message "Wrote %s" target-file)))
((file-writable-p target-file)
;; In case the target directory isn't writable (see e.g. Bug#44631),
;; try writing to the output file directly. We must disable any
@ -2174,6 +2237,17 @@ With argument ARG, insert value in current buffer after the form."
(setq byte-compile-unresolved-functions nil)
(setq byte-compile-noruntime-functions nil)
(setq byte-compile-new-defuns nil)
(when byte-native-compiling
(defvar comp-speed)
(push `(comp-speed . ,comp-speed) byte-native-qualities)
(defvar comp-debug)
(push `(comp-debug . ,comp-debug) byte-native-qualities)
(defvar comp-native-driver-options)
(push `(comp-native-driver-options . ,comp-native-driver-options)
byte-native-qualities)
(defvar no-native-compile)
(push `(no-native-compile . ,no-native-compile)
byte-native-qualities))
;; Compile the forms from the input buffer.
(while (progn
@ -2246,6 +2320,10 @@ Call from the source buffer."
;; defalias calls are output directly by byte-compile-file-form-defmumble;
;; it does not pay to first build the defalias in defmumble and then parse
;; it here.
(when byte-native-compiling
;; Spill output for the native compiler here
(push (make-byte-to-native-top-level :form form :lexical lexical-binding)
byte-to-native-top-level-forms))
(let ((print-escape-newlines t)
(print-length nil)
(print-level nil)
@ -2689,6 +2767,15 @@ not to take responsibility for the actual compilation of the code."
;; If there's no doc string, provide -1 as the "doc string
;; index" so that no element will be treated as a doc string.
(if (not (stringp (documentation code t))) -1 4)))
(when byte-native-compiling
;; Spill output for the native compiler here.
(push (if macro
(make-byte-to-native-top-level
:form `(defalias ',name '(macro . ,code) nil)
:lexical lexical-binding)
(make-byte-to-native-func-def :name name
:byte-func code))
byte-to-native-top-level-forms))
;; Output the form by hand, that's much simpler than having
;; b-c-output-file-form analyze the defalias.
(byte-compile-output-docform
@ -2966,30 +3053,37 @@ for symbols generated by the byte compiler itself."
reserved-csts)))
;; Build the actual byte-coded function.
(cl-assert (eq 'byte-code (car-safe compiled)))
(apply #'make-byte-code
(if lexical-binding
(byte-compile-make-args-desc arglist)
arglist)
(append
;; byte-string, constants-vector, stack depth
(cdr compiled)
;; optionally, the doc string.
(cond ((and lexical-binding arglist)
;; byte-compile-make-args-desc lost the args's names,
;; so preserve them in the docstring.
(list (help-add-fundoc-usage doc arglist)))
((or doc int)
(list doc)))
;; optionally, the interactive spec (and the modes the
;; command applies to).
(cond
;; We have some command modes, so use the vector form.
(command-modes
(list (vector (nth 1 int) command-modes)))
;; No command modes, use the simple form with just the
;; interactive spec.
(int
(list (nth 1 int)))))))))
(let ((out
(apply #'make-byte-code
(if lexical-binding
(byte-compile-make-args-desc arglist)
arglist)
(append
;; byte-string, constants-vector, stack depth
(cdr compiled)
;; optionally, the doc string.
(cond ((and lexical-binding arglist)
;; byte-compile-make-args-desc lost the args's names,
;; so preserve them in the docstring.
(list (help-add-fundoc-usage doc arglist)))
((or doc int)
(list doc)))
;; optionally, the interactive spec (and the modes the
;; command applies to).
(cond
;; We have some command modes, so use the vector form.
(command-modes
(list (vector (nth 1 int) command-modes)))
;; No command modes, use the simple form with just the
;; interactive spec.
(int
(list (nth 1 int))))))))
(when byte-native-compiling
(setf (byte-to-native-lambda-byte-func
(gethash (cadr compiled)
byte-to-native-lambdas-h))
out))
out))))
(defvar byte-compile-reserved-constants 0)
@ -5232,7 +5326,7 @@ Use with caution."
;; so it can cause recompilation to fail.
(not (member (file-name-nondirectory f)
'("pcase.el" "bytecomp.el" "macroexp.el"
"cconv.el" "byte-opt.el"))))
"cconv.el" "byte-opt.el" "comp.el"))))
(message "Reloading stale %s" (file-name-nondirectory f))
(condition-case nil
(load f 'noerror nil 'nosuffix)
@ -5313,13 +5407,15 @@ and corresponding effects."
;;
(eval-when-compile
(or (byte-code-function-p (symbol-function 'byte-compile-form))
(subr-native-elisp-p (symbol-function 'byte-compile-form))
(assq 'byte-code (symbol-function 'byte-compile-form))
(let ((byte-optimize nil) ; do it fast
(byte-compile-warnings nil))
(mapc (lambda (x)
(or noninteractive (message "compiling %s..." x))
(byte-compile x)
(or noninteractive (message "compiling %s...done" x)))
(unless (subr-native-elisp-p x)
(or noninteractive (message "compiling %s..." x))
(byte-compile x)
(or noninteractive (message "compiling %s...done" x))))
'(byte-compile-normal-call
byte-compile-form
byte-compile-body

34
lisp/emacs-lisp/cl-macs.el
View file

@ -2477,6 +2477,14 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
(defmacro cl-the (type form)
"Return FORM. If type-checking is enabled, assert that it is of TYPE."
(declare (indent 1) (debug (cl-type-spec form)))
;; When native compiling possibly add the appropriate type hint.
(when (and (boundp 'byte-native-compiling)
byte-native-compiling)
(setf form
(cl-case type
(fixnum `(comp-hint-fixnum ,form))
(cons `(comp-hint-cons ,form))
(otherwise form))))
(if (not (or (not (macroexp-compiling-p))
(< cl--optimize-speed 3)
(= cl--optimize-safety 3)))
@ -2487,6 +2495,28 @@ values. For compatibility, (cl-values A B C) is a synonym for (list A B C).
(list ',type ,temp ',form)))
,temp))))
;;;###autoload
(or (assq 'cl-optimize defun-declarations-alist)
(let ((x (list 'cl-optimize #'cl--optimize)))
(push x macro-declarations-alist)
(push x defun-declarations-alist)))
(defun cl--optimize (f _args &rest qualities)
"Serve 'cl-optimize' in function declarations.
Example:
(defun foo (x)
(declare (cl-optimize (speed 3) (safety 0)))
x)"
;; FIXME this should make use of `cl--declare-stack' but I suspect
;; this mechanism should be reviewed first.
(cl-loop for (qly val) in qualities
do (cl-ecase qly
(speed
(setf cl--optimize-speed val)
(byte-run--set-speed f nil val))
(safety
(setf cl--optimize-safety val)))))
(defvar cl--proclaim-history t) ; for future compilers
(defvar cl--declare-stack t) ; for future compilers
@ -3556,6 +3586,10 @@ The type name can then be used in `cl-typecase', `cl-check-type', etc."
(cl-function (lambda (&cl-defs ('*) ,@arglist) ,@body)))))
(cl-deftype extended-char () '(and character (not base-char)))
;; Define fixnum so `cl-typep' recognize it and the type check emitted
;; by `cl-the' is effective.
(cl-deftype fixnum () 'fixnump)
(cl-deftype bignum () 'bignump)
;;; Additional functions that we can now define because we've defined
;;; `cl-defsubst' and `cl-typep'.

1187
lisp/emacs-lisp/comp-cstr.el Normal file
View file

File diff suppressed because it is too large Load diff

4210
lisp/emacs-lisp/comp.el Normal file
View file

File diff suppressed because it is too large Load diff

29
lisp/emacs-lisp/disass.el
View file

@ -43,6 +43,8 @@
;; Since we don't use byte-decompile-lapcode, let's try not loading byte-opt.
(require 'byte-compile "bytecomp")
(declare-function comp-c-func-name "comp.el")
(defvar disassemble-column-1-indent 8 "*")
(defvar disassemble-column-2-indent 10 "*")
@ -73,8 +75,9 @@ redefine OBJECT if it is a symbol."
(disassemble-internal object indent nil)))
nil)
(defun disassemble-internal (obj indent interactive-p)
(declare-function native-comp-unit-file "data.c")
(declare-function subr-native-comp-unit "data.c")
(cl-defun disassemble-internal (obj indent interactive-p)
(let ((macro 'nil)
(name (when (symbolp obj)
(prog1 obj
@ -82,7 +85,27 @@ redefine OBJECT if it is a symbol."
args)
(setq obj (autoload-do-load obj name))
(if (subrp obj)
(error "Can't disassemble #<subr %s>" name))
(if (and (fboundp 'subr-native-elisp-p)
(subr-native-elisp-p obj))
(progn
(require 'comp)
(call-process "objdump" nil (current-buffer) t "-S"
(native-comp-unit-file (subr-native-comp-unit obj)))
(goto-char (point-min))
(re-search-forward (concat "^.*"
(regexp-quote
(concat "<"
(comp-c-func-name
(subr-name obj) "F" t)
">:"))))
(beginning-of-line)
(delete-region (point-min) (point))
(when (re-search-forward "^.*<.*>:" nil t 2)
(delete-region (match-beginning 0) (point-max)))
(asm-mode)
(setq buffer-read-only t)
(cl-return-from disassemble-internal))
(error "Can't disassemble #<subr %s>" name)))
(if (eq (car-safe obj) 'macro) ;Handle macros.
(setq macro t
obj (cdr obj)))

9
lisp/emacs-lisp/find-func.el
View file

@ -178,13 +178,18 @@ See the functions `find-function' and `find-variable'."
(setq name rel))))
(unless (equal name library) name)))
(defvar comp-eln-to-el-h)
(defun find-library-name (library)
"Return the absolute file name of the Emacs Lisp source of LIBRARY.
LIBRARY should be a string (the name of the library)."
;; If the library is byte-compiled, try to find a source library by
;; the same name.
(when (string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library)
(cond
((string-match "\\.el\\(c\\(\\..*\\)?\\)\\'" library)
(setq library (replace-match "" t t library)))
((string-match "\\.eln\\'" library)
(setq library (gethash (file-name-nondirectory library) comp-eln-to-el-h))))
(or
(locate-file library
(or find-function-source-path load-path)
@ -491,7 +496,7 @@ message about the whole chain of aliases."
(cons function
(cond
((autoloadp def) (nth 1 def))
((subrp def)
((subr-primitive-p def)
(if lisp-only
(error "%s is a built-in function" function))
(help-C-file-name def 'subr))

18
lisp/emacs-lisp/nadvice.el
View file

@ -316,8 +316,26 @@ is also interactive. There are 3 cases:
`(advice--add-function ,where (gv-ref ,(advice--normalize-place place))
,function ,props))
(declare-function comp-subr-trampoline-install "comp")
;;;###autoload
(defun advice--add-function (where ref function props)
(when (and (featurep 'nativecomp)
(subr-primitive-p (gv-deref ref)))
(let ((subr-name (intern (subr-name (gv-deref ref)))))
;; Requiring the native compiler to advice `macroexpand' cause a
;; circular dependency in eager macro expansion.
;; uniquify is advising `rename-buffer' while being loaded in
;; loadup.el. This would require the whole native compiler
;; machinery but we don't want to include it in the dump.
;; Because these two functions are already handled in
;; `comp-never-optimize-functions' we hack the problem this way
;; for now :/
(unless (memq subr-name '(macroexpand rename-buffer))
;; Must require explicitly as during bootstrap we have no
;; autoloads.
(require 'comp)
(comp-subr-trampoline-install subr-name))))
(let* ((name (cdr (assq 'name props)))
(a (advice--member-p (or name function) (if name t) (gv-deref ref))))
(when a

33
lisp/emacs-lisp/package.el
View file

@ -396,6 +396,12 @@ a sane initial value."
:version "25.1"
:type '(repeat symbol))
(defcustom package-native-compile nil
"Non-nil means to native compile packages on installation."
:type '(boolean)
:risky t
:version "28.1")
(defcustom package-menu-async t
"If non-nil, package-menu will use async operations when possible.
Currently, only the refreshing of archive contents supports
@ -985,6 +991,8 @@ untar into a directory named DIR; otherwise, signal an error."
;; E.g. for multi-package installs, we should first install all packages
;; and then compile them.
(package--compile new-desc)
(when package-native-compile
(package--native-compile-async new-desc))
;; After compilation, load again any files loaded by
;; `activate-1', so that we use the byte-compiled definitions.
(package--load-files-for-activation new-desc :reload)))
@ -1069,6 +1077,15 @@ This assumes that `pkg-desc' has already been activated with
(load-path load-path))
(byte-recompile-directory (package-desc-dir pkg-desc) 0 t)))
(defun package--native-compile-async (pkg-desc)
"Native compile installed package PKG-DESC asynchronously.
This assumes that `pkg-desc' has already been activated with
`package-activate-1'."
(when (and (featurep 'nativecomp)
(native-comp-available-p))
(let ((warning-minimum-level :error))
(native-compile-async (package-desc-dir pkg-desc) t))))
;;;; Inferring package from current buffer
(defun package-read-from-string (str)
"Read a Lisp expression from STR.
@ -2243,6 +2260,17 @@ confirmation to install packages."
(equal (cadr (assq (package-desc-name pkg) package-alist))
pkg))
(declare-function comp-el-to-eln-filename "comp.c")
(defun package--delete-directory (dir)
"Delete DIR recursively.
Clean-up the corresponding .eln files if Emacs is native
compiled."
(when (featurep 'nativecomp)
(cl-loop
for file in (directory-files-recursively dir ".el\\'")
do (comp-clean-up-stale-eln (comp-el-to-eln-filename file))))
(delete-directory dir t))
(defun package-delete (pkg-desc &optional force nosave)
"Delete package PKG-DESC.
@ -2295,7 +2323,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
@ -4118,7 +4146,8 @@ activations need to be changed, such as when `package-load-list' is modified."
(let ((load-suffixes '(".el" ".elc")))
(locate-library (package--autoloads-file-name pkg))))
(pfile (prin1-to-string file)))
(insert "(let ((load-file-name " pfile "))\n")
(insert "(let ((load-true-file-name " pfile ")\
(load-file-name " pfile "))\n")
(insert-file-contents file)
;; Fixup the special #$ reader form and throw away comments.
(while (re-search-forward "#\\$\\|^;\\(.*\n\\)" nil 'move)

3
lisp/faces.el
View file

@ -2244,7 +2244,8 @@ If you set `term-file-prefix' to nil, this function does nothing."
(let ((file (locate-library (concat term-file-prefix type))))
(and file
(or (assoc file load-history)
(load file t t)))))
(load (file-name-sans-extension file)
t t)))))
type)
;; Next, try to find a matching initialization function, and call it.
(tty-find-type #'(lambda (type)

7
lisp/files.el
View file

@ -908,6 +908,8 @@ See `file-symlink-p' to distinguish symlinks."
(read-file-name "Load file: " nil nil 'lambda))))
(load (expand-file-name file) nil nil t))
(defvar comp-eln-to-el-h)
(defun locate-file (filename path &optional suffixes predicate)
"Search for FILENAME through PATH.
If found, return the absolute file name of FILENAME; otherwise
@ -934,7 +936,10 @@ one or more of those symbols."
(logior (if (memq 'executable predicate) 1 0)
(if (memq 'writable predicate) 2 0)
(if (memq 'readable predicate) 4 0))))
(locate-file-internal filename path suffixes predicate))
(let ((file (locate-file-internal filename path suffixes predicate)))
(if (and file (string-match "\\.eln\\'" file))
(gethash (file-name-nondirectory file) comp-eln-to-el-h)
file)))
(defun locate-file-completion-table (dirs suffixes string pred action)
"Do completion for file names passed to `locate-file'."

5
lisp/gnus/gnus.el
View file

@ -4156,8 +4156,9 @@ prompt the user for the name of an NNTP server to use."
;; file.
(unless (string-match "^Gnus" gnus-version)
(load "gnus-load" nil t))
(unless (byte-code-function-p (symbol-function 'gnus))
(message "You should byte-compile Gnus")
(unless (or (byte-code-function-p (symbol-function 'gnus))
(subr-native-elisp-p (symbol-function 'gnus)))
(message "You should compile Gnus")
(sit-for 2))
(let ((gnus-action-message-log (list nil)))
(gnus-1 arg dont-connect child)

2
lisp/help-fns.el
View file

@ -805,6 +805,8 @@ Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)."
;; aliases before functions.
(aliased
(format-message "an alias for `%s'" real-def))
((subr-native-elisp-p def)
(concat beg "native compiled Lisp function"))
((subrp def)
(concat beg (if (eq 'unevalled (cdr (subr-arity def)))
"special form"

6
lisp/help.el
View file

@ -1870,6 +1870,8 @@ ARGLIST can also be t or a string of the form \"(FUN ARG1 ARG2 ...)\"."
(error "Unrecognized usage format"))
(help--make-usage-docstring 'fn arglist)))))
(declare-function subr-native-lambda-list "data.c")
(defun help-function-arglist (def &optional preserve-names)
"Return a formal argument list for the function DEF.
If PRESERVE-NAMES is non-nil, return a formal arglist that uses
@ -1885,6 +1887,10 @@ the same names as used in the original source code, when possible."
((and (byte-code-function-p def) (listp (aref def 0))) (aref def 0))
((eq (car-safe def) 'lambda) (nth 1 def))
((eq (car-safe def) 'closure) (nth 2 def))
((and (featurep 'nativecomp)
(subrp def)
(listp (subr-native-lambda-list def)))
(subr-native-lambda-list def))
((or (and (byte-code-function-p def) (integerp (aref def 0)))
(subrp def) (module-function-p def))
(or (when preserve-names

5
lisp/international/mule.el
View file

@ -317,8 +317,9 @@ Return t if file exists."
(when purify-flag
(push (purecopy file) preloaded-file-list))
(unwind-protect
(let ((load-file-name fullname)
(set-auto-coding-for-load t)
(let ((load-true-file-name fullname)
(load-file-name fullname)
(set-auto-coding-for-load t)
(inhibit-file-name-operation nil))
(with-current-buffer buffer
;; So that we don't get completely screwed if the

46
lisp/loadup.el
View file

@ -157,7 +157,8 @@
;; Load-time macro-expansion can only take effect after setting
;; load-source-file-function because of where it is called in lread.c.
(load "emacs-lisp/macroexp")
(if (byte-code-function-p (symbol-function 'macroexpand-all))
(if (or (byte-code-function-p (symbol-function 'macroexpand-all))
(subr-native-elisp-p (symbol-function 'macroexpand-all)))
nil
;; Since loaddefs is not yet loaded, macroexp's uses of pcase will simply
;; fail until pcase is explicitly loaded. This also means that we have to
@ -448,6 +449,43 @@ lost after dumping")))
;; At this point, we're ready to resume undo recording for scratch.
(buffer-enable-undo "*scratch*")
(when (featurep 'nativecomp)
;; Fix the compilation unit filename to have it working when
;; installed or if the source directory got moved. This is set to be
;; a pair in the form of:
;; (rel-filename-from-install-bin . rel-filename-from-local-bin).
(let ((h (make-hash-table :test #'eq))
(bin-dest-dir (cadr (member "--bin-dest" command-line-args)))
(eln-dest-dir (cadr (member "--eln-dest" command-line-args))))
(when (and bin-dest-dir eln-dest-dir)
(setq eln-dest-dir
(concat eln-dest-dir "native-lisp/" comp-native-version-dir "/"))
(mapatoms (lambda (s)
(let ((f (symbol-function s)))
(when (subr-native-elisp-p f)
(puthash (subr-native-comp-unit f) nil h)))))
(maphash (lambda (cu _)
(let* ((file (native-comp-unit-file cu))
(preloaded (equal (substring (file-name-directory file)
-10 -1)
"preloaded"))
(eln-dest-dir-eff (if preloaded
(expand-file-name "preloaded"
eln-dest-dir)
eln-dest-dir)))
(native-comp-unit-set-file
cu
(cons
;; Relative filename from the installed binary.
(file-relative-name (expand-file-name
(file-name-nondirectory
file)
eln-dest-dir-eff)
bin-dest-dir)
;; Relative filename from the built uninstalled binary.
(file-relative-name file invocation-directory)))))
h))))
(when (hash-table-p purify-flag)
(let ((strings 0)
(vectors 0)
@ -483,6 +521,11 @@ lost after dumping")))
((equal dump-mode "bootstrap") "emacs")
((equal dump-mode "pbootstrap") "bootstrap-emacs.pdmp")
(t (error "unrecognized dump mode %s" dump-mode)))))
(when (and (featurep 'nativecomp)
(equal dump-mode "pdump"))
;; Don't enable this before bootstrap is completed, as the
;; compiler infrastructure may not be usable yet.
(setq comp-enable-subr-trampolines t))
(message "Dumping under the name %s" output)
(condition-case ()
(delete-file output)
@ -539,6 +582,7 @@ lost after dumping")))
;; Don't keep `load-file-name' set during the top-level session!
;; Otherwise, it breaks a lot of code which does things like
;; (or load-file-name byte-compile-current-file).
(setq load-true-file-name nil)
(setq load-file-name nil)
(eval top-level t)

2
lisp/mail/emacsbug.el
View file

@ -309,7 +309,7 @@ usually do not have translators for other languages.\n\n")))
(lambda (var)
(let ((val (getenv var)))
(if val (insert (format " value of $%s: %s\n" var val)))))
'("EMACSDATA" "EMACSDOC" "EMACSLOADPATH" "EMACSPATH"
'("EMACSDATA" "EMACSDOC" "EMACSLOADPATH" "EMACSNATIVELOADPATH" "EMACSPATH"
"LC_ALL" "LC_COLLATE" "LC_CTYPE" "LC_MESSAGES"
"LC_MONETARY" "LC_NUMERIC" "LC_TIME" "LANG" "XMODIFIERS"))
(insert (format " locale-coding-system: %s\n" locale-coding-system))

11
lisp/progmodes/cc-bytecomp.el
View file

@ -97,6 +97,8 @@
;; compilation can trigger loading (various `require' type forms)
;; and loading can trigger compilation (the package manager does
;; this). We walk the lisp stack if necessary.
;; Never native compile to allow cc-defs.el:2345 hack.
(declare (speed -1))
(cond
((and load-in-progress
(boundp 'byte-compile-dest-file)
@ -108,14 +110,15 @@
(memq (cadr elt)
'(load require
byte-compile-file byte-recompile-directory
batch-byte-compile)))))
batch-byte-compile batch-native-compile)))))
(setq n (1+ n)))
(cond
((memq (cadr elt) '(load require))
'loading)
((memq (cadr elt) '(byte-compile-file
byte-recompile-directory
batch-byte-compile))
batch-byte-compile
batch-native-compile))
'compiling)
(t ; Can't happen.
(message "cc-bytecomp-compiling-or-loading: System flags spuriously set")
@ -284,7 +287,9 @@ perhaps a `cc-bytecomp-restore-environment' is forgotten somewhere"))
(cons cc-file cc-bytecomp-loaded-files))
(cc-bytecomp-debug-msg
"cc-bytecomp-load: Loading %S" cc-file)
(load cc-file nil t t)
;; native-comp may async compile also intalled el.gz
;; files therefore we may have to load here other el.gz.
(load cc-part nil t)
(cc-bytecomp-debug-msg
"cc-bytecomp-load: Loaded %S" cc-file)))
(cc-bytecomp-setup-environment)

3
lisp/progmodes/cc-langs.el
View file

@ -333,7 +333,8 @@ the evaluated constant value at compile time."
This includes setting \\=' and \" as string delimiters, and setting up
the comment syntax to handle both line style \"//\" and block style
\"/*\" \"*/\" comments."
;; Never native compile to allow cc-mode.el:467 hack.
(declare (speed -1))
(modify-syntax-entry ?_ "_" table)
(modify-syntax-entry ?\\ "\\" table)
(modify-syntax-entry ?+ "." table)

26
lisp/progmodes/elisp-mode.el
View file

@ -160,19 +160,35 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(byte-compile-file buffer-file-name)
(error "The buffer must be saved in a file first")))
(defun emacs-lisp-byte-compile-and-load ()
"Byte-compile the current file (if it has changed), then load compiled code."
(interactive nil emacs-lisp-mode)
(defun emacs-lisp--before-compile-buffer ()
"Make sure the buffer is saved before compiling."
(or buffer-file-name
(error "The buffer must be saved in a file first"))
(require 'bytecomp)
;; Recompile if file or buffer has changed since last compilation.
(if (and (buffer-modified-p)
(y-or-n-p (format "Save buffer %s first? " (buffer-name))))
(save-buffer))
(save-buffer)))
(defun emacs-lisp-byte-compile-and-load ()
"Byte-compile the current file (if it has changed), then load compiled code."
(interactive nil emacs-lisp-mode)
(emacs-lisp--before-compile-buffer)
(require 'bytecomp)
(byte-recompile-file buffer-file-name nil 0)
(load buffer-file-name))
(declare-function native-compile "comp")
(defun emacs-lisp-native-compile-and-load ()
"Native-compile synchronously the current file (if it has changed).
Load the compiled code when finished.
Use `emacs-lisp-byte-compile-and-load' in combination with
`comp-deferred-compilation' set to `t' to achieve asynchronous
native compilation."
(interactive nil emacs-lisp-mode)
(emacs-lisp--before-compile-buffer)
(load (native-compile buffer-file-name)))
(defun emacs-lisp-macroexpand ()
"Macroexpand the form after point.
Comments in the form will be lost."

25
lisp/startup.el
View file

@ -536,6 +536,21 @@ It is the default value of the variable `top-level'."
(setq user-emacs-directory
(startup--xdg-or-homedot startup--xdg-config-home-emacs nil))
(when (featurep 'nativecomp)
;; Form `comp-eln-load-path'.
(defvar comp-eln-load-path)
(let ((path-env (getenv "EMACSNATIVELOADPATH")))
(when path-env
(dolist (path (split-string path-env path-separator))
(unless (string= "" path)
(push path comp-eln-load-path)))))
(push (expand-file-name "eln-cache/" user-emacs-directory)
comp-eln-load-path)
;; When $HOME is set to '/nonexistent' means we are running the
;; testsuite, add a temporary folder in front to produce there
;; new compilations.
(when (equal (getenv "HOME") "/nonexistent")
(push (make-temp-file "emacs-testsuite-" t) comp-eln-load-path)))
;; Look in each dir in load-path for a subdirs.el file. If we
;; find one, load it, which will add the appropriate subdirs of
;; that dir into load-path. This needs to be done before setting
@ -622,6 +637,16 @@ It is the default value of the variable `top-level'."
(set pathsym (mapcar (lambda (dir)
(decode-coding-string dir coding t))
path)))))
(when (featurep 'nativecomp)
(let ((npath (symbol-value 'comp-eln-load-path)))
(set 'comp-eln-load-path
(mapcar (lambda (dir)
;; Call expand-file-name to remove all the
;; pesky ".." from the directyory names in
;; comp-eln-load-path.
(expand-file-name
(decode-coding-string dir coding t)))
npath))))
(dolist (filesym '(data-directory doc-directory exec-directory
installation-directory
invocation-directory invocation-name

7
lisp/subr.el
View file

@ -246,6 +246,11 @@ value of last one, or nil if there are none.
(declare (indent 1) (debug t))
(cons 'if (cons cond (cons nil body))))
(defsubst subr-primitive-p (object)
"Return t if OBJECT is a built-in primitive function."
(and (subrp object)
(not (subr-native-elisp-p object))))
(defsubst xor (cond1 cond2)
"Return the boolean exclusive-or of COND1 and COND2.
If only one of the arguments is non-nil, return it; otherwise
@ -5529,7 +5534,7 @@ command is called from a keyboard macro?"
;; Now `frame' should be "the function from which we were called".
(pcase (cons frame nextframe)
;; No subr calls `interactive-p', so we can rule that out.
(`((,_ ,(pred (lambda (f) (subrp (indirect-function f)))) . ,_) . ,_) nil)
(`((,_ ,(pred (lambda (f) (subr-primitive-p (indirect-function f)))) . ,_) . ,_) nil)
;; In case #<subr funcall-interactively> without going through the
;; `funcall-interactively' symbol (bug#3984).
(`(,_ . (t ,(pred (lambda (f)

3
lisp/term/w32-win.el
View file

@ -284,7 +284,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.")
'(libxml2 "libxml2-2.dll" "libxml2.dll")
'(zlib "zlib1.dll" "libz-1.dll")
'(lcms2 "liblcms2-2.dll")
'(json "libjansson-4.dll")))
'(json "libjansson-4.dll")
'(gccjit "libgccjit-0.dll")))
;;; multi-tty support
(defvar w32-initialized nil

5
nt/epaths.nt
View file

@ -49,6 +49,11 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
*/
#define PATH_SITELOADSEARCH "%emacs_dir%/share/emacs/@VER@/site-lisp;%emacs_dir%/share/emacs/site-lisp"
/* Like PATH_LOADSEARCH, but contains the relative path from the
installation directory.
*/
#define PATH_REL_LOADSEARCH ""
/* Like PATH_LOADSEARCH, but used only during the build process
when Emacs is dumping. Configure (using "make epaths-force-w32") sets
this to $buildlisppath, which normally has the value: <srcdir>/lisp.

4
nt/mingw-cfg.site
View file

@ -158,6 +158,10 @@ gl_cv_func_copy_file_range=yes
# We don't want to build Emacs so it depends on bcrypt.dll, since then
# it will refuse to start on systems where that DLL is absent.
gl_cv_lib_assume_bcrypt=no
# Force 'ac_cv_func_strsignal' to no as mingw64 libgccjit exports this
# symbol erroneously
# <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=45303#83>.
ac_cv_func_strsignal=no
# Don't build the Gnulib free.c: it is not needed, since the w32
# implementation of 'free' doesn't touch errno, and it emits a
# compilation warning.

18
src/Makefile.in
View file

@ -242,7 +242,7 @@ LIBZ = @LIBZ@
## system-specific libs for dynamic modules, else empty
LIBMODULES = @LIBMODULES@
## dynlib.o emacs-module.o if modules enabled, else empty
## emacs-module.o if modules enabled, else empty
MODULES_OBJ = @MODULES_OBJ@
XRANDR_LIBS = @XRANDR_LIBS@
@ -326,6 +326,11 @@ GETLOADAVG_LIBS = @GETLOADAVG_LIBS@
LIBGMP = @LIBGMP@
LIBGCCJIT = @LIBGCCJIT_LIB@
## dynlib.o if necessary, else empty
DYNLIB_OBJ = @DYNLIB_OBJ@
RUN_TEMACS = ./temacs
# Whether builds should contain details. '--no-build-details' or empty.
@ -392,7 +397,7 @@ base_obj = dispnew.o frame.o scroll.o xdisp.o menu.o $(XMENU_OBJ) window.o \
cmds.o casetab.o casefiddle.o indent.o search.o regex-emacs.o undo.o \
alloc.o pdumper.o data.o doc.o editfns.o callint.o \
eval.o floatfns.o fns.o font.o print.o lread.o $(MODULES_OBJ) \
syntax.o $(UNEXEC_OBJ) bytecode.o \
syntax.o $(UNEXEC_OBJ) bytecode.o comp.o $(DYNLIB_OBJ) \
process.o gnutls.o callproc.o \
region-cache.o sound.o timefns.o atimer.o \
doprnt.o intervals.o textprop.o composite.o xml.o lcms.o $(NOTIFY_OBJ) \
@ -495,6 +500,7 @@ shortlisp := $(filter-out ${shortlisp_filter},${shortlisp})
## the critical path (relevant in parallel compilations).
## We don't really need to sort, but may as well use it to remove duplicates.
shortlisp := loaddefs.el loadup.el $(sort ${shortlisp})
export LISP_PRELOADED = ${shortlisp}
lisp = $(addprefix ${lispsource}/,${shortlisp})
## Construct full set of libraries to be linked.
@ -510,7 +516,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \
$(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \
$(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \
$(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \
$(JSON_LIBS) $(LIBGMP)
$(JSON_LIBS) $(LIBGMP) $(LIBGCCJIT)
## FORCE it so that admin/unidata can decide whether this file is
## up-to-date. Although since charprop depends on bootstrap-emacs,
@ -560,7 +566,8 @@ endif
ifeq ($(DUMPING),pdumper)
$(pdmp): emacs$(EXEEXT)
LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump
LC_ALL=C $(RUN_TEMACS) -batch $(BUILD_DETAILS) -l loadup --temacs=pdump \
--bin-dest $(BIN_DESTDIR) --eln-dest $(ELN_DESTDIR)
cp -f $@ $(bootstrap_pdmp)
endif
@ -791,7 +798,8 @@ endif
ifeq ($(DUMPING),pdumper)
$(bootstrap_pdmp): bootstrap-emacs$(EXEEXT)
rm -f $@
$(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=pbootstrap
$(RUN_TEMACS) --batch $(BUILD_DETAILS) -l loadup --temacs=pbootstrap \
--bin-dest $(BIN_DESTDIR) --eln-dest $(ELN_DESTDIR)
@: Compile some files earlier to speed up further compilation.
$(MAKE) -C ../lisp compile-first EMACS="$(bootstrap_exe)"
endif

37
src/alloc.c
View file

@ -3152,6 +3152,26 @@ cleanup_vector (struct Lisp_Vector *vector)
module_finalize_function (function);
}
#endif
else if (NATIVE_COMP_FLAG
&& PSEUDOVECTOR_TYPEP (&vector->header, PVEC_NATIVE_COMP_UNIT))
{
struct Lisp_Native_Comp_Unit *cu =
PSEUDOVEC_STRUCT (vector, Lisp_Native_Comp_Unit);
unload_comp_unit (cu);
}
else if (NATIVE_COMP_FLAG
&& PSEUDOVECTOR_TYPEP (&vector->header, PVEC_SUBR))
{
struct Lisp_Subr *subr =
PSEUDOVEC_STRUCT (vector, Lisp_Subr);
if (!NILP (subr->native_comp_u[0]))
{
/* FIXME Alternative and non invasive solution to this
cast? */
xfree ((char *)subr->symbol_name);
xfree (subr->native_c_name[0]);
}
}
}
/* Reclaim space used by unmarked vectors. */
@ -6725,6 +6745,15 @@ mark_object (Lisp_Object arg)
break;
case PVEC_SUBR:
if (SUBR_NATIVE_COMPILEDP (obj))
{
set_vector_marked (ptr);
struct Lisp_Subr *subr = XSUBR (obj);
mark_object (subr->native_intspec);
mark_object (subr->native_comp_u[0]);
mark_object (subr->lambda_list[0]);
mark_object (subr->type[0]);
}
break;
case PVEC_FREE:
@ -6869,7 +6898,9 @@ survives_gc_p (Lisp_Object obj)
break;
case Lisp_Vectorlike:
survives_p = SUBRP (obj) || vector_marked_p (XVECTOR (obj));
survives_p =
(SUBRP (obj) && !SUBR_NATIVE_COMPILEDP (obj)) ||
vector_marked_p (XVECTOR (obj));
break;
case Lisp_Cons:
@ -7629,14 +7660,14 @@ N should be nonnegative. */);
static union Aligned_Lisp_Subr Swatch_gc_cons_threshold =
{{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
{ .a4 = watch_gc_cons_threshold },
4, 4, "watch_gc_cons_threshold", 0, 0}};
4, 4, "watch_gc_cons_threshold", {0}, 0}};
XSETSUBR (watcher, &Swatch_gc_cons_threshold.s);
Fadd_variable_watcher (Qgc_cons_threshold, watcher);
static union Aligned_Lisp_Subr Swatch_gc_cons_percentage =
{{{ PSEUDOVECTOR_FLAG | (PVEC_SUBR << PSEUDOVECTOR_AREA_BITS) },
{ .a4 = watch_gc_cons_percentage },
4, 4, "watch_gc_cons_percentage", 0, 0}};
4, 4, "watch_gc_cons_percentage", {0}, 0}};
XSETSUBR (watcher, &Swatch_gc_cons_percentage.s);
Fadd_variable_watcher (Qgc_cons_percentage, watcher);
}

2
src/callproc.c
View file

@ -457,7 +457,7 @@ call_process (ptrdiff_t nargs, Lisp_Object *args, int filefd,
int ok;
ok = openp (Vexec_path, args[0], Vexec_suffixes, &path,
make_fixnum (X_OK), false);
make_fixnum (X_OK), false, false);
if (ok < 0)
report_file_error ("Searching for program", args[0]);
}

2
src/charset.c
View file

@ -486,7 +486,7 @@ load_charset_map_from_file (struct charset *charset, Lisp_Object mapfile,
ptrdiff_t count = SPECPDL_INDEX ();
record_unwind_protect_nothing ();
specbind (Qfile_name_handler_alist, Qnil);
fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false);
fd = openp (Vcharset_map_path, mapfile, suffixes, NULL, Qnil, false, false);
fp = fd < 0 ? 0 : fdopen (fd, "r");
if (!fp)
{

5410
src/comp.c Normal file
View file

File diff suppressed because it is too large Load diff

113
src/comp.h Normal file
View file

@ -0,0 +1,113 @@
/* Elisp native compiler definitions
Copyright (C) 2019-2020 Free Software Foundation, Inc.
This file is part of GNU Emacs.
GNU Emacs is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
GNU Emacs is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#ifndef COMP_H
#define COMP_H
/* To keep ifdefs under control. */
enum {
NATIVE_COMP_FLAG =
#ifdef HAVE_NATIVE_COMP
1
#else
0
#endif
};
#include <dynlib.h>
struct Lisp_Native_Comp_Unit
{
union vectorlike_header header;
/* The original eln file loaded. In the pdumper file this is stored
as a cons cell of 2 alternative file names: the car is the
filename relative to the directory of an installed binary, the
cdr is the filename relative to the directory of an uninstalled
binary. This is arranged in loadup.el. */
Lisp_Object file;
Lisp_Object optimize_qualities;
/* Guard anonymous lambdas against Garbage Collection and serve
sanity checks. */
Lisp_Object lambda_gc_guard_h;
/* Hash c_name -> d_reloc_imp index. */
Lisp_Object lambda_c_name_idx_h;
/* Hash doc-idx -> function documentation. */
Lisp_Object data_fdoc_v;
/* Analogous to the constant vector but per compilation unit. */
Lisp_Object data_vec;
/* 'data_impure_vec' must be last (see allocate_native_comp_unit).
Same as data_vec but for data that cannot be moved to pure space. */
Lisp_Object data_impure_vec;
/* STUFFS WE DO NOT DUMP!! */
Lisp_Object *data_imp_relocs;
bool loaded_once;
bool load_ongoing;
dynlib_handle_ptr handle;
} GCALIGNED_STRUCT;
#ifdef HAVE_NATIVE_COMP
INLINE bool
NATIVE_COMP_UNITP (Lisp_Object a)
{
return PSEUDOVECTORP (a, PVEC_NATIVE_COMP_UNIT);
}
INLINE struct Lisp_Native_Comp_Unit *
XNATIVE_COMP_UNIT (Lisp_Object a)
{
eassert (NATIVE_COMP_UNITP (a));
return XUNTAG (a, Lisp_Vectorlike, struct Lisp_Native_Comp_Unit);
}
/* Defined in comp.c. */
extern void hash_native_abi (void);
extern Lisp_Object load_comp_unit (struct Lisp_Native_Comp_Unit *comp_u,
bool loading_dump, bool late_load);
extern void unload_comp_unit (struct Lisp_Native_Comp_Unit *);
extern Lisp_Object native_function_doc (Lisp_Object function);
extern void syms_of_comp (void);
extern void maybe_defer_native_compilation (Lisp_Object function_name,
Lisp_Object definition);
extern void eln_load_path_final_clean_up (void);
extern void fixup_eln_load_path (Lisp_Object directory);
#else /* #ifdef HAVE_NATIVE_COMP */
static inline void
maybe_defer_native_compilation (Lisp_Object function_name,
Lisp_Object definition)
{}
static inline
void unload_comp_unit (struct Lisp_Native_Comp_Unit *cu)
{}
extern void syms_of_comp (void);
#endif /* #ifdef HAVE_NATIVE_COMP */
#endif /* #ifndef COMP_H */

95
src/data.c
View file

@ -87,12 +87,6 @@ XOBJFWD (lispfwd a)
return a.fwdptr;
}
static void
CHECK_SUBR (Lisp_Object x)
{
CHECK_TYPE (SUBRP (x), Qsubrp, x);
}
static void
set_blv_found (struct Lisp_Buffer_Local_Value *blv, int found)
{
@ -259,6 +253,8 @@ for example, (type-of 1) returns `integer'. */)
}
case PVEC_MODULE_FUNCTION:
return Qmodule_function;
case PVEC_NATIVE_COMP_UNIT:
return Qnative_comp_unit;
case PVEC_XWIDGET:
return Qxwidget;
case PVEC_XWIDGET_VIEW:
@ -779,6 +775,13 @@ DEFUN ("fset", Ffset, Sfset, 2, 2, 0,
eassert (valid_lisp_object_p (definition));
#ifdef HAVE_NATIVE_COMP
if (comp_enable_subr_trampolines
&& SUBRP (function)
&& !SUBR_NATIVE_COMPILEDP (function))
CALLN (Ffuncall, Qcomp_subr_trampoline_install, symbol);
#endif
set_symbol_function (symbol, definition);
return definition;
@ -824,6 +827,8 @@ The return value is undefined. */)
Ffset (symbol, definition);
}
maybe_defer_native_compilation (symbol, definition);
if (!NILP (docstring))
Fput (symbol, Qfunction_documentation, docstring);
/* We used to return `definition', but now that `defun' and `defmacro' expand
@ -870,6 +875,72 @@ SUBR must be a built-in function. */)
return build_string (name);
}
DEFUN ("subr-native-elisp-p", Fsubr_native_elisp_p, Ssubr_native_elisp_p, 1, 1,
0, doc: /* Return t if the object is native compiled lisp
function, nil otherwise. */)
(Lisp_Object object)
{
return SUBR_NATIVE_COMPILEDP (object) ? Qt : Qnil;
}
DEFUN ("subr-native-lambda-list", Fsubr_native_lambda_list,
Ssubr_native_lambda_list, 1, 1, 0,
doc: /* Return the lambda list for a native compiled lisp/d
function or t otherwise. */)
(Lisp_Object subr)
{
CHECK_SUBR (subr);
return SUBR_NATIVE_COMPILED_DYNP (subr)
? XSUBR (subr)->lambda_list[0]
: Qt;
}
DEFUN ("subr-type", Fsubr_type,
Ssubr_type, 1, 1, 0,
doc: /* Return the type of SUBR. */)
(Lisp_Object subr)
{
CHECK_SUBR (subr);
#ifdef HAVE_NATIVE_COMP
return SUBR_TYPE (subr);
#else
return Qnil;
#endif
}
#ifdef HAVE_NATIVE_COMP
DEFUN ("subr-native-comp-unit", Fsubr_native_comp_unit,
Ssubr_native_comp_unit, 1, 1, 0,
doc: /* Return the native compilation unit. */)
(Lisp_Object subr)
{
CHECK_SUBR (subr);
return XSUBR (subr)->native_comp_u[0];
}
DEFUN ("native-comp-unit-file", Fnative_comp_unit_file,
Snative_comp_unit_file, 1, 1, 0,
doc: /* Return the file of the native compilation unit. */)
(Lisp_Object comp_unit)
{
CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit);
return XNATIVE_COMP_UNIT (comp_unit)->file;
}
DEFUN ("native-comp-unit-set-file", Fnative_comp_unit_set_file,
Snative_comp_unit_set_file, 2, 2, 0,
doc: /* Return the file of the native compilation unit. */)
(Lisp_Object comp_unit, Lisp_Object new_file)
{
CHECK_TYPE (NATIVE_COMP_UNITP (comp_unit), Qnative_comp_unit, comp_unit);
XNATIVE_COMP_UNIT (comp_unit)->file = new_file;
return comp_unit;
}
#endif
DEFUN ("interactive-form", Finteractive_form, Sinteractive_form, 1, 1, 0,
doc: /* Return the interactive form of CMD or nil if none.
If CMD is not a command, the return value is nil.
@ -895,6 +966,9 @@ Value, if non-nil, is a list (interactive SPEC). */)
if (SUBRP (fun))
{
if (SUBR_NATIVE_COMPILEDP (fun) && !NILP (XSUBR (fun)->native_intspec))
return XSUBR (fun)->native_intspec;
const char *spec = XSUBR (fun)->intspec;
if (spec)
return list2 (Qinteractive,
@ -3961,6 +4035,7 @@ syms_of_data (void)
DEFSYM (Qoverlay, "overlay");
DEFSYM (Qfinalizer, "finalizer");
DEFSYM (Qmodule_function, "module-function");
DEFSYM (Qnative_comp_unit, "native-comp-unit");
DEFSYM (Quser_ptr, "user-ptr");
DEFSYM (Qfloat, "float");
DEFSYM (Qwindow_configuration, "window-configuration");
@ -4085,6 +4160,14 @@ syms_of_data (void)
defsubr (&Sbyteorder);
defsubr (&Ssubr_arity);
defsubr (&Ssubr_name);
defsubr (&Ssubr_native_elisp_p);
defsubr (&Ssubr_native_lambda_list);
defsubr (&Ssubr_type);
#ifdef HAVE_NATIVE_COMP
defsubr (&Ssubr_native_comp_unit);
defsubr (&Snative_comp_unit_file);
defsubr (&Snative_comp_unit_set_file);
#endif
#ifdef HAVE_MODULES
defsubr (&Suser_ptrp);
#endif

102
src/decompress.c
View file

@ -25,6 +25,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include "lisp.h"
#include "buffer.h"
#include "composite.h"
#include "md5.h"
#include <verify.h>
@ -66,6 +67,107 @@ init_zlib_functions (void)
#endif /* WINDOWSNT */
#define MD5_BLOCKSIZE 32768 /* From md5.c */
static char acc_buff[2 * MD5_BLOCKSIZE];
static size_t acc_size;
static void
accumulate_and_process_md5 (void *data, size_t len, struct md5_ctx *ctxt)
{
eassert (len <= MD5_BLOCKSIZE);
/* We may optimize this saving some of these memcpy/move using
directly the outer buffers but so far don't bother. */
memcpy (acc_buff + acc_size, data, len);
acc_size += len;
if (acc_size >= MD5_BLOCKSIZE)
{
acc_size -= MD5_BLOCKSIZE;
md5_process_block (acc_buff, MD5_BLOCKSIZE, ctxt);
memmove (acc_buff, acc_buff + MD5_BLOCKSIZE, acc_size);
}
}
static void
final_process_md5 (struct md5_ctx *ctxt)
{
if (acc_size)
{
md5_process_bytes (acc_buff, acc_size, ctxt);
acc_size = 0;
}
}
int
md5_gz_stream (FILE *source, void *resblock)
{
z_stream stream;
unsigned char in[MD5_BLOCKSIZE];
unsigned char out[MD5_BLOCKSIZE];
#ifdef WINDOWSNT
if (!zlib_initialized)
zlib_initialized = init_zlib_functions ();
if (!zlib_initialized)
{
message1 ("zlib library not found");
return -1;
}
#endif
eassert (!acc_size);
struct md5_ctx ctx;
md5_init_ctx (&ctx);
/* allocate inflate state */
stream.zalloc = Z_NULL;
stream.zfree = Z_NULL;
stream.opaque = Z_NULL;
stream.avail_in = 0;
stream.next_in = Z_NULL;
int res = inflateInit2 (&stream, MAX_WBITS + 32);
if (res != Z_OK)
return -1;
do {
stream.avail_in = fread (in, 1, MD5_BLOCKSIZE, source);
if (ferror (source)) {
inflateEnd (&stream);
return -1;
}
if (stream.avail_in == 0)
break;
stream.next_in = in;
do {
stream.avail_out = MD5_BLOCKSIZE;
stream.next_out = out;
res = inflate (&stream, Z_NO_FLUSH);
if (res != Z_OK && res != Z_STREAM_END)
return -1;
accumulate_and_process_md5 (out, MD5_BLOCKSIZE - stream.avail_out, &ctx);
} while (!stream.avail_out);
} while (res != Z_STREAM_END);
final_process_md5 (&ctx);
inflateEnd (&stream);
if (res != Z_STREAM_END)
return -1;
md5_finish_ctx (&ctx, resblock);
return 0;
}
#undef MD5_BLOCKSIZE
struct decompress_unwind_data
{
ptrdiff_t old_point, orig, start, nbytes;

12
src/doc.c
View file

@ -327,6 +327,11 @@ string is passed through `substitute-command-keys'. */)
xsignal1 (Qvoid_function, function);
if (CONSP (fun) && EQ (XCAR (fun), Qmacro))
fun = XCDR (fun);
#ifdef HAVE_NATIVE_COMP
if (!NILP (Fsubr_native_elisp_p (fun)))
doc = native_function_doc (fun);
else
#endif
if (SUBRP (fun))
doc = make_fixnum (XSUBR (fun)->doc);
#ifdef HAVE_MODULES
@ -495,10 +500,11 @@ store_function_docstring (Lisp_Object obj, EMACS_INT offset)
XSETCAR (tem, make_fixnum (offset));
}
}
/* Lisp_Subrs have a slot for it. */
else if (SUBRP (fun))
XSUBR (fun)->doc = offset;
else if (SUBRP (fun) && !SUBR_NATIVE_COMPILEDP (fun))
{
XSUBR (fun)->doc = offset;
}
/* Bytecode objects sometimes have slots for it. */
else if (COMPILEDP (fun))

4
src/dynlib.c
View file

@ -301,15 +301,11 @@ dynlib_error (void)
return dlerror ();
}
/* FIXME: Currently there is no way to unload a module, so this
function is never used. */
#if false
int
dynlib_close (dynlib_handle_ptr h)
{
return dlclose (h) == 0;
}
#endif
#else

174
src/emacs.c
View file

@ -37,6 +37,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
#include <fcntl.h>
#include <sys/socket.h>
#include <mbstring.h>
#include <filename.h> /* for IS_ABSOLUTE_FILE_NAME */
#include "w32.h"
#include "w32heap.h"
#endif
@ -438,9 +439,9 @@ terminate_due_to_signal (int sig, int backtrace_limit)
/* This shouldn't be executed, but it prevents a warning. */
exit (1);
}
/* Code for dealing with Lisp access to the Unix command line. */
static void
init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd)
{
@ -482,8 +483,8 @@ init_cmdargs (int argc, char **argv, int skip_args, char const *original_pwd)
if (NILP (Vinvocation_directory))
{
Lisp_Object found;
int yes = openp (Vexec_path, Vinvocation_name,
Vexec_suffixes, &found, make_fixnum (X_OK), false);
int yes = openp (Vexec_path, Vinvocation_name, Vexec_suffixes,
&found, make_fixnum (X_OK), false, false);
if (yes == 1)
{
/* Add /: to the front of the name
@ -738,15 +739,29 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size)
implementation of malloc, since the caller calls our free. */
#ifdef WINDOWSNT
char *prog_fname = w32_my_exename ();
if (prog_fname)
*candidate_size = strlen (prog_fname) + 1;
return prog_fname ? xstrdup (prog_fname) : NULL;
#else /* !WINDOWSNT */
char *candidate = NULL;
/* If the executable name contains a slash, we have some kind of
path already, so just copy it. */
path already, so just resolve symlinks and return the result. */
eassert (argv0);
if (strchr (argv0, DIRECTORY_SEP))
return xstrdup (argv0);
{
char *real_name = realpath (argv0, NULL);
if (real_name)
{
*candidate_size = strlen (real_name) + 1;
return real_name;
}
char *val = xstrdup (argv0);
*candidate_size = strlen (val) + 1;
return val;
}
ptrdiff_t argv0_length = strlen (argv0);
const char *path = getenv ("PATH");
@ -783,7 +798,22 @@ load_pdump_find_executable (char const *argv0, ptrdiff_t *candidate_size)
struct stat st;
if (file_access_p (candidate, X_OK)
&& stat (candidate, &st) == 0 && S_ISREG (st.st_mode))
return candidate;
{
/* People put on PATH a symlink to the real Emacs
executable, with all the auxiliary files where the real
executable lives. Support that. */
if (lstat (candidate, &st) == 0 && S_ISLNK (st.st_mode))
{
char *real_name = realpath (candidate, NULL);
if (real_name)
{
*candidate_size = strlen (real_name) + 1;
return real_name;
}
}
return candidate;
}
*candidate = '\0';
}
while (*path++ != '\0');
@ -797,6 +827,7 @@ load_pdump (int argc, char **argv)
{
const char *const suffix = ".pdmp";
int result;
char *emacs_executable = argv[0];
const char *strip_suffix =
#if defined DOS_NT || defined CYGWIN
".exe"
@ -804,6 +835,7 @@ load_pdump (int argc, char **argv)
NULL
#endif
;
const char *argv0_base = "emacs";
/* TODO: maybe more thoroughly scrub process environment in order to
make this use case (loading a dump file in an unexeced emacs)
@ -826,9 +858,19 @@ load_pdump (int argc, char **argv)
skip_args++;
}
/* Where's our executable? */
ptrdiff_t bufsize, exec_bufsize;
emacs_executable = load_pdump_find_executable (argv[0], &bufsize);
exec_bufsize = bufsize;
/* If we couldn't find our executable, go straight to looking for
the dump in the hardcoded location. */
if (!(emacs_executable && *emacs_executable))
goto hardcoded;
if (dump_file)
{
result = pdumper_load (dump_file);
result = pdumper_load (dump_file, emacs_executable);
if (result != PDUMPER_LOAD_SUCCESS)
fatal ("could not load dump file \"%s\": %s",
@ -842,49 +884,29 @@ load_pdump (int argc, char **argv)
so we can't use decode_env_path. We're working in whatever
encoding the system natively uses for filesystem access, so
there's no need for character set conversion. */
ptrdiff_t bufsize;
dump_file = load_pdump_find_executable (argv[0], &bufsize);
/* If we couldn't find our executable, go straight to looking for
the dump in the hardcoded location. */
if (dump_file && *dump_file)
ptrdiff_t exenamelen = strlen (emacs_executable);
if (strip_suffix)
{
#ifdef WINDOWSNT
/* w32_my_exename resolves symlinks internally, so no need to
call realpath. */
#else
char *real_exename = realpath (dump_file, NULL);
if (!real_exename)
fatal ("could not resolve realpath of \"%s\": %s",
dump_file, strerror (errno));
xfree (dump_file);
dump_file = real_exename;
#endif
ptrdiff_t exenamelen = strlen (dump_file);
#ifndef WINDOWSNT
bufsize = exenamelen + 1;
#endif
if (strip_suffix)
{
ptrdiff_t strip_suffix_length = strlen (strip_suffix);
ptrdiff_t prefix_length = exenamelen - strip_suffix_length;
if (0 <= prefix_length
&& !memcmp (&dump_file[prefix_length], strip_suffix,
strip_suffix_length))
exenamelen = prefix_length;
}
ptrdiff_t needed = exenamelen + strlen (suffix) + 1;
if (bufsize < needed)
dump_file = xpalloc (dump_file, &bufsize, needed - bufsize, -1, 1);
strcpy (dump_file + exenamelen, suffix);
result = pdumper_load (dump_file);
if (result == PDUMPER_LOAD_SUCCESS)
goto out;
if (result != PDUMPER_LOAD_FILE_NOT_FOUND)
fatal ("could not load dump file \"%s\": %s",
dump_file, dump_error_to_string (result));
ptrdiff_t strip_suffix_length = strlen (strip_suffix);
ptrdiff_t prefix_length = exenamelen - strip_suffix_length;
if (0 <= prefix_length
&& !memcmp (&emacs_executable[prefix_length], strip_suffix,
strip_suffix_length))
exenamelen = prefix_length;
}
ptrdiff_t needed = exenamelen + strlen (suffix) + 1;
dump_file = xpalloc (NULL, &bufsize, needed - bufsize, -1, 1);
memcpy (dump_file, emacs_executable, exenamelen);
strcpy (dump_file + exenamelen, suffix);
result = pdumper_load (dump_file, emacs_executable);
if (result == PDUMPER_LOAD_SUCCESS)
goto out;
if (result != PDUMPER_LOAD_FILE_NOT_FOUND)
fatal ("could not load dump file \"%s\": %s",
dump_file, dump_error_to_string (result));
hardcoded:
#ifdef WINDOWSNT
/* On MS-Windows, PATH_EXEC normally starts with a literal
@ -895,12 +917,11 @@ load_pdump (int argc, char **argv)
/* Look for "emacs.pdmp" in PATH_EXEC. We hardcode "emacs" in
"emacs.pdmp" so that the Emacs binary still works if the user
copies and renames it. */
const char *argv0_base = "emacs";
ptrdiff_t needed = (strlen (path_exec)
+ 1
+ strlen (argv0_base)
+ strlen (suffix)
+ 1);
needed = (strlen (path_exec)
+ 1
+ strlen (argv0_base)
+ strlen (suffix)
+ 1);
if (bufsize < needed)
{
xfree (dump_file);
@ -908,7 +929,21 @@ load_pdump (int argc, char **argv)
}
sprintf (dump_file, "%s%c%s%s",
path_exec, DIRECTORY_SEP, argv0_base, suffix);
result = pdumper_load (dump_file);
/* Assume the Emacs binary lives in a sibling directory as set up by
the default installation configuration. */
const char *go_up = "../../../../bin/";
needed += (strip_suffix ? strlen (strip_suffix) : 0)
- strlen (suffix) + strlen (go_up);
if (exec_bufsize < needed)
{
xfree (emacs_executable);
emacs_executable = xpalloc (NULL, &exec_bufsize, needed - exec_bufsize,
-1, 1);
}
sprintf (emacs_executable, "%s%c%s%s%s",
path_exec, DIRECTORY_SEP, go_up, argv0_base,
strip_suffix ? strip_suffix : "");
result = pdumper_load (dump_file, emacs_executable);
if (result == PDUMPER_LOAD_FILE_NOT_FOUND)
{
@ -943,7 +978,7 @@ load_pdump (int argc, char **argv)
#endif
sprintf (dump_file, "%s%c%s%s",
path_exec, DIRECTORY_SEP, argv0_base, suffix);
result = pdumper_load (dump_file);
result = pdumper_load (dump_file, emacs_executable);
}
if (result != PDUMPER_LOAD_SUCCESS)
@ -955,6 +990,7 @@ load_pdump (int argc, char **argv)
out:
xfree (dump_file);
xfree (emacs_executable);
}
#endif /* HAVE_PDUMPER */
@ -1809,6 +1845,9 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
init_json ();
#endif
if (!initialized)
syms_of_comp ();
no_loadup
= argmatch (argv, argc, "-nl", "--no-loadup", 6, NULL, &skip_args);
@ -1980,7 +2019,8 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
/* Init buffer storage and default directory of main buffer. */
init_buffer ();
init_callproc_1 (); /* Must precede init_cmdargs and init_sys_modes. */
/* Must precede init_cmdargs and init_sys_modes. */
init_callproc_1 ();
/* Must precede init_lread. */
init_cmdargs (argc, argv, skip_args, original_pwd);
@ -2160,6 +2200,11 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem
#endif
keys_of_keyboard ();
#ifdef HAVE_NATIVE_COMP
/* Must be after the last defsubr has run. */
hash_native_abi ();
#endif
}
else
{
@ -2598,6 +2643,10 @@ all of which are called before Emacs is actually killed. */
unlink (SSDATA (listfile));
}
#ifdef HAVE_NATIVE_COMP
eln_load_path_final_clean_up ();
#endif
if (FIXNUMP (arg))
exit_code = (XFIXNUM (arg) < 0
? XFIXNUM (arg) | INT_MIN
@ -3248,7 +3297,18 @@ because they do not depend on external libraries and are always available.
Also note that this is not a generic facility for accessing external
libraries; only those already known by Emacs will be loaded. */);
#ifdef WINDOWSNT
/* FIXME: We may need to load libgccjit when dumping before
term/w32-win.el defines `dynamic-library-alist`. This will fail
if that variable is empty, so add libgccjit-0.dll to it. */
if (will_dump_p ())
Vdynamic_library_alist = list1 (list2 (Qgccjit,
build_string ("libgccjit-0.dll")));
else
Vdynamic_library_alist = Qnil;
#else
Vdynamic_library_alist = Qnil;
#endif
Fput (intern_c_string ("dynamic-library-alist"), Qrisky_local_variable, Qt);
#ifdef WINDOWSNT

4
src/epaths.in
View file

@ -27,6 +27,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */
*/
#define PATH_LOADSEARCH "/usr/local/share/emacs/lisp"
/* Like PATH_LOADSEARCH, but contains the relative path from the
installation directory.
*/
#define PATH_REL_LOADSEARCH ""
/* Like PATH_LOADSEARCH, but contains the non-standard pieces.
These are the site-lisp directories. Configure sets this to

121
src/eval.c
View file

@ -219,8 +219,17 @@ void
init_eval_once (void)
{
/* Don't forget to update docs (lispref node "Local Variables"). */
max_specpdl_size = 1800; /* See bug#46818. */
max_lisp_eval_depth = 800;
if (!NATIVE_COMP_FLAG)
{
max_specpdl_size = 1800; /* See bug#46818. */
max_lisp_eval_depth = 800;
}
else
{
/* Original values increased for comp.el. */
max_specpdl_size = 2500;
max_lisp_eval_depth = 1600;
}
Vrun_hooks = Qnil;
pdumper_do_now_and_after_load (init_eval_once_for_pdumper);
}
@ -1521,6 +1530,90 @@ 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_1 but call BFUN with ARG1, ARG2, ARG3,
ARG4, ARG5 as its arguments. */
Lisp_Object
internal_condition_case_5 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object,
Lisp_Object),
Lisp_Object arg1, Lisp_Object arg2,
Lisp_Object arg3, Lisp_Object arg4,
Lisp_Object arg5, 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, arg5);
eassert (handlerlist == c);
handlerlist = c->next;
return val;
}
}
/* Like internal_condition_case but call BFUN with NARGS as first,
and ARGS as second argument. */
@ -2356,7 +2449,7 @@ eval_sub (Lisp_Object form)
else if (!NILP (fun) && (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
fun = indirect_function (fun);
if (SUBRP (fun))
if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
{
Lisp_Object args_left = original_args;
ptrdiff_t numargs = list_length (args_left);
@ -2459,7 +2552,9 @@ eval_sub (Lisp_Object form)
}
}
}
else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
else if (COMPILEDP (fun)
|| SUBR_NATIVE_COMPILED_DYNP (fun)
|| MODULE_FUNCTIONP (fun))
return apply_lambda (fun, original_args, count);
else
{
@ -2937,9 +3032,11 @@ usage: (funcall FUNCTION &rest ARGUMENTS) */)
&& (fun = XSYMBOL (fun)->u.s.function, SYMBOLP (fun)))
fun = indirect_function (fun);
if (SUBRP (fun))
if (SUBRP (fun) && !SUBR_NATIVE_COMPILED_DYNP (fun))
val = funcall_subr (XSUBR (fun), numargs, args + 1);
else if (COMPILEDP (fun) || MODULE_FUNCTIONP (fun))
else if (COMPILEDP (fun)
|| SUBR_NATIVE_COMPILED_DYNP (fun)
|| MODULE_FUNCTIONP (fun))
val = funcall_lambda (fun, numargs, args + 1);
else
{
@ -3149,6 +3246,11 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
else if (MODULE_FUNCTIONP (fun))
return funcall_module (fun, nargs, arg_vector);
#endif
else if (SUBR_NATIVE_COMPILED_DYNP (fun))
{
syms_left = XSUBR (fun)->lambda_list[0];
lexenv = Qnil;
}
else
emacs_abort ();
@ -3209,6 +3311,13 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs,
if (CONSP (fun))
val = Fprogn (XCDR (XCDR (fun)));
else if (SUBR_NATIVE_COMPILEDP (fun))
{
eassert (SUBR_NATIVE_COMPILED_DYNP (fun));
/* No need to use funcall_subr as we have zero arguments by
construction. */
val = XSUBR (fun)->function.a0 ();
}
else
val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL);

43
src/fns.c
View file

@ -4492,6 +4492,15 @@ check_mutable_hash_table (Lisp_Object obj, struct Lisp_Hash_Table *h)
eassert (!PURE_P (h));
}
static void
collect_interval (INTERVAL interval, Lisp_Object collector)
{
nconc2 (collector,
list1(list3 (make_fixnum (interval->position),
make_fixnum (interval->position + LENGTH (interval)),
interval->plist)));
}
/* Put an entry into hash table H that associates KEY with VALUE.
HASH is a previously computed hash code of KEY.
Value is the index of the entry in H matching KEY. */
@ -4949,6 +4958,30 @@ Hash codes are not guaranteed to be preserved across Emacs sessions. */)
return hashfn_equal (obj, NULL);
}
DEFUN ("sxhash-equal-including-properties", Fsxhash_equal_including_properties,
Ssxhash_equal_including_properties, 1, 1, 0,
doc: /* Return an integer hash code for OBJ suitable for
`equal-including-properties'.
If (sxhash-equal-including-properties A B), then
(= (sxhash-equal-including-properties A) (sxhash-equal-including-properties B)).
Hash codes are not guaranteed to be preserved across Emacs sessions. */)
(Lisp_Object obj)
{
if (STRINGP (obj))
{
Lisp_Object collector = Fcons (Qnil, Qnil);
traverse_intervals (string_intervals (obj), 0, collect_interval,
collector);
return
make_ufixnum (
SXHASH_REDUCE (sxhash_combine (sxhash (obj),
sxhash (CDR (collector)))));
}
return hashfn_equal (obj, NULL);
}
DEFUN ("make-hash-table", Fmake_hash_table, Smake_hash_table, 0, MANY, 0,
doc: /* Create and return a new hash table.
@ -5832,15 +5865,6 @@ Case is always significant and text properties are ignored. */)
return make_int (string_byte_to_char (haystack, res - SSDATA (haystack)));
}
static void
collect_interval (INTERVAL interval, Lisp_Object collector)
{
nconc2 (collector,
list1(list3 (make_fixnum (interval->position),
make_fixnum (interval->position + LENGTH (interval)),
interval->plist)));
}
DEFUN ("object-intervals", Fobject_intervals, Sobject_intervals, 1, 1, 0,
doc: /* Return a copy of the text properties of OBJECT.
OBJECT must be a buffer or a string.
@ -5922,6 +5946,7 @@ syms_of_fns (void)
defsubr (&Ssxhash_eq);
defsubr (&Ssxhash_eql);
defsubr (&Ssxhash_equal);
defsubr (&Ssxhash_equal_including_properties);
defsubr (&Smake_hash_table);
defsubr (&Scopy_hash_table);
defsubr (&Shash_table_count);

4
src/image.c
View file

@ -511,7 +511,7 @@ image_create_bitmap_from_file (struct frame *f, Lisp_Object file)
/* Search bitmap-file-path for the file, if appropriate. */
if (openp (Vx_bitmap_file_path, file, Qnil, &found,
make_fixnum (R_OK), false)
make_fixnum (R_OK), false, false)
< 0)
return -1;
@ -3152,7 +3152,7 @@ image_find_image_fd (Lisp_Object file, int *pfd)
/* Try to find FILE in data-directory/images, then x-bitmap-file-path. */
fd = openp (search_path, file, Qnil, &file_found,
pfd ? Qt : make_fixnum (R_OK), false);
pfd ? Qt : make_fixnum (R_OK), false, false);
if (fd >= 0 || fd == -2)
{
file_found = ENCODE_FILE (file_found);

76
src/lisp.h
View file

@ -294,12 +294,12 @@ DEFINE_GDB_SYMBOL_END (VALMASK)
/* Lisp_Word is a scalar word suitable for holding a tagged pointer or
integer. Usually it is a pointer to a deliberately-incomplete type
'union Lisp_X'. However, it is EMACS_INT when Lisp_Objects and
'struct Lisp_X'. However, it is EMACS_INT when Lisp_Objects and
pointers differ in width. */
#define LISP_WORDS_ARE_POINTERS (EMACS_INT_MAX == INTPTR_MAX)
#if LISP_WORDS_ARE_POINTERS
typedef union Lisp_X *Lisp_Word;
typedef struct Lisp_X *Lisp_Word;
#else
typedef EMACS_INT Lisp_Word;
#endif
@ -563,6 +563,7 @@ enum Lisp_Fwd_Type
#ifdef CHECK_LISP_OBJECT_TYPE
typedef struct Lisp_Object { Lisp_Word i; } Lisp_Object;
# define LISP_OBJECT_IS_STRUCT
# define LISP_INITIALLY(w) {w}
# undef CHECK_LISP_OBJECT_TYPE
enum CHECK_LISP_OBJECT_TYPE { CHECK_LISP_OBJECT_TYPE = true };
@ -1068,6 +1069,7 @@ enum pvec_type
PVEC_MUTEX,
PVEC_CONDVAR,
PVEC_MODULE_FUNCTION,
PVEC_NATIVE_COMP_UNIT,
/* These should be last, for internal_equal and sxhash_obj. */
PVEC_COMPILED,
@ -1313,6 +1315,7 @@ dead_object (void)
#define XSETTHREAD(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_THREAD))
#define XSETMUTEX(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_MUTEX))
#define XSETCONDVAR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CONDVAR))
#define XSETNATIVE_COMP_UNIT(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_NATIVE_COMP_UNIT))
/* Efficiently convert a pointer to a Lisp object and back. The
pointer is represented as a fixnum, so the garbage collector
@ -2036,6 +2039,8 @@ CHAR_TABLE_SET (Lisp_Object ct, int idx, Lisp_Object val)
char_table_set (ct, idx, val);
}
#include "comp.h"
/* This structure describes a built-in function.
It is generated by the DEFUN macro only.
defsubr makes it into a Lisp object. */
@ -2058,8 +2063,15 @@ struct Lisp_Subr
} function;
short min_args, max_args;
const char *symbol_name;
const char *intspec;
union {
const char *intspec;
Lisp_Object native_intspec;
};
EMACS_INT doc;
Lisp_Object native_comp_u[NATIVE_COMP_FLAG];
char *native_c_name[NATIVE_COMP_FLAG];
Lisp_Object lambda_list[NATIVE_COMP_FLAG];
Lisp_Object type[NATIVE_COMP_FLAG];
} GCALIGNED_STRUCT;
union Aligned_Lisp_Subr
{
@ -2972,6 +2984,12 @@ CHECK_INTEGER (Lisp_Object x)
{
CHECK_TYPE (INTEGERP (x), Qnumberp, x);
}
INLINE void
CHECK_SUBR (Lisp_Object x)
{
CHECK_TYPE (SUBRP (x), Qsubrp, x);
}
/* If we're not dumping using the legacy dumper and we might be using
@ -3019,7 +3037,7 @@ CHECK_INTEGER (Lisp_Object x)
static union Aligned_Lisp_Subr sname = \
{{{ PVEC_SUBR << PSEUDOVECTOR_AREA_BITS }, \
{ .a ## maxargs = fnname }, \
minargs, maxargs, lname, intspec, 0}}; \
minargs, maxargs, lname, {intspec}, 0}}; \
Lisp_Object fnname
/* defsubr (Sname);
@ -4066,10 +4084,11 @@ LOADHIST_ATTACH (Lisp_Object x)
if (initialized)
Vcurrent_load_list = Fcons (x, Vcurrent_load_list);
}
extern bool suffix_p (Lisp_Object, const char *);
extern Lisp_Object save_match_data_load (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object, Lisp_Object);
extern int openp (Lisp_Object, Lisp_Object, Lisp_Object,
Lisp_Object *, Lisp_Object, bool);
Lisp_Object *, Lisp_Object, bool, bool);
enum { S2N_IGNORE_TRAILING = 1 };
extern Lisp_Object string_to_number (char const *, int, ptrdiff_t *);
extern void map_obarray (Lisp_Object, void (*) (Lisp_Object, Lisp_Object),
@ -4140,6 +4159,9 @@ extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_
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_5 (Lisp_Object (*) (Lisp_Object, 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 *));
@ -4705,7 +4727,11 @@ extern void syms_of_lcms2 (void);
#endif
#ifdef HAVE_ZLIB
#include <stdio.h>
/* Defined in decompress.c. */
extern int md5_gz_stream (FILE *, void *);
extern void syms_of_decompress (void);
#endif
@ -4727,6 +4753,46 @@ extern void syms_of_profiler (void);
extern char *emacs_root_dir (void);
#endif /* DOS_NT */
#ifdef HAVE_NATIVE_COMP
INLINE bool
SUBR_NATIVE_COMPILEDP (Lisp_Object a)
{
return SUBRP (a) && !NILP (XSUBR (a)->native_comp_u[0]);
}
INLINE bool
SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a)
{
return SUBR_NATIVE_COMPILEDP (a) && !NILP (XSUBR (a)->lambda_list[0]);
}
INLINE Lisp_Object
SUBR_TYPE (Lisp_Object a)
{
return XSUBR (a)->type[0];
}
INLINE struct Lisp_Native_Comp_Unit *
allocate_native_comp_unit (void)
{
return ALLOCATE_ZEROED_PSEUDOVECTOR (struct Lisp_Native_Comp_Unit,
data_impure_vec, PVEC_NATIVE_COMP_UNIT);
}
#else
INLINE bool
SUBR_NATIVE_COMPILEDP (Lisp_Object a)
{
return false;
}
INLINE bool
SUBR_NATIVE_COMPILED_DYNP (Lisp_Object a)
{
return false;
}
#endif
/* Defined in lastfile.c. */
extern char my_edata[];
extern char my_endbss[];

231
src/lread.c
View file

@ -1119,7 +1119,7 @@ This uses the variables `load-suffixes' and `load-file-rep-suffixes'. */)
}
/* Return true if STRING ends with SUFFIX. */
static bool
bool
suffix_p (Lisp_Object string, const char *suffix)
{
ptrdiff_t suffix_len = strlen (suffix);
@ -1138,6 +1138,24 @@ close_infile_unwind (void *arg)
infile = prev_infile;
}
/* Compute the filename we want in `load-history' and `load-file-name'. */
static Lisp_Object
compute_found_effective (Lisp_Object found)
{
/* Reconstruct the .elc filename. */
Lisp_Object src_name =
Fgethash (Ffile_name_nondirectory (found), Vcomp_eln_to_el_h, Qnil);
if (NILP (src_name))
/* Manual eln load. */
return found;
if (suffix_p (src_name, "el.gz"))
src_name = Fsubstring (src_name, make_fixnum (0), make_fixnum (-3));
return concat2 (src_name, build_string ("c"));
}
DEFUN ("load", Fload, Sload, 1, 5, 0,
doc: /* Execute a file of Lisp code named FILE.
First try FILE with `.elc' appended, then try with `.el', then try
@ -1222,6 +1240,8 @@ Return t if the file exists and loads successfully. */)
else
file = Fsubstitute_in_file_name (file);
bool no_native = suffix_p (file, ".elc");
/* Avoid weird lossage with null string as arg,
since it would try to load a directory as a Lisp file. */
if (SCHARS (file) == 0)
@ -1245,7 +1265,7 @@ Return t if the file exists and loads successfully. */)
|| suffix_p (file, MODULES_SECONDARY_SUFFIX)
#endif
#endif
)
|| (NATIVE_COMP_FLAG && suffix_p (file, NATIVE_ELISP_SUFFIX)))
must_suffix = Qnil;
/* Don't insist on adding a suffix
if the argument includes a directory name. */
@ -1262,7 +1282,9 @@ Return t if the file exists and loads successfully. */)
suffixes = CALLN (Fappend, suffixes, Vload_file_rep_suffixes);
}
fd = openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer);
fd =
openp (Vload_path, file, suffixes, &found, Qnil, load_prefer_newer,
no_native);
}
if (fd == -1)
@ -1323,6 +1345,9 @@ Return t if the file exists and loads successfully. */)
bool is_module = false;
#endif
bool is_native_elisp =
NATIVE_COMP_FLAG && suffix_p (found, NATIVE_ELISP_SUFFIX) ? true : false;
/* Check if we're stuck in a recursive load cycle.
2000-09-21: It's not possible to just check for the file loaded
@ -1349,11 +1374,15 @@ Return t if the file exists and loads successfully. */)
Vload_source_file_function. */
specbind (Qlexical_binding, Qnil);
/* Get the name for load-history. */
Lisp_Object found_eff =
is_native_elisp
? compute_found_effective (found)
: found;
hist_file_name = (! NILP (Vpurify_flag)
? concat2 (Ffile_name_directory (file),
Ffile_name_nondirectory (found))
: found) ;
Ffile_name_nondirectory (found_eff))
: found_eff);
version = -1;
@ -1417,7 +1446,7 @@ Return t if the file exists and loads successfully. */)
} /* !load_prefer_newer */
}
}
else if (!is_module)
else if (!is_module && !is_native_elisp)
{
/* We are loading a source file (*.el). */
if (!NILP (Vload_source_file_function))
@ -1444,7 +1473,7 @@ Return t if the file exists and loads successfully. */)
stream = NULL;
errno = EINVAL;
}
else if (!is_module)
else if (!is_module && !is_native_elisp)
{
#ifdef WINDOWSNT
emacs_close (fd);
@ -1460,7 +1489,7 @@ Return t if the file exists and loads successfully. */)
might be accessed by the unbind_to call below. */
struct infile input;
if (is_module)
if (is_module || is_native_elisp)
{
/* `module-load' uses the file name, so we can close the stream
now. */
@ -1487,6 +1516,8 @@ Return t if the file exists and loads successfully. */)
{
if (is_module)
message_with_string ("Loading %s (module)...", file, 1);
else if (is_native_elisp)
message_with_string ("Loading %s (native compiled elisp)...", file, 1);
else if (!compiled)
message_with_string ("Loading %s (source)...", file, 1);
else if (newer)
@ -1496,7 +1527,8 @@ Return t if the file exists and loads successfully. */)
message_with_string ("Loading %s...", file, 1);
}
specbind (Qload_file_name, found);
specbind (Qload_file_name, found_eff);
specbind (Qload_true_file_name, found);
specbind (Qinhibit_file_name_operation, Qnil);
specbind (Qload_in_progress, Qt);
@ -1511,6 +1543,19 @@ Return t if the file exists and loads successfully. */)
/* This cannot happen. */
emacs_abort ();
#endif
}
else if (is_native_elisp)
{
#ifdef HAVE_NATIVE_COMP
specbind (Qcurrent_load_list, Qnil);
LOADHIST_ATTACH (hist_file_name);
Fnative_elisp_load (found, Qnil);
build_load_history (hist_file_name, true);
#else
/* This cannot happen. */
emacs_abort ();
#endif
}
else
{
@ -1547,6 +1592,8 @@ Return t if the file exists and loads successfully. */)
{
if (is_module)
message_with_string ("Loading %s (module)...done", file, 1);
else if (is_native_elisp)
message_with_string ("Loading %s (native compiled elisp)...done", file, 1);
else if (!compiled)
message_with_string ("Loading %s (source)...done", file, 1);
else if (newer)
@ -1592,12 +1639,108 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */)
(Lisp_Object filename, Lisp_Object path, Lisp_Object suffixes, Lisp_Object predicate)
{
Lisp_Object file;
int fd = openp (path, filename, suffixes, &file, predicate, false);
int fd = openp (path, filename, suffixes, &file, predicate, false, false);
if (NILP (predicate) && fd >= 0)
emacs_close (fd);
return file;
}
#ifdef HAVE_NATIVE_COMP
static bool
maybe_swap_for_eln1 (Lisp_Object src_name, Lisp_Object eln_name,
Lisp_Object *filename, int *fd, struct timespec mtime)
{
struct stat eln_st;
int eln_fd = emacs_open (SSDATA (ENCODE_FILE (eln_name)), O_RDONLY, 0);
if (eln_fd > 0)
{
if (fstat (eln_fd, &eln_st) || S_ISDIR (eln_st.st_mode))
emacs_close (eln_fd);
else
{
struct timespec eln_mtime = get_stat_mtime (&eln_st);
if (timespec_cmp (eln_mtime, mtime) >= 0)
{
emacs_close (*fd);
*fd = eln_fd;
*filename = eln_name;
/* Store the eln -> el relation. */
Fputhash (Ffile_name_nondirectory (eln_name),
src_name, Vcomp_eln_to_el_h);
return true;
}
else
emacs_close (eln_fd);
}
}
return false;
}
#endif
/* Look for a suitable .eln file to be loaded in place of FILENAME.
If found replace the content of FILENAME and FD. */
static void
maybe_swap_for_eln (bool no_native, Lisp_Object *filename, int *fd,
struct timespec mtime)
{
#ifdef HAVE_NATIVE_COMP
if (no_native
|| load_no_native)
Fputhash (*filename, Qt, V_comp_no_native_file_h);
else
Fremhash (*filename, V_comp_no_native_file_h);
if (no_native
|| load_no_native
|| !suffix_p (*filename, ".elc"))
return;
/* Search eln in the eln-cache directories. */
Lisp_Object eln_path_tail = Vcomp_eln_load_path;
Lisp_Object src_name =
Fsubstring (*filename, Qnil, make_fixnum (-1));
if (NILP (Ffile_exists_p (src_name)))
{
src_name = concat2 (src_name, build_string (".gz"));
if (NILP (Ffile_exists_p (src_name)))
{
if (!NILP (find_symbol_value (Qcomp_warning_on_missing_source)))
call2 (intern_c_string ("display-warning"),
Qcomp,
CALLN (Fformat,
build_string ("Cannot look-up eln file as no source "
"file was found for %s"),
*filename));
return;
}
}
Lisp_Object eln_rel_name = Fcomp_el_to_eln_rel_filename (src_name);
Lisp_Object dir = Qnil;
FOR_EACH_TAIL_SAFE (eln_path_tail)
{
dir = XCAR (eln_path_tail);
Lisp_Object eln_name =
Fexpand_file_name (eln_rel_name,
Fexpand_file_name (Vcomp_native_version_dir, dir));
if (maybe_swap_for_eln1 (src_name, eln_name, filename, fd, mtime))
return;
}
/* Look also in preloaded subfolder of the last entry in
`comp-eln-load-path'. */
dir = Fexpand_file_name (build_string ("preloaded"),
Fexpand_file_name (Vcomp_native_version_dir,
dir));
maybe_swap_for_eln1 (src_name, Fexpand_file_name (eln_rel_name, dir),
filename, fd, mtime);
#endif
}
/* Search for a file whose name is STR, looking in directories
in the Lisp list PATH, and trying suffixes from SUFFIX.
On success, return a file descriptor (or 1 or -2 as described below).
@ -1622,11 +1765,14 @@ directories, make sure the PREDICATE function returns `dir-ok' for them. */)
If NEWER is true, try all SUFFIXes and return the result for the
newest file that exists. Does not apply to remote files,
or if a non-nil and non-t PREDICATE is specified. */
or if a non-nil and non-t PREDICATE is specified.
if NO_NATIVE is true do not try to load native code. */
int
openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
Lisp_Object *storeptr, Lisp_Object predicate, bool newer)
Lisp_Object *storeptr, Lisp_Object predicate, bool newer,
bool no_native)
{
ptrdiff_t fn_size = 100;
char buf[100];
@ -1836,6 +1982,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
}
else
{
maybe_swap_for_eln (no_native, &string, &fd,
get_stat_mtime (&st));
/* We succeeded; return this descriptor and filename. */
if (storeptr)
*storeptr = string;
@ -1847,6 +1995,8 @@ openp (Lisp_Object path, Lisp_Object str, Lisp_Object suffixes,
/* No more suffixes. Return the newest. */
if (0 <= save_fd && ! CONSP (XCDR (tail)))
{
maybe_swap_for_eln (no_native, &save_string, &save_fd,
save_mtime);
if (storeptr)
*storeptr = save_string;
SAFE_FREE ();
@ -1942,8 +2092,8 @@ readevalloop_1 (int old)
static AVOID
end_of_file_error (void)
{
if (STRINGP (Vload_file_name))
xsignal1 (Qend_of_file, Vload_file_name);
if (STRINGP (Vload_true_file_name))
xsignal1 (Qend_of_file, Vload_true_file_name);
xsignal0 (Qend_of_file);
}
@ -4204,10 +4354,14 @@ intern_c_string_1 (const char *str, ptrdiff_t len)
if (!SYMBOLP (tem))
{
/* Creating a non-pure string from a string literal not implemented yet.
We could just use make_string here and live with the extra copy. */
eassert (!NILP (Vpurify_flag));
tem = intern_driver (make_pure_c_string (str, len), obarray, tem);
Lisp_Object string;
if (NILP (Vpurify_flag))
string = make_string (str, len);
else
string = make_pure_c_string (str, len);
tem = intern_driver (string, obarray, tem);
}
return tem;
}
@ -4467,6 +4621,10 @@ defsubr (union Aligned_Lisp_Subr *aname)
XSETPVECTYPE (sname, PVEC_SUBR);
XSETSUBR (tem, sname);
set_symbol_function (sym, tem);
#ifdef HAVE_NATIVE_COMP
eassert (NILP (Vcomp_abi_hash));
Vcomp_subr_list = Fpurecopy (Fcons (tem, Vcomp_subr_list));
#endif
}
#ifdef NOTDEF /* Use fset in subr.el now! */
@ -4767,6 +4925,7 @@ init_lread (void)
load_in_progress = 0;
Vload_file_name = Qnil;
Vload_true_file_name = Qnil;
Vstandard_input = Qt;
Vloads_in_progress = Qnil;
}
@ -4891,20 +5050,15 @@ This list includes suffixes for both compiled and source Emacs Lisp files.
This list should not include the empty string.
`load' and related functions try to append these suffixes, in order,
to the specified file name if a suffix is allowed or required. */);
#ifdef HAVE_MODULES
#ifdef MODULES_SECONDARY_SUFFIX
Vload_suffixes = list4 (build_pure_c_string (".elc"),
build_pure_c_string (".el"),
build_pure_c_string (MODULES_SUFFIX),
build_pure_c_string (MODULES_SECONDARY_SUFFIX));
#else
Vload_suffixes = list3 (build_pure_c_string (".elc"),
build_pure_c_string (".el"),
build_pure_c_string (MODULES_SUFFIX));
#endif
#else
Vload_suffixes = list2 (build_pure_c_string (".elc"),
build_pure_c_string (".el"));
#ifdef HAVE_MODULES
Vload_suffixes = Fcons (build_pure_c_string (MODULES_SUFFIX), Vload_suffixes);
#ifdef MODULES_SECONDARY_SUFFIX
Vload_suffixes =
Fcons (build_pure_c_string (MODULES_SECONDARY_SUFFIX), Vload_suffixes);
#endif
#endif
DEFVAR_LISP ("module-file-suffix", Vmodule_file_suffix,
doc: /* Suffix of loadable module file, or nil if modules are not supported. */);
@ -4971,9 +5125,17 @@ directory. These file names are converted to absolute at startup. */);
Vload_history = Qnil;
DEFVAR_LISP ("load-file-name", Vload_file_name,
doc: /* Full name of file being loaded by `load'. */);
doc: /* Full name of file being loaded by `load'.
In case of native code being loaded this is indicating the
corresponding bytecode filename. Use `load-true-file-name' to obtain
the .eln filename. */);
Vload_file_name = Qnil;
DEFVAR_LISP ("load-true-file-name", Vload_true_file_name,
doc: /* Full name of file being loaded by `load'. */);
Vload_true_file_name = Qnil;
DEFVAR_LISP ("user-init-file", Vuser_init_file,
doc: /* File name, including directory, of user's initialization file.
If the file loaded had extension `.elc', and the corresponding source file
@ -5093,6 +5255,10 @@ Note that if you customize this, obviously it will not affect files
that are loaded before your customizations are read! */);
load_prefer_newer = 0;
DEFVAR_BOOL ("load-no-native", load_no_native,
doc: /* Non-nil means not to load a .eln file when a .elc was requested. */);
load_no_native = false;
/* Vsource_directory was initialized in init_lread. */
DEFSYM (Qcurrent_load_list, "current-load-list");
@ -5115,6 +5281,7 @@ that are loaded before your customizations are read! */);
DEFSYM (Qfunction, "function");
DEFSYM (Qload, "load");
DEFSYM (Qload_file_name, "load-file-name");
DEFSYM (Qload_true_file_name, "load-true-file-name");
DEFSYM (Qeval_buffer_list, "eval-buffer-list");
DEFSYM (Qdir_ok, "dir-ok");
DEFSYM (Qdo_after_load_evaluation, "do-after-load-evaluation");

331
src/pdumper.c
View file

@ -121,6 +121,9 @@ static const char dump_magic[16] = {
static pdumper_hook dump_hooks[24];
static int nr_dump_hooks = 0;
static pdumper_hook dump_late_hooks[24];
static int nr_dump_late_hooks = 0;
static struct
{
void *mem;
@ -175,6 +178,8 @@ enum dump_reloc_type
/* dump_ptr = dump_ptr + dump_base */
RELOC_DUMP_TO_DUMP_PTR_RAW,
/* dump_mpz = [rebuild bignum] */
RELOC_NATIVE_COMP_UNIT,
RELOC_NATIVE_SUBR,
RELOC_BIGNUM,
/* dump_lv = make_lisp_ptr (dump_lv + dump_base,
type - RELOC_DUMP_TO_DUMP_LV)
@ -317,6 +322,20 @@ dump_fingerprint (char const *label,
fprintf (stderr, "%s: %.*s\n", label, hexbuf_size, hexbuf);
}
/* To be used if some order in the relocation process has to be enforced. */
enum reloc_phase
{
/* First to run. Place every relocation with no dependency here. */
EARLY_RELOCS,
/* Late and very late relocs are relocated at the very last after
all hooks has been run. All lisp machinery is at disposal
(memory allocation allowed too). */
LATE_RELOCS,
VERY_LATE_RELOCS,
/* Fake, must be last. */
RELOC_NUM_PHASES
};
/* Format of an Emacs dump file. All offsets are relative to
the beginning of the file. An Emacs dump file is coupled
to exactly the Emacs binary that produced it, so details of
@ -344,7 +363,7 @@ struct dump_header
/* Relocation table for the dump file; each entry is a
struct dump_reloc. */
struct dump_table_locator dump_relocs;
struct dump_table_locator dump_relocs[RELOC_NUM_PHASES];
/* "Relocation" table we abuse to hold information about the
location and type of each lisp object in the dump. We need for
@ -425,6 +444,7 @@ enum cold_op
COLD_OP_CHARSET,
COLD_OP_BUFFER,
COLD_OP_BIGNUM,
COLD_OP_NATIVE_SUBR,
};
/* This structure controls what operations we perform inside
@ -524,7 +544,7 @@ struct dump_context
Lisp_Object cold_queue;
/* Relocations in the dump. */
Lisp_Object dump_relocs;
Lisp_Object dump_relocs[RELOC_NUM_PHASES];
/* Object starts. */
Lisp_Object object_starts;
@ -919,7 +939,7 @@ dump_note_reachable (struct dump_context *ctx, Lisp_Object object)
static void *
dump_object_emacs_ptr (Lisp_Object lv)
{
if (SUBRP (lv))
if (SUBRP (lv) && !SUBR_NATIVE_COMPILEDP (lv))
return XSUBR (lv);
if (dump_builtin_symbol_p (lv))
return XSYMBOL (lv);
@ -1405,7 +1425,7 @@ dump_reloc_dump_to_emacs_ptr_raw (struct dump_context *ctx,
dump_off dump_offset)
{
if (ctx->flags.dump_object_contents)
dump_push (&ctx->dump_relocs,
dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (RELOC_DUMP_TO_EMACS_PTR_RAW),
dump_off_to_lisp (dump_offset)));
}
@ -1438,7 +1458,7 @@ dump_reloc_dump_to_dump_lv (struct dump_context *ctx,
emacs_abort ();
}
dump_push (&ctx->dump_relocs,
dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (reloc_type),
dump_off_to_lisp (dump_offset)));
}
@ -1454,7 +1474,7 @@ dump_reloc_dump_to_dump_ptr_raw (struct dump_context *ctx,
dump_off dump_offset)
{
if (ctx->flags.dump_object_contents)
dump_push (&ctx->dump_relocs,
dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (RELOC_DUMP_TO_DUMP_PTR_RAW),
dump_off_to_lisp (dump_offset)));
}
@ -1487,7 +1507,7 @@ dump_reloc_dump_to_emacs_lv (struct dump_context *ctx,
emacs_abort ();
}
dump_push (&ctx->dump_relocs,
dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (reloc_type),
dump_off_to_lisp (dump_offset)));
}
@ -2200,7 +2220,7 @@ dump_bignum (struct dump_context *ctx, Lisp_Object object)
Lisp_Bignum instead of the actual mpz field so that the
relocation offset is aligned. The relocation-application
code knows to actually advance past the header. */
dump_push (&ctx->dump_relocs,
dump_push (&ctx->dump_relocs[EARLY_RELOCS],
list2 (make_fixnum (RELOC_BIGNUM),
dump_off_to_lisp (bignum_offset)));
}
@ -2840,21 +2860,74 @@ dump_bool_vector (struct dump_context *ctx, const struct Lisp_Vector *v)
static dump_off
dump_subr (struct dump_context *ctx, const struct Lisp_Subr *subr)
{
#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_594AB72B54)
#if CHECK_STRUCTS && !defined (HASH_Lisp_Subr_AA236F7759)
# error "Lisp_Subr changed. See CHECK_STRUCTS comment in config.h."
#endif
struct Lisp_Subr out;
dump_object_start (ctx, &out, sizeof (out));
DUMP_FIELD_COPY (&out, subr, header.size);
dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0]))
out.function.a0 = NULL;
else
dump_field_emacs_ptr (ctx, &out, subr, &subr->function.a0);
DUMP_FIELD_COPY (&out, subr, min_args);
DUMP_FIELD_COPY (&out, subr, max_args);
dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name);
dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec);
if (NATIVE_COMP_FLAG && !NILP (subr->native_comp_u[0]))
{
dump_field_fixup_later (ctx, &out, subr, &subr->symbol_name);
dump_remember_cold_op (ctx,
COLD_OP_NATIVE_SUBR,
make_lisp_ptr ((void *) subr, Lisp_Vectorlike));
dump_field_lv (ctx, &out, subr, &subr->native_intspec, WEIGHT_NORMAL);
}
else
{
dump_field_emacs_ptr (ctx, &out, subr, &subr->symbol_name);
dump_field_emacs_ptr (ctx, &out, subr, &subr->intspec);
}
DUMP_FIELD_COPY (&out, subr, doc);
return dump_object_finish (ctx, &out, sizeof (out));
if (NATIVE_COMP_FLAG)
{
dump_field_lv (ctx, &out, subr, &subr->native_comp_u[0], WEIGHT_NORMAL);
if (!NILP (subr->native_comp_u[0]))
dump_field_fixup_later (ctx, &out, subr, &subr->native_c_name[0]);
dump_field_lv (ctx, &out, subr, &subr->lambda_list[0], WEIGHT_NORMAL);
dump_field_lv (ctx, &out, subr, &subr->type[0], WEIGHT_NORMAL);
}
dump_off subr_off = dump_object_finish (ctx, &out, sizeof (out));
if (NATIVE_COMP_FLAG
&& ctx->flags.dump_object_contents
&& !NILP (subr->native_comp_u[0]))
/* We'll do the final addr relocation during VERY_LATE_RELOCS time
after the compilation units has been loaded. */
dump_push (&ctx->dump_relocs[VERY_LATE_RELOCS],
list2 (make_fixnum (RELOC_NATIVE_SUBR),
dump_off_to_lisp (subr_off)));
return subr_off;
}
#ifdef HAVE_NATIVE_COMP
static dump_off
dump_native_comp_unit (struct dump_context *ctx,
struct Lisp_Native_Comp_Unit *comp_u)
{
/* Have function documentation always lazy loaded to optimize load-time. */
comp_u->data_fdoc_v = Qnil;
START_DUMP_PVEC (ctx, &comp_u->header, struct Lisp_Native_Comp_Unit, out);
dump_pseudovector_lisp_fields (ctx, &out->header, &comp_u->header);
out->handle = NULL;
dump_off comp_u_off = finish_dump_pvec (ctx, &out->header);
if (ctx->flags.dump_object_contents)
/* We'll do the real elf load during LATE_RELOCS relocation time. */
dump_push (&ctx->dump_relocs[LATE_RELOCS],
list2 (make_fixnum (RELOC_NATIVE_COMP_UNIT),
dump_off_to_lisp (comp_u_off)));
return comp_u_off;
}
#endif
static void
fill_pseudovec (union vectorlike_header *header, Lisp_Object item)
{
@ -2879,7 +2952,7 @@ dump_vectorlike (struct dump_context *ctx,
Lisp_Object lv,
dump_off offset)
{
#if CHECK_STRUCTS && !defined HASH_pvec_type_A4A6E9984D
#if CHECK_STRUCTS && !defined HASH_pvec_type_F5BA506141
# error "pvec_type changed. See CHECK_STRUCTS comment in config.h."
#endif
const struct Lisp_Vector *v = XVECTOR (lv);
@ -2932,6 +3005,11 @@ dump_vectorlike (struct dump_context *ctx,
case PVEC_BIGNUM:
offset = dump_bignum (ctx, lv);
break;
#ifdef HAVE_NATIVE_COMP
case PVEC_NATIVE_COMP_UNIT:
offset = dump_native_comp_unit (ctx, XNATIVE_COMP_UNIT (lv));
break;
#endif
case PVEC_WINDOW_CONFIGURATION:
error_unsupported_dump_object (ctx, lv, "window configuration");
case PVEC_OTHER:
@ -3167,6 +3245,12 @@ dump_metadata_for_pdumper (struct dump_context *ctx)
(void const *) dump_hooks[i]);
dump_emacs_reloc_immediate_int (ctx, &nr_dump_hooks, nr_dump_hooks);
for (int i = 0; i < nr_dump_late_hooks; ++i)
dump_emacs_reloc_to_emacs_ptr_raw (ctx, &dump_late_hooks[i],
(void const *) dump_late_hooks[i]);
dump_emacs_reloc_immediate_int (ctx, &nr_dump_late_hooks,
nr_dump_late_hooks);
for (int i = 0; i < nr_remembered_data; ++i)
{
dump_emacs_reloc_to_emacs_ptr_raw (ctx, &remembered_data[i].mem,
@ -3328,6 +3412,29 @@ dump_cold_bignum (struct dump_context *ctx, Lisp_Object object)
}
}
#ifdef HAVE_NATIVE_COMP
static void
dump_cold_native_subr (struct dump_context *ctx, Lisp_Object subr)
{
/* Dump subr contents. */
dump_off subr_offset = dump_recall_object (ctx, subr);
eassert (subr_offset > 0);
dump_remember_fixup_ptr_raw
(ctx,
subr_offset + dump_offsetof (struct Lisp_Subr, symbol_name),
ctx->offset);
const char *symbol_name = XSUBR (subr)->symbol_name;
dump_write (ctx, symbol_name, 1 + strlen (symbol_name));
dump_remember_fixup_ptr_raw
(ctx,
subr_offset + dump_offsetof (struct Lisp_Subr, native_c_name[0]),
ctx->offset);
const char *c_name = XSUBR (subr)->native_c_name[0];
dump_write (ctx, c_name, 1 + strlen (c_name));
}
#endif
static void
dump_drain_cold_data (struct dump_context *ctx)
{
@ -3371,6 +3478,11 @@ dump_drain_cold_data (struct dump_context *ctx)
case COLD_OP_BIGNUM:
dump_cold_bignum (ctx, data);
break;
#ifdef HAVE_NATIVE_COMP
case COLD_OP_NATIVE_SUBR:
dump_cold_native_subr (ctx, data);
break;
#endif
default:
emacs_abort ();
}
@ -3779,7 +3891,7 @@ dump_do_fixup (struct dump_context *ctx,
/* Dump wants a pointer to a Lisp object.
If DUMP_FIXUP_LISP_OBJECT_RAW, we should stick a C pointer in
the dump; otherwise, a Lisp_Object. */
if (SUBRP (arg))
if (SUBRP (arg) && !SUBR_NATIVE_COMPILEDP (arg))
{
dump_value = emacs_offset (XSUBR (arg));
if (type == DUMP_FIXUP_LISP_OBJECT)
@ -3960,7 +4072,8 @@ types. */)
ctx->symbol_aux = Qnil;
ctx->copied_queue = Qnil;
ctx->cold_queue = Qnil;
ctx->dump_relocs = Qnil;
for (int i = 0; i < RELOC_NUM_PHASES; ++i)
ctx->dump_relocs[i] = Qnil;
ctx->object_starts = Qnil;
ctx->emacs_relocs = Qnil;
ctx->bignum_data = make_eq_hash_table ();
@ -4128,8 +4241,9 @@ types. */)
/* Emit instructions for Emacs to execute when loading the dump.
Note that this relocation information ends up in the cold section
of the dump. */
drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger,
&ctx->dump_relocs, &ctx->header.dump_relocs);
for (int i = 0; i < RELOC_NUM_PHASES; ++i)
drain_reloc_list (ctx, dump_emit_dump_reloc, emacs_reloc_merger,
&ctx->dump_relocs[i], &ctx->header.dump_relocs[i]);
dump_off number_hot_relocations = ctx->number_hot_relocations;
ctx->number_hot_relocations = 0;
dump_off number_discardable_relocations = ctx->number_discardable_relocations;
@ -4147,7 +4261,8 @@ types. */)
eassert (NILP (ctx->deferred_symbols));
eassert (NILP (ctx->deferred_hash_tables));
eassert (NILP (ctx->fixups));
eassert (NILP (ctx->dump_relocs));
for (int i = 0; i < RELOC_NUM_PHASES; ++i)
eassert (NILP (ctx->dump_relocs[i]));
eassert (NILP (ctx->emacs_relocs));
/* Dump is complete. Go back to the header and write the magic
@ -4207,6 +4322,15 @@ pdumper_do_now_and_after_load_impl (pdumper_hook hook)
hook ();
}
void
pdumper_do_now_and_after_late_load_impl (pdumper_hook hook)
{
if (nr_dump_late_hooks == ARRAYELTS (dump_late_hooks))
fatal ("out of dump hooks: make dump_late_hooks[] bigger");
dump_late_hooks[nr_dump_late_hooks++] = hook;
hook ();
}
static void
pdumper_remember_user_data_1 (void *mem, int nbytes)
{
@ -4232,6 +4356,16 @@ pdumper_remember_lv_ptr_raw_impl (void *ptr, enum Lisp_Type type)
}
#ifdef HAVE_NATIVE_COMP
/* This records the directory where the Emacs executable lives, to be
used for locating the native-lisp directory from which we need to
load the preloaded *.eln files. See pdumper_set_emacs_execdir
below. */
static char *emacs_execdir;
static ptrdiff_t execdir_size;
static ptrdiff_t execdir_len;
#endif
/* Dump runtime */
enum dump_memory_protection
{
@ -5138,6 +5272,117 @@ dump_do_dump_relocation (const uintptr_t dump_base,
dump_write_word_to_dump (dump_base, reloc_offset, value);
break;
}
#ifdef HAVE_NATIVE_COMP
case RELOC_NATIVE_COMP_UNIT:
{
static enum { UNKNOWN, LOCAL_BUILD, INSTALLED } installation_state;
struct Lisp_Native_Comp_Unit *comp_u =
dump_ptr (dump_base, reloc_offset);
comp_u->lambda_gc_guard_h = CALLN (Fmake_hash_table, QCtest, Qeq);
if (STRINGP (comp_u->file))
error ("Trying to load incoherent dumped eln file %s",
SSDATA (comp_u->file));
/* emacs_execdir is always unibyte, but the file names in
comp_u->file could be multibyte, so we need to encode
them. */
Lisp_Object cu_file1 = ENCODE_FILE (XCAR (comp_u->file));
Lisp_Object cu_file2 = ENCODE_FILE (XCDR (comp_u->file));
ptrdiff_t fn1_len = SBYTES (cu_file1), fn2_len = SBYTES (cu_file2);
Lisp_Object eln_fname;
char *fndata;
/* Check just once if this is a local build or Emacs was installed. */
/* Can't use expand-file-name here, because we are too early
in the startup, and we will crash at least on WINDOWSNT. */
if (installation_state == UNKNOWN)
{
eln_fname = make_uninit_string (execdir_len + fn1_len);
fndata = SSDATA (eln_fname);
memcpy (fndata, emacs_execdir, execdir_len);
memcpy (fndata + execdir_len, SSDATA (cu_file1), fn1_len);
if (file_access_p (fndata, F_OK))
installation_state = INSTALLED;
else
{
eln_fname = make_uninit_string (execdir_len + fn2_len);
fndata = SSDATA (eln_fname);
memcpy (fndata, emacs_execdir, execdir_len);
memcpy (fndata + execdir_len, SSDATA (cu_file2), fn2_len);
installation_state = LOCAL_BUILD;
}
fixup_eln_load_path (eln_fname);
}
else
{
ptrdiff_t fn_len =
installation_state == INSTALLED ? fn1_len : fn2_len;
Lisp_Object cu_file =
installation_state == INSTALLED ? cu_file1 : cu_file2;
eln_fname = make_uninit_string (execdir_len + fn_len);
fndata = SSDATA (eln_fname);
memcpy (fndata, emacs_execdir, execdir_len);
memcpy (fndata + execdir_len, SSDATA (cu_file), fn_len);
}
/* FIXME: This records the names of the *.eln files in an
unexpanded form, with one or more ".." elements (and on
Windows with the first part using backslashes). The file
names are also unibyte. If we care about this, we need to
loop in startup.el over all the preloaded modules and run
their file names through expand-file-name and
decode-coding-string. */
comp_u->file = eln_fname;
comp_u->handle = dynlib_open (SSDATA (eln_fname));
if (!comp_u->handle)
{
fprintf (stderr, "Error using execdir %s:\n",
emacs_execdir);
error ("%s", dynlib_error ());
}
load_comp_unit (comp_u, true, false);
break;
}
case RELOC_NATIVE_SUBR:
{
if (!NATIVE_COMP_FLAG)
/* This cannot happen. */
emacs_abort ();
/* When resurrecting from a dump given non all the original
native compiled subrs may be still around we can't rely on
a 'top_level_run' mechanism, we revive them one-by-one
here. */
struct Lisp_Subr *subr = dump_ptr (dump_base, reloc_offset);
struct Lisp_Native_Comp_Unit *comp_u =
XNATIVE_COMP_UNIT (subr->native_comp_u[0]);
if (!comp_u->handle)
error ("NULL handle in compilation unit %s", SSDATA (comp_u->file));
const char *c_name = subr->native_c_name[0];
eassert (c_name);
void *func = dynlib_sym (comp_u->handle, c_name);
if (!func)
error ("can't find function \"%s\" in compilation unit %s", c_name,
SSDATA (comp_u->file));
subr->function.a0 = func;
Lisp_Object lambda_data_idx =
Fgethash (build_string (c_name), comp_u->lambda_c_name_idx_h, Qnil);
if (!NILP (lambda_data_idx))
{
/* This is an anonymous lambda.
We must fixup d_reloc_imp so the lambda can be referenced
by code. */
Lisp_Object tem;
XSETSUBR (tem, subr);
Lisp_Object *fixup =
&(comp_u->data_imp_relocs[XFIXNUM (lambda_data_idx)]);
eassert (EQ (*fixup, Qlambda_fixup));
*fixup = tem;
Fputhash (tem, Qt, comp_u->lambda_gc_guard_h);
}
break;
}
#endif
case RELOC_BIGNUM:
{
struct Lisp_Bignum *bignum = dump_ptr (dump_base, reloc_offset);
@ -5160,11 +5405,12 @@ dump_do_dump_relocation (const uintptr_t dump_base,
}
static void
dump_do_all_dump_relocations (const struct dump_header *const header,
const uintptr_t dump_base)
dump_do_all_dump_reloc_for_phase (const struct dump_header *const header,
const uintptr_t dump_base,
const enum reloc_phase phase)
{
struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs.offset);
dump_off nr_entries = header->dump_relocs.nr_entries;
struct dump_reloc *r = dump_ptr (dump_base, header->dump_relocs[phase].offset);
dump_off nr_entries = header->dump_relocs[phase].nr_entries;
for (dump_off i = 0; i < nr_entries; ++i)
dump_do_dump_relocation (dump_base, r[i]);
}
@ -5229,6 +5475,26 @@ dump_do_all_emacs_relocations (const struct dump_header *const header,
dump_do_emacs_relocation (dump_base, r[i]);
}
#ifdef HAVE_NATIVE_COMP
/* Compute and record the directory of the Emacs executable given the
file name of that executable. */
static void
pdumper_set_emacs_execdir (char *emacs_executable)
{
char *p = emacs_executable + strlen (emacs_executable);
while (p > emacs_executable
&& !IS_DIRECTORY_SEP (p[-1]))
--p;
eassert (p > emacs_executable);
emacs_execdir = xpalloc (emacs_execdir, &execdir_size,
p - emacs_executable + 1 - execdir_size, -1, 1);
memcpy (emacs_execdir, emacs_executable, p - emacs_executable);
execdir_len = p - emacs_executable;
emacs_execdir[execdir_len] = '\0';
}
#endif
enum dump_section
{
DS_HOT,
@ -5245,7 +5511,7 @@ static Lisp_Object *pdumper_hashes = &zero_vector;
N.B. We run very early in initialization, so we can't use lisp,
unwinding, xmalloc, and so on. */
int
pdumper_load (const char *dump_filename)
pdumper_load (const char *dump_filename, char *argv0)
{
intptr_t dump_size;
struct stat stat;
@ -5380,7 +5646,7 @@ pdumper_load (const char *dump_filename)
dump_public.start = dump_base;
dump_public.end = dump_public.start + dump_size;
dump_do_all_dump_relocations (header, dump_base);
dump_do_all_dump_reloc_for_phase (header, dump_base, EARLY_RELOCS);
dump_do_all_emacs_relocations (header, dump_base);
dump_mmap_discard_contents (&sections[DS_DISCARDABLE]);
@ -5400,6 +5666,21 @@ pdumper_load (const char *dump_filename)
initialization. */
for (int i = 0; i < nr_dump_hooks; ++i)
dump_hooks[i] ();
#ifdef HAVE_NATIVE_COMP
pdumper_set_emacs_execdir (argv0);
#else
(void) argv0;
#endif
dump_do_all_dump_reloc_for_phase (header, dump_base, LATE_RELOCS);
dump_do_all_dump_reloc_for_phase (header, dump_base, VERY_LATE_RELOCS);
/* Run the functions Emacs registered for doing post-dump-load
initialization. */
for (int i = 0; i < nr_dump_late_hooks; ++i)
dump_late_hooks[i] ();
initialized = true;
struct timespec load_timespec =

15
src/pdumper.h
View file

@ -81,6 +81,7 @@ pdumper_remember_lv_ptr_raw (void *ptr, enum Lisp_Type type)
typedef void (*pdumper_hook)(void);
extern void pdumper_do_now_and_after_load_impl (pdumper_hook hook);
extern void pdumper_do_now_and_after_late_load_impl (pdumper_hook hook);
INLINE void
pdumper_do_now_and_after_load (pdumper_hook hook)
@ -92,6 +93,18 @@ pdumper_do_now_and_after_load (pdumper_hook hook)
#endif
}
/* Same as 'pdumper_do_now_and_after_load' but for hooks running code
that can call into Lisp. */
INLINE void
pdumper_do_now_and_after_late_load (pdumper_hook hook)
{
#ifdef HAVE_PDUMPER
pdumper_do_now_and_after_late_load_impl (hook);
#else
hook ();
#endif
}
/* Macros useful in pdumper callback functions. Assign a value if
we're loading a dump and the value needs to be reset to its
original value, and if we're initializing for the first time,
@ -127,7 +140,7 @@ enum pdumper_load_result
PDUMPER_LOAD_ERROR /* Must be last, as errno may be added. */
};
int pdumper_load (const char *dump_filename);
int pdumper_load (const char *dump_filename, char *argv0);
struct pdumper_loaded_dump
{

13
src/print.c
View file

@ -1841,7 +1841,18 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag,
}
break;
#endif
#ifdef HAVE_NATIVE_COMP
case PVEC_NATIVE_COMP_UNIT:
{
struct Lisp_Native_Comp_Unit *cu = XNATIVE_COMP_UNIT (obj);
print_c_string ("#<native compilation unit: ", printcharfun);
print_string (cu->file, printcharfun);
printchar (' ', printcharfun);
print_object (cu->optimize_qualities, printcharfun, escapeflag);
printchar ('>', printcharfun);
}
break;
#endif
default:
emacs_abort ();
}

2
src/process.c
View file

@ -1936,7 +1936,7 @@ usage: (make-process &rest ARGS) */)
{
tem = Qnil;
openp (Vexec_path, program, Vexec_suffixes, &tem,
make_fixnum (X_OK), false);
make_fixnum (X_OK), false, false);
if (NILP (tem))
report_file_error ("Searching for program", program);
tem = Fexpand_file_name (tem, Qnil);

5
src/sound.c
View file

@ -1370,8 +1370,9 @@ Internal use only, use `play-sound' instead. */)
if (STRINGP (attrs[SOUND_FILE]))
{
/* Open the sound file. */
current_sound->fd = openp (list1 (Vdata_directory),
attrs[SOUND_FILE], Qnil, &file, Qnil, false);
current_sound->fd =
openp (list1 (Vdata_directory), attrs[SOUND_FILE], Qnil, &file, Qnil,
false, false);
if (current_sound->fd < 0)
sound_perror ("Could not open sound file");

8
src/verbose.mk.in
View file

@ -34,7 +34,15 @@ AM_V_AR = @echo " AR " $@;
AM_V_at = @
AM_V_CC = @echo " CC " $@;
AM_V_CCLD = @echo " CCLD " $@;
ifeq ($(HAVE_NATIVE_COMP),yes)
ifeq ($(NATIVE_DISABLED),1)
AM_V_ELC = @echo " ELC " $@;
else
AM_V_ELC = @echo " ELC+ELN " $@;
endif
else
AM_V_ELC = @echo " ELC " $@;
endif
AM_V_GEN = @echo " GEN " $@;
AM_V_GLOBALS = @echo " GEN " globals.h;
AM_V_NO_PD = --no-print-directory

28
src/w32.c
View file

@ -1941,11 +1941,10 @@ buf_prev (int from)
return prev_idx;
}
static void
sample_system_load (ULONGLONG *idle, ULONGLONG *kernel, ULONGLONG *user)
unsigned
w32_get_nproc (void)
{
SYSTEM_INFO sysinfo;
FILETIME ft_idle, ft_user, ft_kernel;
/* Initialize the number of processors on this machine. */
if (num_of_processors <= 0)
@ -1960,6 +1959,15 @@ sample_system_load (ULONGLONG *idle, ULONGLONG *kernel, ULONGLONG *user)
if (num_of_processors <= 0)
num_of_processors = 1;
}
return num_of_processors;
}
static void
sample_system_load (ULONGLONG *idle, ULONGLONG *kernel, ULONGLONG *user)
{
FILETIME ft_idle, ft_user, ft_kernel;
(void) w32_get_nproc ();
/* TODO: Take into account threads that are ready to run, by
sampling the "\System\Processor Queue Length" performance
@ -10247,7 +10255,8 @@ check_windows_init_file (void)
need to ENCODE_FILE here, but we do need to convert the file
names from UTF-8 to ANSI. */
init_file = build_string ("term/w32-win");
fd = openp (Vload_path, init_file, Fget_load_suffixes (), NULL, Qnil, 0);
fd =
openp (Vload_path, init_file, Fget_load_suffixes (), NULL, Qnil, 0, 0);
if (fd < 0)
{
Lisp_Object load_path_print = Fprin1_to_string (Vload_path, Qnil);
@ -10439,6 +10448,13 @@ shutdown_handler (DWORD type)
|| type == CTRL_LOGOFF_EVENT /* User logs off. */
|| type == CTRL_SHUTDOWN_EVENT) /* User shutsdown. */
{
/* If we are being shut down in noninteractive mode, we don't
care about the message stack, so clear it to avoid abort in
shut_down_emacs. This happens when an noninteractive Emacs
is invoked as a subprocess of Emacs, and the parent wants to
kill us, e.g. because it's about to exit. */
if (noninteractive)
clear_message_stack ();
/* Shut down cleanly, making sure autosave files are up to date. */
shut_down_emacs (0, Qnil);
}
@ -10657,6 +10673,10 @@ globals_of_w32 (void)
#endif
w32_crypto_hprov = (HCRYPTPROV)0;
/* We need to forget about libraries that were loaded during the
dumping process (e.g. libgccjit) */
Vlibrary_cache = Qnil;
}
/* For make-serial-process */

3
src/w32.h
View file

@ -233,6 +233,9 @@ extern int w32_memory_info (unsigned long long *, unsigned long long *,
/* Compare 2 UTF-8 strings in locale-dependent fashion. */
extern int w32_compare_strings (const char *, const char *, char *, int);
/* Return the number of processor execution units on this system. */
extern unsigned w32_get_nproc (void);
/* Return a cryptographically secure seed for PRNG. */
extern int w32_init_random (void *, ptrdiff_t);

8
src/w32common.h
View file

@ -86,6 +86,14 @@ get_proc_addr (HINSTANCE handle, LPCSTR fname)
} \
while (false)
/* Load a function from the DLL, and don't fail if it does not exist. */
#define LOAD_DLL_FN_OPT(lib, func) \
do \
{ \
fn_##func = (W32_PFN_##func) get_proc_addr (lib, #func); \
} \
while (false)
#ifdef HAVE_HARFBUZZ
extern bool hbfont_init_w32_funcs (HMODULE);
#endif

13
src/w32proc.c
View file

@ -1918,7 +1918,8 @@ sys_spawnve (int mode, char *cmdname, char **argv, char **envp)
{
program = build_string (cmdname);
full = Qnil;
openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK), 0);
openp (Vexec_path, program, Vexec_suffixes, &full, make_fixnum (X_OK),
0, 0);
if (NILP (full))
{
errno = EINVAL;
@ -3877,6 +3878,14 @@ w32_compare_strings (const char *s1, const char *s2, char *locname,
return val - 2;
}
DEFUN ("w32-get-nproc", Fw32_get_nproc,
Sw32_get_nproc, 0, 0, 0,
doc: /* Return the number of system's processor execution units. */)
(void)
{
return make_fixnum (w32_get_nproc ());
}
void
syms_of_ntproc (void)
@ -3911,6 +3920,8 @@ syms_of_ntproc (void)
defsubr (&Sw32_get_keyboard_layout);
defsubr (&Sw32_set_keyboard_layout);
defsubr (&Sw32_get_nproc);
DEFVAR_LISP ("w32-quote-process-args", Vw32_quote_process_args,
doc: /* Non-nil enables quoting of process arguments to ensure correct parsing.
Because Windows does not directly pass argv arrays to child processes,

2
src/window.c
View file

@ -8159,7 +8159,7 @@ init_window_once (void)
minibuf_selected_window = Qnil;
staticpro (&minibuf_selected_window);
pdumper_do_now_and_after_load (init_window_once_for_pdumper);
pdumper_do_now_and_after_late_load (init_window_once_for_pdumper);
}
static void init_window_once_for_pdumper (void)

10
test/Makefile.in
View file

@ -47,6 +47,8 @@ SO = @MODULES_SUFFIX@
SEPCHAR = @SEPCHAR@
HAVE_NATIVE_COMP = @HAVE_NATIVE_COMP@
-include ${top_builddir}/src/verbose.mk
# Load any GNU ELPA dependencies that are present, for optional tests.
@ -118,6 +120,8 @@ emacs = LANG=C EMACSLOADPATH= \
# Set HOME to a nonexistent directory to prevent tests from accessing
# it accidentally (e.g., popping up a gnupg dialog if ~/.authinfo.gpg
# exists, or writing to ~/.bzr.log when running bzr commands).
# NOTE if the '/nonexistent' name is changed `normal-top-level' in
# startup.el must be updated too.
TEST_HOME = /nonexistent
test_module_dir := src/emacs-module-resources
@ -126,9 +130,15 @@ test_module_dir := src/emacs-module-resources
all: check
ifeq ($(HAVE_NATIVE_COMP),yes)
SELECTOR_DEFAULT = (not (or (tag :expensive-test) (tag :unstable)))
SELECTOR_EXPENSIVE = (not (tag :unstable))
SELECTOR_ALL = t
else
SELECTOR_DEFAULT = (not (or (tag :expensive-test) (tag :unstable) (tag :nativecomp)))
SELECTOR_EXPENSIVE = (not (or (tag :unstable) (tag :nativecomp)))
SELECTOR_ALL = (not (tag :nativecomp))
endif
ifdef SELECTOR
SELECTOR_ACTUAL=$(SELECTOR)
else ifndef MAKECMDGOALS

32
test/infra/gitlab-ci.yml
View file

@ -243,6 +243,38 @@ test-filenotify-gio:
target: emacs-filenotify-gio
make_params: "-k -C test autorevert-tests.log filenotify-tests.log"
test-native-bootstrap-speed0:
# Test a full native bootstrap
# Run for now only speed 0 to limit memory usage and compilation time.
stage: slow
# Uncomment the following to run it only when sceduled.
# only:
# - schedules
script:
- DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
- ./autogen.sh autoconf
- ./configure --without-makeinfo --with-nativecomp
- make bootstrap NATIVE_FULL_AOT=1 BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 0)"' -j2
timeout: 8 hours
test-native-bootstrap-speed1:
stage: slow
script:
- DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
- ./autogen.sh autoconf
- ./configure --without-makeinfo --with-nativecomp
- make bootstrap BYTE_COMPILE_EXTRA_FLAGS='--eval "(setq comp-speed 1)"'
timeout: 8 hours
test-native-bootstrap-speed2:
stage: slow
script:
- DEBIAN_FRONTEND=noninteractive apt install --no-install-recommends -y -qq -o=Dpkg::Use-Pty=0 libgccjit-6-dev
- ./autogen.sh autoconf
- ./configure --without-makeinfo --with-nativecomp
- make bootstrap
timeout: 8 hours
test-gnustep:
# This tests the GNUstep build process
stage: platforms

3
test/lisp/auth-source-tests.el
View file

@ -320,7 +320,8 @@
;; Redefine `read-*' in order to avoid interactive input.
(cl-letf (((symbol-function 'read-passwd) (lambda (_) passwd))
((symbol-function 'read-string)
(lambda (_prompt _initial _history default) default)))
(lambda (_prompt _initial _history default _inherit-input-method)
default)))
(setq auth-info
(car (auth-source-search
:max 1 :host host :require '(:user :secret) :create t))))

229
test/lisp/emacs-lisp/comp-cstr-tests.el Normal file
View file

@ -0,0 +1,229 @@
;;; comp-cstr-tests.el --- unit tests for src/comp.c -*- lexical-binding: t; -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; Author: Andrea Corallo <akrl@sdf.org>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Unit tests for lisp/emacs-lisp/comp-cstr.el
;;; Code:
(require 'ert)
(require 'cl-lib)
(require 'comp-cstr)
(cl-eval-when (compile eval load)
(defun comp-cstr-test-ts (type-spec)
"Create a constraint from TYPE-SPEC and convert it back to type specifier."
(let ((comp-ctxt (make-comp-cstr-ctxt)))
(comp-cstr-to-type-spec (comp-type-spec-to-cstr type-spec))))
(defun comp-cstr-typespec-test (number type-spec expected-type-spec)
`(ert-deftest ,(intern (concat "comp-cstr-test-" (int-to-string number))) ()
(should (equal (comp-cstr-test-ts ',type-spec)
',expected-type-spec))))
(defconst comp-cstr-typespec-tests-alist
`(;; 1
(symbol . symbol)
;; 2
((or string array) . array)
;; 3
((or symbol number) . (or number symbol))
;; 4
((or cons atom) . (or atom cons)) ;; SBCL return T
;; 5
((or integer number) . number)
;; 6
((or (or integer symbol) number) . (or number symbol))
;; 7
((or (or integer symbol) (or number list)) . (or list number symbol))
;; 8
((or (or integer number) nil) . number)
;; 9
((member foo) . (member foo))
;; 10
((member foo bar) . (member bar foo))
;; 11
((or (member foo) (member bar)) . (member bar foo))
;; 12
((or (member foo) symbol) . symbol) ;; SBCL return (OR SYMBOL (MEMBER FOO))
;; 13
((or (member foo) number) . (or (member foo) number))
;; 14
((or (integer 1 3) number) . number)
;; 15
(integer . integer)
;; 16
((integer 1 2) . (integer 1 2))
;; 17
((or (integer -1 0) (integer 3 4)) . (or (integer -1 0) (integer 3 4)))
;; 18
((or (integer -1 2) (integer 3 4)) . (integer -1 4))
;; 19
((or (integer -1 3) (integer 3 4)) . (integer -1 4))
;; 20
((or (integer -1 4) (integer 3 4)) . (integer -1 4))
;; 21
((or (integer -1 5) (integer 3 4)) . (integer -1 5))
;; 22
((or (integer -1 *) (integer 3 4)) . (integer -1 *))
;; 23
((or (integer -1 2) (integer * 4)) . (integer * 4))
;; 24
((and string array) . string)
;; 25
((and cons atom) . nil)
;; 26
((and (member foo) (member foo bar baz)) . (member foo))
;; 27
((and (member foo) (member bar)) . nil)
;; 28
((and (member foo) symbol) . (member foo))
;; 29
((and (member foo) string) . nil)
;; 30
((and (member foo) (integer 1 2)) . nil)
;; 31
((and (member 1 2) (member 3 2)) . (integer 2 2))
;; 32
((and number (integer 1 2)) . (integer 1 2))
;; 33
((and integer (integer 1 2)) . (integer 1 2))
;; 34
((and (integer -1 0) (integer 3 5)) . nil)
;; 35
((and (integer -1 2) (integer 3 5)) . nil)
;; 36
((and (integer -1 3) (integer 3 5)) . (integer 3 3))
;; 37
((and (integer -1 4) (integer 3 5)) . (integer 3 4))
;; 38
((and (integer -1 5) nil) . nil)
;; 39
((not symbol) . (not symbol))
;; 40
((or (member foo) (not (member foo bar))) . (not (member bar)))
;; 41
((or (member foo bar) (not (member foo))) . t)
;; 42
((or symbol (not sequence)) . (not sequence))
;; 43
((or symbol (not symbol)) . t)
;; 44
((or symbol (not sequence)) . (not sequence))
;; 45 Conservative.
((or vector (not sequence)) . t)
;; 46
((or (integer 1 10) (not (integer * 5))) . (not (integer * 0)))
;; 47
((or symbol (integer 1 10) (not (integer * 5))) . (not (integer * 0)))
;; 48
((or (not symbol) (integer 1 10) (not (integer * 5))) . (not (or symbol (integer * 0))))
;; 49
((or symbol (not (member foo))) . (not (member foo)))
;; 50
((or (not symbol) (not (member foo))) . (not symbol))
;; 51 Conservative.
((or (not (member foo)) string) . (not (member foo)))
;; 52 Conservative.
((or (member foo) (not string)) . (not string))
;; 53
((or (not (integer 1 2)) integer) . t)
;; 54
((or (not (integer 1 2)) (not integer)) . (not integer))
;; 55
((or (integer 1 2) (not integer)) . (not (or (integer * 0) (integer 3 *))))
;; 56
((or number (not (integer 1 2))) . t)
;; 57
((or atom (not (integer 1 2))) . t)
;; 58
((or atom (not (member foo))) . t)
;; 59
((and symbol (not cons)) . symbol)
;; 60
((and symbol (not symbol)) . nil)
;; 61
((and atom (not symbol)) . atom)
;; 62
((and atom (not string)) . (or array sequence atom))
;; 63 Conservative
((and symbol (not (member foo))) . symbol)
;; 64 Conservative
((and symbol (not (member 3))) . symbol)
;; 65
((and (not (member foo)) (integer 1 10)) . (integer 1 10))
;; 66
((and (member foo) (not (integer 1 10))) . (member foo))
;; 67
((and t (not (member foo))) . (not (member foo)))
;; 68
((and integer (not (integer 3 4))) . (or (integer * 2) (integer 5 *)))
;; 69
((and (integer 0 20) (not (integer 5 10))) . (or (integer 0 4) (integer 11 20)))
;; 70
((and (not (member a)) (not (member b))) . (not (member a b)))
;; 71
((and (not boolean) (not (member b))) . (not (or (member b) boolean)))
;; 72
((and t (integer 1 1)) . (integer 1 1))
;; 73
((not (integer -1 5)) . (not (integer -1 5)))
;; 74
((and boolean (or number marker)) . nil)
;; 75
((and atom (or number marker)) . (or marker number))
;; 76
((and symbol (or number marker)) . nil)
;; 77
((and (or symbol string) (or number marker)) . nil)
;; 78
((and t t) . t)
;; 80
((and (or marker number) (integer 0 0)) . (integer 0 0))
;; 81
((and t (not t)) . nil)
;; 82
((or (integer 1 1) (not (integer 1 1))) . t)
;; 83
((not t) . nil)
;; 84
((not nil) . t)
;; 85
((or (not string) t) . t)
;; 86
((or (not vector) sequence) . sequence)
;; 87
((or (not symbol) null) . t))
"Alist type specifier -> expected type specifier."))
(defmacro comp-cstr-synthesize-tests ()
"Generate all tests from `comp-cstr-typespec-tests-alist'."
`(progn
,@(cl-loop
for i from 1
for (ts . exp-ts) in comp-cstr-typespec-tests-alist
append (list (comp-cstr-typespec-test i ts exp-ts)))))
(comp-cstr-synthesize-tests)
;;; comp-cstr-tests.el ends here

8
test/lisp/help-fns-tests.el
View file

@ -62,12 +62,16 @@ Return first line of the output of (describe-function-1 FUNC)."
(should (string-match regexp result))))
(ert-deftest help-fns-test-lisp-defun ()
(let ((regexp "a compiled Lisp function in .+subr\\.el")
(let ((regexp (if (boundp 'comp-ctxt)
"a native compiled Lisp function in .+subr\\.el"
"a compiled Lisp function in .+subr\\.el"))
(result (help-fns-tests--describe-function 'last)))
(should (string-match regexp result))))
(ert-deftest help-fns-test-lisp-defsubst ()
(let ((regexp "a compiled Lisp function in .+subr\\.el")
(let ((regexp (if (boundp 'comp-ctxt)
"a native compiled Lisp function in .+subr\\.el"
"a compiled Lisp function in .+subr\\.el"))
(result (help-fns-tests--describe-function 'posn-window)))
(should (string-match regexp result))))

2
test/lisp/subr-tests.el
View file

@ -382,7 +382,7 @@ cf. Bug#25477."
"Test for https://debbugs.gnu.org/22027 ."
(let ((default "foo") res)
(cl-letf (((symbol-function 'read-string)
(lambda (_prompt _init _hist def) def)))
(lambda (_prompt _init _hist def _inher-input) def)))
(setq res (read-passwd "pass: " 'confirm (mapconcat #'string default "")))
(should (string= default res)))))

28
test/src/comp-test-45603.el Normal file
View file

@ -0,0 +1,28 @@
;;; -*- lexical-binding: t; -*-
;; Reduced from ivy.el.
(defvar comp-test-45603-last)
(defvar comp-test-45603-mark-prefix)
(defvar comp-test-45603-directory)
(defvar comp-test-45603-marked-candidates)
(defun comp-test-45603--call-marked (action)
(let* ((prefix-len (length comp-test-45603-mark-prefix))
(marked-candidates
(mapcar
(lambda (s)
(let ((cand (substring s prefix-len)))
(if comp-test-45603-directory
(expand-file-name cand comp-test-45603-directory)
cand)))
comp-test-45603-marked-candidates))
(multi-action (comp-test-45603--get-multi-action comp-test-45603-last)))))
(defalias 'comp-test-45603--file-local-name
(if (fboundp 'file-local-name)
#'file-local-name
(lambda (file)
(or (file-remote-p file 'localname) file))))
(provide 'comp-test-45603)

50
test/src/comp-test-funcs-dyn.el Normal file
View file

@ -0,0 +1,50 @@
;;; comp-test-funcs-dyn.el --- compilation unit tested by comp-tests.el -*- lexical-binding: nil; -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; Author: Andrea Corallo <akrl@sdf.org>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'cl-lib)
(defun comp-tests-ffuncall-callee-dyn-f (a b)
(list a b))
(defun comp-tests-ffuncall-callee-opt-dyn-f (a b &optional c d)
(list a b c d))
(defun comp-tests-ffuncall-callee-rest-dyn-f (a b &rest c)
(list a b c))
(defun comp-tests-ffuncall-callee-opt-rest-dyn-f (a b &optional c &rest d)
(list a b c d))
(defun comp-tests-cl-macro-exp-f ()
(cl-loop for xxx in '(a b)
for yyy = xxx
collect xxx))
(cl-defun comp-tests-cl-uninterned-arg-parse-f (a &optional b &aux)
(list a b))
(provide 'comp-test-dyn-funcs)
;;; comp-test-funcs-dyn.el ends here

710
test/src/comp-test-funcs.el Normal file
View file

@ -0,0 +1,710 @@
;;; comp-test-funcs.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*-
;; Copyright (C) 2019-2021 Free Software Foundation, Inc.
;; Author: Andrea Corallo <akrl@sdf.org>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(defvar comp-tests-var1 3)
(defun comp-tests-varref-f ()
comp-tests-var1)
(defun comp-tests-list-f ()
(list 1 2 3))
(defun comp-tests-list2-f (a b c)
(list a b c))
(defun comp-tests-car-f (x)
;; Bcar
(car x))
(defun comp-tests-cdr-f (x)
;; Bcdr
(cdr x))
(defun comp-tests-car-safe-f (x)
;; Bcar_safe
(car-safe x))
(defun comp-tests-cdr-safe-f (x)
;; Bcdr_safe
(cdr-safe x))
(defun comp-tests-cons-car-f ()
(car (cons 1 2)))
(defun comp-tests-cons-cdr-f (x)
(cdr (cons 'foo x)))
(defun comp-tests-hint-fixnum-f (n)
(1+ (comp-hint-fixnum n)))
(defun comp-tests-hint-cons-f (c)
(car (comp-hint-cons c)))
(defun comp-tests-varset0-f ()
(setq comp-tests-var1 55))
(defun comp-tests-varset1-f ()
(setq comp-tests-var1 66)
4)
(defun comp-tests-length-f ()
(length '(1 2 3)))
(defun comp-tests-aref-aset-f ()
(let ((vec (make-vector 3 0)))
(aset vec 2 100)
(aref vec 2)))
(defvar comp-tests-var2 3)
(defun comp-tests-symbol-value-f ()
(symbol-value 'comp-tests-var2))
(defun comp-tests-concat-f (x)
(concat "a" "b" "c" "d"
(concat "a" "b" "c" (concat "a" "b" (concat "foo" x)))))
(defun comp-tests-ffuncall-callee-f (x y z)
(list x y z))
(defun comp-tests-ffuncall-callee-optional-f (a b &optional c d)
(list a b c d))
(defun comp-tests-ffuncall-callee-rest-f (a b &rest c)
(list a b c))
(defun comp-tests-ffuncall-callee-more8-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 p10)
;; More then 8 args.
(list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10))
(defun comp-tests-ffuncall-callee-more8-rest-f (p1 p2 p3 p4 p5 p6 p7 p8 p9 &rest p10)
;; More then 8 args.
(list p1 p2 p3 p4 p5 p6 p7 p8 p9 p10))
(defun comp-tests-ffuncall-native-f ()
"Call a primitive with no dedicate op."
(make-vector 1 nil))
(defun comp-tests-ffuncall-native-rest-f ()
"Call a primitive with no dedicate op with &rest."
(vector 1 2 3))
(defun comp-tests-ffuncall-apply-many-f (x)
(apply #'list x))
(defun comp-tests-ffuncall-lambda-f (x)
(let ((fun (lambda (x)
(1+ x))))
(funcall fun x)))
(defun comp-tests-jump-table-1-f (x)
(pcase x
('x 'a)
('y 'b)
(_ 'c)))
(defun comp-tests-jump-table-2-f (x)
(pcase x
("aaa" 'a)
("bbb" 'b)))
(defun comp-tests-conditionals-1-f (x)
;; Generate goto-if-nil
(if x 1 2))
(defun comp-tests-conditionals-2-f (x)
;; Generate goto-if-nil-else-pop
(when x
1340))
(defun comp-tests-fixnum-1-minus-f (x)
;; Bsub1
(1- x))
(defun comp-tests-fixnum-1-plus-f (x)
;; Badd1
(1+ x))
(defun comp-tests-fixnum-minus-f (x)
;; Bnegate
(- x))
(defun comp-tests-eqlsign-f (x y)
;; Beqlsign
(= x y))
(defun comp-tests-gtr-f (x y)
;; Bgtr
(> x y))
(defun comp-tests-lss-f (x y)
;; Blss
(< x y))
(defun comp-tests-les-f (x y)
;; Bleq
(<= x y))
(defun comp-tests-geq-f (x y)
;; Bgeq
(>= x y))
(defun comp-tests-setcar-f (x y)
(setcar x y)
x)
(defun comp-tests-setcdr-f (x y)
(setcdr x y)
x)
(defun comp-bubble-sort-f (list)
(let ((i (length list)))
(while (> i 1)
(let ((b list))
(while (cdr b)
(when (< (cadr b) (car b))
(setcar b (prog1 (cadr b)
(setcdr b (cons (car b) (cddr b))))))
(setq b (cdr b))))
(setq i (1- i)))
list))
(defun comp-tests-consp-f (x)
;; Bconsp
(consp x))
(defun comp-tests-setcar2-f (x)
;; Bsetcar
(setcar x 3))
(defun comp-tests-integerp-f (x)
;; Bintegerp
(integerp x))
(defun comp-tests-numberp-f (x)
;; Bnumberp
(numberp x))
(defun comp-tests-discardn-f (x)
;; BdiscardN
(1+ (let ((a 1)
(_b)
(_c))
a)))
(defun comp-tests-insertn-f (a b c d)
;; Binsert
(insert a b c d))
(defun comp-tests-err-arith-f ()
(/ 1 0))
(defun comp-tests-err-foo-f ()
(error "foo"))
(defun comp-tests-condition-case-0-f ()
;; Bpushhandler Bpophandler
(condition-case
err
(comp-tests-err-arith-f)
(arith-error (concat "arith-error "
(error-message-string err)
" catched"))
(error (concat "error "
(error-message-string err)
" catched"))))
(defun comp-tests-condition-case-1-f ()
;; Bpushhandler Bpophandler
(condition-case
err
(comp-tests-err-foo-f)
(arith-error (concat "arith-error "
(error-message-string err)
" catched"))
(error (concat "error "
(error-message-string err)
" catched"))))
(defun comp-tests-catch-f (f)
(catch 'foo
(funcall f)))
(defun comp-tests-throw-f (x)
(throw 'foo x))
(defun comp-tests-buff0-f ()
(with-temp-buffer
(insert "foo")
(buffer-string)))
(defun comp-tests-lambda-return-f ()
(lambda (x) (1+ x)))
(defun comp-tests-fib-f (n)
(cond ((= n 0) 0)
((= n 1) 1)
(t (+ (comp-tests-fib-f (- n 1))
(comp-tests-fib-f (- n 2))))))
(defmacro comp-tests-macro-m (x)
x)
(defun comp-tests-string-trim-f (url)
(string-trim url))
(defun comp-tests-trampoline-removal-f ()
(make-hash-table))
(defun comp-tests-signal-f ()
(signal 'foo t))
(defun comp-tests-func-call-removal-f ()
(let ((a 10)
(b 3))
(% a b)))
(defun comp-tests-doc-f ()
"A nice docstring"
t)
(defun comp-test-interactive-form0-f (dir)
(interactive "D")
dir)
(defun comp-test-interactive-form1-f (x y)
(interactive '(1 2))
(+ x y))
(defun comp-test-interactive-form2-f ()
(interactive))
(defun comp-test-40187-2-f ()
'foo)
(defalias 'comp-test-40187-1-f (symbol-function 'comp-test-40187-2-f))
(defun comp-test-40187-2-f ()
'bar)
(defun comp-test-speed--1-f ()
(declare (speed -1))
3)
(defun comp-test-42360-f (str end-column
&optional start-column padding ellipsis
ellipsis-text-property)
;; From `truncate-string-to-width'. A large enough function to
;; potentially use all registers and that is modifying local
;; variables inside condition-case.
(let ((str-len (length str))
(str-width 14)
(ellipsis-width 3)
(idx 0)
(column 0)
(head-padding "") (tail-padding "")
ch last-column last-idx from-idx)
(condition-case nil
(while (< column start-column)
(setq ch (aref str idx)
column (+ column (char-width ch))
idx (1+ idx)))
(args-out-of-range (setq idx str-len)))
(if (< column start-column)
(if padding (make-string end-column padding) "")
(when (and padding (> column start-column))
(setq head-padding (make-string (- column start-column) padding)))
(setq from-idx idx)
(when (>= end-column column)
(condition-case nil
(while (< column end-column)
(setq last-column column
last-idx idx
ch (aref str idx)
column (+ column (char-width ch))
idx (1+ idx)))
(args-out-of-range (setq idx str-len)))
(when (> column end-column)
(setq column last-column
idx last-idx))
(when (and padding (< column end-column))
(setq tail-padding (make-string (- end-column column) padding))))
(if (and ellipsis-text-property
(not (equal ellipsis ""))
idx)
(concat head-padding
(substring str from-idx idx)
(propertize (substring str idx) 'display (or ellipsis "")))
(concat head-padding (substring str from-idx idx)
tail-padding ellipsis)))))
(defun comp-test-primitive-advice-f (x y)
(declare (speed 2))
(+ x y))
(defun comp-test-primitive-redefine-f (x y)
(declare (speed 2))
(- x y))
(defsubst comp-test-defsubst-f ()
t)
(defvar comp-test-and-3-var 1)
(defun comp-test-and-3-f (x)
(and (atom x)
comp-test-and-3-var
2))
(defun comp-test-copy-insn-f (insn)
;; From `comp-copy-insn'.
(if (consp insn)
(let (result)
(while (consp insn)
(let ((newcar (car insn)))
(if (or (consp (car insn)) (comp-mvar-p (car insn)))
(setf newcar (comp-copy-insn (car insn))))
(push newcar result))
(setf insn (cdr insn)))
(nconc (nreverse result)
(if (comp-mvar-p insn) (comp-copy-insn insn) insn)))
(if (comp-mvar-p insn)
(copy-comp-mvar insn)
insn)))
(defun comp-test-cond-rw-1-1-f ())
(defun comp-test-cond-rw-1-2-f ()
(let ((it (comp-test-cond-rw-1-1-f))
(key 't))
(if (or (equal it key)
(eq key t))
it
nil)))
(defun comp-test-44968-f (start end)
(let ((dirlist)
(dir (expand-file-name start))
(end (expand-file-name end)))
(while (not (or (equal dir (car dirlist))
(file-equal-p dir end)))
(push dir dirlist)
(setq dir (directory-file-name (file-name-directory dir))))
(nreverse dirlist)))
(defun comp-test-45342-f (n)
(pcase n
(1 " ➊") (2 " ➋") (3 " ➌") (4 " ➍") (5 " ➎") (6 " ➏")
(7 " ➐") (8 " ➑") (9 " ➒") (10 " ➓") (_ "")))
(defun comp-test-assume-double-neg-f (collection value)
;; Reduced from `auth-source-search-collection'.
(when (atom collection)
(setq collection (list collection)))
(or (eq value t)
;; value is (not (member t))
(eq collection value)
;; collection is t, not (member t)!
(member value collection)))
(defun comp-test-assume-in-loop-1-f (arg)
;; Reduced from `comint-delim-arg'.
(let ((args nil)
(pos 0)
(len (length arg)))
(while (< pos len)
(let ((start pos))
(while (< pos len)
(setq pos (1+ pos)))
(setq args (cons (substring arg start pos) args))))
args))
(defun comp-test-45376-1-f ()
;; Reduced from `eshell-ls-find-column-lengths'.
(let* (res
(len 2)
(i 0)
(j 0))
(while (< j len)
(if (= i len)
(setq i 0))
(setq res (cons i res)
j (1+ j)
i (1+ i)))
res))
(defun comp-test-45376-2-f ()
;; Also reduced from `eshell-ls-find-column-lengths'.
(let* ((x 1)
res)
(while x
(let* ((y 4)
(i 0))
(while (> y 0)
(when (= i x)
(setq i 0))
(setf res (cons i res))
(setq y (1- y)
i (1+ i)))
(if (>= x 3)
(setq x nil)
(setq x (1+ x)))))
res))
(defun comp-test-not-cons-f (x)
;; Reduced from `cl-copy-list'.
(if (consp x)
(print x)
(car x)))
(defun comp-test-45576-f ()
;; Reduced from `eshell-find-alias-function'.
(let ((sym (intern-soft "eval")))
(if (and (functionp sym)
'(eshell-ls eshell-pred eshell-prompt eshell-script
eshell-term eshell-unix))
sym)))
(defun comp-test-45635-f (&rest args)
;; Reduced from `set-face-attribute'.
(let ((spec args)
family)
(while spec
(cond ((eq (car spec) :family)
(setq family (cadr spec))))
(setq spec (cddr spec)))
(when (and (stringp family)
(string-match "\\([^-]*\\)-\\([^-]*\\)" family))
(setq family (match-string 2 family)))
(when (or (stringp family)
(eq family 'unspecified))
family)))
(defun comp-test-46670-1-f (_)
"foo")
(defun comp-test-46670-2-f (s)
(and (equal (comp-test-46670-1-f (length s)) s)
s))
(cl-defun comp-test-46824-1-f ()
(let ((next-repos '(1)))
(while t
(let ((recipe (car next-repos)))
(cl-block loop
(while t
(let ((err
(condition-case e
(progn
(setq next-repos
(cdr next-repos))
(cl-return-from loop))
(error e))))
(format "%S"
(error-message-string err))))))
(cl-return-from comp-test-46824-1-f))))
(defun comp-test-47868-1-f ()
" ")
(defun comp-test-47868-2-f ()
#(" " 0 1 (face font-lock-keyword-face)))
(defun comp-test-47868-3-f ()
" ")
(defun comp-test-47868-4-f ()
#(" " 0 1 (face font-lock-keyword-face)))
;;;;;;;;;;;;;;;;;;;;
;; Tromey's tests ;;
;;;;;;;;;;;;;;;;;;;;
;; Test Bconsp.
(defun comp-test-consp (x) (consp x))
;; Test Blistp.
(defun comp-test-listp (x) (listp x))
;; Test Bstringp.
(defun comp-test-stringp (x) (stringp x))
;; Test Bsymbolp.
(defun comp-test-symbolp (x) (symbolp x))
;; Test Bintegerp.
(defun comp-test-integerp (x) (integerp x))
;; Test Bnumberp.
(defun comp-test-numberp (x) (numberp x))
;; Test Badd1.
(defun comp-test-add1 (x) (1+ x))
;; Test Bsub1.
(defun comp-test-sub1 (x) (1- x))
;; Test Bneg.
(defun comp-test-negate (x) (- x))
;; Test Bnot.
(defun comp-test-not (x) (not x))
;; Test Bbobp, Beobp, Bpoint, Bpoint_min, Bpoint_max.
(defun comp-test-bobp () (bobp))
(defun comp-test-eobp () (eobp))
(defun comp-test-point () (point))
(defun comp-test-point-min () (point-min))
(defun comp-test-point-max () (point-max))
;; Test Bcar and Bcdr.
(defun comp-test-car (x) (car x))
(defun comp-test-cdr (x) (cdr x))
;; Test Bcar_safe and Bcdr_safe.
(defun comp-test-car-safe (x) (car-safe x))
(defun comp-test-cdr-safe (x) (cdr-safe x))
;; Test Beq.
(defun comp-test-eq (x y) (eq x y))
;; Test Bgotoifnil.
(defun comp-test-if (x y) (if x x y))
;; Test Bgotoifnilelsepop.
(defun comp-test-and (x y) (and x y))
;; Test Bgotoifnonnilelsepop.
(defun comp-test-or (x y) (or x y))
;; Test Bsave_excursion.
(defun comp-test-save-excursion ()
(save-excursion
(insert "XYZ")))
;; Test Bcurrent_buffer.
(defun comp-test-current-buffer () (current-buffer))
;; Test Bgtr.
(defun comp-test-> (a b)
(> a b))
;; Test Bpushcatch.
(defun comp-test-catch (&rest l)
(catch 'done
(dolist (v l)
(when (> v 23)
(throw 'done v)))))
;; Test Bmemq.
(defun comp-test-memq (val list)
(memq val list))
;; Test BlistN.
(defun comp-test-listN (x)
(list x x x x x x x x x x x x x x x x))
;; Test BconcatN.
(defun comp-test-concatN (x)
(concat x x x x x x))
;; Test optional and rest arguments.
(defun comp-test-opt-rest (a &optional b &rest c)
(list a b c))
;; Test for too many arguments.
(defun comp-test-opt (a &optional b)
(cons a b))
;; Test for unwind-protect.
(defvar comp-test-up-val nil)
(defun comp-test-unwind-protect (fun)
(setq comp-test-up-val nil)
(unwind-protect
(progn
(setq comp-test-up-val 23)
(funcall fun)
(setq comp-test-up-val 24))
(setq comp-test-up-val 999)))
;; Non tested functions that proved just to be difficult to compile.
(defun comp-test-callee (_ __) t)
(defun comp-test-silly-frame1 (x)
;; Check robustness against dead code.
(cl-case x
(0 (comp-test-callee
(pcase comp-tests-var1
(1 1)
(2 2))
3))))
(defun comp-test-silly-frame2 (token)
;; Check robustness against dead code.
(while c
(cl-case c
(?< 1)
(?> 2))))
(defun comp-test-big-interactive (filename &optional force arg load)
;; Check non trivial interactive form using `byte-recompile-file'.
(interactive
(let ((file buffer-file-name)
(file-name nil)
(file-dir nil))
(and file
(derived-mode-p 'emacs-lisp-mode)
(setq file-name (file-name-nondirectory file)
file-dir (file-name-directory file)))
(list (read-file-name (if current-prefix-arg
"Byte compile file: "
"Byte recompile file: ")
file-dir file-name nil)
current-prefix-arg)))
(let ((dest (byte-compile-dest-file filename))
;; Expand now so we get the current buffer's defaults
(filename (expand-file-name filename)))
(if (if (file-exists-p dest)
;; File was already compiled
;; Compile if forced to, or filename newer
(or force
(file-newer-than-file-p filename dest))
(and arg
(or (eq 0 arg)
(y-or-n-p (concat "Compile "
filename "? ")))))
(progn
(if (and noninteractive (not byte-compile-verbose))
(message "Compiling %s..." filename))
(byte-compile-file filename load))
(when load
(load (if (file-exists-p dest) dest filename)))
'no-byte-compile)))
(defun comp-test-no-return-1 (x)
(while x
(error "foo")))
(defun comp-test-no-return-2 (x)
(cond
((eql x '2) t)
((error "bar") nil)))
(defun comp-test-no-return-3 ())
(defun comp-test-no-return-4 (x)
(when x
(error "foo")
(while (comp-test-no-return-3)
(comp-test-no-return-3))))
(defun comp-test-=-nan (x)
(when (= x 0.0e+NaN)
x))
(defun comp-test-=-infinity (x)
(when (= x 1.0e+INF)
x))
(provide 'comp-test-funcs)
;;; comp-test-funcs.el ends here

40
test/src/comp-test-pure.el Normal file
View file

@ -0,0 +1,40 @@
;;; comp-test-pure.el --- compilation unit tested by comp-tests.el -*- lexical-binding: t; -*-
;; Copyright (C) 2020 Free Software Foundation, Inc.
;; Author: Andrea Corallo <akrl@sdf.org>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(defun comp-tests-pure-callee-f (x)
(1+ x))
(defun comp-tests-pure-caller-f ()
(comp-tests-pure-callee-f 3))
(defun comp-tests-pure-fibn-f (a b count)
(if (= count 0)
b
(comp-tests-pure-fibn-f (+ a b) a (- count 1))))
(defun comp-tests-pure-fibn-entry-f ()
(comp-tests-pure-fibn-f 1 0 20))
;;; comp-test-pure.el ends here

1446
test/src/comp-tests.el Normal file
View file

File diff suppressed because it is too large Load diff